diff --git a/LeanPool.lean b/LeanPool.lean index 7f0a0359e3..11af12599b 100644 --- a/LeanPool.lean +++ b/LeanPool.lean @@ -1869,6 +1869,780 @@ public import LeanPool.ConnesRigidity.Paper.Section6.QuotientModuleTransport public import LeanPool.ConnesRigidity.Paper.Section7 public import LeanPool.ConnesRigidity.Paper.Section7.TheoremACompletion public import LeanPool.ConnesRigidity.Porting.CoreTransfer +public import LeanPool.ConwayRefinement +public import LeanPool.ConwayRefinement.CombinatorialGames +public import LeanPool.ConwayRefinement.CombinatorialGames.Game +public import LeanPool.ConwayRefinement.CombinatorialGames.Game.Basic +public import LeanPool.ConwayRefinement.CombinatorialGames.Game.Birthday +public import LeanPool.ConwayRefinement.CombinatorialGames.Game.Classes +public import LeanPool.ConwayRefinement.CombinatorialGames.Game.Functor +public import LeanPool.ConwayRefinement.CombinatorialGames.Game.IGame +public import LeanPool.ConwayRefinement.CombinatorialGames.Game.Ordinal +public import LeanPool.ConwayRefinement.CombinatorialGames.Game.Player +public import LeanPool.ConwayRefinement.CombinatorialGames.Game.Special +public import LeanPool.ConwayRefinement.CombinatorialGames.Mathlib +public import LeanPool.ConwayRefinement.CombinatorialGames.Mathlib.Dyadic +public import LeanPool.ConwayRefinement.CombinatorialGames.Mathlib.Small +public import LeanPool.ConwayRefinement.CombinatorialGames.NatOrdinal +public import LeanPool.ConwayRefinement.CombinatorialGames.NatOrdinal.Basic +public import LeanPool.ConwayRefinement.CombinatorialGames.NatOrdinal.Pow +public import LeanPool.ConwayRefinement.CombinatorialGames.Surreal +public import LeanPool.ConwayRefinement.CombinatorialGames.Surreal.Basic +public import LeanPool.ConwayRefinement.CombinatorialGames.Surreal.Birthday +public import LeanPool.ConwayRefinement.CombinatorialGames.Surreal.Birthday.Basic +public import LeanPool.ConwayRefinement.CombinatorialGames.Surreal.Division +public import LeanPool.ConwayRefinement.CombinatorialGames.Surreal.Dyadic +public import LeanPool.ConwayRefinement.CombinatorialGames.Surreal.HahnSeries +public import LeanPool.ConwayRefinement.CombinatorialGames.Surreal.HahnSeries.Basic +public import LeanPool.ConwayRefinement.CombinatorialGames.Surreal.Leading +public import LeanPool.ConwayRefinement.CombinatorialGames.Surreal.Multiplication +public import LeanPool.ConwayRefinement.CombinatorialGames.Surreal.Ordinal +public import LeanPool.ConwayRefinement.CombinatorialGames.Surreal.Pow +public import LeanPool.ConwayRefinement.CombinatorialGames.Surreal.Real +public import LeanPool.ConwayRefinement.CombinatorialGames.Tactic +public import LeanPool.ConwayRefinement.CombinatorialGames.Tactic.AddInstances +public import LeanPool.ConwayRefinement.CombinatorialGames.Tactic.GameCmp +public import LeanPool.ConwayRefinement.CombinatorialGames.Tactic.OrdinalAlias +public import LeanPool.ConwayRefinement.CombinatorialGames.Tactic.Register +public import LeanPool.ConwayRefinement.ConwayRefinement +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.DirectSum +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.DirectSum.GermChainRule +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.DirectSum.GermFinitePartIdeal +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.DirectSum.GermPolynomial +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.DirectSum.GermSuccessorStep +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.DirectSum.GermSyzygy +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.DirectSum.HomogeneousDivisibility +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.DirectSum.HomogeneousPrime +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.DirectSum.InternalGrading +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.DirectSum.LeadingGrade +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.DirectSum.TrailingGrade +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Divisibility +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Divisibility.DenominatorIdeal +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Divisibility.MaximalDivisor +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Divisibility.PrimalPreimage +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Divisibility.PrimalProduct +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Divisibility.Refinement +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Divisibility.Tests +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Divisibility.Tests.Refinement +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Finset.FilterCard +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.GeometricIntegrality +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.GradedRing +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.GradedRing.Extension +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.GradedRing.FinitePartSubstitution +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.GradedRing.HomogeneousSpan +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.GradedRing.HomogeneousZeroDivisors +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.GradedRing.OrdinalGenerators +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.LoweringDerivation +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.LoweringDerivation.BaseChange +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.LoweringDerivation.Correction +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.LoweringDerivation.FilteredModule +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.LoweringDerivation.Grading +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.LoweringDerivation.IdealGEGraded +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.LoweringDerivation.Mu +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.LoweringDerivation.Polynomial +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MonoidAlgebra +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MonoidAlgebra.LatticeFunctional +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MonoidAlgebra.SingleZeroFactors +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MvPolynomial +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MvPolynomial.BaseChange +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MvPolynomial.Components +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MvPolynomial.ComponentsSpan +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MvPolynomial.Expansion +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MvPolynomial.FinitePartDecomposition +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MvPolynomial.FinitePartErasure +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MvPolynomial.FinitePartVars +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MvPolynomial.GCDMonoid +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MvPolynomial.LimitOrdinalContradiction +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MvPolynomial.MapWeight +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MvPolynomial.OrdinalDerivation +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MvPolynomial.OrdinalExpansion +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MvPolynomial.RemainderBound +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MvPolynomial.Syzygy +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MvPolynomial.TermDegree +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MvPolynomial.WeightedTotalDegree +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Order +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Order.ArchimedeanBall +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Order.ArchimedeanQuotient +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Order.ConvexQuotient +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Order.Module +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Order.Module.ArchimedeanBallSplitting +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Order.Module.ConvexQuotientSplitting +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Order.Module.Tests +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Order.Module.Tests.ArchimedeanBallSplitting +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Ring +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Ring.Hom +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Ring.Hom.OfInjectiveComp +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Tests +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Tests.GeometricIntegrality +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.AssociatedGradedDivisibility +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.AssociatedGradedValuation +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.BasisOver +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.DegreeAssociatedGraded +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.DegreeAssociatedGradedDomain +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.DegreeAssociatedGradedMap +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.DegreeAssociatedGradedQuotient +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.DegreeInitialForm +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.DegreeOver +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.DegreePrincipalInitialIdeal +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.DegreeRepresentatives +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.DegreeScalar +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.DegreeSum +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.DegreeWeightedPolynomial +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.FiltrationDegree +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.MaxAddDegree +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.OfValuation +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.QuotientDegree +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.RV +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.Residue +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.ResidueMathlib +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.Tests +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.Tests.AssociatedGraded +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.Tests.AssociatedGradedValuation +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.Tests.DegreeAssociatedGraded +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.Tests.DegreeAssociatedGradedQuotient +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.Tests.FiltrationDegree +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.Tests.Fixtures +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.Tests.Fixtures.PolynomialAssociatedGraded +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.Tests.Fixtures.PolynomialDegree +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.Tests.Fixtures.PolynomialQuotientDegree +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.Tests.QuotientDegree +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.Tests.RV +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.Tests.Residue +public import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint +public import LeanPool.ConwayRefinement.ConwayRefinement.Data +public import LeanPool.ConwayRefinement.ConwayRefinement.Data.Multiset +public import LeanPool.ConwayRefinement.ConwayRefinement.Data.Multiset.SelectionComplexity +public import LeanPool.ConwayRefinement.ConwayRefinement.Data.Multiset.Tests +public import LeanPool.ConwayRefinement.ConwayRefinement.Data.Multiset.Tests.SelectionComplexity +public import LeanPool.ConwayRefinement.ConwayRefinement.Examples +public import LeanPool.ConwayRefinement.ConwayRefinement.Examples.OmnificInteger +public import LeanPool.ConwayRefinement.ConwayRefinement.Examples.OmnificInteger.DegreeTwoNormalForm +public import LeanPool.ConwayRefinement.ConwayRefinement.Examples.OmnificInteger.DegreeTwoPrime +public import LeanPool.ConwayRefinement.ConwayRefinement.Examples.OmnificInteger.OneRowNormalForm +public import LeanPool.ConwayRefinement.ConwayRefinement.Examples.OmnificInteger.OneRowPrime +public import LeanPool.ConwayRefinement.ConwayRefinement.Examples.OmnificInteger.ZFCDegreeTwoPrime +public import LeanPool.ConwayRefinement.ConwayRefinement.FieldTheory +public import LeanPool.ConwayRefinement.ConwayRefinement.FieldTheory.LatticeFactorCoefficients +public import LeanPool.ConwayRefinement.ConwayRefinement.FieldTheory.LaurentFactorCoefficients +public import LeanPool.ConwayRefinement.ConwayRefinement.FieldTheory.MonicFactorCoefficients +public import LeanPool.ConwayRefinement.ConwayRefinement.FieldTheory.RelativeAlgebraicClosure +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.ArchimedeanSplitting +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.CardinalTruncation +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.CardinalTruncationDomainEmbedding +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.CardinalTruncationDomainEquiv +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.CardinalTruncationIrreducible +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.CardinalTruncationResidue +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.CharZero +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.CoefficientMap +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.ConvexFactorSupport +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.ConvexQuotientSplitting +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Degree +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Degree.PrincipalMultiplicativity +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Degree.Statements +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Degree.Statements.Degree +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Degree.Statements.DegreeResidue +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Degree.Statements.DegreeValuation +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Degree.SupportSupremumMultiplicativity +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Degree.Tests +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Degree.Tests.SupportSupremumMultiplicativity +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.DegreeTermCount +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.DegreeValuation +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Domain +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.DomainEmbedding +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.DomainEquiv +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.DomainOrderType +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.EPrimitive +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.FactorCoefficients +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.AlmostIrreducible +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.AlmostIrreducibleFactorization +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.DegreeTwo +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.DegreeTwo.DegreeTwo +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.DegreeTwo.DegreeTwoExample +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.DegreeTwo.Factorization +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.DegreeTwo.FactorizationClassification +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.DegreeTwo.TranslatedSpanFactorization +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.DegreeTwo.TranslatedTruncationSpan +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.FiniteSupportFactorUniqueness +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.GermLike +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.GradedDivisibility +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.InfiniteSupport +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.MaximalFinite +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.MaximalFiniteMultiplicativity +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.NormalizedHPart +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.NormalizedHPartMultiplicativity +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.NormalizedHPartSeries +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.NormalizedMaximalFinite +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.NormalizedSeriesMaximalFinite +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.PreSchreier +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.PrincipalMaximalFinite +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.PrincipalSubringLocalization +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.PrincipalSubringPrimality +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.RVGradedMaximalFinite +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.RVMaximalFinite +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Random +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Random.ClassIrreducible +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Random.CoefficientRandom +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Random.GradedIrreducible +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Random.HereditaryIndependence +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Random.IndependenceWindow +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Random.MainTheorem +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Random.NonPrincipalIrreducible +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Random.NormalFormBlocks +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Random.PrincipalIrreducible +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Random.Random +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Random.RandomBlocks +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Random.ReducibleSpan +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Random.SuccessorStep +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Random.SupportRandom +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Random.TruncationIndependence +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.SeriesMaximalFinite +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.SeriesMaximalMultiplicativity +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.SeriesPrimality +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Statements +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Statements.Factorization +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Statements.FiniteSupportFactorUniqueness +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Statements.MaximalFiniteMultiplicativity +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Statements.MaximalFiniteSupportDivisor +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Statements.PrincipalDivisibilityReflection +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Statements.PrincipalMaximalDivisor +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Statements.PrincipalScalarRedistribution +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Statements.PrincipalSubringFraction +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Statements.PrincipalSubringPrimality +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Statements.SeriesMaximalFiniteSupportDivisor +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Statements.SeriesPrimality +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Tests +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Tests.AlmostIrreducible +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Tests.AlmostIrreducibleFactorization +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Tests.DegreeTwo +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Tests.DegreeTwo.FactorizationClassification +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Tests.DegreeTwo.TranslatedSpanFactorization +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Tests.DegreeTwo.TranslatedTruncationSpan +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Tests.GermLikeFactorization +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Tests.GradedDivisibility +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Tests.InfiniteSupportFactorization +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Tests.MaximalFiniteSupportDivisor +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Tests.NormalizedHPart +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Tests.NormalizedHPartMultiplicativity +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Tests.PrincipalMaximalFiniteSupportDivisor +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Tests.SectionSixFour +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Tests.SeriesMaximalFiniteSupportDivisor +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.FiniteSupport +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.FiniteSupportConstantTermOne +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.FiniteSupportGCDProof +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.FiniteSupportMonoidAlgebra +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.FiniteSupportNormalization +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.FiniteSupportNormalizedGCD +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.FiniteSupportResidue +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.FiniteSupportScalarExtension +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.FiniteSupportScalarTensor +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.FiniteSupportUnit +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.Additive +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.AlgebraicIndependence +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.Boundary +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.Cancellation +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.CantorBendixsonRankLevels +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.CantorBendixsonValue +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.CantorBendixsonValueMultiplicativity +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.CofactorInduction +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.Convolution +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.Derivation +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.DerivationIdeal +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.DerivationSet +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.Derivative +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.Germ +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.GlobalCofactors +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.Graded +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.LeadingCoefficient +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.Leibniz +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.LiftFamily +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.Lifts +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.LimitOrdinalEvaluation +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.LimitOrdinalRelationAtCutoff +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.LinearMaximal +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.LowerTruncationDegree +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.Multiplication +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.Obligations +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.OrderedIntervalCantorBendixson +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.PartialDerivativeIndices +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.PartialDerivativesAtLimitOrdinal +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.Power +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.PrincipalSeries +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.Scalar +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.ScalarLeadingCoefficientAtLimitOrdinal +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.SeparatedPieceCantorBendixson +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.SuccessorLeibniz +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.SyzygyIntegration +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.TranslatedTruncationInterpolation +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.TranslatedTruncationInterpolationOnSets +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.Truncation +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.TruncationExpansion +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.TruncationPolynomial +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Assumptions +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.CardinalFiniteClassReduction +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.CardinalIntegerPartSplitting +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.CardinalPrimalityTransfer +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.CardinalProposition922 +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.CardinalSplitting +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.ClassTruncation +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.FiniteClassPrimality +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.FiniteClassReduction +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.IntegerPartSplitting +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.IrreducibilityTransfer +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.LimitTailPrimality +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.PrimalityTransfer +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Reduced +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.ReducedCharacterization +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.ReducedDivisibility +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.ReducedPrimality +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Reduction +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Refinement +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Refinement.CardinalGermRefinement +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Refinement.CardinalTruncationClosedClass +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Refinement.ClosedClassRefinementTransport +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Refinement.CompleteGermRefinement +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Refinement.ConvexRestrictionFactorization +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Refinement.FiniteGermError +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Refinement.LimitTailRefinement +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Refinement.SupportClassFactorization +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Refinement.SupportClassRefinement +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Refinement.TruncationIntegerPartFractionField +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.SplitTruncation +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Tests +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Tests.Assumptions +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Tests.Basic +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Tests.CardinalPrimalityTransfer +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Tests.CardinalProposition922 +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Tests.ClassTruncation +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Tests.FiniteClassReduction +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Tests.IntegerPartSplitting +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Tests.PrimalityTransfer +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Tests.Reduced +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Tests.ReducedCharacterization +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Tests.ReducedDivisibility +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Tests.Reduction +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Tests.SplitTruncation +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Tests.TruncationDivisibility +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Tests.TruncationPrimality +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.TruncationDivisibility +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.TruncationPrimality +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Iterate +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IterateOrderType +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.LimitTailQuotient +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Monomial +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Multiplicativity +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Negative +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.NegativeMonomialIdeal +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Nonpositive +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.NonpositiveCoefficientMap +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.NonpositiveDomainEquiv +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.NormalForm +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrderType +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrderedIntervalSum +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.BaseChange +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.CantorBendixsonGrading +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.CantorBendixsonRank +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.CantorBendixsonRepresentatives +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.CombinedCofactors +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.DerivAt +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.DerivAtInjective +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.DerivationIdeal +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.IdealFromTruncations +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.InductionOverDegrees +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.LeadingCoefficient +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.Lifts +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.LimitOrdinalRelationAtCutoff +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.LinearMaximal +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.LowDegreeParts +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.LoweringDerivation +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.OmegaSupport +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.OrdinalValueCutoffs +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.PartialDerivativeIndices +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.Partials +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.Pieces +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.Polynomiality +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.PrincipalGraded +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.PrincipalIdealGE +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.PrincipalRepresentatives +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.ProductCondition +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.ProductTruncation +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.ProductValues +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.RealPartials +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.SeriesTruncations +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.Shift +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.SuccessorLeibniz +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.SuccessorSupportBound +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.SumAlongCutoffs +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.SupportLoweringPieces +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.Syzygy +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.TruncationExpansion +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.TruncationPolynomial +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.TruncationsIdeal +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.UnboundedTruncations +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.CoefficientMap +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.ComplexityDecrease +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Convolution +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.ConvolutionList +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.ConvolutionRemainder +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.CriticalPoint +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.CriticalPointExistence +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.FormalExpression +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Germ +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.GermDegree +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.GermValueCut +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Irreducibility +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.LeibnizRemainder +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.MainLemma +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OneRow +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrderTypeMultiplicativity +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValue +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValueConstantMul +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValueDegree +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValueFinalSegment +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValueImage +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValueSubmultiplicative +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValueSupport +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValueValuation +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PowerRemainder +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalComponent +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalComponentDegree +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalComponentTensor +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalSubring +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalSubringFiniteSupport +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalSubringFraction +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalSubringFractionAlgebraic +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalSubringLocalization +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalSubringMonoidAlgebra +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalSubringScalarRedistributionProof +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalSubringTensor +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalValue +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PurePowerRemainder +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.ResidualPoint +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.ResidualPointCofinality +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.ResidualPointOrderType +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.ResidualPointSupport +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.ResidualPointTail +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.ResidualPointValue +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.ResidualPointWellOrdered +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.StableInterval +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Statements +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Statements.MainLemma +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Statements.OrdinalValueDegree +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Statements.ProductValue +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Statements.ResidualPoint +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Tests +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Tests.AlgebraicIndependence +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Tests.AlgebraicIndependence.BaseChange +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Tests.AlgebraicIndependence.CutoffConvolution +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Tests.AlgebraicIndependence.DerivAt +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Tests.AlgebraicIndependence.FinitePowerFamily +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Tests.AlgebraicIndependence.LoweringDerivation +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Tests.AlgebraicIndependence.OmegaOmegaBoundary +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Tests.AlgebraicIndependence.PrincipalGraded +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Tests.AlgebraicIndependence.PrincipalIdealGE +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Tests.AlgebraicIndependence.SuccessorLeibniz +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Tests.BerarducciPrimitives +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Tests.ComplexityDecrease +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Tests.Convolution +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Tests.ConvolutionList +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Tests.ConvolutionRemainder +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Tests.CriticalPoint +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Tests.OrdinalValueFinalSegment +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Tests.OrdinalValueSubmultiplicative +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Tests.PrincipalComponent +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Tests.PrincipalComponentDegree +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Tests.PrincipalComponentTensor +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Tests.PrincipalSubring +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Tests.PrincipalSubringFiniteSupport +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Tests.PrincipalSubringFraction +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Tests.PrincipalSubringTensor +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Tests.PrincipalValue +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Tests.ResidualPoint +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Tests.SectionSixThree +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Truncation +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.TruncationDrop +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.PolynomialAlgebra +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.PolynomialAlgebra.CompleteGerm +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.PolynomialAlgebra.CompleteGermOfCauchyComplete +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.PolynomialAlgebra.InitialForms +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.PolynomialAlgebra.PolynomialPresentation +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.PolynomialAlgebra.PolynomialRing +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.PolynomialAlgebra.Tests +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.PolynomialAlgebra.Tests.GCDMonoid +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.PolynomialAlgebra.Tests.PolynomialRing +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Primality +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Primality.Consequences +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Primality.DegreeOne +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Primality.GCDMonoid +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Primality.OrdinalValueQuotient +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Primality.Primality +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Primality.Random +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Primality.SupportOrderTypeFactorization +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.PrincipalAddition +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.RealSupportSupremum +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.SeparatedPieceSum +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.SeparatedSupport +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.SourceStatements +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.SubgroupAlgebra +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.SubgroupGCD +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.SubgroupSupport +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.SupportArchimedeanClasses +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.SupportSupremum +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Tests +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Tests.ArchimedeanSplitting +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Tests.CardinalTruncation +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Tests.FiniteSupportGCD +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Tests.FiniteSupportResidue +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Tests.FiniteSupportScalarExtension +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Tests.Fixtures +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Tests.Fixtures.ApproachZero +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Tests.Iterate +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Tests.Multiplicativity +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Tests.NegativePresentation +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Tests.NonpositiveDomainEquiv +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Tests.NormalForm +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Tests.OrderTypeDegree +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Tests.PrincipalAddition +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Tests.Truncation +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Tests.TruncationIntegerPartPrimal +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Tests.WeakNormalForm +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Translation +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Truncation +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.TruncationIntegerPartPrimal +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.WeakNormalForm +public import LeanPool.ConwayRefinement.ConwayRefinement.LinearAlgebra +public import LeanPool.ConwayRefinement.ConwayRefinement.LinearAlgebra.AlgebraicIndependentDet +public import LeanPool.ConwayRefinement.ConwayRefinement.LinearAlgebra.FiniteSpanRelation +public import LeanPool.ConwayRefinement.ConwayRefinement.LinearAlgebra.IndicatorFinsupp +public import LeanPool.ConwayRefinement.ConwayRefinement.LinearAlgebra.TensorProduct +public import LeanPool.ConwayRefinement.ConwayRefinement.LinearAlgebra.TensorProduct.Content +public import LeanPool.ConwayRefinement.ConwayRefinement.LinearAlgebra.TensorProduct.SubalgebraBasis +public import LeanPool.ConwayRefinement.ConwayRefinement.Order +public import LeanPool.ConwayRefinement.ConwayRefinement.Order.Archimedean +public import LeanPool.ConwayRefinement.ConwayRefinement.Order.DifferenceAvoidance +public import LeanPool.ConwayRefinement.ConwayRefinement.Order.Filter +public import LeanPool.ConwayRefinement.ConwayRefinement.Order.Filter.FunAtZeroMinus +public import LeanPool.ConwayRefinement.ConwayRefinement.Order.Filter.FunAtZeroMinus.Pointwise +public import LeanPool.ConwayRefinement.ConwayRefinement.Order.Filter.Germ +public import LeanPool.ConwayRefinement.ConwayRefinement.Order.Filter.Germ.LinearMap +public import LeanPool.ConwayRefinement.ConwayRefinement.Order.Filter.Tests +public import LeanPool.ConwayRefinement.ConwayRefinement.Order.Filter.Tests.FunAtZeroMinus +public import LeanPool.ConwayRefinement.ConwayRefinement.RingTheory +public import LeanPool.ConwayRefinement.ConwayRefinement.RingTheory.LaurentTower +public import LeanPool.ConwayRefinement.ConwayRefinement.RingTheory.LocalizationUFM +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.FinitePWOUnion +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.AdditivelyPrincipal +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.AlgebraicOrder +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.CantorBendixson +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.CantorTermCount +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.Degree +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.FinitePart +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.GeneralFactorization +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.IncreasingSequenceUnion +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.LeastTerm +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.LeastTermSup +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.MultiplicativelyPrincipal +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.NaturalOrder +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.NaturalPowerFactorization +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.NaturalPrincipal +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.OrderedUnion +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.PairBounds +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.Separation +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.SetOrderType +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.Split +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.SuccessorFactorization +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.Sumset +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.Tests +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.Tests.GeneralFactorization +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.Tests.NaturalPrincipal +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.Tests.OrderedUnion +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.Tests.OrdinalFactors +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.Tests.OrdinalFinitePart +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.Tests.OrdinalSuccessorFactorization +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.Tests.SetOrderType +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.Tests.Sumset +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.ZFC +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.ZFC.Game +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.ZFC.GameOperations +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.ZFC.Tests +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.ZFC.Tests.Game +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.ZFC.Tests.GameOperations +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.ConwayRefinement +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.ConwayRefinementProof +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Examples +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Examples.DegreeTwoPrime +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Examples.DegreeTwoPrimeProof +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Examples.FiniteDegreeFamily +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Examples.FiniteDegreeFamilyProof +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Examples.OmegaOmegaBoundary +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Examples.OmegaOmegaBoundaryProof +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Examples.OmegaRoots +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Examples.OmegaRootsProof +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Examples.OmnificFactorization +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Examples.OmnificFactorizationProof +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Examples.OneRowPrime +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Examples.OneRowPrimeProof +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.PrincipalRVAlgebraicIndependence +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.PrincipalRVAlgebraicIndependenceProof +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Support +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Support.ConwayNormalForm +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Support.ConwayRefinementConsequences +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Support.DegreeTwoExample +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Support.FinitePowerFamily +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Support.FinitePowerFamilyProof +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Support.OmegaOmegaBoundary +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Support.OmnificFactorizationProof +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Support.OmnificFiniteDegree +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Support.OmnificIntegers +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Support.OneRowExample +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Support.PrincipalRVAlgebraicIndependenceProof +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.CompleteHahnGerm +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.CompleteHahnGermProof +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.Examples +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.Examples.DegreeTwoPrime +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.Examples.DegreeTwoPrimeProof +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.Examples.HahnIntegerPartRefinementCriterion +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.Examples.HahnIntegerPartRefinementCriterionProof +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.Examples.NegativeMonomialRoots +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.Examples.NegativeMonomialRootsProof +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.GermPolynomialRing +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.GermPolynomialRingProof +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.HahnIntegerPartRefinement +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.HahnIntegerPartRefinementProof +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.HahnSeriesGCD +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.HahnSeriesGCDProof +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.HahnSeriesPolynomialRing +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.HahnSeriesPolynomialRingProof +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.InlineConwayRefinement +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.InlineConwayRefinementProof +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.Support +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.Support.ArchimedeanQuotient +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.Support.CompleteHahnGermProof +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.Support.ConvexQuotient +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.Support.ConvexQuotientSplitting +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.Support.ConwayRefinement +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.Support.ConwayRefinementProof +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.Support.GermPolynomialRingProof +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.Support.HahnIntegerPartRefinementProof +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.Support.HahnLimitTailQuotient +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.Support.HahnSeriesGCDProof +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.Support.HahnSeriesPolynomialRingProof +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.Support.InlineConwayRefinementProof +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.Support.InlineSurreal +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.Support.OrderedAddGroup +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.Support.SeriesConsequences +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.ArchimedeanAssumptions +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.Cardinal +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.CutFilling +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.HahnSeries +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.HahnSeries.CardinalIntegerPart +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.HahnSeries.Degree +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.HahnSeries.DegreeTransfer +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.HahnSeries.Full +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.HahnSeries.IntegerPart +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.HahnSeries.Multiplication +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.HahnSeries.NormalForm +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.HahnSeries.NormalFormAdd +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.HahnSeries.NormalFormBasic +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.HahnSeries.NormalFormMul +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.HahnSeries.NormalFormRecursion +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.HahnSeries.NormalFormSupport +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.HahnSeries.RealLeadingSplit +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.HahnSeries.SignedFull +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.HahnSeries.Tests +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.HahnSeries.Tests.CardinalIntegerPart +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.HahnSeries.Tests.DegreeTransfer +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.HahnSeries.Tests.Full +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.HahnSeries.Tests.Multiplication +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.HahnSeries.Tests.NormalForm +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.HahnSeries.Tests.NormalFormAdd +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.HahnSeries.Tests.NormalFormMul +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.HahnSeries.Transfer +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.OmnificInteger +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.OmnificInteger.Basic +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.OmnificInteger.NormalForm +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.OmnificInteger.Ordinal +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.OmnificInteger.Primality +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.OmnificInteger.Primality.FiniteClasses +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.OmnificInteger.Primality.IrreducibleOmnificIntegers +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.OmnificInteger.Primality.OmnificIntegers +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.OmnificInteger.Primality.OrdinaryIntegers +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.OmnificInteger.Primality.ZFC +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.OmnificInteger.Refinement +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.OmnificInteger.Refinement.ConwayRefinement +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.OmnificInteger.RefinementConjecture +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.OmnificInteger.Tests +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.OmnificInteger.Tests.Basic +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.OmnificInteger.Tests.ConwayRefinement +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.OmnificInteger.Tests.DegreeTwoOzPrime +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.OmnificInteger.Tests.FiniteClasses +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.OmnificInteger.Tests.NormalForm +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.OmnificInteger.Tests.ZFC +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.RationalTailQuotient +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.RealArchimedeanStratum +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.RealModule +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.Round +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.SmallDiscrete +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.Tests +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.Tests.ArchimedeanAssumptions +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.Tests.RealModule +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.ZFC +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.ZFC.Basic +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.ZFC.Cuts +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.ZFC.Identification +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.ZFC.NormalForm +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.ZFC.OmnificCodes +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.ZFC.OmnificInteger +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.ZFC.Properness +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.ZFC.Reduced +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.ZFC.Refinement +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.ZFC.Tests +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.ZFC.Tests.Cuts +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.ZFC.Tests.Identification +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.ZFC.Tests.NormalForm +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.ZFC.Tests.Properness +public import LeanPool.ConwayRefinement.ConwayRefinement.Tests +public import LeanPool.ConwayRefinement.ConwayRefinement.Tests.SourceIndex +public import LeanPool.ConwayRefinement.ConwayRefinement.Tests.UpstreamReuse +public import LeanPool.ConwayRefinement.ConwayRefinement.Topology +public import LeanPool.ConwayRefinement.ConwayRefinement.Topology.CantorBendixson +public import LeanPool.ConwayRefinement.ConwayRefinement.Topology.CantorBendixsonProduct +public import LeanPool.ConwayRefinement.ConwayRefinement.Topology.CantorBendixsonRank +public import LeanPool.ConwayRefinement.ConwayRefinement.Topology.CantorBendixsonReconstruction +public import LeanPool.ConwayRefinement.ConwayRefinement.Topology.Order +public import LeanPool.ConwayRefinement.ConwayRefinement.Topology.Order.ArchimedeanBallBase +public import LeanPool.ConwayRefinement.ConwayRefinement.Topology.Order.CantorBendixsonAddition +public import LeanPool.ConwayRefinement.ConwayRefinement.Topology.Order.CantorBendixsonConvexCover +public import LeanPool.ConwayRefinement.ConwayRefinement.Topology.Order.ClosedPWO +public import LeanPool.ConwayRefinement.ConwayRefinement.Topology.Order.CoinitialComplete +public import LeanPool.ConwayRefinement.ConwayRefinement.Topology.Order.LeftNeighborhood +public import LeanPool.ConwayRefinement.ConwayRefinement.Topology.Order.OrderedAddGroup +public import LeanPool.ConwayRefinement.ConwayRefinement.Topology.Order.OrderedIntervalFamily +public import LeanPool.ConwayRefinement.ConwayRefinement.Topology.Order.PWOAddition +public import LeanPool.ConwayRefinement.ConwayRefinement.Topology.Order.PWOAdditionFiber +public import LeanPool.ConwayRefinement.ConwayRefinement.Topology.Order.PWOSumset +public import LeanPool.ConwayRefinement.ConwayRefinement.Topology.Order.SeparatedPieceFamily +public import LeanPool.ConwayRefinement.ConwayRefinement.Topology.Order.SmallClosedSubspace +public import LeanPool.ConwayRefinement.ConwayRefinement.Topology.Order.Tests +public import LeanPool.ConwayRefinement.ConwayRefinement.Topology.Order.Tests.CantorBendixsonConvexCover +public import LeanPool.ConwayRefinement.ConwayRefinement.Topology.Order.Tests.PWOAddition +public import LeanPool.ConwayRefinement.ConwayRefinement.Topology.Tests +public import LeanPool.ConwayRefinement.ConwayRefinement.Topology.Tests.CantorBendixson +public import LeanPool.ConwayRefinement.Solution public import LeanPool.CramerWold public import LeanPool.CriticalPortraits public import LeanPool.CriticalPortraits.Census diff --git a/LeanPool/ConwayRefinement.lean b/LeanPool/ConwayRefinement.lean new file mode 100644 index 0000000000..7baa5faae1 --- /dev/null +++ b/LeanPool/ConwayRefinement.lean @@ -0,0 +1,20 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.Solution + +/-! +# Conway refinement for omnific integers + +Source: url:https://github.com/gaearon/conway-refinement +Authors: Dan Abramov +Status: verified +Main declarations: `ConwayRefinement.Palomar.conwayRefinement` +Tags: surreal-numbers, ordered-algebra, factorization +MSC: 06A05, 13F25 +-/ diff --git a/LeanPool/ConwayRefinement/CombinatorialGames.lean b/LeanPool/ConwayRefinement/CombinatorialGames.lean new file mode 100644 index 0000000000..1a8a6171a0 --- /dev/null +++ b/LeanPool/ConwayRefinement/CombinatorialGames.lean @@ -0,0 +1,15 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.CombinatorialGames.Game +public import LeanPool.ConwayRefinement.CombinatorialGames.Mathlib +public import LeanPool.ConwayRefinement.CombinatorialGames.NatOrdinal +public import LeanPool.ConwayRefinement.CombinatorialGames.Surreal +public import LeanPool.ConwayRefinement.CombinatorialGames.Tactic + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/CombinatorialGames/Game.lean b/LeanPool/ConwayRefinement/CombinatorialGames/Game.lean new file mode 100644 index 0000000000..cb0fc075f1 --- /dev/null +++ b/LeanPool/ConwayRefinement/CombinatorialGames/Game.lean @@ -0,0 +1,18 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.CombinatorialGames.Game.Basic +public import LeanPool.ConwayRefinement.CombinatorialGames.Game.Birthday +public import LeanPool.ConwayRefinement.CombinatorialGames.Game.Classes +public import LeanPool.ConwayRefinement.CombinatorialGames.Game.Functor +public import LeanPool.ConwayRefinement.CombinatorialGames.Game.IGame +public import LeanPool.ConwayRefinement.CombinatorialGames.Game.Ordinal +public import LeanPool.ConwayRefinement.CombinatorialGames.Game.Player +public import LeanPool.ConwayRefinement.CombinatorialGames.Game.Special + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/CombinatorialGames/Game/Basic.lean b/LeanPool/ConwayRefinement/CombinatorialGames/Game/Basic.lean new file mode 100644 index 0000000000..bf666a4dd5 --- /dev/null +++ b/LeanPool/ConwayRefinement/CombinatorialGames/Game/Basic.lean @@ -0,0 +1,362 @@ +/- +Copyright (c) 2025 Violeta Hernández Palacios. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: V.Hernández Palacios, R.Barton, M.Carneiro, I.Longbottom, K.Morrison, A.Nakade, Y.Zhao +-/ +module + +/- Full upstream author names: Violeta Hernández Palacios, Reid Barton, Mario Carneiro, Isabel +Longbottom, Kim Morrison, Apurva Nakade, Yuyang Zhao. -/ + +public import LeanPool.ConwayRefinement.CombinatorialGames.Game.Classes +public import Mathlib.Algebra.CharZero.Defs +public import Mathlib.Algebra.Order.Monoid.Defs + +import Mathlib.Algebra.Order.Ring.Cast +import Mathlib.Tactic.Abel + +/-! +# Combinatorial games + +In this file we construct the quotient of games `IGame` under equivalence, and prove that it forms +an `OrderedAddCommGroup`. We take advantage of this structure to prove two particularly tedious +theorems on `IGame`, namely `IGame.mul_add_equiv` and `IGame.mul_assoc_equiv`. + +It might be tempting to write `mk (x * y)` as `mk x * mk y`, but the latter is not well-defined, as +there exist `x₁ ≈ x₂` and `y₁ ≈ y₂` with `x₁ * y₁ ≉ x₂ * y₂`. See +`CombinatorialGames.Counterexamples.Multiplication` for a proof. +-/ + +universe u + +@[expose] public noncomputable section + +open IGame Set Pointwise + +/-- Games up to equivalence. + +If `x` and `y` are combinatorial games (`IGame`), we say that `x ≈ y` when both `x ≤ y` and `y ≤ x`. +Broadly, this means neither player has a preference in playing either game, as a component of a +larger game. This is the standard meaning of `x = y` in the literature, though it is not a strict +equality, e.g. `{0, 1 | 0}` and `{1 | 0}` are equivalent, but not identical as the former has an +extra move for Left. + +In particular, note that a `ConwayGame` has no well-defined notion of left and right options. +This means +you should prefer `IGame` when analyzing specific games. -/ +def ConwayGame : Type (u + 1) := + Antisymmetrization IGame (· ≤ ·) + +namespace ConwayGame + +/-- The quotient map from `IGame` into `ConwayGame`. -/ +def mk (x : IGame) : ConwayGame := Quotient.mk _ x +theorem mk_eq_mk {x y : IGame} : mk x = mk y ↔ x ≈ y := Quotient.eq + +alias ⟨_, mk_eq⟩ := mk_eq_mk + +@[cases_eliminator] +theorem ind {motive : ConwayGame → Prop} (mk : ∀ y, motive (mk y)) (x : ConwayGame) : motive x := + Quotient.ind mk x + +/-- Choose an element of the equivalence class using the axiom of choice. -/ +@[no_expose] def out (x : ConwayGame) : IGame := Quotient.out x +@[simp] theorem out_eq (x : ConwayGame) : mk x.out = x := Quotient.out_eq x + +theorem mk_out_equiv (x : IGame) : (mk x).out ≈ x := Quotient.mk_out (s := AntisymmRel.setoid ..) x +theorem equiv_mk_out (x : IGame) : x ≈ (mk x).out := (mk_out_equiv x).symm + +/-- Construct a `ConwayGame` from its left and right sets. + +Note that although this function is well-defined, this function isn't injective, nor do equivalence +classes in `ConwayGame` have a canonical representative. -/ +instance : OfSets ConwayGame.{u} fun _ ↦ True where + ofSets st _ := mk !{fun p ↦ out '' (st p)} + +theorem mk_ofSets' (st : Player → Set IGame.{u}) [Small.{u} (st left)] [Small.{u} (st right)] : + mk !{st} = !{fun p ↦ mk '' st p} := by + refine mk_eq <| IGame.equiv_of_exists ?_ ?_ ?_ ?_ <;> + simpa using fun a ha ↦ ⟨a, ha, equiv_mk_out a⟩ + +@[simp] +theorem mk_ofSets (s t : Set IGame.{u}) [Small.{u} s] [Small.{u} t] : + mk !{s | t} = !{mk '' s | mk '' t} := by + rw [mk_ofSets'] + simp_rw [Player.apply_cases] + +private theorem ofSets_cases (s t : Set ConwayGame.{u}) [Small.{u} s] [Small.{u} t] : + !{s | t} = mk !{out '' s | out '' t} := by + simp [mk_ofSets, image_image] + +instance : Zero ConwayGame := ⟨mk 0⟩ +instance : One ConwayGame := ⟨mk 1⟩ +instance : Add ConwayGame := ⟨Quotient.map₂ _ @add_congr⟩ +instance : Neg ConwayGame := ⟨Quotient.map _ @neg_congr⟩ +instance : PartialOrder ConwayGame := inferInstanceAs (PartialOrder (Antisymmetrization ..)) +instance : Inhabited ConwayGame := ⟨0⟩ + +instance : AddCommGroupWithOne ConwayGame where + zero_add := by rintro ⟨x⟩; exact congr(mk $(zero_add _)) + add_zero := by rintro ⟨x⟩; exact congr(mk $(add_zero _)) + add_comm := by rintro ⟨x⟩ ⟨y⟩; exact congr(mk $(add_comm _ _)) + add_assoc := by rintro ⟨x⟩ ⟨y⟩ ⟨z⟩; exact congr(mk $(add_assoc _ _ _)) + neg_add_cancel := by rintro ⟨a⟩; exact mk_eq (neg_add_equiv _) + nsmul := nsmulRec + zsmul := zsmulRec + +instance : IsOrderedAddMonoid ConwayGame where + add_le_add_left := by rintro ⟨a⟩ ⟨b⟩ h ⟨c⟩; exact add_le_add_left (α := IGame) h _ + +instance : RatCast ConwayGame where + ratCast q := mk q + +@[simp] theorem mk_zero : mk 0 = 0 := rfl +@[simp] theorem mk_one : mk 1 = 1 := rfl +@[simp] theorem mk_add (x y : IGame) : mk (x + y) = mk x + mk y := rfl +@[simp] theorem mk_neg (x : IGame) : mk (-x) = -mk x := rfl +@[simp] theorem mk_sub (x y : IGame) : mk (x - y) = mk x - mk y := rfl + +theorem mk_mulOption (x y a b : IGame) : + mk (mulOption x y a b) = mk (a * y) + mk (x * b) - mk (a * b) := + rfl + +@[simp] theorem mk_le_mk {x y : IGame} : mk x ≤ mk y ↔ x ≤ y := .rfl +@[simp] theorem mk_lt_mk {x y : IGame} : mk x < mk y ↔ x < y := .rfl +@[simp] theorem mk_fuzzy_mk {x y : IGame} : mk x ‖ mk y ↔ x ‖ y := .rfl + +@[simp, norm_cast] +theorem mk_natCast : ∀ n : ℕ, mk n = n + | 0 => rfl + | n + 1 => by rw [Nat.cast_add, Nat.cast_add, mk_add, mk_natCast]; rfl + +@[simp, norm_cast] +theorem mk_intCast (n : ℤ) : mk n = n := by + cases n <;> simp + +@[simp, norm_cast] theorem mk_ratCast (q : ℚ) : mk q = q := rfl +@[simp, norm_cast] theorem ratCast_neg (q : ℚ) : ((-q : ℚ) : ConwayGame) = -q := by + simp [← mk_ratCast] + +theorem zero_def : (0 : ConwayGame) = !{fun _ ↦ ∅} := by apply (mk_ofSets' ..).trans; simp +theorem one_def : (1 : ConwayGame) = !{{0} | ∅} := by apply (mk_ofSets ..).trans; simp + +instance : ZeroLEOneClass ConwayGame where + zero_le_one := zero_le_one (α := IGame) + +instance : NeZero (1 : ConwayGame) where + out := by apply ne_of_gt; exact IGame.zero_lt_one + +instance : Nontrivial ConwayGame := ⟨_, _, zero_ne_one⟩ +instance : CharZero ConwayGame := AddMonoidWithOne.toCharZero + +theorem mk_mul_add (x y z : IGame) : mk (x * (y + z)) = mk (x * y) + mk (x * z) := by + rw [← mk_add, add_eq' (x * y), mul_eq'] + simp only [moves_add, moves_mul, prod_union, union_assoc, image_image, image_union, mk_ofSets'] + congr! 2 + ext p + nth_rewrite 2 [union_left_comm] + congrm _ ∈ ?_ ∪ (?_ ∪ (?_ ∪ ?_)) + all_goals + ext + simp only [mulOption, mk_sub, mk_add, mem_image, mem_prod, and_assoc, Prod.exists, + exists_and_left, exists_exists_and_eq_and] + iterate 2 (congr! 2; rw [and_congr_right_iff]; intros) + congr! 1 + rw [mk_mul_add, mk_mul_add, mk_mul_add] + abel +termination_by (x, y, z) +decreasing_by igame_wf + +theorem mk_mul_sub (x y z : IGame) : mk (x * (y - z)) = mk (x * y) - mk (x * z) := by + simpa [sub_eq_add_neg] using mk_mul_add x y (-z) + +theorem mk_add_mul (x y z : IGame) : mk ((x + y) * z) = mk (x * z) + mk (y * z) := by + rw [mul_comm, mk_mul_add, mul_comm, mul_comm z] + +theorem mk_sub_mul (x y z : IGame) : mk ((x - y) * z) = mk (x * z) - mk (y * z) := by + simpa [sub_eq_add_neg] using mk_add_mul x (-y) z + +theorem mk_mul_assoc (x y z : IGame) : mk (x * y * z) = mk (x * (y * z)) := by + induction x using IGame.ofSetsRecOn generalizing y z with | ofSets xL xR ihxl ihxr + induction y using IGame.ofSetsRecOn generalizing z with | ofSets yL yR ihyl ihyr + induction z using IGame.ofSetsRecOn with | ofSets zL zR ihzl ihzr + simp_rw [ofSets_mul_ofSets, mk_ofSets, Set.image_union, Set.image_image, mk_mulOption, + ← Set.image_union, ← ofSets_mul_ofSets, + Set.prod_image_left, Set.prod_image_right, Set.union_prod, Set.prod_union, + ← Equiv.prod_assoc_image, ← Set.image_union, Set.image_image, Equiv.prodAssoc_apply] + have e1 : (xL ×ˢ yL) ×ˢ zL ∪ (xR ×ˢ yR) ×ˢ zL ∪ ((xL ×ˢ yR) ×ˢ zR ∪ (xR ×ˢ yL) ×ˢ zR) = + (xL ×ˢ yL) ×ˢ zL ∪ (xL ×ˢ yR) ×ˢ zR ∪ ((xR ×ˢ yL) ×ˢ zR ∪ (xR ×ˢ yR) ×ˢ zL) := by + ac_rfl + have e2 : (xL ×ˢ yL) ×ˢ zR ∪ (xR ×ˢ yR) ×ˢ zR ∪ ((xL ×ˢ yR) ×ˢ zL ∪ (xR ×ˢ yL) ×ˢ zL) = + (xL ×ˢ yL) ×ˢ zR ∪ (xL ×ˢ yR) ×ˢ zL ∪ ((xR ×ˢ yL) ×ˢ zL ∪ (xR ×ˢ yR) ×ˢ zR) := by + ac_rfl + simp only [e1, e2] + congrm !{?_ | ?_} <;> + · refine Set.image_congr fun ⟨⟨x, y⟩, z⟩ hxyz => ?_ + obtain ⟨hx, hy, hz⟩ : (x ∈ xL ∨ x ∈ xR) ∧ (y ∈ yL ∨ y ∈ yR) ∧ (z ∈ zL ∨ z ∈ zR) := by + simp only [mem_union, mem_prod] at hxyz + tauto + simp only [mulOption, mk_sub_mul, mk_add_mul, mk_mul_sub, mk_mul_add, + hx.elim (ihxl x) (ihxr x), hy.elim (ihyl y) (ihyr y), hz.elim (ihzl z) (ihzr z)] + abel + +theorem lf_ofSets_of_mem_left {s t : Set ConwayGame.{u}} [Small.{u} s] [Small.{u} t] + {x : ConwayGame.{u}} + (h : x ∈ s) : x ⧏ !{s | t} := by + rw [ofSets_cases] + have : x.out ∈ !{out '' s | out '' t}ᴸ := by simpa using mem_image_of_mem _ h + simpa [← mk_le_mk] using left_lf this + +theorem ofSets_lf_of_mem_right {s t : Set ConwayGame.{u}} [Small.{u} s] [Small.{u} t] + {x : ConwayGame.{u}} + (h : x ∈ t) : !{s | t} ⧏ x := by + rw [ofSets_cases] + have : x.out ∈ !{out '' s | out '' t}ᴿ := by simpa using mem_image_of_mem _ h + simpa [← mk_le_mk] using lf_right this + +end ConwayGame + +namespace IGame + +protected theorem sub_le_iff_le_add {x y z : IGame} : x - z ≤ y ↔ x ≤ y + z := + @sub_le_iff_le_add ConwayGame _ _ _ (.mk x) (.mk y) (.mk z) + +protected theorem le_sub_iff_add_le {x y z : IGame} : x ≤ z - y ↔ x + y ≤ z := + @le_sub_iff_add_le ConwayGame _ _ _ (.mk x) (.mk y) (.mk z) + +protected theorem sub_lt_iff_lt_add {x y z : IGame} : x - z < y ↔ x < y + z := + @sub_lt_iff_lt_add ConwayGame _ _ _ (.mk x) (.mk y) (.mk z) + +protected theorem lt_sub_iff_add_lt {x y z : IGame} : x < z - y ↔ x + y < z := + @lt_sub_iff_add_lt ConwayGame _ _ _ (.mk x) (.mk y) (.mk z) + +protected theorem sub_nonneg {x y : IGame} : 0 ≤ x - y ↔ y ≤ x := + @sub_nonneg ConwayGame _ _ _ (.mk x) (.mk y) + +protected theorem sub_nonpos {x y : IGame} : x - y ≤ 0 ↔ x ≤ y := + @sub_nonpos ConwayGame _ _ _ (.mk x) (.mk y) + +protected theorem sub_pos {x y : IGame} : 0 < x - y ↔ y < x := + @sub_pos ConwayGame _ _ _ (.mk x) (.mk y) + +protected theorem sub_neg {x y : IGame} : x - y < 0 ↔ x < y := + @sub_neg ConwayGame _ _ _ (.mk x) (.mk y) + +theorem mul_add_equiv (x y z : IGame) : x * (y + z) ≈ x * y + x * z := + ConwayGame.mk_eq_mk.1 (ConwayGame.mk_mul_add x y z) + +theorem mul_sub_equiv (x y z : IGame) : x * (y - z) ≈ x * y - x * z := + ConwayGame.mk_eq_mk.1 (ConwayGame.mk_mul_sub x y z) + +theorem add_mul_equiv (x y z : IGame) : (x + y) * z ≈ x * z + y * z := + ConwayGame.mk_eq_mk.1 (ConwayGame.mk_add_mul x y z) + +theorem sub_mul_equiv (x y z : IGame) : (x - y) * z ≈ x * z - y * z := + ConwayGame.mk_eq_mk.1 (ConwayGame.mk_sub_mul x y z) + +theorem mul_assoc_equiv (x y z : IGame) : x * y * z ≈ x * (y * z) := + ConwayGame.mk_eq_mk.1 (ConwayGame.mk_mul_assoc x y z) + +@[simp, norm_cast] +theorem natCast_le {m n : ℕ} : (m : IGame) ≤ n ↔ m ≤ n := by + simp [← ConwayGame.mk_le_mk] + +@[simp, norm_cast] +theorem natCast_lt {m n : ℕ} : (m : IGame) < n ↔ m < n := by + simp [← ConwayGame.mk_lt_mk] + +@[simp] +theorem natCast_nonneg (n : ℕ) : 0 ≤ (n : IGame) := + natCast_le.2 n.zero_le + +theorem natCast_strictMono : StrictMono ((↑) : ℕ → IGame) := + fun _ _ h ↦ natCast_lt.2 h + +instance : CharZero IGame where + cast_injective := natCast_strictMono.injective + +@[simp, norm_cast] +theorem natCast_equiv {m n : ℕ} : (m : IGame) ≈ n ↔ m = n := by + simp [AntisymmRel, le_antisymm_iff] + +@[simp, norm_cast] +theorem intCast_le {m n : ℤ} : (m : IGame) ≤ n ↔ m ≤ n := by + simp [← ConwayGame.mk_le_mk] + +@[simp, norm_cast] +theorem intCast_lt {m n : ℤ} : (m : IGame) < n ↔ m < n := by + simp [← ConwayGame.mk_lt_mk] + +theorem intCast_strictMono : StrictMono ((↑) : ℤ → IGame) := + fun _ _ h ↦ intCast_lt.2 h + +@[simp, norm_cast] +theorem intCast_inj {m n : ℤ} : (m : IGame) = n ↔ m = n := + intCast_strictMono.injective.eq_iff + +@[simp, norm_cast] +theorem intCast_equiv {m n : ℤ} : (m : IGame) ≈ n ↔ m = n := by + simp [AntisymmRel, le_antisymm_iff] + +theorem intCast_add_equiv (m n : ℤ) : ((m + n : ℤ) : IGame) ≈ m + n := by + simp [← ConwayGame.mk_eq_mk] + +theorem intCast_sub_equiv (m n : ℤ) : ((m - n : ℤ) : IGame) ≈ m - n := by + simp [← ConwayGame.mk_eq_mk] + +@[simp, norm_cast] +theorem zero_lt_intCast {n : ℤ} : 0 < (n : IGame) ↔ 0 < n := by + simpa using intCast_lt (m := 0) + +@[simp, norm_cast] +theorem intCast_lt_zero {n : ℤ} : (n : IGame) < 0 ↔ n < 0 := by + simpa using intCast_lt (n := 0) + +@[simp, norm_cast] +theorem zero_le_intCast {n : ℤ} : 0 ≤ (n : IGame) ↔ 0 ≤ n := by + simpa using intCast_le (m := 0) + +@[simp, norm_cast] +theorem intCast_le_zero {n : ℤ} : (n : IGame) ≤ 0 ↔ n ≤ 0 := by + simpa using intCast_le (n := 0) + +namespace Impartial +variable (x y : IGame) [hx : Impartial x] [hy : Impartial y] + +@[simp] +theorem neg_mk : -ConwayGame.mk x = ConwayGame.mk x := + ConwayGame.mk_eq (equiv_neg x).symm + +@[simp] +theorem sub_mk (x : ConwayGame) : x - ConwayGame.mk y = x + ConwayGame.mk y := by + rw [sub_eq_add_neg, neg_mk] + +@[simp] +theorem mk_add_self : ConwayGame.mk x + ConwayGame.mk x = 0 := by + rw [add_eq_zero_iff_neg_eq, neg_mk] + +-- TODO: move these four lemmas earlier: + +theorem add_self_equiv (x : IGame) [Impartial x] : x + x ≈ 0 := + ConwayGame.mk_eq_mk.1 (mk_add_self x) + +variable {x y} + +omit hx in +/-- This lemma doesn't require `x` to be impartial. -/ +theorem equiv_iff_add_equiv_zero : x ≈ y ↔ x + y ≈ 0 := by + rw [← ConwayGame.mk_eq_mk, ← ConwayGame.mk_eq_mk, + ConwayGame.mk_add, ConwayGame.mk_zero, + add_eq_zero_iff_eq_neg, neg_mk] + +omit hy in +/-- This lemma doesn't require `y` to be impartial. -/ +theorem equiv_iff_add_equiv_zero' : x ≈ y ↔ x + y ≈ 0 := by + rw [antisymmRel_comm, add_comm, equiv_iff_add_equiv_zero] + +theorem fuzzy_iff_add_fuzzy_zero : x ‖ y ↔ x + y ‖ 0 := by + simpa using (@equiv_iff_add_equiv_zero x y).not + +end Impartial +end IGame +end diff --git a/LeanPool/ConwayRefinement/CombinatorialGames/Game/Birthday.lean b/LeanPool/ConwayRefinement/CombinatorialGames/Game/Birthday.lean new file mode 100644 index 0000000000..9d47c78928 --- /dev/null +++ b/LeanPool/ConwayRefinement/CombinatorialGames/Game/Birthday.lean @@ -0,0 +1,422 @@ +/- +Copyright (c) 2022 Violeta Hernández Palacios. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Violeta Hernández Palacios +-/ +module + +public import LeanPool.ConwayRefinement.CombinatorialGames.Game.Ordinal +public import LeanPool.ConwayRefinement.CombinatorialGames.Game.Special + +import Mathlib.Algebra.Order.Group.OrderIso +import Mathlib.Data.Fintype.Order +import Mathlib.Data.Set.Finite.Lattice + +/-! +# Birthdays of games + +There are two related but distinct notions of a birthday within combinatorial game theory. One is +the birthday of an `IGame`, which represents the "step" at which it is constructed. We define it +recursively as the least ordinal larger than the birthdays of its left and right options. On the +other hand, the birthday of a `ConwayGame` is the smallest birthday among all `IGame`s that +quotient to +it. + +The birthday of an `IGame` can be understood as representing the depth of its game tree. Meanwhile, +the birthday of a `ConwayGame` more closely matches Conway's original description. The lemma +`ConwayGame.birthday_eq_iGameBirthday` links both definitions together. +-/ + +universe u + +open NatOrdinal Order Set + +/-! ### Stuff for Mathlib -/ + +private theorem ciSup_eq_bot {α : Type*} {ι : Sort*} [ConditionallyCompleteLinearOrderBot α] + {f : ι → α} + (hf : BddAbove (range f)) : ⨆ i, f i = ⊥ ↔ ∀ i, f i = ⊥ := by + simpa using ciSup_le_iff' hf (a := ⊥) + +/-! ### `IGame` birthday -/ + +public noncomputable section + +namespace IGame + +/-- The birthday of an `IGame` is inductively defined as the least strict upper bound of the +birthdays of its options. It may be thought as the "step" in which a certain game is constructed. -/ +def birthday (x : IGame.{u}) : NatOrdinal.{u} := + ⨆ p, ⨆ y : x.moves p, succ (birthday y) +termination_by x +decreasing_by igame_wf + +theorem lt_birthday_iff {x : IGame} {o : NatOrdinal} : o < x.birthday ↔ + ∃ p y, y ∈ x.moves p ∧ o ≤ y.birthday := by + rw [birthday] + simp [NatOrdinal.lt_iSup_iff] + +theorem birthday_le_iff {x : IGame} {o : NatOrdinal} : x.birthday ≤ o ↔ + ∀ p, ∀ y ∈ x.moves p, y.birthday < o := by + simpa using lt_birthday_iff.not + +theorem birthday_eq_max (x : IGame) : birthday x = + max (⨆ y : xᴸ, succ y.1.birthday) (⨆ y : xᴿ, succ y.1.birthday) := by + apply eq_of_forall_lt_iff + simp [lt_birthday_iff, NatOrdinal.lt_iSup_iff] + +@[aesop apply safe] +theorem birthday_lt_of_mem_moves {p : Player} {x y : IGame} (hy : y ∈ x.moves p) : + y.birthday < x.birthday := + lt_birthday_iff.2 ⟨p, y, hy, le_rfl⟩ + +theorem birthday_lt_of_subposition {x y : IGame} (hy : Subposition y x) : + y.birthday < x.birthday := by + induction x using moveRecOn with | ind x ih + obtain ⟨p, z, hz, hy⟩ := subposition_iff_exists.1 hy + obtain rfl | hy := wsubposition_iff_eq_or_subposition.1 hy + · exact birthday_lt_of_mem_moves hz + · exact (ih p z hz hy).trans (birthday_lt_of_mem_moves hz) + +theorem birthday_ofSets (s t : Set IGame.{u}) [Small.{u} s] [Small.{u} t] : + birthday !{s | t} = max (sSup (succ ∘ birthday '' s)) (sSup (succ ∘ birthday '' t)) := by + rw [birthday_eq_max, leftMoves_ofSets, rightMoves_ofSets] + simp [iSup, image_eq_range] + +theorem birthday_ofSets_const (s : Set IGame.{u}) [Small.{u} s] : + birthday !{fun _ ↦ s} = sSup (succ ∘ birthday '' s) := by + rw [ofSets_eq_ofSets_cases, birthday_ofSets, max_self] + +@[simp] +theorem birthday_eq_zero {x : IGame} : birthday x = 0 ↔ x = 0 := by + rw [birthday] + simp [iSup_eq_zero_iff, IGame.ext_iff, eq_empty_iff_forall_notMem] + +@[simp] theorem birthday_zero : birthday 0 = 0 := by simp +@[simp] theorem birthday_one : birthday 1 = 1 := by rw [one_def, birthday_ofSets]; simp +@[simp] theorem birthday_star : birthday ⋆ = 1 := by rw [star, birthday_ofSets_const]; simp + +@[simp] +theorem birthday_half : birthday ½ = 2 := by + rw [half, birthday_ofSets] + simpa using one_add_one_eq_two + +@[simp] +theorem birthday_up : birthday ↑ = 2 := by + rw [up, birthday_ofSets] + simpa using one_add_one_eq_two + +@[simp] +theorem birthday_down : birthday ↓ = 2 := by + rw [down, birthday_ofSets] + simpa using one_add_one_eq_two + +@[simp] +theorem birthday_neg (x : IGame) : (-x).birthday = x.birthday := by + refine eq_of_forall_lt_iff fun y ↦ ?_ + simp_rw [lt_birthday_iff, exists_moves_neg, Player.exists] + rw [or_comm] + congr! 3 + all_goals + dsimp; rw [and_congr_right] + intro h + rw [birthday_neg] +termination_by x +decreasing_by igame_wf + +@[simp] +theorem birthday_toIGame (o : NatOrdinal) : o.toIGame.birthday = o := by + rw [toIGame_def, birthday_ofSets, image_empty, csSup_empty, max_bot_right, image_image] + conv_rhs => rw [← iSup_succ o, iSup] + simp_rw [Function.comp_apply, ← image_eq_range] + congr! + rw [birthday_toIGame] +termination_by o + +theorem le_toIGame_birthday (x : IGame) : x ≤ x.birthday.toIGame := by + rw [le_iff_forall_lf] + refine ⟨fun y hy ↦ ((le_toIGame_birthday y).trans_lt ?_).not_ge, ?_⟩ + · simpa using birthday_lt_of_mem_moves hy + · simp +termination_by x +decreasing_by igame_wf + +theorem neg_toIGame_birthday_le (x : IGame) : -x.birthday.toIGame ≤ x := by + simpa [IGame.neg_le] using le_toIGame_birthday (-x) + +/-- A game without right options is equivalent to an ordinal. -/ +theorem equiv_ordinal_of_right_eq_empty {x : IGame} (hx : xᴿ = ∅) : + ∃ o : NatOrdinal, x ≈ o := by + obtain ⟨o, ho, ho'⟩ := wellFounded_lt.has_min {o : NatOrdinal | x ≤ o} ⟨_, x.le_toIGame_birthday⟩ + use o + apply equiv_of_forall_lf + · exact fun a ha ha' ↦ left_lf ha <| ho.trans ha' + · simp [hx] + · rw [forall_leftMoves_toIGame] + exact fun a ha ha' ↦ ho' _ ha' ha + · simp + +/-- A game without left options is equivalent to the negative of an ordinal. -/ +theorem equiv_neg_ordinal_of_left_eq_empty {x : IGame} (hx : xᴸ = ∅) : + ∃ o : NatOrdinal, x ≈ -o := by + simpa [hx, ← IGame.neg_equiv] using equiv_ordinal_of_right_eq_empty (x := -x) + +@[simp] +theorem birthday_add (x y : IGame) : (x + y).birthday = x.birthday + y.birthday := by + refine eq_of_forall_lt_iff fun o ↦ ?_ + simp_rw [lt_add_iff, lt_birthday_iff, Player.exists, exists_moves_add, + or_and_right, exists_or, or_or_or_comm] + congr! 2 + all_goals + constructor + · rintro ⟨z, hz, hz'⟩ + refine ⟨_, ⟨z, hz, le_rfl⟩, ?_⟩ + rwa [← birthday_add] + · rintro ⟨a, ⟨⟨z, hz, hz'⟩, ha⟩⟩ + use z, hz + rw [birthday_add] + apply ha.trans + first | exact add_le_add_left hz' _ | exact add_le_add_right hz' _ +termination_by (x, y) +decreasing_by igame_wf + +@[simp] +theorem birthday_sub (x y : IGame) : (x - y).birthday = x.birthday + y.birthday := by + simp [sub_eq_add_neg] + +@[simp, norm_cast] +theorem birthday_natCast : ∀ n : ℕ, birthday n = n + | 0 => birthday_zero + | n + 1 => by simp_rw [Nat.cast_add_one, birthday_add, birthday_natCast, birthday_one] + +@[simp] +theorem birthday_ofNat (n : ℕ) [n.AtLeastTwo] : birthday ofNat(n) = n := + birthday_natCast n + +@[simp] +theorem birthday_tiny (x : IGame) : (⧾x).birthday = x.birthday + 2 := by + simp [tiny, Order.succ_eq_add_one, birthday_ofSets, ← one_add_one_eq_two, ← add_assoc] + +@[simp] +theorem birthday_miny (x : IGame) : (⧿x).birthday = x.birthday + 2 := by + rw [← neg_tiny, birthday_neg, birthday_tiny] + +/-- Games with a bounded birthday form a small set. -/ +instance small_setOf_birthday_lt (o : NatOrdinal.{u}) : Small.{u} {x | birthday x < o} := by + induction o using SuccOrder.prelimitRecOn with + | succ o _ ih => + apply small_subset + (s := range fun s : Set {x | birthday x < o} × Set {x | birthday x < o} ↦ + (!{s.1 | ↑s.2} : IGame)) + refine fun x hx ↦ ⟨((↑) ⁻¹' xᴸ, (↑) ⁻¹' xᴿ), ?_⟩ + simp_rw [lt_succ_iff, birthday_le_iff] at hx + ext p; cases p <;> simp_all + | isSuccPrelimit o ho ih => + convert @small_biUnion _ _ (Iio o) _ (fun i _ => {x : IGame.{u} | x.birthday < i}) ih + ext x + simpa [Set.nonempty_def, and_comm] using ho.lt_iff_nonempty_Ioo + +/-- Games with a bounded birthday form a small set. -/ +instance small_setOf_birthday_le (o : NatOrdinal.{u}) : Small.{u} {x | birthday x ≤ o} := by + convert small_setOf_birthday_lt (succ o) using 1 + simp + +/-- A variant of `small_setOf_birthday_le` in simp-normal form -/ +instance small_subtype_birthday_le (o : NatOrdinal.{u}) : Small.{u} {x // birthday x ≤ o} := + small_setOf_birthday_le o + +/-- A variant of `small_setOf_birthday_lt` in simp-normal form -/ +instance small_subtype_birthday_lt (o : NatOrdinal.{u}) : Small.{u} {x // birthday x < o} := + small_setOf_birthday_lt o + +/-! #### Short games -/ + +/-- The finset of all games with birthday ≤ n. -/ +noncomputable def birthdayFinset : ℕ → Finset IGame.{u} + | 0 => {0} + | n + 1 => ((birthdayFinset n).powerset ×ˢ (birthdayFinset n).powerset).map + ⟨fun a => !{a.1 | a.2}, fun a b hab => by aesop⟩ + +theorem mem_birthdayFinset_succ {x : IGame} {n : ℕ} : x ∈ birthdayFinset (n + 1) ↔ + ∃ l r, (l ⊆ birthdayFinset n ∧ r ⊆ birthdayFinset n) ∧ !{l | r} = x := by + simp [birthdayFinset] + rfl + +@[simp] theorem birthdayFinset_zero : birthdayFinset 0 = {0} := (rfl) + +theorem birthdayFinset_one : + birthdayFinset 1 = ⟨[0, 1, -1, ⋆], by aesop (add simp [IGame.ext_iff])⟩ := by + ext + rw [mem_birthdayFinset_succ] + aesop (add simp [IGame.ext_iff]) + +@[simp] +theorem card_birthdayFinset (n : ℕ) : + (birthdayFinset.{u} (n + 1)).card = 4 ^ (birthdayFinset.{u} n).card := by + rw [birthdayFinset, Finset.card_map, Finset.card_product, Finset.card_powerset, ← mul_pow] + rfl + +theorem mem_birthdayFinset_of_mem_moves {p : Player} {x y : IGame} + {n : ℕ} (hnx : x ∈ birthdayFinset (n + 1)) (hy : y ∈ x.moves p) : y ∈ birthdayFinset n := by + rw [mem_birthdayFinset_succ] at hnx + aesop + +@[simp] +theorem mem_birthdayFinset {x : IGame} {n : ℕ} : x ∈ birthdayFinset n ↔ x.birthday ≤ n := by + induction n generalizing x with + | zero => simp + | succ n IH => + simp_rw [mem_birthdayFinset_succ, birthday_le_iff, Finset.subset_iff, Nat.cast_add_one, + ← succ_eq_add_one, lt_succ_iff, IH] + constructor + · aesop + · intro p + have hx (p) : x.moves p ⊆ birthdayFinset n := by cases p <;> simp_all [subset_def] + classical have (p : Player) := Set.fintypeSubset _ (hx p) + use xᴸ.toFinset, xᴿ.toFinset + aesop + +theorem strictMono_birthdayFinset : StrictMono birthdayFinset := by + refine strictMono_nat_of_lt_succ fun n ↦ ⟨fun y hy ↦ ?_, fun h ↦ ?_⟩ + · rw [mem_birthdayFinset] at * + apply hy.trans + simp + · have := Finset.card_le_card h + rw [card_birthdayFinset] at this + exact (Nat.lt_pow_self (Nat.one_lt_succ_succ 2)).not_ge this + +theorem short_iff_birthday_finite {x : IGame} : x.Short ↔ x.birthday < of .omega0 := by + refine ⟨fun h ↦ ?_, ?_⟩ + · have (p : Player) (y : x.moves p) : ∃ n : ℕ, birthday y = n := by + rw [← NatOrdinal.lt_omega0, ← short_iff_birthday_finite] + exact .of_mem_moves y.2 + choose f hf using this + obtain ⟨n, hn⟩ := (finite_iUnion fun p => finite_range (f p)).exists_le + apply lt_of_le_of_lt _ (NatOrdinal.natCast_lt_omega0 (n + 1)) + rw [birthday_le_iff, Nat.cast_add_one, ← succ_eq_add_one] + aesop + · rw [NatOrdinal.lt_omega0, short_iff_finite_setOf_subposition] + intro ⟨n, hn⟩ + apply (birthdayFinset n).finite_toSet.subset fun y hy ↦ ?_ + simpa using (birthday_lt_of_subposition hy).le.trans_eq hn +termination_by x +decreasing_by igame_wf + +theorem Short.birthday_lt_omega0 (x : IGame) [Short x] : birthday x < of .omega0 := + short_iff_birthday_finite.1 ‹_› + +end IGame + +/-! ### `ConwayGame` birthday -/ + +namespace ConwayGame + +/-- The birthday of a game is defined as the least birthday among all pre-games that define it. -/ +noncomputable def birthday (x : ConwayGame.{u}) : NatOrdinal.{u} := + sInf (IGame.birthday '' (mk ⁻¹' {x})) + +theorem birthday_eq_iGameBirthday (x : ConwayGame) : + ∃ y : IGame, ConwayGame.mk y = x ∧ y.birthday = birthday x := by + refine csInf_mem (image_nonempty.2 ?_) + exact ⟨_, x.out_eq⟩ + +theorem birthday_mk_le (x : IGame) : birthday (mk x) ≤ x.birthday := + csInf_le' ⟨x, rfl, rfl⟩ + +theorem le_birthday_iff {x : ConwayGame} {o : NatOrdinal} : + o ≤ x.birthday ↔ ∀ y, mk y = x → o ≤ y.birthday := + ⟨fun hx y hy => hx.trans (hy ▸ (birthday_mk_le y)), + fun h => (birthday_eq_iGameBirthday x).elim fun y hy => (h y hy.1).trans_eq hy.2⟩ + +@[simp] +theorem birthday_zero : birthday 0 = 0 := by + simpa using birthday_mk_le 0 + +@[simp] +theorem birthday_eq_zero {x : ConwayGame} : birthday x = 0 ↔ x = 0 := by + obtain ⟨_, _, _⟩ := birthday_eq_iGameBirthday x + refine ⟨fun _ ↦ ?_, ?_⟩ <;> simp_all + +private theorem birthday_neg_le (x : ConwayGame) : (-x).birthday ≤ x.birthday := by + obtain ⟨y, hy, hy'⟩ := birthday_eq_iGameBirthday x + rw [← hy', ← hy] + apply (birthday_mk_le _).trans + rw [IGame.birthday_neg] + +@[simp] +theorem birthday_neg (x : ConwayGame) : (-x).birthday = x.birthday := by + apply (birthday_neg_le x).antisymm + simpa using birthday_neg_le (-x) + +theorem le_toGame_birthday (x : ConwayGame) : x ≤ x.birthday.toGame := by + obtain ⟨y, hy, hy'⟩ := birthday_eq_iGameBirthday x + rw [← hy', ← hy] + exact y.le_toIGame_birthday + +theorem neg_toGame_birthday_le (x : ConwayGame) : -x.birthday.toGame ≤ x := by + simpa [neg_le] using le_toGame_birthday (-x) + +@[simp] +theorem birthday_toGame (o : NatOrdinal) : birthday o.toGame = o := by + apply le_antisymm + · simpa using birthday_mk_le o.toIGame + · simpa using o.toGame.le_toGame_birthday + +@[simp, norm_cast] +theorem birthday_natCast (n : ℕ) : birthday n = n := by + simpa using birthday_toGame n + +@[simp] +theorem birthday_ofNat (n : ℕ) [n.AtLeastTwo] : birthday ofNat(n) = n := + birthday_natCast n + +@[simp] +theorem birthday_one : birthday 1 = 1 := by + simpa using birthday_natCast 1 + +@[simp] +theorem birthday_star : birthday (ConwayGame.mk ⋆) = 1 := by + apply le_antisymm + · simpa using birthday_mk_le ⋆ + · rw [one_le_iff_ne_zero, birthday_eq_zero.ne] + exact IncompRel.ne (r := (· ≤ ·)) IGame.star_fuzzy_zero + +theorem birthday_ofSets_le {s t : Set ConwayGame.{u}} [Small.{u} s] [Small.{u} t] : + birthday !{s | t} ≤ max (sSup (succ ∘ birthday '' s)) (sSup (succ ∘ birthday '' t)) := by + choose f hf using birthday_eq_iGameBirthday + trans !{f '' s | f '' t}.birthday + · convert birthday_mk_le !{f '' s | f '' t} using 2 + simp_rw [mk_ofSets, image_image] + aesop + · simp_rw [IGame.birthday_ofSets, image_comp] + congr! <;> aesop + +theorem birthday_add_le (x y : ConwayGame) : (x + y).birthday ≤ x.birthday + y.birthday := by + obtain ⟨a, ha, ha'⟩ := birthday_eq_iGameBirthday x + obtain ⟨b, hb, hb'⟩ := birthday_eq_iGameBirthday y + rw [← ha', ← hb', ← ha, ← hb, ← IGame.birthday_add] + exact birthday_mk_le _ + +theorem birthday_sub_le (x y : ConwayGame) : (x - y).birthday ≤ x.birthday + y.birthday := by + simpa [sub_eq_add_neg] using birthday_add_le x (-y) + +/-- Games with a bounded birthday form a small set. -/ +instance small_setOf_birthday_le (o : NatOrdinal.{u}) : Small.{u} {x | birthday x ≤ o} := by + refine small_subset (s := mk '' {x | IGame.birthday x ≤ o}) fun x hx ↦ ?_ + obtain ⟨y, rfl, hy⟩ := birthday_eq_iGameBirthday x + exact mem_image_of_mem mk (hy.trans_le hx) + +/-- Games with a bounded birthday form a small set. -/ +instance small_setOf_birthday_lt (o : NatOrdinal.{u}) : Small.{u} {x | birthday x < o} := + small_subset (s := {x | birthday x ≤ o}) <| Set.ofPred_subset_ofPred.2 fun _ => le_of_lt + +/-- A variant of `small_setOf_birthday_le` in simp-normal form -/ +instance small_subtype_birthday_le (o : NatOrdinal.{u}) : Small.{u} {x // birthday x ≤ o} := + small_setOf_birthday_le o + +/-- A variant of `small_setOf_birthday_lt` in simp-normal form -/ +instance small_subtype_birthday_lt (o : NatOrdinal.{u}) : Small.{u} {x // birthday x < o} := + small_setOf_birthday_lt o + +end ConwayGame +end diff --git a/LeanPool/ConwayRefinement/CombinatorialGames/Game/Classes.lean b/LeanPool/ConwayRefinement/CombinatorialGames/Game/Classes.lean new file mode 100644 index 0000000000..f16eb77e0f --- /dev/null +++ b/LeanPool/ConwayRefinement/CombinatorialGames/Game/Classes.lean @@ -0,0 +1,528 @@ +/- +Copyright (c) 2025 Violeta Hernández Palacios. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Violeta Hernández Palacios, Kim Morrison, Fox Thomson +-/ +module + +public import LeanPool.ConwayRefinement.CombinatorialGames.Game.IGame +public meta import LeanPool.ConwayRefinement.CombinatorialGames.Tactic.AddInstances + +import Mathlib.Basic.Finite.Prod +import Mathlib.Data.Set.Finite.Lattice + +/-! +# Classes of games + +This file collects multiple basic classes of games, so as to make them available on most files. We +develop their theory elsewhere. + +## Dicotic games + +A game is dicotic when every non-zero subposition has both left and right moves. The Lawnmower +theorem (proven in `CombinatorialGames.Game.Small`) shows that every dicotic game is small. + +## Impartial games + +We define an impartial game as one where every subposition is equivalent to its negative. This is a +weaker definition than that found in the literature (which requires equality, rather than +equivalence), but this is still strong enough to prove the Sprague--Grundy theorem, as well as +closure under the basic arithmetic operations of multiplication and division. + +## Numeric games + +A game is `Numeric` if all the Left options are strictly smaller than all the Right options, and all +those options are themselves numeric. In terms of combinatorial games, the numeric games have +"frozen"; you can only make your position worse by playing, and Left is some definite "number" of +moves ahead (or behind) Right. + +## Short games + +A combinatorial game is `Short` if it has only finitely many subpositions. In particular, this means +there is a finite set of moves at every point. + +We historically defined `Short x` as data, which we then used to enable some degree of computation +on combinatorial games. This functionality is now implemented through the `game_cmp` tactic instead. +-/ + +universe u + +@[expose] public section + +namespace IGame + +/-! ### Dicotic games -/ + +/-- A game `x` is dicotic if both players can move from every nonempty subposition of `x`. -/ +@[mk_iff dicotic_def'] +class +inductive Dicotic : IGame → Prop where + | mk {x : IGame} : (xᴸ = ∅ ↔ xᴿ = ∅) → (∀ p, ∀ y ∈ x.moves p, Dicotic y) → Dicotic x + +theorem dicotic_def {x : IGame} : Dicotic x ↔ (xᴸ = ∅ ↔ xᴿ = ∅) ∧ ∀ p, ∀ l ∈ x.moves p, Dicotic l := + dicotic_def' x + +namespace Dicotic +variable {x y z : IGame} + +theorem eq_zero_iff [hx : Dicotic x] : x = 0 ↔ ∃ p, x.moves p = ∅ := by + rw [dicotic_def] at hx + simp_all [Player.exists, IGame.ext_iff] + +theorem ne_zero_iff [Dicotic x] : x ≠ 0 ↔ ∀ p, x.moves p ≠ ∅ := by + simpa using eq_zero_iff.not + +theorem moves_eq_empty_iff [hx : Dicotic x] : ∀ p q, x.moves p = ∅ ↔ x.moves q = ∅ := + Player.const_of_left_eq_right' (dicotic_def.1 hx).1 + +protected theorem of_mem_moves {p : Player} [hx : Dicotic x] (h : y ∈ x.moves p) : Dicotic y := + (dicotic_def.1 hx).2 p y h + +/-- `dicotic` eagerly adds all possible `Dicotic` hypotheses. -/ +elab "dicotic" : tactic => + addInstances <| .mk [`IGame.Dicotic.of_mem_moves] + +@[simp] +protected instance zero : Dicotic 0 := by + apply mk <;> simp + +protected instance neg (x) [Dicotic x] : Dicotic (-x) := by + apply mk + · simp [moves_eq_empty_iff .left .right] + · simp_rw [moves_neg, Set.mem_neg] + intro p y hy + dicotic + rw [← neg_neg y] + exact .neg _ +termination_by x +decreasing_by igame_wf + +@[simp] +theorem neg_iff {x : IGame} : Dicotic (-x) ↔ Dicotic x := + ⟨fun _ ↦ by simpa using Dicotic.neg (-x), fun _ ↦ .neg x⟩ + +end Dicotic + +/-! ### Impartial games -/ + +/-- An impartial game is one that's equivalent to its negative, such that each left and right move +is also impartial. + +Note that this is a slightly more general definition than the one that's usually in the literature, +as we don't require `x = -x`. Despite this, the Sprague-Grundy theorem still holds: see +`IGame.equiv_nim_grundyValue`. + +In such a game, both players have the same payoffs at any subposition. -/ +@[mk_iff impartial_def'] +class +inductive Impartial : IGame → Prop where + | mk {x : IGame} : -x ≈ x → (∀ p, ∀ y ∈ x.moves p, Impartial y) → Impartial x + +theorem impartial_def {x : IGame} : x.Impartial ↔ -x ≈ x ∧ ∀ p, ∀ y ∈ x.moves p, Impartial y := + impartial_def' x + +namespace Impartial +variable (x y : IGame) [hx : Impartial x] [hy : Impartial y] + +@[simp] theorem neg_equiv : -x ≈ x := (impartial_def.1 hx).1 +@[simp] theorem equiv_neg : x ≈ -x := (neg_equiv _).symm + +omit hx in +theorem sub_equiv : x - y ≈ x + y := add_congr_right (neg_equiv y) + +@[aesop safe apply] +protected theorem of_mem_moves {p} {x y : IGame} [h : Impartial x] : + y ∈ x.moves p → Impartial y := + (impartial_def.1 h).2 p y + +/-- `impartial` eagerly adds all possible `Impartial` hypotheses. -/ +elab "impartial" : tactic => + addInstances <| .mk [`IGame.Impartial.of_mem_moves] + +@[simp] protected instance zero : Impartial 0 := by rw [impartial_def]; simp + +protected instance neg (x : IGame) [Impartial x] : Impartial (-x) := by + apply mk + · simp + · simp_rw [moves_neg, Set.mem_neg] + intro p y hy + impartial + rw [← neg_neg y] + exact .neg _ +termination_by x +decreasing_by igame_wf + +protected instance add (x y : IGame) [Impartial x] [Impartial y] : Impartial (x + y) := by + apply mk + · rw [neg_add] + exact add_congr (neg_equiv x) (neg_equiv y) + · simp_rw [forall_moves_add] + intro p + constructor + all_goals intro z hz; impartial; exact .add .. +termination_by (x, y) +decreasing_by igame_wf + +protected instance sub (x y : IGame) [Impartial x] [Impartial y] : Impartial (x - y) := + .add x (-y) + +/-- The product instance is proven in `ConwayGame.Impartial.Grundy`. -/ +theorem le_comm {x y} [Impartial x] [Impartial y] : x ≤ y ↔ y ≤ x := by + rw [← IGame.neg_le_neg_iff, (neg_equiv y).le_congr (neg_equiv x)] + +@[simp] +theorem not_lt : ¬x < y := by + apply (lt_asymm · ?_) + rwa [← IGame.neg_lt_neg_iff, (neg_equiv x).lt_congr (neg_equiv y)] + +/-- By setting `y = 0`, we find that in an impartial game, either the first player always wins, or +the second player always wins. -/ +theorem equiv_or_fuzzy : x ≈ y ∨ x ‖ y := by + obtain (h | h | h | h) := lt_or_antisymmRel_or_gt_or_incompRel x y + · cases not_lt x y h + · exact .inl h + · cases not_lt y x h + · exact .inr h + +variable {x y} + +@[simp] +theorem not_equiv_iff : ¬ x ≈ y ↔ x ‖ y := + ⟨(equiv_or_fuzzy x y).resolve_left, IncompRel.not_antisymmRel⟩ + +@[simp] +theorem not_fuzzy_iff : ¬ x ‖ y ↔ x ≈ y := + not_iff_comm.1 not_equiv_iff + +@[simp] +theorem le_iff_equiv : x ≤ y ↔ x ≈ y := + ⟨fun h ↦ ⟨h, le_comm.1 h⟩, And.left⟩ + +theorem ge_iff_equiv : y ≤ x ↔ x ≈ y := + ⟨fun h ↦ ⟨le_comm.2 h, h⟩, And.right⟩ + +theorem lf_iff_fuzzy : x ⧏ y ↔ x ‖ y := by simp [comm] +theorem gf_iff_fuzzy : y ⧏ x ↔ x ‖ y := by simp + +theorem fuzzy_of_mem_moves {y : IGame} {p : Player} (hy : y ∈ x.moves p) : y ‖ x := by + have := hx.of_mem_moves hy + cases p with + | left => symm; simpa using left_lf hy + | right => simpa using lf_right hy + +private theorem equiv_iff_forall_fuzzy' : + x ≈ y ↔ (∀ z ∈ xᴸ, z ‖ y) ∧ (∀ z ∈ yᴿ, x ‖ z) := by + rw [← le_iff_equiv, le_iff_forall_lf] + congr! with z hz z hz + all_goals impartial; simp [incompRel_comm] + +theorem equiv_iff_forall_fuzzy (p : Player) : + x ≈ y ↔ (∀ z ∈ x.moves p, z ‖ y) ∧ (∀ z ∈ y.moves (-p), x ‖ z) := by + cases p with + | left => exact equiv_iff_forall_fuzzy' + | right => + rw [antisymmRel_comm, equiv_iff_forall_fuzzy', and_comm] + simp_rw [incompRel_comm] + rfl + +theorem fuzzy_iff_exists_equiv (p : Player) : + x ‖ y ↔ (∃ z ∈ x.moves p, z ≈ y) ∨ (∃ z ∈ y.moves (-p), x ≈ z) := by + rw [← not_equiv_iff, equiv_iff_forall_fuzzy p, not_and_or] + simp_rw [not_forall, ← exists_prop] + congr! with _ h _ h + all_goals impartial; exact not_fuzzy_iff + +theorem equiv_zero (p : Player) : x ≈ 0 ↔ ∀ y ∈ x.moves p, y ‖ 0 := by + rw [equiv_iff_forall_fuzzy p]; simp + +theorem fuzzy_zero (p : Player) : x ‖ 0 ↔ ∃ y ∈ x.moves p, y ≈ 0 := by + rw [fuzzy_iff_exists_equiv p]; simp + +/-- A **strategy stealing** argument. If there's a move in `x`, such that any immediate move could +have also been reached in the first turn, then `x` is won by the first player. -/ +theorem fuzzy_zero_of_forall_exists {p : Player} {y} (hy : y ∈ x.moves p) + (H : ∀ z ∈ y.moves p, ∃ w ∈ x.moves p, z ≈ w) : x ‖ 0 := by + apply (equiv_or_fuzzy _ _).resolve_left fun hx ↦ ?_ + impartial + rw [equiv_zero] at hx + obtain ⟨z, hz, hz'⟩ := (fuzzy_zero _).1 (hx y hy) + obtain ⟨w, hw, hw'⟩ := H z hz + exact (hx w hw).not_antisymmRel (hw'.symm.trans hz') + +end Impartial + +/-! ### Numeric games -/ + +/-- A game `!{s | t}` is numeric if everything in `s` is less than everything in `t`, and all the +elements of these sets are also numeric. + +The `Surreal` numbers are built as the quotient of numeric games under equivalence. -/ +@[mk_iff numeric_def'] +class +inductive Numeric : IGame → Prop where + | mk {x : IGame} : (∀ y ∈ xᴸ, ∀ z ∈ xᴿ, y < z) → (∀ p, ∀ y ∈ x.moves p, Numeric y) → Numeric x + +theorem numeric_def {x : IGame} : Numeric x ↔ + (∀ y ∈ xᴸ, ∀ z ∈ xᴿ, y < z) ∧ (∀ p, ∀ y ∈ x.moves p, Numeric y) := + numeric_def' x + +namespace Numeric +variable {x y z : IGame} + +theorem left_lt_right [h : Numeric x] (hy : y ∈ xᴸ) (hz : z ∈ xᴿ) : y < z := + (numeric_def.1 h).1 y hy z hz + +protected theorem of_mem_moves {p : Player} [h : Numeric x] (hy : y ∈ x.moves p) : Numeric y := + (numeric_def.1 h).2 p y hy + +/-- `numeric` eagerly adds all possible `Numeric` hypotheses. -/ +elab "numeric" : tactic => + addInstances <| .mk [`IGame.Numeric.of_mem_moves] + +protected theorem subposition [Numeric x] (h : Subposition y x) : Numeric y := by + induction x using IGame.moveRecOn generalizing ‹x.Numeric› with | ind x ih + obtain ⟨p, z, hz, hy⟩ := subposition_iff_exists.1 h + obtain rfl | hy := wsubposition_iff_eq_or_subposition.1 hy + · exact .of_mem_moves hz + · exact @ih p z hz (.of_mem_moves hz) hy + +@[simp] +protected instance zero : Numeric 0 := by + rw [numeric_def]; simp + +@[simp] +protected instance one : Numeric 1 := by + rw [numeric_def]; simp + +protected instance subtype (x : Subtype Numeric) : Numeric x.1 := x.2 +protected instance moves {x : IGame} [Numeric x] {p : Player} (y : x.moves p) : Numeric y := + .of_mem_moves y.2 + +protected theorem le_of_not_le {x y : IGame} [Numeric x] [Numeric y] : ¬ x ≤ y → y ≤ x := by + rw [lf_iff_exists_le, le_iff_forall_lf] + rintro (⟨z, hz, h⟩ | ⟨z, hz, h⟩) <;> constructor <;> intro a ha h' + · numeric + exact left_lf_of_le h' hz (Numeric.le_of_not_le (left_lf_of_le h ha)) + · exact (left_lt_right hz ha).not_ge (h'.trans h) + · exact (left_lt_right ha hz).not_ge (h.trans h') + · numeric + exact lf_right_of_le h' hz (Numeric.le_of_not_le (lf_right_of_le h ha)) +termination_by x +decreasing_by igame_wf + +protected theorem le_total (x y : IGame) [Numeric x] [Numeric y] : x ≤ y ∨ y ≤ x := by + rw [or_iff_not_imp_left] + exact Numeric.le_of_not_le + +protected theorem lt_of_not_ge [Numeric x] [Numeric y] (h : ¬ x ≤ y) : y < x := + (Numeric.le_of_not_le h).lt_of_not_ge h + +@[simp] +protected theorem not_le [Numeric x] [Numeric y] : ¬ x ≤ y ↔ y < x := + ⟨Numeric.lt_of_not_ge, not_le_of_gt⟩ + +@[simp] +protected theorem not_lt [Numeric x] [Numeric y] : ¬ x < y ↔ y ≤ x := + not_iff_comm.1 Numeric.not_le + +protected theorem le_or_gt (x y : IGame) [Numeric x] [Numeric y] : x ≤ y ∨ y < x := by + rw [← Numeric.not_le] + exact em _ + +protected theorem lt_or_ge (x y : IGame) [Numeric x] [Numeric y] : x < y ∨ y ≤ x := by + rw [← Numeric.not_lt] + exact em _ + +theorem not_fuzzy (x y : IGame) [Numeric x] [Numeric y] : ¬ x ‖ y := by + simpa [not_incompRel_iff_symmGen, Relation.SymmGen] using Numeric.le_total x y + +theorem lt_or_equiv_or_gt (x y : IGame) [Numeric x] [Numeric y] : x < y ∨ x ≈ y ∨ y < x := by + simp_rw [← Numeric.not_le]; tauto + +/-- To prove a game is numeric, it suffices to show the left options are less or fuzzy +to the right options. -/ +theorem mk_of_lf (h₁ : ∀ y ∈ xᴸ, ∀ z ∈ xᴿ, y ⧏ z) (h₂ : ∀ p, ∀ y ∈ x.moves p, Numeric y) : + Numeric x := + mk (fun y hy z hz ↦ (@Numeric.not_le z y (h₂ _ z hz) (h₂ _ y hy)).1 (h₁ y hy z hz)) h₂ + +theorem le_iff_forall_lt [Numeric x] [Numeric y] : + x ≤ y ↔ (∀ z ∈ xᴸ, z < y) ∧ (∀ z ∈ yᴿ, x < z) := by + rw [le_iff_forall_lf] + congr! with z hz z hz <;> numeric <;> rw [Numeric.not_le] + +theorem lt_iff_exists_le [Numeric x] [Numeric y] : + x < y ↔ (∃ z ∈ yᴸ, x ≤ z) ∨ (∃ z ∈ xᴿ, z ≤ y) := by + rw [← Numeric.not_le, lf_iff_exists_le] + +theorem left_lt [Numeric x] (h : y ∈ xᴸ) : y < x := by + numeric; simpa using left_lf h + +theorem lt_right [Numeric x] (h : y ∈ xᴿ) : x < y := by + numeric; simpa using lf_right h + +protected instance neg (x : IGame) [Numeric x] : Numeric (-x) := by + refine mk (fun y hy z hz ↦ ?_) ?_ + · rw [← IGame.neg_lt_neg_iff] + apply @left_lt_right x <;> simp_all + · simp_rw [forall_moves_neg] + intro p y hy + numeric + simpa using Numeric.neg y +termination_by x +decreasing_by igame_wf + +@[simp] +theorem neg_iff {x : IGame} : Numeric (-x) ↔ Numeric x := + ⟨fun _ ↦ by simpa using Numeric.neg (-x), fun _ ↦ Numeric.neg x⟩ + +protected instance add (x y : IGame) [Numeric x] [Numeric y] : Numeric (x + y) := by + apply mk <;> simp only [moves_add, Set.mem_union, Set.mem_image] + · rintro _ (⟨a, ha, rfl⟩ | ⟨a, ha, rfl⟩) _ (⟨b, hb, rfl⟩ | ⟨b, hb, rfl⟩) + any_goals simpa using left_lt_right ha hb + all_goals + trans (x + y) + · simpa using left_lt ha + · simpa using lt_right hb + · rintro p _ (⟨z, hz, rfl⟩ | ⟨z, hz, rfl⟩) + all_goals numeric; exact Numeric.add .. +termination_by (x, y) +decreasing_by igame_wf + +protected instance sub (x y : IGame) [Numeric x] [Numeric y] : Numeric (x - y) := + inferInstanceAs (Numeric (x + -y)) + +protected instance natCast : ∀ n : ℕ, Numeric n + | 0 => inferInstanceAs (Numeric 0) + | n + 1 => have := Numeric.natCast n; inferInstanceAs (Numeric (n + 1)) + +protected instance ofNat (n : ℕ) [n.AtLeastTwo] : Numeric ofNat(n) := + inferInstanceAs (Numeric n) + +protected instance intCast : ∀ n : ℤ, Numeric n + | .ofNat n => inferInstanceAs (Numeric n) + | .negSucc n => inferInstanceAs (Numeric (-(n + 1))) + +end Numeric + +/-! ### Short games -/ + +/-- A short game is one with finitely many subpositions. That is, the left and right sets are +finite, and all of the games in them are short as well. -/ +@[mk_iff short_def'] +class +inductive Short : IGame → Prop where + | mk' (x : IGame) : (∀ p, (x.moves p).Finite) → (∀ p, ∀ y ∈ x.moves p, Short y) → Short x + +theorem short_def {x : IGame} : Short x ↔ ∀ p, (x.moves p).Finite ∧ ∀ y ∈ x.moves p, Short y := by + rw [short_def', ← forall_and] + +alias ⟨_, Short.mk⟩ := short_def + +namespace Short +variable {x y : IGame} + +theorem finite_moves (p : Player) (x : IGame) [h : Short x] : (x.moves p).Finite := + (short_def.1 h p).1 + +instance (p : Player) (x : IGame) [Short x] : Finite (x.moves p) := + (Short.finite_moves _ x).to_subtype + +protected theorem of_mem_moves [h : Short x] {p} (hy : y ∈ x.moves p) : Short y := + (short_def.1 h p).2 y hy + +/-- `short` eagerly adds all possible `Short` hypotheses. -/ +elab "short" : tactic => + addInstances <| .mk [`IGame.Short.of_mem_moves] + +protected theorem subposition {x : IGame} [Short x] (h : Subposition y x) : Short y := by + induction x using IGame.moveRecOn generalizing ‹x.Short› with | ind x ih + obtain ⟨p, z, hz, hy⟩ := subposition_iff_exists.1 h + obtain rfl | hy := wsubposition_iff_eq_or_subposition.1 hy + · exact .of_mem_moves hz + · exact @ih p z hz (.of_mem_moves hz) hy + +theorem finite_setOf_subposition (x : IGame) [Short x] : {y | Subposition y x}.Finite := by + induction x using IGame.moveRecOn generalizing ‹x.Short› with | ind x ih + convert Set.finite_iUnion fun p => (finite_moves p x).biUnion fun y hy ↦ + (@ih p y hy (.of_mem_moves hy)).insert y + ext + rw [Set.mem_ofPred, subposition_iff_exists] + simp [wsubposition_iff_eq_or_subposition] + +instance (x : IGame) [Short x] : Finite {y // Subposition y x} := + (Short.finite_setOf_subposition x).to_subtype + +theorem _root_.IGame.short_iff_finite_setOf_subposition {x : IGame} : + Short x ↔ {y | Subposition y x}.Finite := by + refine ⟨@finite_setOf_subposition x, fun h ↦ mk fun p ↦ ⟨?_, ?_⟩⟩ + on_goal 1 => refine h.subset fun y hy ↦ ?_ + on_goal 2 => refine fun y hy ↦ short_iff_finite_setOf_subposition.2 <| h.subset fun z hz ↦ ?_ + all_goals igame_wf +termination_by x +decreasing_by igame_wf + +@[simp] +protected instance zero : Short 0 := by + rw [short_def]; simp + +@[simp] +protected instance one : Short 1 := by + rw [short_def]; simp + +protected instance neg (x : IGame) [Short x] : Short (-x) := by + refine mk fun p ↦ ⟨?_, ?_⟩ + · simpa [← Set.image_neg_eq_neg] using (finite_moves _ x).image _ + · rw [forall_moves_neg] + intro y hy + simpa using (Short.of_mem_moves hy).neg +termination_by x +decreasing_by igame_wf + +@[simp] +theorem neg_iff {x : IGame} : Short (-x) ↔ Short x := + ⟨fun _ ↦ by simpa using Short.neg (-x), fun _ ↦ Short.neg x⟩ + +protected instance add (x y : IGame) [Short x] [Short y] : Short (x + y) := by + refine mk fun p ↦ ⟨?_, ?_⟩ + · simpa using ⟨(finite_moves _ x).image _, (finite_moves _ y).image _⟩ + · rw [forall_moves_add] + constructor + all_goals intro z hz; short; exact Short.add .. +termination_by (x, y) +decreasing_by igame_wf + +protected instance sub (x y : IGame) [Short x] [Short y] : Short (x - y) := + .add .. + +protected instance natCast : ∀ n : ℕ, Short n + | 0 => inferInstanceAs (Short 0) + | n + 1 => have := Short.natCast n; inferInstanceAs (Short (n + 1)) + +protected instance ofNat (n : ℕ) [n.AtLeastTwo] : Short ofNat(n) := + inferInstanceAs (Short n) + +protected instance intCast : ∀ n : ℤ, Short n + | .ofNat n => inferInstanceAs (Short n) + | .negSucc n => inferInstanceAs (Short (-(n + 1))) + +protected instance mul (x y : IGame) [Short x] [Short y] : Short (x * y) := by + refine mk fun p ↦ ⟨?_, ?_⟩ + · simpa [Set.image_union] using + ⟨(finite_moves _ x).image2 _ (finite_moves _ y), + (finite_moves _ x).image2 _ (finite_moves _ y)⟩ + · rw [forall_moves_mul] + intro p' a ha b hb + replace ha := Short.of_mem_moves ha + replace hb := Short.of_mem_moves hb + have := Short.mul a y; have := Short.mul x b; have := Short.mul a b + rw [mulOption] + infer_instance +termination_by (x, y) +decreasing_by igame_wf + +protected instance mulOption (x y a b : IGame) [Short x] [Short y] [Short a] [Short b] : + Short (mulOption x y a b) := + .sub .. + +end Short +end IGame diff --git a/LeanPool/ConwayRefinement/CombinatorialGames/Game/Functor.lean b/LeanPool/ConwayRefinement/CombinatorialGames/Game/Functor.lean new file mode 100644 index 0000000000..79fcb23f74 --- /dev/null +++ b/LeanPool/ConwayRefinement/CombinatorialGames/Game/Functor.lean @@ -0,0 +1,92 @@ +/- +Copyright (c) 2025 Aaron Liu. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Aaron Liu, Violeta Hernández Palacios, Yuyang Zhao +-/ +module + +public import LeanPool.ConwayRefinement.CombinatorialGames.Game.Player +public import Mathlib.Data.QPF.Univariate.Basic + +import Mathlib.Logic.Small.Set + +/-! +# ConwayGame functor + +The type of games `IGame` is an inductive type, with a single constructor `ofSets` taking in two +small sets of games (one for each player) and outputting a new game. This suggests the definition: + +``` +inductive IGame : Type (u + 1) + | ofSets (st : Player → Set IGame) [∀ p, Small.{u} (st p)] : IGame.{u} +``` + +However, the kernel does not accept this, as `Set IGame = IGame → Prop` contains a non-positive +occurence of `IGame` (see [counterexamples.org](https://counterexamples.org/strict-positivity.html) +for an explanation of what this is and why it's disallowed). We can get around this technical +limitation using the machinery of `QPF`s (quotients of polynomial functors). We define a functor +`GameFunctor` by + +``` +def GameFunctor (α : Type (u + 1)) : Type (u + 1) := + {st : Player → Set α // Small.{u} (st left) ∧ Small.{u} (st right)} +``` + +We can prove that this is a `QPF`, which then allows us to build its initial algebra through +`QPF.Fix`, which is exactly the inductive type `IGame`. As a bonus, we're able to describe the +coinductive type of loopy games `LGame` as the final coalgebra `QPF.Cofix` of the exact same +functor. +-/ + +universe u + +@[expose] public section + +/-! ### ConwayGame Functor -/ + +/-- The functor from a type into the subtype of small pairs of sets in that type. + +This is the quotient of a polynomial functor. The type `IGame` of well-founded games is defined as +the initial algebra of that `QPF`, while the type `LGame` of loopy games is defined as its final +coalgebra. + +In other words, `IGame` and `LGame` have the following descriptions (which don't work verbatim due +to various Lean limitations): + +``` +inductive IGame : Type (u + 1) + | ofSets (st : Player → Set IGame) [∀ p, Small.{u} (st p)] : IGame.{u} + +coinductive LGame : Type (u + 1) + | ofSets (st : Player → Set IGame) [∀ p, Small.{u} (st p)] : LGame.{u} +``` +-/ +def GameFunctor (α : Type (u + 1)) : Type (u + 1) := + {s : Player → Set α // ∀ p, Small.{u} (s p)} + +namespace GameFunctor + +@[ext] theorem ext {α : Type (u + 1)} {x y : GameFunctor α} : x.1 = y.1 → x = y := Subtype.ext + +instance {α : Type (u + 1)} (x : GameFunctor α) (p : Player) : Small.{u} (x.1 p) := x.2 p + +instance : Functor GameFunctor where + map f s := ⟨(f '' s.1 ·), fun _ ↦ by infer_instance⟩ + +theorem map_def {α β} (f : α → β) (s : GameFunctor α) : + f <$> s = ⟨(f '' s.1 ·), fun _ ↦ by infer_instance⟩ := + rfl +noncomputable instance : QPF GameFunctor where + P := ⟨Player → Type u, fun x ↦ Σ p, PLift (x p)⟩ + abs x := ⟨fun p ↦ Set.range (x.2 ∘ .mk p ∘ PLift.up), fun _ ↦ by infer_instance⟩ + repr x := ⟨fun p ↦ Shrink (x.1 p), Sigma.rec (fun _ y ↦ ((equivShrink _).symm y.1).1)⟩ + abs_repr x := by ext; simp [← (equivShrink _).exists_congr_right] + abs_map f := by + intro ⟨x, g⟩ + apply Subtype.ext + funext p + change Set.range (f ∘ g ∘ Sigma.mk p ∘ PLift.up) = + f '' Set.range (g ∘ Sigma.mk p ∘ PLift.up) + exact Set.range_comp f _ + +end GameFunctor diff --git a/LeanPool/ConwayRefinement/CombinatorialGames/Game/IGame.lean b/LeanPool/ConwayRefinement/CombinatorialGames/Game/IGame.lean new file mode 100644 index 0000000000..151c73a717 --- /dev/null +++ b/LeanPool/ConwayRefinement/CombinatorialGames/Game/IGame.lean @@ -0,0 +1,1315 @@ +/- +Copyright (c) 2025 Violeta Hernández Palacios. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: V.Hernández Palacios, R.Barton, M.Carneiro, I.Longbottom, K.Morrison, Y.Zhao +-/ +module + +/- Full upstream author names: Violeta Hernández Palacios, Reid Barton, Mario Carneiro, Isabel +Longbottom, Kim Morrison, Yuyang Zhao. -/ + +public import Batteries.Classes.RatCast +public import LeanPool.ConwayRefinement.CombinatorialGames.Game.Player +public meta import LeanPool.ConwayRefinement.CombinatorialGames.Tactic.Register +public import Mathlib.Algebra.Group.Pointwise.Set.Small +public import Mathlib.Algebra.Order.ZeroLEOne +public import Mathlib.Order.Comparable + +import LeanPool.ConwayRefinement.CombinatorialGames.Game.Functor +import LeanPool.ConwayRefinement.CombinatorialGames.Mathlib.Small +import Mathlib.Lean.PrettyPrinter.Delaborator +import Mathlib.Logic.Hydra +import Mathlib.Order.GameAdd + +/-! +# Combinatorial (pre-)games + +The basic theory of combinatorial games, following Conway's book `On Numbers and Games`. + +In ZFC, games are built inductively out of two other sets of games, representing the options for two +players Left and Right. In Lean, we instead define the type of games `IGame` as arising from two +`Small` sets of games, with notation `!{s | t}`. A `u`-small type `α : Type v` +is one that is equivalent to some `β : Type u`, and the distinction between small and large types in +a given universe closely mimics the ZFC distinction between sets and proper classes. + +This definition requires some amount of setup, since Lean's inductive types aren't powerful enough +to express this on their own. See the docstring on `GameFunctor` for more information. + +We are also interested in further quotients of `IGame`. The quotient of games under equivalence +`x ≈ y ↔ x ≤ y ∧ y ≤ x`, which in the literature is often what is meant by a "combinatorial game", +is defined as `ConwayGame` in `CombinatorialGames.Game.Basic`. The surreal numbers `Surreal` +are defined +as a quotient (of a subtype) of games in `CombinatorialGames.Surreal.Basic`. + +## Conway induction + +Most constructions within game theory, and as such, many proofs within it, are done by structural +induction. Structural induction on games is sometimes called "Conway induction". + +The most straightforward way to employ Conway induction is by using the termination checker, with +the auxiliary `igame_wf` tactic. This uses `solve_by_elim` to search the context for proofs of the +form `y ∈ xᴸ` or `y ∈ xᴿ`, which prove termination. Alternatively, you can use +the explicit recursion principles `IGame.ofSetsRecOn` or `IGame.moveRecOn`. + +## Order properties + +Pregames have both a `≤` and a `<` relation, satisfying the properties of a `Preorder`. The relation +`0 < x` means that `x` can always be won by Left, while `0 ≤ x` means that `x` can be won by Left as +the second player. Likewise, `x < 0` means that `x` can always be won by Right, while `x ≤ 0` means +that `x` can be won by Right as the second player. + +Note that we don't actually prove these characterizations. Indeed, in Conway's setup, combinatorial +game theory can be done entirely without the concept of a strategy. For instance, `IGame.zero_le` +implies that if `0 ≤ x`, then any move by Right satisfies `¬ x ≤ 0`, and `IGame.zero_lf` implies +that if `¬ x ≤ 0`, then some move by Left satisfies `0 ≤ x`. The strategy is thus already encoded +within these game relations. + +For convenience, we define notation `x ⧏ y` (pronounced "less or fuzzy") for `¬ y ≤ x`, notation +`x ‖ y` for `¬ x ≤ y ∧ ¬ y ≤ x`, and notation `x ≈ y` for `x ≤ y ∧ y ≤ x`. + +You can prove most (simple) inequalities on concrete games through the `game_cmp` tactic, which +repeatedly unfolds the definition of `≤` and applies `simp` until it solves the goal. + +## Algebraic structures + +Most of the usual arithmetic operations can be defined for games. Addition is defined for +`x = !{s₁ | t₁}` and `y = !{s₂ | t₂}` by `x + y = !{s₁ + y, x + s₂ | t₁ + y, x + t₂}`. Negation is +defined by `-!{s | t} = !{-t | -s}`. + +The order structures interact in the expected way with arithmetic. In particular, `ConwayGame` is an +`OrderedAddCommGroup`. Meanwhile, `IGame` satisfies the slightly weaker axioms of a +`SubtractionCommMonoid`, since the equation `x - x = 0` is only true up to equivalence. +-/ + +private theorem Relation.transGen_iff_exists {α : Type*} {r : α → α → Prop} {x y : α} : + Relation.TransGen r x y ↔ ∃ z, r z y ∧ (x = z ∨ TransGen r x z) := by + rw [transGen_iff] + simp [and_or_left, exists_or, and_comm] + +universe u + +open Set Pointwise + +-- Computations can be performed through the `game_cmp` tactic. +public noncomputable section + +/-! ### ConwayGame moves -/ + +/-- Well-founded games up to identity. + +`IGame` uses the set-theoretic notion of equality on games, meaning that two `IGame`s are equal +exactly when their left and right sets of options are. + +This is not the same equivalence as used broadly in combinatorial game theory literature, as a game +like `{0, 1 | 0}` is not *identical* to `{1 | 0}`, despite being equivalent. However, many theorems +can be proven over the 'identical' equivalence relation, and the literature may occasionally +specifically use the 'identical' equivalence relation for this reason. The quotient +`ConwayGame` of games +up to equality is defined in `CombinatorialGames.Game.Basic`. + +More precisely, `IGame` is the inductive type for the single constructor + +``` + | ofSets (s t : Set IGame.{u}) [Small.{u} s] [Small.{u} t] : IGame.{u} +``` + +(though for technical reasons it's not literally defined as such). A consequence of this is that +there is no infinite line of play. See `LGame` for a definition of loopy games. -/ +def IGame : Type (u + 1) := + QPF.Fix GameFunctor + +namespace IGame +export Player (left right) + +/-- Construct an `IGame` from its left and right sets. + +This function is regrettably noncomputable. Among other issues, sets simply do not carry data in +Lean. To perform computations on `IGame` we can instead make use of the `game_cmp` tactic. -/ +@[no_expose] +instance : OfSets IGame fun _ ↦ True where + ofSets st _ := QPF.Fix.mk ⟨st, by rintro (_ | _) <;> assumption⟩ + +/-- The set of moves of the game. -/ +def moves (p : Player) (x : IGame.{u}) : Set IGame.{u} := x.dest.1 p + +/-- The set of left moves of the game. -/ +scoped notation:max x:max "ᴸ" => moves left x + +/-- The set of right moves of the game. -/ +scoped notation:max x:max "ᴿ" => moves right x + +instance (p : Player) (x : IGame.{u}) : Small.{u} (x.moves p) := x.dest.2 p + +@[simp, game_cmp] +theorem moves_ofSets (p) (st : Player → Set IGame) [Small.{u} (st left)] [Small.{u} (st right)] : + !{st}.moves p = st p := by + exact congrArg (fun s : GameFunctor IGame => s.val p) + (QPF.Fix.dest_mk ⟨st, by rintro (_ | _) <;> assumption⟩) + +@[simp] +theorem ofSets_moves (x : IGame) : !{x.moves} = x := x.mk_dest + +@[game_cmp] +theorem leftMoves_ofSets (s t : Set IGame) [Small.{u} s] [Small.{u} t] : !{s | t}ᴸ = s := + moves_ofSets .. + +@[game_cmp] +theorem rightMoves_ofSets (s t : Set IGame) [Small.{u} s] [Small.{u} t] : !{s | t}ᴿ = t := + moves_ofSets .. + +@[simp] +theorem ofSets_leftMoves_rightMoves (x : IGame) : !{xᴸ | xᴿ} = x := by + convert x.ofSets_moves with p + cases p <;> rfl + +/-- Two `IGame`s are equal when their move sets are. + +For the weaker but more common notion of equivalence where `x = y` if `x ≤ y` and `y ≤ x`, +use `ConwayGame`. -/ +@[ext] +theorem ext {x y : IGame.{u}} (h : ∀ p, x.moves p = y.moves p) : + x = y := by + rw [← ofSets_moves x, ← ofSets_moves y] + simp_rw [funext h] + +@[simp] +theorem ofSets_inj' {st₁ st₂ : Player → Set IGame} + [Small (st₁ left)] [Small (st₁ right)] [Small (st₂ left)] [Small (st₂ right)] : + !{st₁} = !{st₂} ↔ st₁ = st₂ := by + simp_rw [IGame.ext_iff, moves_ofSets, funext_iff] + +theorem ofSets_inj {s₁ s₂ t₁ t₂ : Set IGame} [Small s₁] [Small s₂] [Small t₁] [Small t₂] : + !{s₁ | t₁} = !{s₂ | t₂} ↔ s₁ = s₂ ∧ t₁ = t₂ := by + simp + +/-- A (proper) subposition is any game reachable a nonempty sequence of +(not necessarily alternating) left and right moves. -/ +def Subposition : IGame → IGame → Prop := + Relation.TransGen fun x y => x ∈ ⋃ p, y.moves p + +@[aesop safe apply] +theorem Subposition.of_mem_moves {p} {x y : IGame} (h : x ∈ y.moves p) : Subposition x y := + Relation.TransGen.single (Set.mem_iUnion_of_mem p h) + +theorem Subposition.trans {x y z : IGame} (h₁ : Subposition x y) (h₂ : Subposition y z) : + Subposition x z := + Relation.TransGen.trans h₁ h₂ + +instance : IsTrans _ Subposition := inferInstanceAs (IsTrans _ (Relation.TransGen _)) + +/-- The set of games reachable from a given game is small. -/ +instance small_setOf_subposition (x : IGame.{u}) : Small.{u} {y | Subposition y x} := + small_transGen' _ x + +/-- A variant of `small_setOf_subposition` in simp-normal form -/ +instance small_subtype_subposition (x : IGame.{u}) : Small.{u} {y // Subposition y x} := + small_transGen' _ x + +theorem subposition_wf : WellFounded Subposition := by + change WellFounded (Relation.TransGen fun (x y : QPF.Fix GameFunctor) => + x ∈ ⋃ p, (QPF.Fix.dest y).val p) + refine ⟨fun x => Acc.transGen ?_⟩ + apply QPF.Fix.ind + rintro _ ⟨⟨st, hst⟩, rfl⟩ + constructor + rintro y hy + rw [QPF.Fix.dest_mk] at hy + change y ∈ ⋃ p, Subtype.val '' st p at hy + obtain ⟨p, hp⟩ := Set.mem_iUnion.mp hy + obtain ⟨z, _, rfl⟩ := hp + exact z.property + +-- We make no use of `IGame`'s definition from a `QPF` after this point. +attribute [irreducible] IGame + +instance : WellFounded Subposition := subposition_wf +instance : WellFoundedRelation IGame := ⟨Subposition, subposition_wf⟩ + +theorem Subposition.irrefl (x : IGame) : ¬Subposition x x := _root_.irrefl x + +theorem self_notMem_moves (p : Player) (x : IGame) : x ∉ x.moves p := + fun hx ↦ Subposition.irrefl x (.of_mem_moves hx) + +/-- `WSubposition x y` means that `x` is reachable from `y` by a sequence of moves. +It is the non-strict version of `Subposition`. -/ +def WSubposition (x y : IGame) : Prop := x = y ∨ Subposition x y + +theorem wsubposition_iff_eq_or_subposition {x y : IGame} : + WSubposition x y ↔ x = y ∨ Subposition x y := .rfl + +theorem subposition_iff_exists {x y : IGame} : Subposition x y ↔ + ∃ p, ∃ z ∈ y.moves p, WSubposition x z := by + unfold WSubposition Subposition + rw [Relation.transGen_iff_exists] + simp_rw [mem_iUnion, ← exists_and_right, and_or_left] + exact exists_comm + +/-- The set of games reachable from a given game is small. -/ +instance small_setOf_wsubposition (x : IGame.{u}) : Small.{u} {y | WSubposition y x} := + small_insert x {y | Subposition y x} + +/-- A variant of `small_setOf_wsubposition` in simp-normal form -/ +instance small_subtype_wsubposition (x : IGame.{u}) : Small.{u} {y // WSubposition y x} := + small_insert x {y | Subposition y x} + +@[simp, refl] theorem WSubposition.refl (x : IGame) : WSubposition x x := .inl rfl +theorem WSubposition.rfl {x : IGame} : WSubposition x x := .refl x +theorem wsubposition_of_eq {x y : IGame} (hxy : x = y) : WSubposition x y := hxy ▸ .rfl + +theorem wsubposition_of_subposition {x y : IGame} (h : Subposition x y) : + WSubposition x y := .inr h + +alias Subposition.wsubposition := wsubposition_of_subposition + +theorem subposition_of_wsubposition_of_subposition {x y z : IGame} + (hxy : WSubposition x y) (hyz : Subposition y z) : Subposition x z := by + obtain rfl | hxy := hxy + · exact hyz + · exact hxy.trans hyz + +theorem subposition_of_subposition_of_wsubposition {x y z : IGame} + (hxy : Subposition x y) (hyz : WSubposition y z) : Subposition x z := by + obtain rfl | hyz := hyz + · exact hxy + · exact hxy.trans hyz + +alias WSubposition.trans_subposition := subposition_of_wsubposition_of_subposition +alias Subposition.trans_wsubposition' := subposition_of_wsubposition_of_subposition +alias Subposition.trans_wsubposition := subposition_of_subposition_of_wsubposition +alias WSubposition.trans_subposition' := subposition_of_subposition_of_wsubposition + +@[trans] theorem wsubposition_trans {x y z : IGame} + (hxy : WSubposition x y) (hyz : WSubposition y z) : WSubposition x z := by + obtain rfl | hyz := hyz + · exact hxy + · exact (hxy.trans_subposition hyz).wsubposition + +alias WSubposition.trans := wsubposition_trans + +instance : Trans Subposition Subposition Subposition := ⟨Subposition.trans⟩ +instance : Trans WSubposition Subposition Subposition := ⟨WSubposition.trans_subposition⟩ +instance : Trans Subposition WSubposition Subposition := ⟨Subposition.trans_wsubposition⟩ +instance : Trans WSubposition WSubposition WSubposition := ⟨WSubposition.trans⟩ + +theorem not_subposition_of_wsubposition {x y : IGame} (hxy : WSubposition x y) : + ¬Subposition y x := fun hyx => Subposition.irrefl x (hxy.trans_subposition hyx) + +theorem not_wsubposition_of_subposition {x y : IGame} (hxy : Subposition x y) : + ¬WSubposition y x := fun hyx => Subposition.irrefl x (hxy.trans_wsubposition hyx) + +alias WSubposition.not_subposition := not_subposition_of_wsubposition +alias Subposition.not_wsubposition := not_wsubposition_of_subposition + +theorem wsubposition_antisymm {x y : IGame} + (hxy : WSubposition x y) (hyx : WSubposition y x) : x = y := + hxy.resolve_right fun h => Subposition.irrefl x (h.trans_wsubposition hyx) + +alias WSubposition.antisymm := wsubposition_antisymm + +theorem wsubposition_antisymm_iff {x y : IGame} : x = y ↔ WSubposition x y ∧ WSubposition y x := + ⟨fun h => h ▸ ⟨.rfl, .rfl⟩, fun h => h.1.antisymm h.2⟩ + +theorem subposition_of_wsubposition_of_ne {x y : IGame} (hw : WSubposition x y) (hne : x ≠ y) : + Subposition x y := hw.resolve_left hne + +theorem subposition_of_wsubposition_not_wsubposition {x y : IGame} + (hxy : WSubposition x y) (hyx : ¬WSubposition y x) : Subposition x y := + hxy.resolve_left fun h => hyx (wsubposition_of_eq h.symm) + +theorem subposition_iff_wsubposition_not_wsubposition {x y : IGame} : + Subposition x y ↔ WSubposition x y ∧ ¬WSubposition y x := + ⟨fun hxy => ⟨hxy.wsubposition, hxy.not_wsubposition⟩, + fun h => subposition_of_wsubposition_not_wsubposition h.1 h.2⟩ + +theorem WSubposition.of_mem_moves {p : Player} {x y : IGame} (hxy : x ∈ y.moves p) : + WSubposition x y := (Subposition.of_mem_moves hxy).wsubposition + +/-- **Conway recursion**: build data for a game by recursively building it on its +left and right sets. You rarely need to use this explicitly, as the termination checker will handle +things for you. + +See `ofSetsRecOn` for an alternate form. -/ +@[elab_as_elim] +def moveRecOn {motive : IGame → Sort*} (x) + (ind : Π x, (Π p, Π y ∈ x.moves p, motive y) → motive x) : + motive x := + subposition_wf.recursion x fun x IH ↦ ind x (fun _ _ h ↦ IH _ (.of_mem_moves h)) + +theorem moveRecOn_eq {motive : IGame → Sort*} (x) + (ind : Π x, (Π p, Π y ∈ x.moves p, motive y) → motive x) : + moveRecOn x ind = ind x (fun _ y _ ↦ moveRecOn y ind) := + subposition_wf.fix_eq .. + +/-- **Conway recursion**: build data for a game by recursively building it on its +left and right sets. You rarely need to use this explicitly, as the termination checker will handle +things for you. + +See `moveRecOn` for an alternate form. -/ +@[elab_as_elim] +def ofSetsRecOn {motive : IGame.{u} → Sort*} (x) + (ofSets : Π (s t : Set IGame) [Small s] [Small t], + (Π x ∈ s, motive x) → (Π x ∈ t, motive x) → motive !{s | t}) : + motive x := + cast (by simp) <| moveRecOn (motive := fun x ↦ motive !{xᴸ | xᴿ}) x + fun x IH ↦ ofSets _ _ + (fun y hy ↦ cast (by simp) (IH left y hy)) (fun y hy ↦ cast (by simp) (IH right y hy)) + +@[simp] +theorem ofSetsRecOn_ofSets {motive : IGame.{u} → Sort*} + (s t : Set IGame) [Small.{u} s] [Small.{u} t] + (ofSets : Π (s t : Set IGame) [Small s] [Small t], + (Π x ∈ s, motive x) → (Π x ∈ t, motive x) → motive !{s | t}) : + ofSetsRecOn !{s | t} ofSets = + ofSets _ _ (fun y _ ↦ ofSetsRecOn y ofSets) (fun y _ ↦ ofSetsRecOn y ofSets) := by + rw [ofSetsRecOn, cast_eq_iff_heq, moveRecOn_eq] + simp_rw [ofSetsRecOn] + congr! <;> simp_all + +/-- Discharges proof obligations of the form `⊢ Subposition ..` arising in termination proofs +of definitions using well-founded recursion on `IGame`. -/ +macro "igame_wf" config:Lean.Parser.Tactic.optConfig : tactic => + `(tactic| all_goals solve_by_elim $config + [Prod.Lex.left, Prod.Lex.right, PSigma.Lex.left, PSigma.Lex.right, + Subposition.of_mem_moves, Subposition.trans, Subtype.prop] ) + +/-! ### Basic games -/ + +/-- The game `0 = !{∅ | ∅}`. -/ +instance : Zero IGame := ⟨!{fun _ ↦ ∅}⟩ + +theorem zero_def : (0 : IGame) = !{fun _ ↦ ∅} := rfl + +@[simp, game_cmp] theorem moves_zero (p : Player) : moves p 0 = ∅ := moves_ofSets .. + +instance : Inhabited IGame := ⟨0⟩ + +/-- The game `1 = !{{0} | ∅}`. -/ +instance : One IGame := ⟨!{{0} | ∅}⟩ + +theorem one_def : (1 : IGame) = !{{0} | ∅} := rfl + +@[simp, game_cmp] theorem leftMoves_one : 1ᴸ = {0} := leftMoves_ofSets .. +@[simp, game_cmp] theorem rightMoves_one : 1ᴿ = ∅ := rightMoves_ofSets .. + +/-! ### Order relations -/ + +/-- The less or equal relation on games. + +If `0 ≤ x`, then Left can win `x` as the second player. `x ≤ y` means that `0 ≤ y - x`. -/ +@[no_expose] +instance : LE IGame where + le := Sym2.GameAdd.recursion subposition_wf fun x y le ↦ + (∀ z (h : z ∈ xᴸ), ¬le y z (Sym2.GameAdd.snd_fst (.of_mem_moves h))) ∧ + (∀ z (h : z ∈ yᴿ), ¬le z x (Sym2.GameAdd.fst_snd (.of_mem_moves h))) + +/-- The less or fuzzy relation on games. `x ⧏ y` is notation for `¬ y ≤ x`. + +If `0 ⧏ x`, then Left can win `x` as the first player. `x ⧏ y` means that `0 ⧏ y - x`. -/ +notation:50 x:50 " ⧏ " y:50 => ¬ y ≤ x +recommended_spelling "lf" for "⧏" in [«term_⧏_»] + +/-- Definition of `x ≤ y` on games, in terms of `⧏`. -/ +theorem le_iff_forall_lf {x y : IGame} : + x ≤ y ↔ (∀ z ∈ xᴸ, z ⧏ y) ∧ (∀ z ∈ yᴿ, x ⧏ z) := + propext_iff.1 <| Sym2.GameAdd.recursion_eq .. + +/-- Definition of `x ⧏ y` on games, in terms of `≤`. -/ +theorem lf_iff_exists_le {x y : IGame} : + x ⧏ y ↔ (∃ z ∈ yᴸ, x ≤ z) ∨ (∃ z ∈ xᴿ, z ≤ y) := by + simpa [not_and_or, -not_and] using le_iff_forall_lf.not + +/-- The definition of `0 ≤ x` on games, in terms of `0 ⧏`. -/ +theorem zero_le {x : IGame} : 0 ≤ x ↔ ∀ y ∈ xᴿ, 0 ⧏ y := by + rw [le_iff_forall_lf]; simp + +/-- The definition of `x ≤ 0` on games, in terms of `⧏ 0`. -/ +theorem le_zero {x : IGame} : x ≤ 0 ↔ ∀ y ∈ xᴸ, y ⧏ 0 := by + rw [le_iff_forall_lf]; simp + +/-- The definition of `0 ⧏ x` on games, in terms of `0 ≤`. -/ +theorem zero_lf {x : IGame} : 0 ⧏ x ↔ ∃ y ∈ xᴸ, 0 ≤ y := by + rw [lf_iff_exists_le]; simp + +/-- The definition of `x ⧏ 0` on games, in terms of `≤ 0`. -/ +theorem lf_zero {x : IGame} : x ⧏ 0 ↔ ∃ y ∈ xᴿ, y ≤ 0 := by + rw [lf_iff_exists_le]; simp + +/-- The definition of `x ≤ y` on games, in terms of `≤` two moves later. + +Note that it's often more convenient to use `le_iff_forall_lf`, which only unfolds the definition by +one step. -/ +theorem le_def {x y : IGame} : x ≤ y ↔ + (∀ a ∈ xᴸ, (∃ b ∈ yᴸ, a ≤ b) ∨ (∃ b ∈ aᴿ, b ≤ y)) ∧ + (∀ a ∈ yᴿ, (∃ b ∈ aᴸ, x ≤ b) ∨ (∃ b ∈ xᴿ, b ≤ a)) := by + rw [le_iff_forall_lf] + congr! 2 <;> rw [lf_iff_exists_le] + +/-- The definition of `x ⧏ y` on games, in terms of `⧏` two moves later. + +Note that it's often more convenient to use `lf_iff_exists_le`, which only unfolds the definition by +one step. -/ +theorem lf_def {x y : IGame} : x ⧏ y ↔ + (∃ a ∈ yᴸ, (∀ b ∈ xᴸ, b ⧏ a) ∧ (∀ b ∈ aᴿ, x ⧏ b)) ∨ + (∃ a ∈ xᴿ, (∀ b ∈ aᴸ, b ⧏ y) ∧ (∀ b ∈ yᴿ, a ⧏ b)) := by + rw [lf_iff_exists_le] + congr! <;> rw [le_iff_forall_lf] + +theorem left_lf_of_le {x y z : IGame} (h : x ≤ y) (h' : z ∈ xᴸ) : z ⧏ y := + (le_iff_forall_lf.1 h).1 z h' + +theorem lf_right_of_le {x y z : IGame} (h : x ≤ y) (h' : z ∈ yᴿ) : x ⧏ z := + (le_iff_forall_lf.1 h).2 z h' + +theorem lf_of_le_left {x y z : IGame} (h : x ≤ z) (h' : z ∈ yᴸ) : x ⧏ y := + lf_iff_exists_le.2 <| Or.inl ⟨z, h', h⟩ + +theorem lf_of_right_le {x y z : IGame} (h : z ≤ y) (h' : z ∈ xᴿ) : x ⧏ y := + lf_iff_exists_le.2 <| Or.inr ⟨z, h', h⟩ + +private theorem le_rfl' {x : IGame} : x ≤ x := by + rw [le_iff_forall_lf] + constructor <;> intro y hy + exacts [lf_of_le_left le_rfl' hy, lf_of_right_le le_rfl' hy] +termination_by x +decreasing_by igame_wf + +private theorem le_trans' {x y z : IGame} (h₁ : x ≤ y) (h₂ : y ≤ z) : x ≤ z := by + rw [le_iff_forall_lf] + constructor <;> intro a ha h₃ + exacts [left_lf_of_le h₁ ha (le_trans' h₂ h₃), lf_right_of_le h₂ ha (le_trans' h₃ h₁)] +termination_by subposition_wf.cutExpand.wrap {x, y, z} +decreasing_by + on_goal 1 => convert! Relation.cutExpand_add_single {y, z} (Subposition.of_mem_moves ha) + on_goal 2 => convert Relation.cutExpand_single_add (Subposition.of_mem_moves ha) {x, y} + all_goals simp [← Multiset.singleton_add, add_comm, add_assoc, WellFounded.wrap] + +instance : Preorder IGame where + le_refl _ := private le_rfl' + le_trans x y z := private le_trans' + +theorem left_lf {x y : IGame} (h : y ∈ xᴸ) : y ⧏ x := + lf_of_le_left le_rfl h + +theorem lf_right {x y : IGame} (h : y ∈ xᴿ) : x ⧏ y := + lf_of_right_le le_rfl h + +theorem le_of_forall_moves_right_lf {x y : IGame} + (hx : ∀ z ∈ yᴿ, x ⧏ z) (hl : ∀ z ∈ xᴸ, ∃ w ∈ yᴸ, z ≤ w) : x ≤ y := by + refine le_iff_forall_lf.2 ⟨fun z hz ↦ ?_, hx⟩ + obtain ⟨w, hw, hw'⟩ := hl z hz + exact mt hw'.trans' (left_lf hw) + +theorem le_of_forall_moves_left_lf {x y : IGame} + (hx : ∀ z ∈ yᴸ, z ⧏ x) (hr : ∀ z ∈ xᴿ, ∃ w ∈ yᴿ, w ≤ z) : y ≤ x := by + refine le_iff_forall_lf.2 ⟨hx, fun z hz ↦ ?_⟩ + obtain ⟨w, hw, hw'⟩ := hr z hz + exact mt hw'.trans (lf_right hw) + +/-- The equivalence relation `x ≈ y` means that `x ≤ y` and `y ≤ x`. This is notation for +`AntisymmRel (⬝ ≤ ⬝) x y`. -/ +infix:50 " ≈ " => AntisymmRel (· ≤ ·) +recommended_spelling "equiv" for "≈" in [«term_≈_»] + +/-- The "fuzzy" relation `x ‖ y` means that `x ⧏ y` and `y ⧏ x`. This is notation for +`IncompRel (⬝ ≤ ⬝) x y`. -/ +notation:50 x:50 " ‖ " y:50 => IncompRel (· ≤ ·) x y +recommended_spelling "fuzzy" for "‖" in [«term_‖_»] + +open Lean PrettyPrinter Delaborator SubExpr Qq in +/-- Delaborates `AntisymmRel (· ≤ ·) x y` into `x ≈ y`. -/ +@[delab app.AntisymmRel] +meta def delabEquiv : Delab := do + try + let_expr f@AntisymmRel α r _ _ := ← getExpr | failure + have u := f.constLevels![0]! + have α : Q(Type u) := α + have r : Q($α → $α → Prop) := r + let le ← synthInstanceQ q(LE $α) + _ ← assertDefEqQ q(($le).le) q($r) + let x ← withNaryArg 2 delab + let y ← withNaryArg 3 delab + let stx : Term ← do + let info ← Lean.MonadRef.mkInfoFromRefPos + pure { + raw := Lean.Syntax.node3 info ``IGame.«term_≈_» x.raw (Lean.Syntax.atom info "≈") y.raw + } + annotateGoToSyntaxDef stx + catch _ => failure -- fail over to the default delaborator + +open Lean PrettyPrinter Delaborator SubExpr Qq in +/-- Delaborates `IncompRel (· ≤ ·) x y` into `x ‖ y`. -/ +@[delab app.IncompRel] +meta def delabFuzzy : Delab := do + try + let_expr f@IncompRel α r _ _ := ← getExpr | failure + have u := f.constLevels![0]! + have α : Q(Type u) := α + have r : Q($α → $α → Prop) := r + let le ← synthInstanceQ q(LE $α) + _ ← assertDefEqQ q(($le).le) q($r) + let x ← withNaryArg 2 delab + let y ← withNaryArg 3 delab + let stx : Term ← do + let info ← Lean.MonadRef.mkInfoFromRefPos + pure { + raw := Lean.Syntax.node3 info ``IGame.«term_‖_» x.raw (Lean.Syntax.atom info "‖") y.raw + } + annotateGoToSyntaxDef stx + catch _ => failure -- fail over to the default delaborator + +theorem equiv_of_forall_lf {x y : IGame} + (hl₁ : ∀ a ∈ xᴸ, a ⧏ y) (hr₁ : ∀ a ∈ xᴿ, y ⧏ a) + (hl₂ : ∀ b ∈ yᴸ, b ⧏ x) (hr₂ : ∀ b ∈ yᴿ, x ⧏ b) : x ≈ y := by + constructor <;> refine le_iff_forall_lf.2 ⟨?_, ?_⟩ <;> assumption + +theorem equiv_of_exists_le {x y : IGame} + (hl₁ : ∀ a ∈ xᴸ, ∃ b ∈ yᴸ, a ≤ b) (hr₁ : ∀ a ∈ xᴿ, ∃ b ∈ yᴿ, b ≤ a) + (hl₂ : ∀ b ∈ yᴸ, ∃ a ∈ xᴸ, b ≤ a) (hr₂ : ∀ b ∈ yᴿ, ∃ a ∈ xᴿ, a ≤ b) : x ≈ y := by + apply equiv_of_forall_lf <;> simp +contextual [hl₁, hl₂, hr₁, hr₂, lf_iff_exists_le] + +theorem equiv_of_exists {x y : IGame} + (hl₁ : ∀ a ∈ xᴸ, ∃ b ∈ yᴸ, a ≈ b) (hr₁ : ∀ a ∈ xᴿ, ∃ b ∈ yᴿ, a ≈ b) + (hl₂ : ∀ b ∈ yᴸ, ∃ a ∈ xᴸ, a ≈ b) (hr₂ : ∀ b ∈ yᴿ, ∃ a ∈ xᴿ, a ≈ b) : x ≈ y := by + apply equiv_of_exists_le <;> grind [AntisymmRel] + +@[simp] +protected theorem zero_lt_one : (0 : IGame) < 1 := by + rw [lt_iff_le_not_ge, le_iff_forall_lf, le_iff_forall_lf] + simp + +instance : ZeroLEOneClass IGame where + zero_le_one := IGame.zero_lt_one.le + +/-! ### Negation -/ + +private def neg' (x : IGame) : IGame := + !{range fun y : xᴿ ↦ neg' y.1 | range fun y : xᴸ ↦ neg' y.1} +termination_by x +decreasing_by igame_wf + +#adaptation_note /-- noncomputable is now needed -/ in +/-- The negative of a game is defined by `-!{s | t} = !{-t | -s}`. -/ +@[no_expose] +noncomputable instance : Neg IGame where + neg := neg' + +private theorem neg_ofSets'' (s t : Set IGame) [Small s] [Small t] : + -!{s | t} = !{Neg.neg '' t | Neg.neg '' s} := by + change neg' _ = _ + rw [neg'] + simp [Neg.neg, Set.ext_iff] + +instance : InvolutiveNeg IGame where + neg_neg x := by + refine ofSetsRecOn x ?_ + aesop (add simp [neg_ofSets'']) + +@[simp] +theorem neg_ofSets (s t : Set IGame) [Small s] [Small t] : -!{s | t} = !{-t | -s} := by + simp_rw [neg_ofSets'', Set.image_neg_eq_neg] + +theorem neg_ofSets' (st : Player → Set IGame) [Small (st left)] [Small (st right)] : + -!{st} = !{fun p ↦ -st (-p)} := by + rw [ofSets_eq_ofSets_cases, ofSets_eq_ofSets_cases fun _ ↦ -_, neg_ofSets] + rfl + +@[simp] +theorem neg_ofSets_const (s : Set IGame) [Small s] : + -!{fun _ ↦ s} = !{fun _ ↦ -s} := by + simp [neg_ofSets'] + +instance : NegZeroClass IGame where + neg_zero := by simp [zero_def] + +theorem neg_eq (x : IGame) : -x = !{-xᴿ | -xᴸ} := by + rw [← neg_ofSets, ofSets_leftMoves_rightMoves] + +theorem neg_eq' (x : IGame) : -x = !{fun p ↦ -x.moves (-p)} := by + rw [neg_eq, ofSets_eq_ofSets_cases (fun _ ↦ -_)]; rfl + +@[simp] +theorem moves_neg (p : Player) (x : IGame) : + (-x).moves p = -x.moves (-p) := by + rw [neg_eq', moves_ofSets] + +@[game_cmp] +theorem forall_moves_neg {P : IGame → Prop} {p : Player} {x : IGame} : + (∀ y ∈ (-x).moves p, P y) ↔ (∀ y ∈ x.moves (-p), P (-y)) := by + simp + +@[game_cmp] +theorem exists_moves_neg {P : IGame → Prop} {p : Player} {x : IGame} : + (∃ y ∈ (-x).moves p, P y) ↔ (∃ y ∈ x.moves (-p), P (-y)) := by + simp + +@[simp] +protected theorem neg_le_neg_iff {x y : IGame} : -x ≤ -y ↔ y ≤ x := by + induction x, y using Sym2.GameAdd.recursion subposition_wf with | _ x y IH + rw [le_iff_forall_lf, le_iff_forall_lf, and_comm, forall_moves_neg, forall_moves_neg] + dsimp + congr! 3 with z hz z hz + · rw [IH _ _ (Sym2.GameAdd.fst_snd (.of_mem_moves hz))] + · rw [IH _ _ (Sym2.GameAdd.snd_fst (.of_mem_moves hz))] + +protected theorem neg_le {x y : IGame} : -x ≤ y ↔ -y ≤ x := by + simpa using @IGame.neg_le_neg_iff x (-y) +protected theorem le_neg {x y : IGame} : x ≤ -y ↔ y ≤ -x := by + simpa using @IGame.neg_le_neg_iff (-x) y + +@[simp] +protected theorem neg_lt_neg_iff {x y : IGame} : -x < -y ↔ y < x := by + simp [lt_iff_le_not_ge] + +protected theorem neg_lt {x y : IGame} : -x < y ↔ -y < x := by + simpa using @IGame.neg_lt_neg_iff x (-y) +protected theorem lt_neg {x y : IGame} : x < -y ↔ y < -x := by + simpa using @IGame.neg_lt_neg_iff (-x) y + +@[simp] +theorem neg_equiv_neg_iff {x y : IGame} : -x ≈ -y ↔ x ≈ y := by + simp [AntisymmRel, and_comm] + +theorem neg_equiv {x y : IGame} : -x ≈ y ↔ x ≈ -y := by + simpa using @neg_equiv_neg_iff x (-y) + +alias ⟨_, neg_congr⟩ := neg_equiv_neg_iff + +@[simp] +theorem neg_fuzzy_neg_iff {x y : IGame} : -x ‖ -y ↔ x ‖ y := by + simp [IncompRel, and_comm] + +theorem neg_fuzzy {x y : IGame} : -x ‖ y ↔ x ‖ -y := by + simpa using @neg_fuzzy_neg_iff x (-y) + +@[simp] theorem neg_le_zero {x : IGame} : -x ≤ 0 ↔ 0 ≤ x := by simpa using @IGame.neg_le x 0 +@[simp] theorem zero_le_neg {x : IGame} : 0 ≤ -x ↔ x ≤ 0 := by simpa using @IGame.le_neg 0 x +@[simp] theorem neg_lt_zero {x : IGame} : -x < 0 ↔ 0 < x := by simpa using @IGame.neg_lt x 0 +@[simp] theorem zero_lt_neg {x : IGame} : 0 < -x ↔ x < 0 := by simpa using @IGame.lt_neg 0 x + +@[simp] theorem neg_equiv_zero {x : IGame} : -x ≈ 0 ↔ x ≈ 0 := by + simpa using @IGame.neg_equiv_neg_iff x 0 +@[simp] theorem zero_equiv_neg {x : IGame} : 0 ≈ -x ↔ 0 ≈ x := by + simpa using @IGame.neg_equiv_neg_iff 0 x + +@[simp] theorem neg_fuzzy_zero {x : IGame} : -x ‖ 0 ↔ x ‖ 0 := by + simpa using @IGame.neg_fuzzy_neg_iff x 0 +@[simp] theorem zero_fuzzy_neg {x : IGame} : 0 ‖ -x ↔ 0 ‖ x := by + simpa using @IGame.neg_fuzzy_neg_iff 0 x + +/-! ### Addition and subtraction -/ + +private def add' (x y : IGame) : IGame := + !{(range fun z : xᴸ ↦ add' z y) ∪ (range fun z : yᴸ ↦ add' x z) | + (range fun z : xᴿ ↦ add' z y) ∪ (range fun z : yᴿ ↦ add' x z)} +termination_by (x, y) +decreasing_by igame_wf + +#adaptation_note /-- noncomputable is now needed -/ in +/-- The sum of `x = !{s₁ | t₁}` and `y = !{s₂ | t₂}` is `!{s₁ + y, x + s₂ | t₁ + y, x + t₂}`. -/ +@[no_expose] +noncomputable instance : Add IGame where + add := add' + +theorem add_eq (x y : IGame) : x + y = + !{(· + y) '' xᴸ ∪ (x + ·) '' yᴸ | (· + y) '' xᴿ ∪ (x + ·) '' yᴿ} := by + change add' _ _ = _ + rw [add'] + simp [HAdd.hAdd, Add.add, Set.ext_iff] + +theorem add_eq' (x y : IGame) : x + y = + !{fun p ↦ (· + y) '' x.moves p ∪ (x + ·) '' y.moves p} := by + rw [add_eq, ofSets_eq_ofSets_cases (fun _ ↦ _ ∪ _)] + +theorem ofSets_add_ofSets + (s₁ t₁ s₂ t₂ : Set IGame) [Small s₁] [Small t₁] [Small s₂] [Small t₂] : + !{s₁ | t₁} + !{s₂ | t₂} = + !{(· + !{s₂ | t₂}) '' s₁ ∪ (!{s₁ | t₁} + ·) '' s₂ | + (· + !{s₂ | t₂}) '' t₁ ∪ (!{s₁ | t₁} + ·) '' t₂} := by + rw [add_eq] + simp + +theorem ofSets_add_ofSets' (st₁ st₂ : Player → Set IGame) + [Small (st₁ left)] [Small (st₂ left)] [Small (st₁ right)] [Small (st₂ right)] : + !{st₁} + !{st₂} = + !{fun p ↦ (· + !{st₂}) '' st₁ p ∪ (!{st₁} + ·) '' st₂ p} := by + rw [ofSets_eq_ofSets_cases, ofSets_eq_ofSets_cases st₂, ofSets_eq_ofSets_cases (fun _ ↦ _ ∪ _), + ofSets_add_ofSets] + +@[simp] +theorem moves_add (p : Player) (x y : IGame) : + (x + y).moves p = (· + y) '' x.moves p ∪ (x + ·) '' y.moves p := by + rw [add_eq', moves_ofSets] + +theorem add_left_mem_moves_add {p : Player} {x y : IGame} (h : x ∈ y.moves p) (z : IGame) : + z + x ∈ (z + y).moves p := by + rw [moves_add]; right; use x + +theorem add_right_mem_moves_add {p : Player} {x y : IGame} (h : x ∈ y.moves p) (z : IGame) : + x + z ∈ (y + z).moves p := by + rw [moves_add]; left; use x + +@[game_cmp] +theorem forall_moves_add {p : Player} {P : IGame → Prop} {x y : IGame} : + (∀ a ∈ (x + y).moves p, P a) ↔ + (∀ a ∈ x.moves p, P (a + y)) ∧ (∀ b ∈ y.moves p, P (x + b)) := by + aesop + +@[game_cmp] +theorem exists_moves_add {p : Player} {P : IGame → Prop} {x y : IGame} : + (∃ a ∈ (x + y).moves p, P a) ↔ + (∃ a ∈ x.moves p, P (a + y)) ∨ (∃ b ∈ y.moves p, P (x + b)) := by + aesop + +@[simp] +theorem add_eq_zero_iff {x y : IGame} : x + y = 0 ↔ x = 0 ∧ y = 0 := by + constructor <;> simp_all [IGame.ext_iff] + +private theorem add_zero' (x : IGame) : x + 0 = x := by + refine moveRecOn x ?_ + aesop + +private theorem add_comm' (x y : IGame) : x + y = y + x := by + ext + simp only [moves_add, mem_union, mem_image, or_comm] + congr! 3 <;> + · refine and_congr_right_iff.2 fun h ↦ ?_ + rw [add_comm'] +termination_by (x, y) +decreasing_by igame_wf + +private theorem add_assoc' (x y z : IGame) : x + y + z = x + (y + z) := by + ext1 + simp only [moves_add, image_union, image_image, union_assoc] + refine congrArg₂ _ ?_ (congrArg₂ _ ?_ ?_) <;> + · ext + congr! 2 + rw [add_assoc'] +termination_by (x, y, z) +decreasing_by igame_wf + +instance : AddCommMonoid IGame where + add_zero := private add_zero' + zero_add _ := private add_comm' .. ▸ add_zero' _ + add_comm := private add_comm' + add_assoc := private add_assoc' + nsmul := nsmulRec + +/-- The subtraction of `x` and `y` is defined as `x + (-y)`. -/ +instance : SubNegMonoid IGame where + zsmul := zsmulRec + +@[simp] +theorem moves_sub (p : Player) (x y : IGame) : + (x - y).moves p = (· - y) '' x.moves p ∪ (x + ·) '' (-y.moves (-p)) := by + simp [sub_eq_add_neg] + +theorem sub_left_mem_moves_sub {p : Player} {x y : IGame} (h : x ∈ y.moves p) (z : IGame) : + z - x ∈ (z - y).moves (-p) := by + apply add_left_mem_moves_add; simpa + +theorem sub_left_mem_moves_sub_neg {p : Player} {x y : IGame} (h : x ∈ y.moves (-p)) (z : IGame) : + z - x ∈ (z - y).moves p := by + apply add_left_mem_moves_add; simpa + +theorem sub_right_mem_moves_sub {p : Player} {x y : IGame} (h : x ∈ y.moves p) (z : IGame) : + x - z ∈ (y - z).moves p := + add_right_mem_moves_add h _ + +private theorem neg_add' (x y : IGame) : -(x + y) = -x + -y := by + ext + simp only [moves_neg, moves_add, union_neg, mem_union, mem_neg, mem_image, exists_neg_mem] + congr! 3 <;> + · refine and_congr_right_iff.2 fun _ ↦ ?_ + rw [← neg_inj, neg_add', neg_neg] +termination_by (x, y) +decreasing_by igame_wf + +instance : SubtractionCommMonoid IGame where + neg_neg := neg_neg + neg_add_rev x y := by rw [neg_add', add_comm] + neg_eq_of_add := by simp + add_comm := add_comm + +private theorem sub_self_le (x : IGame) : x - x ≤ 0 := by + rw [le_zero, moves_sub] + rintro _ (⟨y, hy, rfl⟩ | ⟨y, hy, rfl⟩) + · exact lf_of_right_le (sub_self_le y) (sub_left_mem_moves_sub hy y) + · apply lf_of_right_le (sub_self_le (-y)) + rw [mem_neg] at hy + rw [sub_neg_eq_add] + exact add_right_mem_moves_add hy _ +termination_by x +decreasing_by igame_wf + +/-- The sum of a game and its negative is equivalent, though not necessarily identical to zero. -/ +theorem sub_self_equiv (x : IGame) : x - x ≈ 0 := by + rw [AntisymmRel, ← neg_le_zero, neg_sub, and_self] + exact sub_self_le x + +/-- The sum of a game and its negative is equivalent, though not necessarily identical to zero. -/ +theorem neg_add_equiv (x : IGame) : -x + x ≈ 0 := by + simpa [add_comm, sub_eq_add_neg] using sub_self_equiv x + +private theorem add_le_add_left' {x y : IGame} (h : x ≤ y) (z : IGame) : z + x ≤ z + y := by + rw [le_iff_forall_lf, moves_add, moves_add] + refine ⟨?_, ?_⟩ <;> rintro a (⟨a, ha, rfl⟩ | ⟨a, ha, rfl⟩) + · exact lf_of_le_left (add_le_add_left' h a) (add_right_mem_moves_add ha y) + · obtain (⟨b, hb, hb'⟩ | ⟨b, hb, hb'⟩) := lf_iff_exists_le.1 (left_lf_of_le h ha) + · exact lf_of_le_left (add_le_add_left' hb' z) (add_left_mem_moves_add hb z) + · exact lf_of_right_le (add_le_add_left' hb' z) (add_left_mem_moves_add hb z) + · exact lf_of_right_le (add_le_add_left' h a) (add_right_mem_moves_add ha x) + · obtain (⟨b, hb, hb'⟩ | ⟨b, hb, hb'⟩) := lf_iff_exists_le.1 (lf_right_of_le h ha) + · exact lf_of_le_left (add_le_add_left' hb' z) (add_left_mem_moves_add hb z) + · exact lf_of_right_le (add_le_add_left' hb' z) (add_left_mem_moves_add hb z) +termination_by (x, y, z) +decreasing_by igame_wf (maxDepth := 8) + +private theorem add_le_add_right' {x y : IGame} (h : x ≤ y) (z : IGame) : x + z ≤ y + z := by + simpa [add_comm] using add_le_add_left' h z + +instance : AddLeftMono IGame := ⟨fun x _ _ h ↦ add_le_add_left' h x⟩ +instance : AddRightMono IGame := ⟨fun x _ _ h ↦ add_le_add_right' h x⟩ + +instance : AddLeftReflectLE IGame where + le_of_add_le_add_left {x y} z h := by + rw [← zero_add y, ← zero_add z] + apply (add_le_add_left (neg_add_equiv x).ge y).trans + rw [add_assoc] + apply (add_le_add_right h (-x)).trans + rw [← add_assoc] + exact add_le_add_left (neg_add_equiv x).le z + +instance : AddRightReflectLE IGame := + addRightReflectLE_of_addLeftReflectLE _ + +instance : AddLeftStrictMono IGame where + elim x y z h := by + apply lt_of_le_not_ge (add_le_add_right h.le x) + contrapose! h + exact (le_of_add_le_add_left h).not_gt + +instance : AddRightStrictMono IGame := + addRightStrictMono_of_addLeftStrictMono _ + +-- TODO: [AddLeftMono α] [AddLeftReflectLE α] → AddLeftReflectLT α +instance : AddLeftReflectLT IGame where + elim _ := by simp [lt_iff_le_not_ge] + +instance : AddRightReflectLT IGame := + addRightReflectLT_of_addLeftReflectLT _ + +-- TODO: add the general versions of this to Mathlib + +theorem add_congr {a b : IGame} (h₁ : a ≈ b) {c d : IGame} (h₂ : c ≈ d) : a + c ≈ b + d := + ⟨add_le_add h₁.1 h₂.1, add_le_add h₁.2 h₂.2⟩ + +theorem add_congr_left {a b c : IGame} (h : a ≈ b) : a + c ≈ b + c := + add_congr h .rfl + +theorem add_congr_right {a b c : IGame} (h : a ≈ b) : c + a ≈ c + b := + add_congr .rfl h + +@[simp] +theorem add_fuzzy_add_iff_left {a b c : IGame} : a + b ‖ a + c ↔ b ‖ c := by + simp [IncompRel] + +@[simp] +theorem add_fuzzy_add_iff_right {a b c : IGame} : b + a ‖ c + a ↔ b ‖ c := by + simp [IncompRel] + +theorem sub_congr {a b : IGame} (h₁ : a ≈ b) {c d : IGame} (h₂ : c ≈ d) : a - c ≈ b - d := + add_congr h₁ (neg_congr h₂) + +theorem sub_congr_left {a b c : IGame} (h : a ≈ b) : a - c ≈ b - c := + sub_congr h .rfl + +theorem sub_congr_right {a b c : IGame} (h : a ≈ b) : c - a ≈ c - b := + sub_congr .rfl h + +/-- We define the `NatCast` instance as `↑0 = 0` and `↑(n + 1) = !{{↑n} | ∅}`. + +Note that this is equivalent, but not identical, to the more common definition `↑n = !{Iio n | ∅}`. +For that, use `NatOrdinal.toIGame`. -/ +instance : AddCommMonoidWithOne IGame where + +/-- This version of the theorem is more convenient for the `game_cmp` tactic. -/ +@[game_cmp] +theorem leftMoves_natCast_succ' : ∀ n : ℕ, n.succᴸ = {(n : IGame)} + | 0 => by simp + | n + 1 => by + rw [Nat.cast_succ, moves_add, leftMoves_natCast_succ'] + simp + +@[simp 1100] -- This should trigger before `leftMoves_add`. +theorem leftMoves_natCast_succ (n : ℕ) : (n + 1)ᴸ = {(n : IGame)} := + leftMoves_natCast_succ' n + +@[simp 1100, game_cmp] -- This should trigger before `rightMoves_add`. +theorem rightMoves_natCast : ∀ n : ℕ, nᴿ = ∅ + | 0 => by simp + | n + 1 => by + rw [Nat.cast_succ, moves_add, rightMoves_natCast] + simp + +@[simp 1100, game_cmp] +theorem leftMoves_ofNat (n : ℕ) [n.AtLeastTwo] : ofNat(n)ᴸ = {((n - 1 : ℕ) : IGame)} := by + change nᴸ = _ + rw [← Nat.succ_pred (NeZero.out (n := n)), leftMoves_natCast_succ'] + simp + +@[simp 1100, game_cmp] +theorem rightMoves_ofNat (n : ℕ) [n.AtLeastTwo] : ofNat(n)ᴿ = ∅ := + rightMoves_natCast n + +theorem natCast_succ_eq (n : ℕ) : (n + 1 : IGame) = !{{(n : IGame)} | ∅} := by + ext p; cases p <;> simp + +/-- Every left option of a natural number is equal to a smaller natural number. -/ +theorem eq_natCast_of_mem_leftMoves_natCast {n : ℕ} {x : IGame} (hx : x ∈ nᴸ) : + ∃ m : ℕ, m < n ∧ m = x := by + cases n with + | zero => simp at hx + | succ n => + use n + simp_all + +instance : IntCast IGame where + intCast + | .ofNat n => n + | .negSucc n => -(n + 1) + +@[simp, game_cmp, norm_cast] theorem intCast_nat (n : ℕ) : ((n : ℤ) : IGame) = n := rfl +@[simp, game_cmp] theorem intCast_ofNat (n : ℕ) : ((ofNat(n) : ℤ) : IGame) = n := rfl +@[simp] theorem intCast_negSucc (n : ℕ) : (Int.negSucc n : IGame) = -(n + 1) := rfl + +@[game_cmp, norm_cast] theorem intCast_zero : ((0 : ℤ) : IGame) = 0 := rfl +@[game_cmp, norm_cast] theorem intCast_one : ((1 : ℤ) : IGame) = 1 := by simp + +@[simp, game_cmp, norm_cast] +theorem intCast_neg (n : ℤ) : ((-n : ℤ) : IGame) = -(n : IGame) := by + cases n with + | ofNat n => + cases n with + | zero => simp + | succ n => rfl + | negSucc n => exact (neg_neg _).symm + +theorem eq_sub_one_of_mem_leftMoves_intCast {n : ℤ} {x : IGame} (hx : x ∈ nᴸ) : + x = (n - 1 : ℤ) := by + obtain ⟨n, rfl | rfl⟩ := n.eq_nat_or_neg + · cases n + · simp at hx + · rw [intCast_nat] at hx + simp_all + · simp at hx + +theorem eq_add_one_of_mem_rightMoves_intCast {n : ℤ} {x : IGame} (hx : x ∈ nᴿ) : + x = (n + 1 : ℤ) := by + have : -x ∈ (-n : ℤ)ᴸ := by simpa + rw [← neg_inj] + simpa [← IGame.intCast_neg, add_comm, sub_eq_add_neg] using + eq_sub_one_of_mem_leftMoves_intCast this + +/-- Every left option of an integer is equal to a smaller integer. -/ +theorem eq_intCast_of_mem_leftMoves_intCast {n : ℤ} {x : IGame} (hx : x ∈ nᴸ) : + ∃ m : ℤ, m < n ∧ m = x := by + use n - 1 + simp [eq_sub_one_of_mem_leftMoves_intCast hx] + +/-- Every right option of an integer is equal to a larger integer. -/ +theorem eq_intCast_of_mem_rightMoves_intCast {n : ℤ} {x : IGame} (hx : x ∈ nᴿ) : + ∃ m : ℤ, n < m ∧ m = x := by + use n + 1 + simp [eq_add_one_of_mem_rightMoves_intCast hx] + +/-! ### Multiplication -/ + +-- TODO: upstream +attribute [aesop apply safe] Prod.Lex.left Prod.Lex.right + +private def mul' (x y : IGame) : IGame := + !{(range fun a : (xᴸ ×ˢ yᴸ ∪ xᴿ ×ˢ yᴿ :) ↦ + mul' a.1.1 y + mul' x a.1.2 - mul' a.1.1 a.1.2) | + (range fun a : (xᴸ ×ˢ yᴿ ∪ xᴿ ×ˢ yᴸ :) ↦ + mul' a.1.1 y + mul' x a.1.2 - mul' a.1.1 a.1.2)} +termination_by (x, y) +decreasing_by + all_goals + rcases a.property with h | h + all_goals + first + | exact Prod.Lex.left _ _ (Subposition.of_mem_moves h.1) + | exact Prod.Lex.right _ (Subposition.of_mem_moves h.2) + +#adaptation_note /-- noncomputable is now needed -/ in +/-- The product of `x = !{s₁ | t₁}` and `y = !{s₂ | t₂}` is +`!{a₁ * y + x * b₁ - a₁ * b₁ | a₂ * y + x * b₂ - a₂ * b₂}`, where `(a₁, b₁) ∈ s₁ ×ˢ s₂ ∪ t₁ ×ˢ t₂` +and `(a₂, b₂) ∈ s₁ ×ˢ t₂ ∪ t₁ ×ˢ s₂`. + +Using `IGame.mulOption`, this can alternatively be written as +`x * y = !{mulOption x y a₁ b₁ | mulOption x y a₂ b₂}`. -/ +@[no_expose] +noncomputable instance : Mul IGame where + mul := mul' + +/-- The general option of `x * y` looks like `a * y + x * b - a * b`, for `a` and `b` options of +`x` and `y`, respectively. -/ +@[pp_nodot, game_cmp, expose] +def mulOption (x y a b : IGame) : IGame := + a * y + x * b - a * b + +theorem mul_eq (x y : IGame) : x * y = + !{(fun a ↦ mulOption x y a.1 a.2) '' (xᴸ ×ˢ yᴸ ∪ xᴿ ×ˢ yᴿ) | + (fun a ↦ mulOption x y a.1 a.2) '' (xᴸ ×ˢ yᴿ ∪ xᴿ ×ˢ yᴸ)} := by + change mul' _ _ = _ + rw [mul'] + simp [mulOption, HMul.hMul, Mul.mul, Set.ext_iff] + +theorem mul_eq' (x y : IGame) : x * y = + !{fun p ↦ (fun a ↦ mulOption x y a.1 a.2) '' + (xᴸ ×ˢ y.moves p ∪ xᴿ ×ˢ y.moves (-p))} := by + rw [mul_eq, ofSets_eq_ofSets_cases (fun _ ↦ _ '' _)]; rfl + +theorem ofSets_mul_ofSets (s₁ t₁ s₂ t₂ : Set IGame) [Small s₁] [Small t₁] [Small s₂] [Small t₂] : + !{s₁ | t₁} * !{s₂ | t₂} = + !{(fun a ↦ mulOption !{s₁ | t₁} !{s₂ | t₂} a.1 a.2) '' (s₁ ×ˢ s₂ ∪ t₁ ×ˢ t₂) | + (fun a ↦ mulOption !{s₁ | t₁} !{s₂ | t₂} a.1 a.2) '' (s₁ ×ˢ t₂ ∪ t₁ ×ˢ s₂)} := by + rw [mul_eq] + simp + +@[simp] +theorem moves_mul (p : Player) (x y : IGame) : + (x * y).moves p = (fun a ↦ mulOption x y a.1 a.2) '' + (xᴸ ×ˢ y.moves p ∪ xᴿ ×ˢ y.moves (-p)) := by + rw [mul_eq', moves_ofSets] + +@[simp] +theorem moves_mulOption (p : Player) (x y a b : IGame) : + (mulOption x y a b).moves p = (a * y + x * b - a * b).moves p := + rfl + +theorem mulOption_mem_moves_mul {px py : Player} {x y a b : IGame} + (h₁ : a ∈ x.moves px) (h₂ : b ∈ y.moves py) : mulOption x y a b ∈ (x * y).moves (px * py) := by + rw [moves_mul]; use (a, b); cases px <;> cases py <;> simp_all + +@[game_cmp] +theorem forall_moves_mul {p : Player} {P : IGame → Prop} {x y : IGame} : + (∀ a ∈ (x * y).moves p, P a) ↔ + (∀ p', ∀ a ∈ x.moves p', ∀ b ∈ y.moves (p' * p), P (mulOption x y a b)) := by + aesop + +@[game_cmp] +theorem exists_moves_mul {p : Player} {P : IGame → Prop} {x y : IGame} : + (∃ a ∈ (x * y).moves p, P a) ↔ + (∃ p', ∃ a ∈ x.moves p', ∃ b ∈ y.moves (p' * p), P (mulOption x y a b)) := by + aesop + +private theorem zero_mul' (x : IGame) : 0 * x = 0 := by + ext p; cases p <;> simp + +private theorem one_mul' (x : IGame) : 1 * x = x := by + refine moveRecOn x ?_ + aesop (add simp [mulOption, and_assoc, zero_mul']) + +private theorem mul_comm' (x y : IGame) : x * y = y * x := by + ext p + simp only [moves_mul, mem_image, mem_prod, mem_union, Prod.exists] + cases p; all_goals + dsimp + simp only [and_comm, or_comm] + rw [exists_comm] + congr! 4 with b a + rw [and_congr_left_iff] + rintro (⟨_, _⟩ | ⟨_, _⟩) <;> + rw [mulOption, mulOption, mul_comm' x, mul_comm' _ y, add_comm, mul_comm' a b] +termination_by (x, y) +decreasing_by igame_wf + +instance : CommMagma IGame where + mul_comm := private mul_comm' + +instance : MulZeroClass IGame where + zero_mul := private zero_mul' + mul_zero x := private mul_comm' .. ▸ zero_mul' x + +instance : MulZeroOneClass IGame where + one_mul := private one_mul' + mul_one x := private mul_comm' .. ▸ one_mul' x + +theorem mulOption_comm (x y a b : IGame) : mulOption x y a b = mulOption y x b a := by + simp [mulOption, add_comm, mul_comm] + +private theorem neg_mul' (x y : IGame) : -x * y = -(x * y) := by + ext + simp only [moves_mul, moves_neg, mem_image, mem_union, mem_prod, mem_neg, Prod.exists] + rw [← (Equiv.neg _).exists_congr_right] + dsimp only [Player.neg_left, Player.neg_right] + simp only [Equiv.neg_apply, neg_neg, mulOption, or_comm] + congr! 4 + rw [and_congr_right_iff] + rintro (⟨_, _⟩ | ⟨_, _⟩) + all_goals + rw [← neg_inj, neg_mul', neg_mul', neg_mul'] + simp [sub_eq_add_neg, add_comm] +termination_by (x, y) +decreasing_by igame_wf + +instance : HasDistribNeg IGame where + neg_mul := private neg_mul' + mul_neg _ _ := by rw [mul_comm, neg_mul', mul_comm] + +theorem mulOption_neg_left (x y a b : IGame) : mulOption (-x) y a b = -mulOption x y (-a) b := by + simp [mulOption, sub_eq_neg_add, add_comm] + +theorem mulOption_neg_right (x y a b : IGame) : mulOption x (-y) a b = -mulOption x y a (-b) := by + simp [mulOption, sub_eq_neg_add, add_comm] + +theorem mulOption_neg (x y a b : IGame) : mulOption (-x) (-y) a b = mulOption x y (-a) (-b) := by + simp [mulOption, sub_eq_neg_add, add_comm] + +@[simp] +theorem mulOption_zero_left (x y a : IGame) : mulOption x y 0 a = x * a := by + simp [mulOption] + +@[simp] +theorem mulOption_zero_right (x y a : IGame) : mulOption x y a 0 = a * y := by + simp [mulOption] + +/-! Distributivity and associativity only hold up to equivalence; we prove this in +`CombinatorialGames.Game.Basic`. -/ + +/-! ### Division -/ + +/-- An auxiliary inductive type to enumerate the options of `IGame.inv`. -/ +private inductive InvTy (lr : Player → Type u) : Player → Type u + | zero : InvTy lr left + | mk (p₁ p₂) : (lr (-(p₁ * p₂))) → InvTy lr p₁ → InvTy lr p₂ + +private def InvTy.val' {x : IGame} + (IH : ∀ p, Shrink {y ∈ x.moves p | 0 < y} → IGame) (b : Player) : + InvTy (fun p ↦ Shrink {y ∈ x.moves p | 0 < y}) b → IGame + | zero => 0 + | mk _ _ i j => (1 + ((equivShrink _).symm i - x) * val' IH _ j) * IH _ i + +private def inv' (x : IGame.{u}) : IGame.{u} := + let IH (p) : Shrink {y ∈ x.moves p | 0 < y} → IGame := + fun x ↦ inv' (Subtype.val <| (equivShrink _).symm x) + !{.range (InvTy.val' IH left) | .range (InvTy.val' IH right)} +termination_by x +decreasing_by exact .of_mem_moves ((equivShrink _).symm x).2.1 + +private abbrev InvTy.val (x : IGame) (b : Player) + (i : InvTy (fun p ↦ Shrink {y ∈ x.moves p | 0 < y}) b) : IGame := + i.val' (fun _ ↦ inv' ∘ Subtype.val ∘ (equivShrink _).symm) b + +/-- The inverse of a positive game `x = !{s | t}` is `!{s' | t'}`, where `s'` and `t'` are the +smallest sets such that `0 ∈ s'`, and such that `(1 + (z - x) * a) / z, (1 + (y - x) * b) / y ∈ s'` +and `(1 + (y - x) * a) / y, (1 + (z - x) * b) / z ∈ t'` for `y ∈ s` positive, `z ∈ t`, `a ∈ s'`, and +`b ∈ t'`. + +If `x` is negative, we define `x⁻¹ = -(-x)⁻¹`. For any other game, we set `x⁻¹ = 0`. + +If `x` is a non-zero numeric game, then `x * x⁻¹ ≈ 1`. The value of this function on any non-numeric +game should be treated as a junk value. -/ +@[no_expose] +instance : Inv IGame where + inv x := by classical exact if 0 < x then inv' x else if x < 0 then -inv' (-x) else 0 + +instance : Div IGame where + div x y := x * y⁻¹ + +open Classical in +private theorem inv_eq'' {x : IGame} : + x⁻¹ = if 0 < x then inv' x else if x < 0 then -inv' (-x) else 0 := + rfl + +private theorem inv_eq {x : IGame.{u}} (hx : 0 < x) : + x⁻¹ = !{.range (InvTy.val x left) | .range (InvTy.val x right)} := by + rw [inv_eq'', ite_eq_left hx, inv'] + rfl + +private theorem inv_eq' {x : IGame.{u}} (hx : 0 < x) : + x⁻¹ = !{fun p ↦ .range (InvTy.val x p)} := by + rw [inv_eq hx, ofSets_eq_ofSets_cases fun _ ↦ range _] + +protected theorem div_eq_mul_inv (x y : IGame) : x / y = x * y⁻¹ := rfl + +theorem inv_of_equiv_zero {x : IGame} (h : x ≈ 0) : x⁻¹ = 0 := by + simp [inv_eq'', h.not_lt, h.not_gt] + +@[simp] protected theorem inv_zero : (0 : IGame)⁻¹ = 0 := inv_of_equiv_zero .rfl +@[simp] protected theorem zero_div (x : IGame) : 0 / x = 0 := zero_mul _ +@[simp] protected theorem neg_div (x y : IGame) : -x / y = -(x / y) := neg_mul .. + +@[simp] +protected theorem inv_neg (x : IGame) : (-x)⁻¹ = -x⁻¹ := by + rw [inv_eq'', inv_eq''] + obtain h | h | h | h := lt_or_antisymmRel_or_gt_or_incompRel x 0 + repeat + simp [h, h.asymm] + simp [h.not_lt, h.not_gt] + +/-- The general option of `x⁻¹` looks like `(1 + (y - x) * a) / y`, for `y` an option of `x`, and +`a` some other "earlier" option of `x⁻¹`. -/ +@[pp_nodot, expose] +def invOption (x y a : IGame) : IGame := + (1 + (y - x) * a) / y + +private theorem invOption_eq {x y a : IGame} (hy : 0 < y) : + invOption x y a = (1 + (y - x) * a) * inv' y := by + rw [invOption, IGame.div_eq_mul_inv, inv_eq'', ite_eq_left hy] + +theorem zero_mem_leftMoves_inv {x : IGame} (hx : 0 < x) : 0 ∈ x⁻¹ᴸ := by + rw [inv_eq hx, leftMoves_ofSets] + exact ⟨InvTy.zero, rfl⟩ + +theorem inv_nonneg {x : IGame} (hx : 0 < x) : 0 ⧏ x⁻¹ := + left_lf (zero_mem_leftMoves_inv hx) +theorem invOption_mem_moves_inv {x y a : IGame} {p₁ p₂} (hx : 0 < x) (hy : 0 < y) + (hyx : y ∈ x.moves (-(p₁ * p₂))) (ha : a ∈ x⁻¹.moves p₁) : + invOption x y a ∈ x⁻¹.moves p₂ := by + rw [inv_eq' hx, moves_ofSets] at * + obtain ⟨i, rfl⟩ := ha + use InvTy.mk _ _ (equivShrink _ ⟨_, (by simpa [mul_left_comm p₂]), hy⟩) i + simp [InvTy.val, InvTy.val', invOption_eq hy] + +private theorem invRec' {x : IGame.{u}} (hx : 0 < x) + {P : ∀ p, ∀ y ∈ x⁻¹.moves p, Prop} + (zero : P left 0 (zero_mem_leftMoves_inv hx)) + (mk : ∀ p₁ p₂, ∀ y (hy : 0 < y) (hyx : y ∈ x.moves (-(p₁ * p₂))), ∀ a (ha : a ∈ x⁻¹.moves p₁), + P p₁ a ha → P p₂ _ (invOption_eq hy ▸ invOption_mem_moves_inv hx hy hyx ha)) : + (∀ p y (hy : y ∈ x⁻¹.moves p), P p y hy) := by + suffices ∀ p : Player, ∀ i, P p (InvTy.val x p i) (by cases p <;> simp [inv_eq hx]) by + intro p y hy + rw [inv_eq' hx, moves_ofSets] at hy + obtain ⟨i, rfl⟩ := hy + simpa using this p i + intro b i + induction i + · simpa + · apply mk + · exact ((equivShrink {y ∈ _ | 0 < y}).symm _).2.2 + · exact ((equivShrink {y ∈ _ | 0 < y}).symm _).2.1 + · assumption + +/-- An induction principle on left and right moves of `x⁻¹`. -/ +theorem invRec {x : IGame} (hx : 0 < x) + {P : ∀ p, ∀ y ∈ x⁻¹.moves p, Prop} + (zero : P left 0 (zero_mem_leftMoves_inv hx)) + (mk : ∀ p₁ p₂, ∀ y (hy : 0 < y) (hyx : y ∈ x.moves (-(p₁ * p₂))), ∀ a (ha : a ∈ x⁻¹.moves p₁), + P p₁ a ha → P p₂ _ (invOption_mem_moves_inv hx hy hyx ha)) : + (∀ p y (hy : y ∈ x⁻¹.moves p), P p y hy) := by + apply invRec' hx zero + convert mk using 8 with _ _ _ ha + simp_rw [invOption_eq ha] + +instance : RatCast IGame where + ratCast q := q.num / q.den + +theorem ratCast_def (q : ℚ) : (q : IGame) = q.num / q.den := rfl + +@[simp] theorem ratCast_zero : ((0 : ℚ) : IGame) = 0 := by simp [ratCast_def] +@[simp] theorem ratCast_neg (q : ℚ) : ((-q : ℚ) : IGame) = -(q : IGame) := by simp [ratCast_def] + +end IGame +end diff --git a/LeanPool/ConwayRefinement/CombinatorialGames/Game/Ordinal.lean b/LeanPool/ConwayRefinement/CombinatorialGames/Game/Ordinal.lean new file mode 100644 index 0000000000..99a5ea4000 --- /dev/null +++ b/LeanPool/ConwayRefinement/CombinatorialGames/Game/Ordinal.lean @@ -0,0 +1,261 @@ +/- +Copyright (c) 2022 Violeta Hernández Palacios. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Violeta Hernández Palacios +-/ +module + +public import LeanPool.ConwayRefinement.CombinatorialGames.Game.Basic +public import LeanPool.ConwayRefinement.CombinatorialGames.NatOrdinal.Basic +public import Mathlib.Algebra.Order.Hom.Monoid + +import LeanPool.ConwayRefinement.CombinatorialGames.Tactic.GameCmp +import Mathlib.Algebra.Order.Hom.Monoid +import Mathlib.Data.Set.Finite.Lattice + +/-! +# Ordinals as games + +We define the canonical map `NatOrdinal → IGame`, where every ordinal is mapped to the game whose +left set consists of all previous ordinals. We make use of the type alias `NatOrdinal` rather than +`Ordinal`, as this map also preserves addition, and in the case of surreals, multiplication. The map +to surreals is defined in `CombinatorialGames.Surreal.Ordinal`. + +We also prove some properties about `NatCast`, which is related to the previous construction by +`toIGame (↑n) ≈ ↑n`. + +# Main declarations + +- `NatOrdinal.toIGame`: The canonical map between `NatOrdinal` and `IGame`. +- `NatOrdinal.toGame`: The canonical map between `NatOrdinal` and `ConwayGame`. +-/ + +universe u + +open Set IGame + +@[expose] public noncomputable section + +/-! ### Lemmas to upstream -/ + +@[simp] +theorem OrderEmbedding.antisymmRel_iff_antisymmRel {α β : Type*} [Preorder α] [Preorder β] + {a b : α} (f : α ↪o β) : f a ≈ f b ↔ a ≈ b := by + simp [AntisymmRel] + +theorem OrderEmbedding.antisymmRel_iff_eq {α β : Type*} [Preorder α] [PartialOrder β] + {a b : α} (f : α ↪o β) : f a ≈ f b ↔ a = b := by + simp + +namespace NatOrdinal + +/-! ### `NatOrdinal` to `IGame` -/ + +/-- We make this private until we can build the `OrderEmbedding`. -/ +private def toIGame' (o : NatOrdinal.{u}) : IGame.{u} := + !{.range fun (⟨x, _⟩ : Iio o) ↦ toIGame' x | ∅} +termination_by o + +private theorem toIGame'_def (o : NatOrdinal) : o.toIGame' = !{toIGame' '' Iio o | ∅} := by + rw [toIGame']; simp [image_eq_range] + +private theorem leftMoves_toIGame' (o : NatOrdinal) : o.toIGame'ᴸ = toIGame' '' Iio o := by + rw [toIGame'_def]; exact leftMoves_ofSets .. + +private theorem rightMoves_toIGame' (o : NatOrdinal) : o.toIGame'ᴿ = ∅ := by + rw [toIGame'_def]; exact rightMoves_ofSets .. + +private theorem toIGame'_strictMono : StrictMono toIGame' := by + refine fun a b h ↦ lt_of_le_not_ge ?_ (left_lf ?_) + · rw [le_iff_forall_lf] + simpa [leftMoves_toIGame', rightMoves_toIGame'] using + fun c hc ↦ (toIGame'_strictMono (hc.trans h)).not_ge + · rw [leftMoves_toIGame'] + exact ⟨a, h, rfl⟩ +termination_by a => a + +/-- The canonical map from `NatOrdinal` to `IGame`, sending `o` to `{Iio o | ∅}`. -/ +@[no_expose] +def toIGame : NatOrdinal.{u} ↪o IGame.{u} := + .ofStrictMono NatOrdinal.toIGame' toIGame'_strictMono + +instance : Coe NatOrdinal IGame where + coe x := toIGame x + +theorem toIGame_def (o : NatOrdinal) : o.toIGame = !{toIGame '' Iio o | ∅} := + toIGame'_def o + +@[simp] +theorem leftMoves_toIGame (o : NatOrdinal) : o.toIGameᴸ = toIGame '' Iio o := + leftMoves_toIGame' o + +@[simp, game_cmp] +theorem rightMoves_toIGame (o : NatOrdinal) : o.toIGameᴿ = ∅ := + rightMoves_toIGame' o + +theorem forall_leftMoves_toIGame {P : IGame → Prop} {o : NatOrdinal} : + (∀ x ∈ (toIGame o)ᴸ, P x) ↔ ∀ a < o, P (toIGame a) := by + simp + +theorem exists_leftMoves_toIGame {P : IGame → Prop} {o : NatOrdinal} : + (∃ x ∈ (toIGame o)ᴸ, P x) ↔ ∃ a < o, P (toIGame a) := by + simp + +@[game_cmp] +theorem forall_leftMoves_toIGame_natCast {P : IGame → Prop} {n : ℕ} : + (∀ x ∈ (toIGame n)ᴸ, P x) ↔ ∀ m < n, P (toIGame m) := by + simp + +@[game_cmp] +theorem exists_leftMoves_toIGame_natCast {P : IGame → Prop} {n : ℕ} : + (∃ x ∈ (toIGame n)ᴸ, P x) ↔ (∃ m < n, P (toIGame m)) := by + simp + +@[game_cmp] +theorem forall_leftMoves_toIGame_ofNat {P : IGame → Prop} {n : ℕ} [n.AtLeastTwo] : + (∀ x ∈ (toIGame ofNat(n))ᴸ, P x) ↔ ∀ m < n, P (toIGame m) := + forall_leftMoves_toIGame_natCast + +@[game_cmp] +theorem exists_leftMoves_toIGame_ofNat {P : IGame → Prop} {n : ℕ} [n.AtLeastTwo] : + (∃ x ∈ (toIGame ofNat(n))ᴸ, P x) ↔ ∃ m < n, P (toIGame m) := + exists_leftMoves_toIGame_natCast + +theorem mem_leftMoves_toIGame_of_lt {a b : NatOrdinal} (h : a < b) : + a.toIGame ∈ b.toIGameᴸ := by + simpa + +@[simp, game_cmp] theorem toIGame_zero : toIGame 0 = 0 := by ext p; cases p <;> simp +@[simp, game_cmp] theorem toIGame_one : toIGame 1 = 1 := by ext p; cases p <;> simp + +@[simp] +theorem not_toIGame_fuzzy (a b : NatOrdinal) : ¬ toIGame a ‖ toIGame b := by + simpa [IncompRel] using le_of_lt + +@[simp] +theorem toIGame_nonneg (a : NatOrdinal) : 0 ≤ a.toIGame := by + simpa using toIGame.monotone zero_le + +/-! ### `NatOrdinal` to `ConwayGame` -/ + +/-- Converts an ordinal into the corresponding game. -/ +noncomputable def toGame : NatOrdinal.{u} ↪o ConwayGame.{u} := + .ofStrictMono (fun o ↦ .mk o.toIGame) fun _ _ h ↦ toIGame.strictMono h + +instance : Coe NatOrdinal ConwayGame where + coe x := toGame x + +@[simp] theorem _root_.ConwayGame.mk_natOrdinal_toIGame (o : NatOrdinal) : + .mk o.toIGame = o.toGame := + rfl + +theorem toGame_def (o : NatOrdinal) : o.toGame = !{toGame '' Iio o | ∅} := by + rw [← ConwayGame.mk_natOrdinal_toIGame, toIGame_def] + simp [image_image] + +@[simp] theorem toGame_zero : toGame 0 = 0 := by simp [← ConwayGame.mk_natOrdinal_toIGame] +@[simp] theorem toGame_one : toGame 1 = 1 := by simp [← ConwayGame.mk_natOrdinal_toIGame] + +@[simp] +theorem not_toGame_fuzzy (a b : NatOrdinal) : ¬ toGame a ‖ toGame b := + not_toIGame_fuzzy a b + +@[simp] +theorem toGame_nonneg (a : NatOrdinal) : 0 ≤ a.toGame := + toIGame_nonneg a + +/-- The natural addition of ordinals corresponds to their sum as games. -/ +theorem toIGame_add (a b : NatOrdinal) : (a + b).toIGame ≈ a.toIGame + b.toIGame := by + rw [AntisymmRel, le_iff_forall_lf, le_iff_forall_lf] + simp only [game_cmp, leftMoves_toIGame, lt_add_iff] + refine ⟨?_, ⟨fun _ ↦ ?_, fun _ ↦ ?_⟩⟩ + · rintro c (⟨d, _, hd⟩ | ⟨d, _, hd⟩) + all_goals + · rw [← toIGame.le_iff_le] at hd + apply (hd.trans_lt _).not_ge + grw [toIGame_add] + simpa + all_goals + grw [← toIGame_add] + simp +termination_by (a, b) + +@[simp] +theorem toGame_add (a b : NatOrdinal) : (a + b).toGame = a.toGame + b.toGame := + ConwayGame.mk_eq (toIGame_add a b) + +/-- The natural multiplication of ordinals corresponds to their product as games. -/ +theorem toIGame_mul (a b : NatOrdinal) : (a * b).toIGame ≈ a.toIGame * b.toIGame := by + rw [AntisymmRel, le_iff_forall_lf, le_iff_forall_lf] + simp only [game_cmp, leftMoves_toIGame, lt_mul_iff, mulOption] + refine ⟨fun e c hc d hd he ↦ ?_, fun c hc d hd ↦ ?_⟩ + · grw [← toIGame.le_iff_le, toIGame_add, toIGame_add] at he + rw [← add_le_add_iff_right (toIGame (c * d))] + apply mt he.trans' + grw [toIGame_mul, toIGame_mul, toIGame_mul, ← IGame.le_sub_iff_add_le] + exact left_lf <| mulOption_mem_moves_mul + (mem_leftMoves_toIGame_of_lt hc) (mem_leftMoves_toIGame_of_lt hd) + · grw [← sub_eq_add_neg, IGame.le_sub_iff_add_le, ← toIGame_mul, ← toIGame_mul, ← toIGame_mul, + ← toIGame_add, ← toIGame_add, toIGame.le_iff_le, not_le] + exact mul_add_lt hc hd +termination_by (a, b) + +@[simp] +theorem toGame_mul (a b : NatOrdinal) : (a * b).toGame = .mk (a.toIGame * b.toIGame) := + ConwayGame.mk_eq (toIGame_mul a b) + +/-- `NatOrdinal.toGame` as an `OrderAddMonoidHom`. -/ +@[simps] +def toGameAddHom : NatOrdinal →+o ConwayGame where + toFun := toGame + map_zero' := toGame_zero + map_add' := toGame_add + monotone' := toGame.monotone + +/-! ### `NatCast` properties -/ + +@[simp] +theorem toGame_natCast : ∀ n : ℕ, toGame n = n := + map_natCast' toGameAddHom toGame_one + +/-- Note that the equality doesn't hold, as e.g. `↑2 = {1 | }`, while `toIGame 2 = {0, 1 | }`. -/ +theorem toIGame_natCast_equiv (n : ℕ) : toIGame n ≈ n := + ConwayGame.mk_eq_mk.1 (by simp) + +end NatOrdinal + +namespace IGame +open NatOrdinal + +theorem Short.exists_lt_natCast (x : IGame) [Short x] : ∃ n : ℕ, x < n := by + have (y : xᴸ) : ∃ n : ℕ, y.1 < n := by + have := Short.of_mem_moves y.2 + exact Short.exists_lt_natCast y + choose f hf using this + obtain ⟨n, hn⟩ := (finite_range f).bddAbove + refine ⟨n + 1, lt_of_le_of_lt ?_ (IGame.natCast_lt.2 (Nat.lt_succ_self _))⟩ + rw [le_iff_forall_lf] + simpa using fun y hy ↦ ((hf ⟨y, hy⟩).trans_le (mod_cast hn ⟨⟨y, hy⟩, rfl⟩)).not_ge +termination_by x +decreasing_by igame_wf + +theorem Short.exists_neg_natCast_lt (x : IGame) [Short x] : ∃ n : ℕ, -n < x := by + obtain ⟨n, hn⟩ := exists_lt_natCast (-x) + use n + rwa [IGame.neg_lt] + +local notation "ω" => toIGame (NatOrdinal.of Ordinal.omega0) + +theorem Short.lt_omega0 (x : IGame) [Short x] : x < ω := by + obtain ⟨n, hn⟩ := exists_lt_natCast x + apply hn.trans + grw [← toIGame_natCast_equiv n] + rw [toIGame.lt_iff_lt, ← NatOrdinal.of_natCast n] + exact Ordinal.natCast_lt_omega0 n + +theorem Short.neg_omega0_lt (x : IGame) [Short x] : -ω < x := by + rw [IGame.neg_lt] + exact lt_omega0 _ + +end IGame +end diff --git a/LeanPool/ConwayRefinement/CombinatorialGames/Game/Player.lean b/LeanPool/ConwayRefinement/CombinatorialGames/Game/Player.lean new file mode 100644 index 0000000000..aa99e052b3 --- /dev/null +++ b/LeanPool/ConwayRefinement/CombinatorialGames/Game/Player.lean @@ -0,0 +1,188 @@ +/- +Copyright (c) 2025 Yuyang Zhao. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Yuyang Zhao +-/ +module + +public import Mathlib.Algebra.Ring.Defs +public import Mathlib.Algebra.Group.Defs +public import Mathlib.Data.Finset.Insert +import Mathlib.Algebra.Ring.Defs +public import Mathlib.Data.Fintype.Defs +public import Mathlib.Logic.Small.Defs + +import Mathlib.Tactic.DeriveFintype + +/-! +# Type of players + +This file implements the two-element type of players (`Left`, `Right`), alongside other basic +notational machinery to be used within game theory. +-/ + +@[expose] public section + +universe u + +/-! ### Players -/ + +/-- Either the Left or Right player. -/ +@[aesop safe cases, grind cases] +inductive Player where + /-- The Left player. -/ + | left : Player + /-- The Right player. -/ + | right : Player +deriving DecidableEq, Inhabited + +instance : Fintype Player where + elems := {Player.left, Player.right} + complete := by intro p; cases p <;> simp + +namespace Player + +/-- Specify a function `Player → α` from its two outputs. -/ +@[simp] +abbrev cases {α : Sort*} (l r : α) : Player → α + | left => l + | right => r + +lemma apply_cases {α β : Sort*} (f : α → β) (l r : α) (p : Player) : + f (cases l r p) = cases (f l) (f r) p := by + cases p <;> rfl + +@[simp] +theorem cases_inj {α : Sort*} {l₁ r₁ l₂ r₂ : α} : + cases l₁ r₁ = cases l₂ r₂ ↔ l₁ = l₂ ∧ r₁ = r₂ := + ⟨fun h ↦ ⟨congr($h left), congr($h right)⟩, fun ⟨hl, hr⟩ ↦ hl ▸ hr ▸ rfl⟩ + +theorem const_of_left_eq_right {α : Sort*} {f : Player → α} (hf : f left = f right) : + ∀ p q, f p = f q + | left, left | right, right => rfl + | left, right => hf + | right, left => hf.symm + +theorem const_of_left_eq_right' {f : Player → Prop} (hf : f left ↔ f right) (p q) : f p ↔ f q := + (const_of_left_eq_right hf.eq ..).to_iff + +@[simp] +protected lemma «forall» {p : Player → Prop} : + (∀ x, p x) ↔ p left ∧ p right := + ⟨fun h ↦ ⟨h left, h right⟩, fun ⟨hl, hr⟩ ↦ fun | left => hl | right => hr⟩ + +@[simp] +protected lemma «exists» {p : Player → Prop} : + (∃ x, p x) ↔ p left ∨ p right := + ⟨fun | ⟨left, h⟩ => .inl h | ⟨right, h⟩ => .inr h, fun | .inl h | .inr h => ⟨_, h⟩⟩ + +instance : Neg Player where + neg := cases right left + +@[simp, grind =] lemma neg_left : -left = right := rfl +@[simp, grind =] lemma neg_right : -right = left := rfl +@[simp] theorem eq_neg : ∀ {p q : Player}, p = -q ↔ p ≠ q := by decide +@[simp] theorem neg_eq : ∀ {p q : Player}, -p = q ↔ p ≠ q := by decide +theorem ne_neg : ∀ {p q : Player}, p ≠ -q ↔ p = q := by decide +theorem neg_ne : ∀ {p q : Player}, -p ≠ q ↔ p = q := by decide +theorem neg_ne_self : ∀ (p : Player), -p ≠ p := by decide +theorem self_ne_neg : ∀ (p : Player), p ≠ -p := by decide + +instance : InvolutiveNeg Player where + neg_neg := by decide + +/-- +The multiplication of `Player`s is used to state the lemmas about the multiplication of +combinatorial games, such as `IGame.mulOption_mem_moves_mul`. +-/ +instance : Mul Player where mul + | left, p => p + | right, p => -p + +@[simp, grind =] lemma left_mul (p : Player) : left * p = p := rfl +@[simp, grind =] lemma right_mul (p : Player) : right * p = -p := rfl +@[simp, grind =] lemma mul_left : ∀ p, p * left = p := by decide +@[simp, grind =] lemma mul_right : ∀ p, p * right = -p := by decide +@[simp, grind =] lemma mul_self : ∀ p, p * p = left := by decide + +instance : HasDistribNeg Player where + neg_mul := by decide + mul_neg := by decide + +instance : CommGroup Player where + one := left + inv := id + mul_assoc := by decide + mul_comm := by decide + one_mul := by decide + mul_one := by decide + inv_mul_cancel := by decide + +@[simp, grind =] lemma one_eq_left : 1 = left := rfl +@[simp, grind =] lemma inv_eq_self (p : Player) : p⁻¹ = p := rfl + +end Player + +open Player + +/-! ### OfSets -/ + +/-- +Type class for the `ofSets` operation. +Used to implement the `!{st}` and `!{s | t}` syntax. +-/ +class OfSets (α : Type (u + 1)) (Valid : outParam ((Player → Set α) → Prop)) where + /-- Construct a combinatorial game from its left and right sets. -/ + ofSets (st : Player → Set α) (h : Valid st) [Small.{u} (st left)] [Small.{u} (st right)] : α +export OfSets (ofSets) + +@[inherit_doc OfSets.ofSets] +macro "!{" st:term "}'" h:term:max : term => `(OfSets.ofSets $st $h) + +@[inherit_doc OfSets.ofSets] +macro "!{" s:term " | " t:term "}'" h:term:max : term => `(!{Player.cases $s $t}'$h) + +/-- A tactic which attempts to automatically solve goals which appear on `OfSets`. -/ +macro (name := conwayOfSetsTactic) "conway_of_sets_tactic" : tactic => + `(tactic| first + | done + | trivial + | assumption + | aesop + | fail "failed to prove sets are valid, try to use `!{st}'h` notation instead, \ +where `h` is a proof that sets are valid" + ) + +@[inherit_doc OfSets.ofSets] +macro:max "!{" st:term "}" : term => `(!{$st}'(by conway_of_sets_tactic)) + +@[inherit_doc OfSets.ofSets] +macro:max "!{" s:term " | " t:term "}" : term => `(!{$s | $t}'(by conway_of_sets_tactic)) + +recommended_spelling "ofSets" for "!{st}'h" in [ofSets, «term!{_}'_»] +recommended_spelling "ofSets" for "!{s | t}'h" in [ofSets, «term!{_|_}'_»] +recommended_spelling "ofSets" for "!{st}" in [ofSets, «term!{_}»] +recommended_spelling "ofSets" for "!{s | t}" in [ofSets, «term!{_|_}»] + +open Lean PrettyPrinter Delaborator SubExpr in +/-- Delaborates `ofSets (Player.cases s t)` to `!{s | t}` and `ofSets st` to `!{st}`. -/ +@[app_delab OfSets.ofSets] +meta def delabOfSets : Delab := do + let e ← getExpr + guard <| e.isAppOfArity' ``OfSets.ofSets 7 + withNaryArg 3 do + let e ← getExpr + if e.isAppOfArity' ``Player.cases 3 then + let s ← withNaryArg 1 delab + let t ← withNaryArg 2 delab + `(!{$s | $t}) + else + let st ← delab + `(!{$st}) + +theorem ofSets_eq_ofSets_cases {α} {Valid : (Player → Set α) → Prop} [OfSets α Valid] + (st : Player → Set α) (h : Valid st) [Small (st left)] [Small (st right)] : + !{st} = !{st left | st right}'(by convert h; aesop) := by + congr; ext1 p; cases p <;> rfl + +end diff --git a/LeanPool/ConwayRefinement/CombinatorialGames/Game/Special.lean b/LeanPool/ConwayRefinement/CombinatorialGames/Game/Special.lean new file mode 100644 index 0000000000..08e22a947a --- /dev/null +++ b/LeanPool/ConwayRefinement/CombinatorialGames/Game/Special.lean @@ -0,0 +1,233 @@ +/- +Copyright (c) 2022 Violeta Hernández Palacios. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Violeta Hernández Palacios, Tristan Figueroa Reid +-/ +module + +public import LeanPool.ConwayRefinement.CombinatorialGames.Game.Classes + +import LeanPool.ConwayRefinement.CombinatorialGames.Tactic.GameCmp +import Mathlib.Data.Set.Finite.Basic + +/-! +# Special games + +This file defines some simple yet notable combinatorial games: + +* `⋆ = {0 | 0}` +* `½ = {0 | 1}` +* `↑ = {0 | ⋆}` +* `↓ = {⋆ | 0}`. +-/ + +universe u + +@[expose] public noncomputable section + +namespace IGame + +/-! ### Star -/ + +/-- The game `⋆ = {0 | 0}`, which is fuzzy with zero. -/ +def star : IGame := + !{fun _ ↦ {0}} + +@[inherit_doc] notation "⋆" => star +recommended_spelling "star" for "⋆" in [«term⋆»] + +@[simp, game_cmp] theorem moves_star (p : Player) : moves p ⋆ = {0} := moves_ofSets .. + +theorem zero_lf_star : 0 ⧏ ⋆ := by rw [zero_lf]; simp +theorem star_lf_zero : ⋆ ⧏ 0 := by rw [lf_zero]; simp + +theorem star_fuzzy_zero : ⋆ ‖ 0 := ⟨zero_lf_star, star_lf_zero⟩ +theorem zero_fuzzy_star : 0 ‖ ⋆ := ⟨star_lf_zero, zero_lf_star⟩ + +@[simp] theorem not_star_equiv_zero : ¬⋆ ≈ 0 := star_fuzzy_zero.not_antisymmRel +@[simp] theorem not_zero_equiv_star : ¬0 ≈ ⋆ := zero_fuzzy_star.not_antisymmRel + +@[simp, game_cmp] theorem neg_star : -⋆ = ⋆ := by simp [star] + +@[simp] theorem star_mul_star : ⋆ * ⋆ = ⋆ := by ext p; cases p <;> simp [mulOption] + +@[simp] protected instance Dicotic.star : Dicotic ⋆ := by rw [dicotic_def]; simp +protected instance Impartial.star : Impartial ⋆ := by rw [impartial_def]; simp +@[simp] protected instance Short.star : Short ⋆ := by rw [short_def]; simp + +/-! ### Half -/ + +/-- The game `½ = {0 | 1}`, which we prove satisfies `½ + ½ = 1`. -/ +def half : IGame := + !{{0} | {1}} + +@[inherit_doc] notation "½" => half +recommended_spelling "half" for "½" in [«term½»] + +@[simp, game_cmp] theorem leftMoves_half : ½ᴸ = {0} := leftMoves_ofSets .. +@[simp, game_cmp] theorem rightMoves_half : ½ᴿ = {1} := rightMoves_ofSets .. + +theorem zero_lt_half : 0 < ½ := by game_cmp +theorem half_lt_one : ½ < 1 := by game_cmp +theorem half_add_half_equiv_one : ½ + ½ ≈ 1 := by game_cmp + +@[simp] protected instance Numeric.half : Numeric ½ := by rw [numeric_def]; simp +protected instance Short.half : Short ½ := by rw [short_def]; simp + +/-! ### Up and down -/ + +/-- The game `↑ = {0 | ⋆}`. -/ +def up : IGame := + !{{0} | {⋆}} + +@[inherit_doc] notation "↑" => up +recommended_spelling "up" for "↑" in [«term↑»] + +@[simp, game_cmp] theorem leftMoves_up : ↑ᴸ = {0} := leftMoves_ofSets .. +@[simp, game_cmp] theorem rightMoves_up : ↑ᴿ = {⋆} := rightMoves_ofSets .. + +@[simp] theorem up_pos : 0 < ↑ := by game_cmp +theorem up_fuzzy_star : ↑ ‖ ⋆ := by game_cmp +theorem star_fuzzy_up : ⋆ ‖ ↑ := up_fuzzy_star.symm + +protected instance Dicotic.up : Dicotic ↑ := by rw [dicotic_def]; simp +protected instance Short.up : Short ↑ := by rw [short_def]; simp + +/-- The game `↓ = {⋆ | 0}`. -/ +def down : IGame := + !{{⋆} | {0}} + +@[inherit_doc] notation "↓" => down +recommended_spelling "down" for "↓" in [«term↓»] + +@[simp, game_cmp] theorem leftMoves_down : ↓ᴸ = {⋆} := leftMoves_ofSets .. +@[simp, game_cmp] theorem rightMoves_down : ↓ᴿ = {0} := rightMoves_ofSets .. + +@[simp, game_cmp] theorem neg_down : -↓ = ↑ := by simp [up, down] +@[simp, game_cmp] theorem neg_up : -↑ = ↓ := by simp [up, down] + +@[simp] theorem down_neg : ↓ < 0 := by game_cmp +theorem down_fuzzy_star : ↓ ‖ ⋆ := by game_cmp +theorem star_fuzzy_down : ⋆ ‖ ↓ := down_fuzzy_star.symm + +protected instance Dicotic.down : Dicotic ↓ := by rw [dicotic_def]; simp +protected instance Short.down : Short ↓ := by rw [short_def]; simp + +/-! ### Tiny and miny -/ + +/-- A tiny game `⧾x` is defined as `{0 | {0 | -x}}`, and is amongst the smallest of the +infinitesimals. -/ +def tiny (x : IGame) : IGame := + !{{0} | {!{{0} | {-x}}}} + +@[inherit_doc] prefix:75 "⧾" => tiny +recommended_spelling "tiny" for "⧾" in [«term⧾_»] + +@[simp, game_cmp] +theorem leftMoves_tiny (x : IGame) : (⧾x)ᴸ = {0} := + leftMoves_ofSets .. + +@[simp, game_cmp] +theorem rightMoves_tiny (x : IGame) : (⧾x)ᴿ = {!{{0} | {-x}}} := + rightMoves_ofSets .. + +@[simp] +theorem dicotic_tiny_iff {x : IGame} : Dicotic (⧾x) ↔ Dicotic x := by + trans Dicotic !{{0} | {-x}} + all_goals + rw [dicotic_def] + simp + +instance (x : IGame) [Dicotic x] : Dicotic (⧾x) := by rwa [dicotic_tiny_iff] + +@[simp] +theorem short_tiny_iff {x : IGame} : Short (⧾x) ↔ Short x := by + trans Short !{{0} | {-x}} + all_goals + rw [short_def] + simp + +instance (x : IGame) [Short x] : Short (⧾x) := by rwa [short_tiny_iff] + +/-- A miny game `⧿x` is defined as `{{x | 0} | 0}`. -/ +def miny (x : IGame) : IGame := + !{{!{{x} | {0}}} | {0}} + +@[inherit_doc] prefix:75 "⧿" => miny +recommended_spelling "miny" for "⧿" in [«term⧿_»] + +@[simp, game_cmp] +theorem leftMoves_miny (x : IGame) : (⧿x)ᴸ = {!{{x} | {0}}} := + leftMoves_ofSets .. + +@[simp, game_cmp] +theorem rightMoves_miny (x : IGame) : (⧿x)ᴿ = {0} := + rightMoves_ofSets .. + +@[simp, game_cmp] +theorem neg_tiny (x : IGame) : -(⧾x) = ⧿x := by + simp [miny, tiny] + +@[simp, game_cmp] +theorem neg_miny (x : IGame) : -(⧿x) = ⧾x := by + simp [miny, tiny] + +@[simp] +theorem dicotic_miny_iff {x : IGame} : Dicotic (⧿x) ↔ Dicotic x := by + rw [← neg_tiny, Dicotic.neg_iff]; simp + +instance (x : IGame) [Dicotic x] : Dicotic (⧿x) := by + rwa [dicotic_miny_iff] + +@[simp] +theorem short_miny_iff {x : IGame} : Short (⧿x) ↔ Short x := by + rw [← neg_tiny, Short.neg_iff]; simp + +instance (x : IGame) [Short x] : Short (⧿x) := by + rwa [short_miny_iff] + +@[simp, game_cmp] theorem tiny_pos (x : IGame) : 0 < ⧾x := by game_cmp +@[simp, game_cmp] theorem miny_neg (x : IGame) : ⧿x < 0 := by game_cmp + +/-! ### Switches -/ + +/-- A **switch** `±x` is defined as `{x | -x}`: switches are their own confusion interval! -/ +def switch (x : IGame) : IGame := + !{{x} | {-x}} + +@[inherit_doc] prefix:75 "±" => switch +recommended_spelling "switch" for "±" in [«term±_»] + +@[simp, game_cmp] +theorem leftMoves_switch (x : IGame) : (±x)ᴸ = {x} := + leftMoves_ofSets .. + +@[simp, game_cmp] +theorem rightMoves_switch (x : IGame) : (±x)ᴿ = {-x} := + rightMoves_ofSets .. + +@[simp] +theorem neg_switch (x : IGame) : -±x = ±x := by + rw [switch, neg_ofSets] + simp [Set.neg_singleton] + +@[simp] +theorem switch_zero : ±0 = ⋆ := by + ext p; cases p <;> simp + +@[simp] +theorem dicotic_switch_iff {x : IGame} : Dicotic (±x) ↔ Dicotic x := by + rw [dicotic_def]; simp + +instance (x : IGame) [Dicotic x] : Dicotic (±x) := by + rwa [dicotic_switch_iff] + +@[simp] +theorem short_switch_iff {x : IGame} : Short (±x) ↔ Short x := by + rw [short_def]; simp + +instance (x : IGame) [Short x] : Short (±x) := by + rwa [short_switch_iff] + +end IGame +end diff --git a/LeanPool/ConwayRefinement/CombinatorialGames/Mathlib.lean b/LeanPool/ConwayRefinement/CombinatorialGames/Mathlib.lean new file mode 100644 index 0000000000..354f1c62b8 --- /dev/null +++ b/LeanPool/ConwayRefinement/CombinatorialGames/Mathlib.lean @@ -0,0 +1,12 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.CombinatorialGames.Mathlib.Dyadic +public import LeanPool.ConwayRefinement.CombinatorialGames.Mathlib.Small + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/CombinatorialGames/Mathlib/Dyadic.lean b/LeanPool/ConwayRefinement/CombinatorialGames/Mathlib/Dyadic.lean new file mode 100644 index 0000000000..b00dd7ec89 --- /dev/null +++ b/LeanPool/ConwayRefinement/CombinatorialGames/Mathlib/Dyadic.lean @@ -0,0 +1,360 @@ +/- +Copyright (c) 2025 Violeta Hernández Palacios. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Violeta Hernández Palacios +-/ +module + +public import Mathlib.Algebra.Order.Field.Basic +public import Mathlib.Algebra.Order.Ring.Defs +public import Mathlib.Analysis.Normed.Field.Lemmas +public import Mathlib.Data.Nat.Log + +/-! +# Dyadic numbers + +A dyadic (rational) number is a rational number whose denominator is a power of two. We provide +the `CommRing` structure, as well as proving some auxiliary theorems on them. +-/ + +@[expose] public section + +/-! ### For Mathlib -/ + +theorem le_of_le_of_lt_of_lt {α β : Type*} [PartialOrder α] [Preorder β] {x y : α} + {f : α → β} (h : x < y → f x < f y) (hxy : x ≤ y) : f x ≤ f y := by + obtain rfl | h' := hxy.eq_or_lt + · rfl + · exact (h h').le + +theorem Nat.pow_log_eq_self_iff {b n : ℕ} (hb : b ≠ 0) : + b ^ Nat.log b n = n ↔ n ∈ Set.range (b ^ ·) := by + constructor + · aesop + · rintro ⟨n, rfl⟩ + rw [← Nat.one_le_iff_ne_zero, le_iff_eq_or_lt] at hb + obtain rfl | hb := hb + · simp + · rw [Nat.log_pow hb] + +theorem pos_of_mem_powers {n : ℕ} (h : n ∈ Submonoid.powers 2) : 0 < n := by + obtain ⟨n, rfl⟩ := h + exact pow_pos (Nat.succ_pos 1) n + +theorem ne_zero_of_mem_powers {n : ℕ} (h : n ∈ Submonoid.powers 2) : n ≠ 0 := + (pos_of_mem_powers h).ne' + +theorem dvd_iff_le_of_mem_powers {m n : ℕ} + (hm : m ∈ Submonoid.powers 2) (hn : n ∈ Submonoid.powers 2) : m ∣ n ↔ m ≤ n := by + obtain ⟨m, rfl⟩ := hm + obtain ⟨n, rfl⟩ := hn + simp_all [pow_dvd_pow_iff, pow_le_pow_iff_right₀] + +namespace Dyadic + +attribute [coe] toRat + +instance instCoeRatConway : Coe Dyadic Rat where + coe := toRat + +@[norm_cast] alias coe_le_coe := toRat_le_toRat_iff +@[norm_cast] alias coe_lt_coe := toRat_lt_toRat_iff +@[norm_cast] alias coe_inj := toRat_inj + +/-- Numerator of a dyadic number. -/ +abbrev num (x : Dyadic) : ℤ := x.toRat.num +/-- Denominator of a dyadic number. -/ +abbrev den (x : Dyadic) : ℕ := x.toRat.den + +theorem den_ne_zero (x : Dyadic) : x.den ≠ 0 := Rat.den_ne_zero x +theorem den_pos (x : Dyadic) : 0 < x.den := Rat.den_pos x +theorem one_le_den (x : Dyadic) : 1 ≤ x.den := x.den_pos +theorem den_mem_powers (x : Dyadic) : x.den ∈ Submonoid.powers 2 := by + fun_cases toRat x with + | case1 -- zero + | case3 => exact one_mem _ -- integer + | case2 => apply pow_mem; exact Submonoid.mem_powers 2 -- dyadic rational + +@[simp] +theorem den_le_one_iff_eq_one {x : Dyadic} : x.den ≤ 1 ↔ x.den = 1 := by + simp_rw [Nat.le_one_iff_eq_zero_or_eq_one, x.den_ne_zero, false_or] + +@[simp] +theorem one_lt_den_iff_ne_one {x : Dyadic} : 1 < x.den ↔ x.den ≠ 1 := by + simp [← den_le_one_iff_eq_one] + +theorem den_ne_one_of_den_lt {x y : Dyadic} (h : x.den < y.den) : y.den ≠ 1 := by + simpa using (one_le_den x).trans_lt h + +@[ext] theorem ext {x y : Dyadic} (h : (x : ℚ) = y) : x = y := toRat_inj.1 h + +@[norm_cast] alias coe_natCast := toRat_natCast +@[simp, norm_cast] theorem num_natCast (n : ℕ) : (n : Dyadic).num = n := + congrArg Rat.num (toRat_natCast n) +@[simp, norm_cast] theorem den_natCast (n : ℕ) : (n : Dyadic).den = 1 := + congrArg Rat.den (toRat_natCast n) + +@[simp] theorem coe_ofNat (n : ℕ) : (ofNat(n) : Dyadic).toRat = n := + toRat_natCast n +@[simp] theorem num_ofNat (n : ℕ) : (ofNat(n) : Dyadic).num = n := + num_natCast n +@[simp] theorem den_ofNat (n : ℕ) : (ofNat(n) : Dyadic).den = 1 := + den_natCast n + +@[simp] theorem natCast_lt_coe {x : ℕ} {y : Dyadic} : x < y.toRat ↔ x < y := by norm_cast +@[simp] theorem natCast_le_coe {x : ℕ} {y : Dyadic} : x ≤ y.toRat ↔ x ≤ y := by norm_cast +@[simp] theorem coe_lt_natCast {x : Dyadic} {y : ℕ} : x.toRat < y ↔ x < y := by norm_cast +@[simp] theorem coe_le_natCast {x : Dyadic} {y : ℕ} : x.toRat ≤ y ↔ x ≤ y := by norm_cast + +@[simp, norm_cast] theorem coe_eq_natCast {x : Dyadic} {y : ℕ} : x.toRat = y ↔ x = y := by + rw [← toRat_natCast, toRat_inj] +@[simp, norm_cast] theorem natCast_eq_coe {x : ℕ} {y : Dyadic} : x = y.toRat ↔ x = y := by + rw [← toRat_natCast, toRat_inj] + +@[norm_cast] alias coe_intCast := toRat_intCast +@[simp, norm_cast] theorem num_intCast (n : ℤ) : (n : Dyadic).num = n := + congrArg Rat.num (coe_intCast n) +@[simp, norm_cast] theorem den_intCast (n : ℤ) : (n : Dyadic).den = 1 := + congrArg Rat.den (coe_intCast n) + +@[simp] theorem intCast_lt_coe {x : ℤ} {y : Dyadic} : x < y.toRat ↔ x < y := by norm_cast +@[simp] theorem intCast_le_coe {x : ℤ} {y : Dyadic} : x ≤ y.toRat ↔ x ≤ y := by norm_cast +@[simp] theorem coe_lt_intCast {x : Dyadic} {y : ℤ} : x.toRat < y ↔ x < y := by norm_cast +@[simp] theorem coe_le_intCast {x : Dyadic} {y : ℤ} : x.toRat ≤ y ↔ x ≤ y := by norm_cast +@[simp] theorem coe_eq_intCast {x : Dyadic} {y : ℤ} : x.toRat = y ↔ x = y := by norm_cast +@[simp] theorem intCast_eq_coe {x : ℤ} {y : Dyadic} : x = y.toRat ↔ x = y := by norm_cast + +instance instInhabitedConway : Inhabited Dyadic := ⟨0⟩ + +@[simp, norm_cast] theorem coe_zero : (0 : Dyadic).toRat = 0 := rfl +@[simp] theorem num_zero : (0 : Dyadic).num = 0 := rfl +@[simp] theorem den_zero : (0 : Dyadic).den = 1 := rfl + +@[simp] theorem zero_lt_coe {x : Dyadic} : 0 < x.toRat ↔ 0 < x := by norm_cast +@[simp] theorem zero_le_coe {x : Dyadic} : 0 ≤ x.toRat ↔ 0 ≤ x := by norm_cast +@[simp] theorem coe_lt_zero {x : Dyadic} : x.toRat < 0 ↔ x < 0 := by norm_cast +@[simp] theorem coe_le_zero {x : Dyadic} : x.toRat ≤ 0 ↔ x ≤ 0 := by norm_cast +alias coe_eq_zero := toRat_eq_zero_iff +@[simp] theorem zero_eq_coe {x : Dyadic} : 0 = x.toRat ↔ 0 = x := by norm_cast + +@[simp, norm_cast] theorem coe_one : (1 : Dyadic).toRat = 1 := rfl +@[simp] theorem num_one : (1 : Dyadic).num = 1 := rfl +@[simp] theorem den_one : (1 : Dyadic).den = 1 := rfl + +@[simp] theorem one_lt_coe {x : Dyadic} : 1 < x.toRat ↔ 1 < x := by norm_cast +@[simp] theorem one_le_coe {x : Dyadic} : 1 ≤ x.toRat ↔ 1 ≤ x := by norm_cast +@[simp] theorem coe_lt_one {x : Dyadic} : x.toRat < 1 ↔ x < 1 := by norm_cast +@[simp] theorem coe_le_one {x : Dyadic} : x.toRat ≤ 1 ↔ x ≤ 1 := by norm_cast +@[simp] theorem coe_eq_one {x : Dyadic} : x.toRat = 1 ↔ x = 1 := by norm_cast +@[simp] theorem one_eq_coe {x : Dyadic} : 1 = x.toRat ↔ 1 = x := by norm_cast + +instance : Nontrivial Dyadic where + exists_pair_ne := ⟨0, 1, by decide⟩ + +@[simp] theorem num_neg (x : Dyadic) : (-x).num = -x.num := congrArg Rat.num (toRat_neg x) +@[simp] theorem den_neg (x : Dyadic) : (-x).den = x.den := (congrArg Rat.den (toRat_neg x) :) + +@[norm_cast] alias coe_neg := toRat_neg +@[norm_cast] alias coe_add := toRat_add +@[norm_cast] alias coe_sub := toRat_sub +@[norm_cast] alias coe_mul := toRat_mul +@[norm_cast] alias coe_pow := toRat_pow + +instance instSMulNatConway : SMul Nat Dyadic where + smul x y := x * y + +@[norm_cast] theorem coe_nsmul (x : ℕ) (y : Dyadic) : (x • y).toRat = x • y.toRat := + (coe_mul x y).trans (by simp) + +instance instSMulIntConway : SMul Int Dyadic where + smul x y := x * y + +@[norm_cast] theorem coe_zsmul (x : ℤ) (y : Dyadic) : (x • y).toRat = x • y.toRat := + (coe_mul x y).trans (by simp) + +/-- The dyadic number ½. -/ +def half : Dyadic := (1 : Dyadic) >>> 1 + +@[simp, norm_cast] theorem coe_half : half.toRat = 2⁻¹ := (Rat.inv_def 2).symm +@[simp] theorem num_half : half.num = 1 := rfl +@[simp] theorem num_den : half.den = 2 := rfl + +/-- Constructor for the fraction `m / n`. -/ +protected def mkRat (m : ℤ) {n : ℕ} (h : n ∈ Submonoid.powers 2) : Dyadic := + ofIntWithPrec m (Submonoid.log ⟨n, h⟩) + +@[simp, norm_cast] +theorem coe_mkRat (m : ℤ) {n : ℕ} (h : n ∈ Submonoid.powers 2) : + (Dyadic.mkRat m h).toRat = mkRat m n := by + rw [Dyadic.mkRat, toRat_ofIntWithPrec_eq_mul_two_pow, zpow_neg, + ← Nat.cast_two, zpow_natCast, ← Nat.cast_pow, ← Submonoid.pow_coe, + Submonoid.pow_log_eq_self, Rat.mkRat_eq_div, div_eq_mul_inv] + +@[simp] theorem mkRat_self (x : Dyadic) : Dyadic.mkRat x.num x.den_mem_powers = x := by ext; simp + +@[simp] +theorem mkRat_one (m : ℤ) (h : 1 ∈ Submonoid.powers 2) : Dyadic.mkRat m h = m := by + ext; simp [Rat.mkRat_one] + +@[simp] +theorem mkRat_lt_mkRat {m n : ℤ} {k : ℕ} (h₁ h₂ : k ∈ Submonoid.powers 2) : + Dyadic.mkRat m h₁ < Dyadic.mkRat n h₂ ↔ m < n := by + have hk : 0 < (k : ℚ) := by + rw [Rat.natCast_pos, Nat.pos_iff_ne_zero] + obtain ⟨n, rfl⟩ := h₁ + simp + rw [← coe_lt_coe] + simp [Rat.mkRat_eq_div, div_lt_div_iff_of_pos_right hk] + +instance instLinearOrderConway : LinearOrder Dyadic where + le_refl := Dyadic.le_refl + le_trans := @Dyadic.le_trans + le_antisymm := @Dyadic.le_antisymm + le_total := Dyadic.le_total + lt_iff_le_not_ge := Std.LawfulOrderLT.lt_iff + toDecidableLE := Dyadic.instDecidableLE + toDecidableLT := Dyadic.instDecidableLT + toDecidableEq := instDecidableEqDyadic + +@[simp] +theorem mkRat_le_mkRat {m n : ℤ} {k : ℕ} (h₁ h₂ : k ∈ Submonoid.powers 2) : + Dyadic.mkRat m h₁ ≤ Dyadic.mkRat n h₂ ↔ m ≤ n := + le_iff_le_iff_lt_iff_lt.2 (mkRat_lt_mkRat h₁ h₂) + +theorem mkRat_add_mkRat_self {m n : ℤ} {k : ℕ} (h₁ h₂ : k ∈ Submonoid.powers 2) : + Dyadic.mkRat m h₁ + Dyadic.mkRat n h₂ = .mkRat (m + n) h₁ := by + ext; simp [Rat.mkRat_eq_div, add_div] + +instance instCommRingConway : CommRing Dyadic where + add_assoc := add_assoc + zero_add := Dyadic.zero_add + add_zero := Dyadic.add_zero + add_comm := add_comm + mul_comm := mul_comm + left_distrib := mul_add + right_distrib := add_mul + zero_mul := Dyadic.zero_mul + mul_zero := Dyadic.mul_zero + mul_assoc := mul_assoc + one_mul := one_mul + mul_one := mul_one + neg_add_cancel := neg_add_cancel + sub_eq_add_neg _ _ := rfl + natCast_succ _ := by + rw [← coe_inj, coe_natCast, Rat.natCast_add, coe_add, coe_natCast] + rfl + intCast_negSucc _ := by + rw [← coe_inj, coe_intCast, coe_neg, coe_natCast, ← Int.cast_natCast, + ← Rat.intCast_neg, Int.neg_ofNat_succ] + nsmul n x := n • x + nsmul_zero x := by ext; simp [coe_nsmul] + nsmul_succ n x := by ext; simp [add_one_mul, coe_nsmul] + zsmul n x := n • x + zsmul_zero' x := by ext; simp [coe_zsmul] + zsmul_succ' n x := by ext; simp [add_one_mul, coe_zsmul] + zsmul_neg' n x := by + change _ * _ = -(_ * _) + rw [← neg_mul, ← coe_inj, coe_mul, coe_mul, coe_intCast, coe_neg, coe_intCast, + ← Rat.intCast_neg, Int.neg_ofNat_succ] + npow n x := x ^ n + npow_zero x := by ext; simp + npow_succ n x := by ext; simp [pow_succ] + +instance : IsStrictOrderedRing Dyadic where + add_le_add_left := by simp [← toRat_le_toRat_iff] + le_of_add_le_add_left := by simp [← toRat_le_toRat_iff] + mul_lt_mul_of_pos_left x hx y z h := by + rw [← coe_lt_coe] at hx h ⊢ + rw [coe_mul, coe_mul] + rw [coe_zero] at hx + exact mul_lt_mul_of_pos_left h hx + mul_lt_mul_of_pos_right x hx y z h := by + rw [← coe_lt_coe] at hx h ⊢ + rw [coe_mul, coe_mul] + rw [coe_zero] at hx + exact mul_lt_mul_of_pos_right h hx + zero_le_one := by decide + +instance : DenselyOrdered Dyadic where + dense x y h := by + use half * (x + y) + simp_rw [← coe_lt_coe] at * + constructor + · simpa [inv_mul_eq_div] using left_lt_add_div_two.2 h + · simpa [inv_mul_eq_div] using add_div_two_lt_right.2 h + +instance : Archimedean Dyadic where + arch x y h := by + rw [← coe_lt_coe, coe_zero] at h + obtain ⟨n, hn⟩ := exists_lt_nsmul h x.toRat + refine ⟨n, ?_⟩ + rw [← coe_le_coe, nsmul_eq_mul, coe_mul, coe_natCast, ← nsmul_eq_mul] + exact hn.le + +theorem even_den {x : Dyadic} (hx : x.den ≠ 1) : Even x.den := by + obtain ⟨n, hn⟩ := x.den_mem_powers + rw [← hn] + cases n + · simp_all + · rw [even_iff_two_dvd] + exact dvd_mul_left .. + +theorem odd_num {x : Dyadic} (hx : x.den ≠ 1) : Odd x.num := by + rw [← Int.not_even_iff_odd] + have hd := even_den hx + rw [even_iff_two_dvd] at * + rw [← Int.natAbs_dvd_natAbs] + exact (Nat.not_coprime_of_dvd_of_dvd one_lt_two · hd x.toRat.reduced) + +theorem intCast_num_eq_self_of_den_eq_one {x : Dyadic} (hx : x.den = 1) : x.num = x := by + ext + rw [coe_intCast] + exact Rat.coe_int_num_of_den_eq_one hx + +theorem den_mkRat_le (x : ℤ) {n : ℕ} (hn : n ≠ 0) : (mkRat x n).den ≤ n := by + rw [← Rat.normalize_eq_mkRat hn, Rat.normalize_eq hn] + exact Nat.div_le_self n _ + +theorem den_mkRat_lt {x : Dyadic} {n : ℤ} (hn : 2 ∣ n) (hd : x.den ≠ 1) : + (mkRat n x.den).den < x.den := by + rw [← Rat.normalize_eq_mkRat x.den_ne_zero, Rat.normalize_eq] + apply Nat.div_lt_self x.den_pos + apply Nat.le_of_dvd (Nat.gcd_pos_of_pos_right _ x.den_pos) (Nat.dvd_gcd _ (even_den hd).two_dvd) + rwa [← Int.natAbs_dvd_natAbs] at hn + +theorem den_add_self_lt {x : Dyadic} (hx : x.den ≠ 1) : (x + x).den < x.den := by + suffices x + x = Dyadic.mkRat (2 * x.num) x.den_mem_powers by + rw [this, den, Dyadic.coe_mkRat] + exact den_mkRat_lt (Int.dvd_mul_right 2 x.num) hx + ext + simp [Rat.mkRat_eq_div, Rat.num_div_den, mul_div_assoc, ← two_mul] + +theorem eq_mkRat_of_den_le {x : Dyadic} {n : ℕ} (h : x.den ≤ n) (hn : n ∈ Submonoid.powers 2) : + ∃ m, x = .mkRat m hn := by + use x.num * (n / x.den) + ext + rw [← x.mkRat_self, coe_mkRat, coe_mkRat, + Rat.mkRat_eq_iff x.den_ne_zero (ne_zero_of_mem_powers hn), mkRat_self, Int.mul_assoc] + congr + exact (Nat.div_mul_cancel ((dvd_iff_le_of_mem_powers x.den_mem_powers hn).2 h)).symm + +instance : CanLift Dyadic Int Int.cast (·.den = 1) where + prf x hx := ⟨x.num, Dyadic.ext (coe_intCast x.num ▸ x.toRat.den_eq_one_iff.mp hx)⟩ + +theorem den_add_le_den_right {x y : Dyadic} (h : x.den ≤ y.den) : (x + y).den ≤ y.den := by + obtain ⟨n, hn⟩ := eq_mkRat_of_den_le h y.den_mem_powers + conv_lhs => rw [← y.mkRat_self, hn, mkRat_add_mkRat_self] + rw [den, Dyadic.coe_mkRat] + exact den_mkRat_le _ y.den_ne_zero + +/-- Coercion as a `RingHom`. -/ +@[simps] +def coeRingHom : Dyadic →+* ℚ where + toFun := Dyadic.toRat + map_zero' := rfl + map_one' := rfl + map_add' := coe_add + map_mul' := coe_mul + +end Dyadic +end diff --git a/LeanPool/ConwayRefinement/CombinatorialGames/Mathlib/Small.lean b/LeanPool/ConwayRefinement/CombinatorialGames/Mathlib/Small.lean new file mode 100644 index 0000000000..c1429e0707 --- /dev/null +++ b/LeanPool/ConwayRefinement/CombinatorialGames/Mathlib/Small.lean @@ -0,0 +1,69 @@ +/- +Copyright (c) 2025 Violeta Hernández Palacios. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Violeta Hernández Palacios +-/ +module + +public import Mathlib.Logic.Small.Defs + +import Mathlib.Logic.Small.Set +import Mathlib.Logic.Relation +import Mathlib.Order.SetNotation + +/-! +# Tree with small sets of branches is small +-/ + +universe u + +public section + +open Set + +variable {α : Type*} (r : α → α → Prop) [H : ∀ x, Small.{u} {y // r x y}] + +private def level (x : α) : ℕ → Set α + | 0 => {x} + | n + 1 => ⋃₀ ((fun x ↦ {y | r x y}) '' level x n) + +private theorem small_level (x : α) : ∀ n, Small.{u} (level r x n) + | 0 => small_single _ + | n + 1 => by + refine @small_sUnion _ _ ?_ ?_ + · have := small_level x n + exact small_image .. + · intro ⟨a, ha⟩ + obtain ⟨b, _, rfl⟩ := ha + exact H b + +private theorem small_sUnion_level (x : α) : Small.{u} (⋃₀ range (level r x)) := by + refine @small_sUnion _ _ ?_ ?_ + · exact small_range .. + · simp [small_level] + +instance small_transGen (x : α) : Small.{u} {y // Relation.TransGen r x y} := by + refine @small_subset _ _ _ (fun y hy ↦ ?_) (small_sUnion_level r x) + simp_rw [mem_sUnion, mem_range, exists_exists_eq_and] + induction hy with + | single => + use 1 + simpa [level] + | tail hy hr IH => + obtain ⟨n, hn⟩ := IH + use n + 1 + simpa [level] using ⟨_, hn, hr⟩ + +instance small_transGen' [∀ x, Small.{u} {y // r y x}] (x : α) : + Small.{u} {y // Relation.TransGen r y x} := by + simp_rw [← Relation.transGen_swap (r := r)] + infer_instance + +instance small_reflTransGen (x : α) : Small.{u} {y // Relation.ReflTransGen r x y} := by + simp_rw [Relation.reflTransGen_iff_eq_or_transGen] + exact @small_insert _ _ _ (small_transGen ..) + +instance small_reflTransGen' [∀ x, Small.{u} {y // r y x}] (x : α) : + Small.{u} {y // Relation.ReflTransGen r y x} := by + simp_rw [← Relation.reflTransGen_swap (r := r)] + infer_instance diff --git a/LeanPool/ConwayRefinement/CombinatorialGames/NatOrdinal.lean b/LeanPool/ConwayRefinement/CombinatorialGames/NatOrdinal.lean new file mode 100644 index 0000000000..c01afb2edc --- /dev/null +++ b/LeanPool/ConwayRefinement/CombinatorialGames/NatOrdinal.lean @@ -0,0 +1,12 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.CombinatorialGames.NatOrdinal.Basic +public import LeanPool.ConwayRefinement.CombinatorialGames.NatOrdinal.Pow + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/CombinatorialGames/NatOrdinal/Basic.lean b/LeanPool/ConwayRefinement/CombinatorialGames/NatOrdinal/Basic.lean new file mode 100644 index 0000000000..b39d1dc80f --- /dev/null +++ b/LeanPool/ConwayRefinement/CombinatorialGames/NatOrdinal/Basic.lean @@ -0,0 +1,418 @@ +/- +Copyright (c) 2022 Violeta Hernández Palacios. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Violeta Hernández Palacios +-/ +module + +public import Mathlib.SetTheory.Ordinal.Family + +import LeanPool.ConwayRefinement.CombinatorialGames.Tactic.OrdinalAlias +import Mathlib.Tactic.Abel + +/-! +# Natural operations on ordinals + +The goal of this file is to define natural addition and multiplication on ordinals, also known as +the Hessenberg sum and product, and provide a basic API. The natural addition of two ordinals +`a + b` is recursively defined as the least ordinal greater than `a' + b` and `a + b'` for `a' < a` +and `b' < b`. The natural multiplication `a * b` is likewise recursively defined as the least +ordinal such that `a * b + a' * b'` is greater than `a' * b + a * b'` for any `a' < a` and +`b' < b`. + +These operations give the ordinals a `CommSemiring` + `IsStrictOrderedRing` structure. To make the +best use of it, we define them on a type alias `NatOrdinal`. + +An equivalent characterization explains the relevance of these operations to game theory: they are +the restrictions of surreal addition and multiplication to the ordinals. + +## Implementation notes + +To reduce API duplication, we opt not to implement operations on `NatOrdinal` on `Ordinal`. The +order isomorphisms `NatOrdinal.of` and `NatOrdinal.val` allow us to cast between them whenever +needed. + +For similar reasons, most results about ordinals and games are written using `NatOrdinal` rather +than `Ordinal` (except when `Nimber` would make more sense). +-/ + +universe u v + +open Order Set + +public noncomputable section + +/-! ### Basic casts between `Ordinal` and `NatOrdinal` -/ + +ordinal_alias! + /-- A type synonym for ordinals with natural addition and multiplication. -/ NatOrdinal + +namespace NatOrdinal + +variable {a b c d a' b' c' : NatOrdinal.{u}} + +/-! ### Natural addition -/ + +private def add (a b : NatOrdinal.{u}) : NatOrdinal.{u} := + max (⨆ x : Iio a, succ (add x.1 b)) (⨆ x : Iio b, succ (add a x.1)) +termination_by (a, b) +decreasing_by all_goals cases x; decreasing_tactic + +#adaptation_note /-- noncomputable is now needed -/ in +/-- Natural addition on ordinals `a + b`, also known as the Hessenberg sum, is recursively defined +as the least ordinal greater than `a' + b` and `a + b'` for all `a' < a` and `b' < b`. In contrast +to normal ordinal addition, it is commutative. + +Natural addition can equivalently be characterized as the ordinal resulting from adding up +corresponding coefficients in the Cantor normal forms of `a` and `b`. -/ +@[no_expose] noncomputable instance : Add NatOrdinal := ⟨add⟩ + +theorem add_def (a b : NatOrdinal) : + a + b = max (⨆ x : Iio a, succ (x.1 + b)) (⨆ x : Iio b, succ (a + x.1)) := by + change add .. = _ + rw [add] + rfl + +theorem lt_add_iff : a < b + c ↔ (∃ b' < b, a ≤ b' + c) ∨ ∃ c' < c, a ≤ b + c' := by + rw [add_def] + simp [NatOrdinal.lt_iSup_iff] + +theorem add_le_iff : b + c ≤ a ↔ (∀ b' < b, b' + c < a) ∧ ∀ c' < c, b + c' < a := by + rw [← not_lt, lt_add_iff] + simp + +instance : AddLeftStrictMono NatOrdinal where + elim _a _b _c h := lt_add_iff.2 (.inr ⟨_, h, le_rfl⟩) + +instance : AddRightStrictMono NatOrdinal where + elim _a _b _c h := lt_add_iff.2 (.inl ⟨_, h, le_rfl⟩) + +instance : AddLeftMono NatOrdinal := + addLeftMono_of_addLeftStrictMono _ + +instance : AddRightMono NatOrdinal := + addRightMono_of_addRightStrictMono _ + +private theorem add_comm' (a b : NatOrdinal) : a + b = b + a := by + rw [add_def, add_def, max_comm] + congr with x <;> cases x <;> exact congrArg _ (add_comm' ..) +termination_by (a, b) + +private theorem add_zero' (a : NatOrdinal) : a + 0 = a := by + rw [add_def, ciSup_of_empty fun _ : Iio 0 ↦ _, max_bot_right] + convert iSup_succ a with x + cases x + exact add_zero' _ +termination_by a + +private theorem iSup_add_of_monotone (f : NatOrdinal.{u} → NatOrdinal.{u}) (h : Monotone f) : + ⨆ x : Iio (a + b), f x = max (⨆ a' : Iio a, f (a'.1 + b)) (⨆ b' : Iio b, f (a + b'.1)) := by + apply (max_le _ _).antisymm' + · rw [iSup_le_iff] + rintro ⟨i, hi⟩ + obtain ⟨x, hx, hi⟩ | ⟨x, hx, hi⟩ := lt_add_iff.1 hi + · exact le_max_of_le_left ((h hi).trans <| le_iSup (fun x : Iio a ↦ _) ⟨x, hx⟩) + · exact le_max_of_le_right ((h hi).trans <| le_iSup (fun x : Iio b ↦ _) ⟨x, hx⟩) + all_goals + refine csSup_le_csSup' (bddAbove_of_small _) fun _ ↦ ?_ + aesop + +private theorem add_assoc' (a b c : NatOrdinal) : a + b + c = a + (b + c) := by + rw [add_def, add_def a (b + c)] + rw [iSup_add_of_monotone (fun _ ↦ succ _) (succ_mono.comp add_right_mono), + iSup_add_of_monotone (fun _ ↦ succ _) (succ_mono.comp add_left_mono), max_assoc] + congr with x <;> cases x <;> exact congrArg _ (add_assoc' ..) +termination_by (a, b, c) + +instance : AddCommMonoid NatOrdinal where + add_zero := private add_zero' + zero_add x := by rw [add_comm', add_zero'] + add_comm := private add_comm' + add_assoc := private add_assoc' + nsmul := nsmulRec + +instance : IsOrderedCancelAddMonoid NatOrdinal where + add_le_add_left _ _ := add_le_add_left + le_of_add_le_add_left a b c h := by + by_contra! h' + exact h.not_gt (add_lt_add_right h' a) + +theorem le_add_left : a ≤ b + a := by simp +theorem le_add_right : a ≤ a + b := by simp + +@[simp] +theorem add_eq_zero_iff : a + b = 0 ↔ a = 0 ∧ b = 0 := by + refine ⟨fun h ↦ ?_, ?_⟩ + · repeat rw [← le_zero_iff] + exact ⟨le_add_right.trans_eq h, le_add_left.trans_eq h⟩ + · simp +contextual + +private theorem succ_eq_add_one' (a : NatOrdinal) : succ a = a + 1 := by + rw [add_def, ciSup_unique (s := fun _ : Iio 1 ↦ _), Iio_one_default_eq, add_zero, + eq_comm, max_eq_right_iff, iSup_le_iff] + rintro ⟨i, hi⟩ + rwa [← succ_eq_add_one', succ_le_succ_iff, succ_le_iff] +termination_by a + +instance : SuccAddOrder NatOrdinal := ⟨by exact succ_eq_add_one'⟩ + +@[simp] theorem of_add_one (a : Ordinal) : of (a + 1) = of a + 1 := succ_eq_add_one _ +@[simp] theorem val_add_one (a : NatOrdinal) : val (a + 1) = val a + 1 := (succ_eq_add_one a).symm + +instance : AddMonoidWithOne NatOrdinal where + natCast n := of n + natCast_succ n := by simp + +@[simp] theorem of_natCast (n : ℕ) : of n = n := rfl +@[simp] theorem val_natCast (n : ℕ) : val n = n := rfl + +@[simp] +theorem natCast_image_Iio (n : ℕ) : Nat.cast '' Iio n = Iio (n : NatOrdinal) := + Ordinal.natCast_image_Iio n + +@[simp] +theorem forall_lt_natCast {P : NatOrdinal → Prop} {n : ℕ} : (∀ a < ↑n, P a) ↔ ∀ a < n, P a := by + change (∀ a ∈ Iio _, _) ↔ ∀ a ∈ Iio _, _ + simp [← natCast_image_Iio] + +@[simp] +theorem exists_lt_natCast {P : NatOrdinal → Prop} {n : ℕ} : (∃ a < ↑n, P a) ↔ ∃ a < n, P a := by + change (∃ a ∈ Iio _, _) ↔ ∃ a ∈ Iio _, _ + simp [← natCast_image_Iio] + +theorem lt_omega0 {o : NatOrdinal} : o < of .omega0 ↔ ∃ n : ℕ, o = n := + Ordinal.lt_omega0 + +theorem natCast_lt_omega0 (n : ℕ) : n < of .omega0 := + Ordinal.natCast_lt_omega0 n + +instance : CharZero NatOrdinal where + cast_injective m n h := by + apply_fun val at h + simpa using h + +@[simp] +theorem of_add_natCast (a : Ordinal) (n : ℕ) : of (a + n) = of a + n := by + induction n with + | zero => simp + | succ n IH => simp [← add_assoc, IH] + +@[simp] +theorem val_add_natCast (a : NatOrdinal) (n : ℕ) : val (a + n) = val a + n := + (of_add_natCast _ n).symm + +/-- A version of `oadd_le_add` stated in terms of `Ordinal`. -/ +theorem oadd_le_add' (a b : Ordinal) : a + b ≤ val (of a + of b) := by + induction b using Ordinal.limitRecOn with + | zero => simp + | add_one c IH => simpa [← add_assoc] using add_le_add_left IH 1 + | limit c hc IH => + rw [(Ordinal.isNormal_add_right a).apply_of_isSuccLimit hc, Ordinal.iSup_le_iff] + rintro ⟨i, hi⟩ + exact (IH i hi).trans (add_le_add_right hi.le (of a)) + +theorem oadd_le_add (a b : NatOrdinal) : of (a.val + b.val) ≤ a + b := + oadd_le_add' .. + +/-! ### Natural multiplication -/ + +private def mul (a b : NatOrdinal.{u}) : NatOrdinal.{u} := + sInf {c | ∀ a' < a, ∀ b' < b, mul a' b + mul a b' < c + mul a' b'} +termination_by (a, b) + +#adaptation_note /-- noncomputable is now needed -/ in +/-- Natural multiplication on ordinals `a * b`, also known as the Hessenberg product, is recursively +defined as the least ordinal such that `a * b + a' * b'` is greater than `a' * b + a * b'` for all +`a' < a` and `b < b'`. In contrast to normal ordinal multiplication, it is commutative and +distributive (over natural addition). + +Natural multiplication can equivalently be characterized as the ordinal resulting from multiplying +the Cantor normal forms of `a` and `b` as if they were polynomials in `ω`. Addition of exponents is +done via natural addition. -/ +@[no_expose] noncomputable instance : Mul NatOrdinal := ⟨mul⟩ + +theorem mul_def (a b : NatOrdinal) : + a * b = sInf {c | ∀ a' < a, ∀ b' < b, a' * b + a * b' < c + a' * b'} := by + change mul .. = _ + rw [mul] + rfl + +/-- The set in the definition of `mul` is nonempty. -/ +private theorem mul_nonempty (a b : NatOrdinal.{u}) : + {c : NatOrdinal.{u} | ∀ a' < a, ∀ b' < b, a' * b + a * b' < c + a' * b'}.Nonempty := by + obtain ⟨c, hc⟩ : BddAbove ((fun x ↦ x.1 * b + a * x.2) '' Set.Iio a ×ˢ Set.Iio b) := + bddAbove_of_small _ + exact ⟨_, fun x hx y hy ↦ + (lt_succ_of_le <| hc <| Set.mem_image_of_mem _ <| Set.mk_mem_prod hx hy).trans_le le_add_right⟩ + +theorem mul_add_lt (ha : a' < a) (hb : b' < b) : a' * b + a * b' < a * b + a' * b' := by + rw [mul_def a b] + exact csInf_mem (mul_nonempty a b) a' ha b' hb + +theorem mul_add_le (ha : a' ≤ a) (hb : b' ≤ b) : a' * b + a * b' ≤ a * b + a' * b' := by + obtain rfl | ha := ha.eq_or_lt; · rfl + obtain rfl | hb := hb.eq_or_lt; · rw [add_comm] + exact (mul_add_lt ha hb).le + +theorem lt_mul_iff : c < a * b ↔ ∃ a' < a, ∃ b' < b, c + a' * b' ≤ a' * b + a * b' := by + refine ⟨fun h ↦ ?_, fun ⟨a', ha, b', hb, h⟩ ↦ ?_⟩ + · rw [mul_def] at h + simpa using notMem_of_lt_csInf h ⟨0, fun _ _ => bot_le⟩ + · rw [← add_lt_add_iff_right] + exact h.trans_lt (mul_add_lt ha hb) + +theorem mul_le_iff : a * b ≤ c ↔ ∀ a' < a, ∀ b' < b, a' * b + a * b' < c + a' * b' := by + simpa using lt_mul_iff.not + +private theorem mul_comm' (a b : NatOrdinal) : a * b = b * a := by + rw [mul_def, mul_def] + congr with x; constructor <;> intro H c hc d hd + · rw [add_comm, ← mul_comm', ← mul_comm' a, ← mul_comm' d] + exact H _ hd _ hc + · rw [add_comm, mul_comm', mul_comm' c, mul_comm' c] + exact H _ hd _ hc +termination_by (a, b) + +instance : CommMagma NatOrdinal where + mul_comm := private mul_comm' + +private theorem mul_zero' (a : NatOrdinal) : a * 0 = 0 := by + rw [← le_zero_iff, mul_le_iff] + simp + +instance : MulZeroClass NatOrdinal where + mul_zero := private mul_zero' + zero_mul a := by rw [mul_comm', mul_zero'] + +private theorem mul_one' (a : NatOrdinal) : a * 1 = a := by + rw [mul_def] + convert csInf_Ici + ext b + refine ⟨fun H ↦ le_of_forall_lt (a := a) fun c hc ↦ ?_, fun ha c hc ↦ ?_⟩ + · simpa [mul_one' c] using H c hc + · simpa [mul_one' c] using hc.trans_le ha +termination_by a + +instance : MulZeroOneClass NatOrdinal where + mul_one := private mul_one' + one_mul a := by rw [mul_comm', mul_one'] + +instance : PosMulStrictMono NatOrdinal where + mul_lt_mul_of_pos_left a ha b c h := lt_mul_iff.2 ⟨0, ha, b, h, by simp⟩ + +instance : MulPosStrictMono NatOrdinal where + mul_lt_mul_of_pos_right a ha b c h := lt_mul_iff.2 ⟨b, h, 0, ha, by simp⟩ + +instance : MulLeftMono NatOrdinal where + elim a b c h := by + obtain rfl | h₁ := h.eq_or_lt; · simp + obtain rfl | h₂ := eq_zero_or_pos a; · simp + exact (mul_lt_mul_of_pos_left h₁ h₂).le + +instance : MulRightMono NatOrdinal where + elim a b c h := by convert mul_le_mul_right h a using 1 <;> exact mul_comm .. + +private theorem mul_add (a b c : NatOrdinal) : a * (b + c) = a * b + a * c := by + refine le_antisymm (mul_le_iff.2 fun a' ha d hd => ?_) + (add_le_iff.2 ⟨fun d hd => ?_, fun d hd => ?_⟩) + · rw [mul_add] + rcases lt_add_iff.1 hd with (⟨b', hb, hd⟩ | ⟨c', hc, hd⟩) + · have := add_lt_add_of_lt_of_le (mul_add_lt ha hb) (mul_add_le ha.le hd) + rw [mul_add, mul_add] at this + grind + · have := add_lt_add_of_le_of_lt (mul_add_le ha.le hd) (mul_add_lt ha hc) + rw [mul_add, mul_add] at this + grind + · rcases lt_mul_iff.1 hd with ⟨a', ha, b', hb, hd⟩ + have := add_lt_add_of_le_of_lt hd (mul_add_lt ha (add_lt_add_left hb c)) + rw [mul_add, mul_add, mul_add a'] at this + grind + · rcases lt_mul_iff.1 hd with ⟨a', ha, c', hc, hd⟩ + have := add_lt_add_of_lt_of_le (mul_add_lt ha (add_lt_add_right hc b)) hd + rw [mul_add, mul_add, mul_add a'] at this + grind +termination_by (a, b, c) + +instance : Distrib NatOrdinal where + left_distrib := private mul_add + right_distrib a b c := by rw [mul_comm, mul_add, mul_comm, mul_comm c] + +theorem mul_add_lt₃ (ha : a' < a) (hb : b' < b) (hc : c' < c) : + a' * b * c + a * b' * c + a * b * c' + a' * b' * c' < + a * b * c + a' * b' * c + a' * b * c' + a * b' * c' := by + simpa only [add_mul, ← add_assoc] using mul_add_lt (mul_add_lt ha hb) hc + +theorem mul_add_le₃ {a' b' c' : NatOrdinal} (ha : a' ≤ a) (hb : b' ≤ b) (hc : c' ≤ c) : + a' * b * c + a * b' * c + a * b * c' + a' * b' * c' ≤ + a * b * c + a' * b' * c + a' * b * c' + a * b' * c' := by + simpa only [add_mul, ← add_assoc] using mul_add_le (mul_add_le ha hb) hc + +private theorem mul_add_lt₃' {a' b' c' : NatOrdinal} (ha : a' < a) (hb : b' < b) (hc : c' < c) : + a' * (b * c) + a * (b' * c) + a * (b * c') + a' * (b' * c') < + a * (b * c) + a' * (b' * c) + a' * (b * c') + a * (b' * c') := by + simp only [mul_comm _ (_ * _)] + convert mul_add_lt₃ hb hc ha using 1 <;> abel_nf + +theorem lt_mul_iff₃ : d < a * b * c ↔ ∃ a' < a, ∃ b' < b, ∃ c' < c, + d + a' * b' * c + a' * b * c' + a * b' * c' ≤ + a' * b * c + a * b' * c + a * b * c' + a' * b' * c' := by + refine ⟨fun h ↦ ?_, fun ⟨a', ha, b', hb, c', hc, h⟩ ↦ ?_⟩ + · rcases lt_mul_iff.1 h with ⟨e, he, c', hc, H₁⟩ + rcases lt_mul_iff.1 he with ⟨a', ha, b', hb, H₂⟩ + refine ⟨a', ha, b', hb, c', hc, ?_⟩ + have := add_le_add H₁ (mul_add_le H₂ hc.le) + simp only [add_mul, add_assoc] at this + rw [add_left_comm, add_left_comm d, add_left_comm, add_le_add_iff_left, + add_left_comm (a * b' * c), add_left_comm (a' * b * c), add_left_comm (a * b * c'), + add_le_add_iff_left, add_left_comm (a * b * c'), add_left_comm (a * b * c')] at this + simpa only [add_assoc] + · have := h.trans_lt (mul_add_lt₃ ha hb hc) + repeat rw [add_lt_add_iff_right] at this + assumption + +theorem mul_le_iff₃ : a * b * c ≤ d ↔ ∀ a' < a, ∀ b' < b, ∀ c' < c, + a' * b * c + a * b' * c + a * b * c' + a' * b' * c' < + d + a' * b' * c + a' * b * c' + a * b' * c' := by + simpa using lt_mul_iff₃.not + +private theorem mul_le_iff₃' : a * (b * c) ≤ d ↔ ∀ a' < a, ∀ b' < b, ∀ c' < c, + a' * (b * c) + a * (b' * c) + a * (b * c') + a' * (b' * c') < + d + a' * (b' * c) + a' * (b * c') + a * (b' * c') := by + simp only [mul_comm _ (_ * _), mul_le_iff₃] + constructor <;> intro h a' ha b' hb c' hc + · convert h b' hb c' hc a' ha using 1 <;> abel_nf + · convert h c' hc a' ha b' hb using 1 <;> abel_nf + +private theorem mul_assoc (a b c : NatOrdinal) : a * b * c = a * (b * c) := by + apply le_antisymm + · rw [mul_le_iff₃] + intro a' ha b' hb c' hc + repeat rw [mul_assoc] + exact mul_add_lt₃' ha hb hc + · rw [mul_le_iff₃'] + intro a' ha b' hb c' hc + repeat rw [← mul_assoc] + exact mul_add_lt₃ ha hb hc +termination_by (a, b, c) + +instance : CommSemiring NatOrdinal where + mul_assoc := private mul_assoc + +instance : IsStrictOrderedRing NatOrdinal where + +/-- A version of `omul_le_mul` stated in terms of `Ordinal`. -/ +theorem omul_le_mul' (a b : Ordinal) : a * b ≤ val (of a * of b) := by + induction b using Ordinal.limitRecOn with + | zero => simp + | add_one c IH => simpa [mul_add_one] using (add_left_mono IH).trans (oadd_le_add' ..) + | limit c hc IH => + obtain rfl | ha := eq_zero_or_pos a + · simp + · rw [(Ordinal.isNormal_mul_right ha).apply_of_isSuccLimit hc, Ordinal.iSup_le_iff] + rintro ⟨i, hi⟩ + exact (IH i hi).trans (mul_le_mul_right hi.le (of a)) + +theorem omul_le_mul (a b : NatOrdinal) : of (a.val * b.val) ≤ a * b := + omul_le_mul' .. + +end NatOrdinal diff --git a/LeanPool/ConwayRefinement/CombinatorialGames/NatOrdinal/Pow.lean b/LeanPool/ConwayRefinement/CombinatorialGames/NatOrdinal/Pow.lean new file mode 100644 index 0000000000..48515aed5c --- /dev/null +++ b/LeanPool/ConwayRefinement/CombinatorialGames/NatOrdinal/Pow.lean @@ -0,0 +1,200 @@ +/- +Copyright (c) 2025 Violeta Hernández Palacios. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Violeta Hernández Palacios +-/ +module + +public import LeanPool.ConwayRefinement.CombinatorialGames.NatOrdinal.Basic +public import Mathlib.SetTheory.Ordinal.Exponential + +/-! +# Natural operations on `ω ^ x` + +This file characterizes natural operations on powers of `ω`. In particular, we show: + +- If `y < ω^ x`, then `ω^ x * n + y = of (ω ^ x.val * n + y.val)`. +- `ω^ (x + y) = ω^ x * ω^ y`. + +These two results imply the validity of an algorithm to evaluate natural addition and +multiplication: write down the base `ω` Cantor Normal Forms of both ordinals, and add/multiply them +as polynomials. + +## Implementation notes + +Surreal exponentiation is not closed on the ordinals. Because of this, we opt against defining a +`Pow` instance on `NatOrdinal`. Instead, we implement our own custom typeclass `Wpow`, giving us +notation `ω^ x` for `of (ω ^ x.val)`. This typeclass will get reused for `IGame` and `Surreal` in +`CombinatorialGames.Surreal.Pow`. +-/ + +@[expose] public section + +open Ordinal + +theorem Ordinal.lt_mul_add_one {x y z : Ordinal} : x < y * (z + 1) ↔ ∃ w < y, x ≤ y * z + w := by + obtain rfl | hy := eq_or_ne y 0 + · simp + · rw [mul_add_one, lt_add_iff hy] + +/-- A typeclass for the the `ω^` notation. -/ +class Wpow (α : Type*) where + /-- The `ω`-map, i.e. base `ω` exponentiation. -/ + wpow : α → α + +@[inherit_doc] prefix:75 "ω^ " => Wpow.wpow +recommended_spelling "wpow" for "ω^" in [«termω^_»] + +namespace NatOrdinal +variable {x y z : NatOrdinal} + +noncomputable instance : Wpow NatOrdinal where + wpow x := of (ω ^ x.val) + +theorem wpow_def (x : NatOrdinal) : ω^ x = of (ω ^ x.val) := rfl +@[simp] theorem of_omega0_opow (x : Ordinal) : of (ω ^ x) = ω^ of x := rfl +@[simp] theorem val_wpow (x : NatOrdinal) : (ω^ x).val = ω ^ x.val := rfl + +@[simp] theorem wpow_zero : ω^ (0 : NatOrdinal) = 1 := by simp [wpow_def] +@[simp] theorem wpow_pos (x : NatOrdinal) : 0 < ω^ x := opow_pos _ omega0_pos +@[simp] theorem wpow_ne_zero (x : NatOrdinal) : ω^ x ≠ 0 := (wpow_pos x).ne' + +theorem isNormal_wpow : Order.IsNormal (ω^ · : NatOrdinal → NatOrdinal) := + Ordinal.isNormal_opow one_lt_omega0 + +@[simp] theorem wpow_lt_wpow : ω^ x < ω^ y ↔ x < y := isNormal_wpow.strictMono.lt_iff_lt +@[simp] theorem wpow_le_wpow : ω^ x ≤ ω^ y ↔ x ≤ y := isNormal_wpow.strictMono.le_iff_le +@[simp] theorem wpow_inj : ω^ x = ω^ y ↔ x = y := isNormal_wpow.strictMono.injective.eq_iff + +private theorem wpow_mul_natCast_add_of_lt_aux {x y : NatOrdinal} (hy : y < ω^ x) (n : ℕ) : + (∀ z < ω^ x, z + y < ω^ x) ∧ ω^ x * n + y = of (ω ^ x.val * n + y.val) := by + obtain rfl | hx := eq_or_ne x 0 + · simp_all + have H : ∀ z < ω^ x, z + y < ω^ x := by + intro z hz + have hm := max_lt hy hz + rw [wpow_def, ← val_lt_iff, lt_omega0_opow (b := x.val) hx] at hm + obtain ⟨a, ha, n, hn⟩ := hm + have hyz (n) := (wpow_mul_natCast_add_of_lt_aux (wpow_pos (of a)) n).2 + simp_rw [val_zero, add_zero, ← val_eq_iff, val_of] at hyz + rw [← hyz] at hn + calc + z + y ≤ max y z + max y z := add_le_add (le_max_right ..) (le_max_left ..) + _ < ω^ of a * n + ω^ of a * n := add_lt_add hn hn + _ < _ := by + rw [← mul_add, ← Nat.cast_add, ← val.lt_iff_lt, hyz, val_wpow] + exact opow_mul_lt_opow (natCast_lt_omega0 _) ha + refine ⟨H, le_antisymm ?_ ?_⟩ + · refine add_le_iff.2 ⟨?_, ?_⟩ <;> intro z hz + · match n with + | 0 => simp at hz + | 1 => + simp_rw [Nat.cast_one, mul_one] at * + apply (H z hz).trans_le + rw [wpow_def, of.le_iff_le] + exact le_self_add .. + | n + 1 + 1 => + rw [Nat.cast_add_one, mul_add_one] at hz + obtain ⟨a, ha, hz⟩ : ∃ a < ω^ x, z ≤ ω^ x * ↑(n + 1) + a := by + obtain (⟨a, ha, hz⟩ | h) := lt_add_iff.1 hz + · have hxn := (wpow_mul_natCast_add_of_lt_aux (wpow_pos x) (n + 1)).2 + simp_rw [val_zero, add_zero] at hxn + rw [hxn, ← val_lt_iff, Nat.cast_add_one, lt_mul_add_one] at ha + obtain ⟨b, (hb : of b < ω^ x), hbw⟩ := ha + rw [val_le_iff, ← val_of b, ← (wpow_mul_natCast_add_of_lt_aux hb n).2] at hbw + refine ⟨_, hb, hz.trans <| (add_le_add_left hbw _).trans ?_⟩ + rw [add_comm, ← add_assoc, ← mul_one_add, add_comm 1, ← Nat.cast_add_one] + · exact h + have ha' := H a ha + apply (add_le_add_left hz _).trans_lt + rw [add_assoc, (wpow_mul_natCast_add_of_lt_aux ha' _).2, of.lt_iff_lt] + apply (le_self_add ..).trans_lt' + rw [Nat.cast_add_one (n + 1), mul_add] + simpa + · rw [(wpow_mul_natCast_add_of_lt_aux (hz.trans hy) n).2] + simpa + · exact (oadd_le_add ..).trans (add_le_add_left (omul_le_mul ..) _) +termination_by (x, n, y) + +theorem add_lt_wpow (hx : x < ω^ z) (hy : y < ω^ z) : x + y < ω^ z := + (wpow_mul_natCast_add_of_lt_aux hy 0).1 x hx + +/-- See `wpow_mul_natCast_add_of_lt` for a stronger version. -/ +theorem wpow_mul_natCast_add_of_lt' (hy : y < ω^ x) (n : ℕ) : + ω^ x * n + y = of (ω ^ x.val * n + y.val) := + (wpow_mul_natCast_add_of_lt_aux hy n).2 + +/-- See `wpow_add_of_lt` for a stronger version. -/ +theorem wpow_add_of_lt' (hy : y < ω^ x) : ω^ x + y = of (ω ^ x.val + y.val) := by + simpa using wpow_mul_natCast_add_of_lt' hy 1 + +theorem wpow_mul_natCast (x : NatOrdinal) (n : ℕ) : ω^ x * n = of (ω ^ x.val * n) := by + simpa using wpow_mul_natCast_add_of_lt' (wpow_pos _) n + +theorem wpow_mul_natCast_lt (h : x < y) (n : ℕ) : ω^ x * n < ω^ y := by + rw [wpow_mul_natCast] + exact opow_mul_lt_opow (natCast_lt_omega0 n) h + +theorem lt_wpow_iff (hx : x ≠ 0) : y < ω^ x ↔ ∃ z < x, ∃ n : ℕ, y < ω^ z * n := by + rw [wpow_def, ← val_lt_iff, lt_omega0_opow] + · simp_rw [wpow_mul_natCast] + rfl + · assumption + +theorem wpow_le_iff (hx : x ≠ 0) : ω^ x ≤ y ↔ ∀ z < x, ∀ n : ℕ, ω^ z * n ≤ y := by + rw [← not_lt, lt_wpow_iff hx] + simp + +theorem lt_wpow_add_one_iff : y < ω^ (x + 1) ↔ ∃ n : ℕ, y < ω^ x * n := by + rw [wpow_def, ← val_lt_iff, val_add_one, ← Order.succ_eq_add_one, lt_omega0_opow_succ] + simp_rw [wpow_mul_natCast] + rfl + +theorem wpow_add_one_le_iff : ω^ (x + 1) ≤ y ↔ ∀ n : ℕ, ω^ x * n ≤ y := by + rw [← not_lt, lt_wpow_add_one_iff] + simp + +theorem wpow_mul_natCast_add_of_lt (hy : y < ω^ (x + 1)) (n : ℕ) : + ω^ x * n + y = of (ω ^ x.val * n + y.val) := by + obtain ⟨z, hz, m, rfl⟩ : ∃ z < ω^ x, ∃ m : ℕ, y = ω^ x * m + z := by + rw [wpow_def, ← val_lt_iff, val_add_one, opow_add, opow_one, Ordinal.lt_mul_iff_div_lt] at hy + · obtain ⟨m, hm⟩ := Ordinal.lt_omega0.1 hy + have hx : of (y.val % ω ^ x.val) < ω^ x := mod_lt _ (wpow_ne_zero _) + use of (y.val % ω ^ x.val), hx, m + rw [wpow_mul_natCast_add_of_lt' hx, ← hm] + exact (div_add_mod ..).symm + · exact wpow_ne_zero _ + simp_rw [← add_assoc, wpow_mul_natCast_add_of_lt' hz, val_of, ← add_assoc, ← mul_add, + ← Nat.cast_add, wpow_mul_natCast_add_of_lt' hz] + +theorem wpow_add_of_lt (hy : y < ω^ (x + 1)) : ω^ x + y = of (ω ^ x.val + y.val) := by + simpa using wpow_mul_natCast_add_of_lt hy 1 + +theorem wpow_add_wpow (h : x ≤ y) : ω^ y + ω^ x = of (ω ^ y.val + ω ^ x.val) := by + rw [wpow_add_of_lt, val_wpow] + simpa using Order.lt_succ_of_le h + +theorem wpow_add (x y : NatOrdinal) : ω^ (x + y) = ω^ x * ω^ y := by + obtain rfl | hx := eq_or_ne x 0; · simp + obtain rfl | hy := eq_or_ne y 0; · simp + have h : x + y ≠ 0 := by simp_all + apply le_antisymm + · simp_rw [wpow_le_iff h, lt_add_iff] + rintro z (⟨a, ha, hz⟩ | ⟨a, ha, hz⟩) n <;> apply (mul_le_mul_left (wpow_le_wpow.2 hz) _).trans + · rw [wpow_add, mul_comm, ← mul_assoc, mul_comm _ (ω^ a)] + exact mul_le_mul_left (wpow_mul_natCast_lt ha n).le _ + · rw [wpow_add, mul_assoc] + exact mul_le_mul_right (wpow_mul_natCast_lt ha n).le _ + · simp_rw [mul_le_iff, lt_wpow_iff hx, lt_wpow_iff hy] + rintro z ⟨a, ha, n, hz⟩ w ⟨b, hb, m, hw⟩ + apply (add_lt_wpow _ _).trans_le (le_add_right ..) + · apply (mul_le_mul_left hz.le _).trans_lt + rw [← mul_comm, ← mul_assoc, mul_comm (ω^ y), ← wpow_add] + exact wpow_mul_natCast_lt (add_lt_add_left ha y) n + · apply (mul_le_mul_right hw.le _).trans_lt + rw [← mul_assoc, ← wpow_add] + exact wpow_mul_natCast_lt (add_lt_add_right hb x) m +termination_by (x, y) + +end NatOrdinal +end diff --git a/LeanPool/ConwayRefinement/CombinatorialGames/Surreal.lean b/LeanPool/ConwayRefinement/CombinatorialGames/Surreal.lean new file mode 100644 index 0000000000..a067ba6c5d --- /dev/null +++ b/LeanPool/ConwayRefinement/CombinatorialGames/Surreal.lean @@ -0,0 +1,20 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.CombinatorialGames.Surreal.Basic +public import LeanPool.ConwayRefinement.CombinatorialGames.Surreal.Birthday +public import LeanPool.ConwayRefinement.CombinatorialGames.Surreal.Division +public import LeanPool.ConwayRefinement.CombinatorialGames.Surreal.Dyadic +public import LeanPool.ConwayRefinement.CombinatorialGames.Surreal.HahnSeries +public import LeanPool.ConwayRefinement.CombinatorialGames.Surreal.Leading +public import LeanPool.ConwayRefinement.CombinatorialGames.Surreal.Multiplication +public import LeanPool.ConwayRefinement.CombinatorialGames.Surreal.Ordinal +public import LeanPool.ConwayRefinement.CombinatorialGames.Surreal.Pow +public import LeanPool.ConwayRefinement.CombinatorialGames.Surreal.Real + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/CombinatorialGames/Surreal/Basic.lean b/LeanPool/ConwayRefinement/CombinatorialGames/Surreal/Basic.lean new file mode 100644 index 0000000000..7e52b91077 --- /dev/null +++ b/LeanPool/ConwayRefinement/CombinatorialGames/Surreal/Basic.lean @@ -0,0 +1,320 @@ +/- +Copyright (c) 2019 Mario Carneiro. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Mario Carneiro, Kim Morrison, Violeta Hernández Palacios +-/ +module + +public import LeanPool.ConwayRefinement.CombinatorialGames.Game.Birthday + +import LeanPool.ConwayRefinement.CombinatorialGames.Tactic.AddInstances +import Mathlib.Data.Int.Cast.Lemmas + +/-! +# Surreal numbers + +The basic theory of surreal numbers, built on top of the theory of combinatorial (pre-)games. A +surreal number is defined as an equivalence class of numeric games. + +Surreal numbers inherit the relations `≤` and `<` from games, and these relations satisfy the axioms +of a linear order. In fact, the surreals form a complete ordered field, containing a copy of the +reals, and much else besides! + +## Algebraic operations + +In this file, we show that the surreals form a linear ordered commutative group. + +In `CombinatorialGames.Surreal.Multiplication`, we define multiplication and show that the surreals +form a linear ordered commutative ring. In `CombinatorialGames.Surreal.Division` we further show the +surreals are a field. +-/ + +universe u + +@[expose] public noncomputable section + +/-! ### Simplicity theorem -/ + +namespace IGame + +/-- `x` fits within `y` when `z ⧏ x` for every `z ∈ yᴸ`, and `x ⧏ z` for every +`z ∈ yᴿ`. + +The simplicity theorem states that if a game fits a numeric game, but none of its options do, then +the games are equivalent. In particular, a numeric game is equivalent to the game of the least +birthday that fits in it -/ +def Fits (x y : IGame) : Prop := + (∀ z ∈ yᴸ, z ⧏ x) ∧ (∀ z ∈ yᴿ, x ⧏ z) + +theorem fits_of_equiv {x y : IGame} (h : x ≈ y) : Fits x y := + ⟨fun _ hz ↦ mt h.ge.trans (left_lf hz), fun _ hz ↦ mt h.le.trans' (lf_right hz) ⟩ + +alias AntisymmRel.Fits := fits_of_equiv + +theorem Fits.refl (x : IGame) : x.Fits x := + fits_of_equiv .rfl + +instance : Std.Refl Fits where + refl := Fits.refl + +theorem Fits.antisymm {x y : IGame} (h₁ : Fits x y) (h₂ : Fits y x) : x ≈ y := by + rw [AntisymmRel, le_iff_forall_lf, le_iff_forall_lf] + exact ⟨⟨h₂.1, h₁.2⟩, ⟨h₁.1, h₂.2⟩⟩ + +@[simp] +theorem fits_neg_iff {x y : IGame} : Fits (-x) (-y) ↔ Fits x y := by + simp [Fits, and_comm] + +alias ⟨_, Fits.neg⟩ := fits_neg_iff + +theorem not_fits_iff {x y : IGame} : + ¬ Fits x y ↔ (∃ z ∈ yᴸ, x ≤ z) ∨ (∃ z ∈ yᴿ, z ≤ x) := by + rw [Fits, not_and_or]; simp + +theorem Fits.congr {x y z : IGame} (h : x ≈ y) (hx : x.Fits z) : y.Fits z := by + constructor <;> intro w hw <;> grw [← h] + exacts [hx.1 w hw, hx.2 w hw] + +theorem fits_congr {x y z : IGame} (h : x ≈ y) : x.Fits z ↔ y.Fits z := + ⟨.congr h, .congr h.symm⟩ + +/-- A variant of the **simplicity theorem** with hypotheses that are easier to show. -/ +theorem Fits.equiv_of_forall_moves {x y : IGame} (hx : x.Fits y) + (hl : ∀ z ∈ xᴸ, ∃ w ∈ yᴸ, z ≤ w) (hr : ∀ z ∈ xᴿ, ∃ w ∈ yᴿ, w ≤ z) : x ≈ y := + ⟨le_of_forall_moves_right_lf hx.2 hl, le_of_forall_moves_left_lf hx.1 hr⟩ + +/-- A variant of the **simplicity theorem**: if a numeric game `x` fits within a game `y`, but none +of its options do, then `x ≈ y`. + +Note that under most circumstances, `Fits.equiv_of_forall_moves` is easier to use. -/ +theorem Fits.equiv_of_forall_not_fits {x y : IGame} [Numeric x] (hx : x.Fits y) + (h : ∀ p, ∀ z ∈ x.moves p, ¬ z.Fits y) : x ≈ y := by + simp_rw [not_fits_iff] at h + apply hx.equiv_of_forall_moves + · refine fun z hz ↦ (h _ z hz).resolve_right ?_ + rintro ⟨w, hw, hwz⟩ + exact hx.2 w hw <| hwz.trans (Numeric.left_lt hz).le + · refine fun z hz ↦ (h _ z hz).resolve_left ?_ + rintro ⟨w, hw, hwz⟩ + exact hx.1 w hw <| (Numeric.lt_right hz).le.trans hwz + +/-- A variant of the **simplicity theorem**: if `x` is the numeric game with the least birthday that +fits within `y`, then `x ≈ y`. -/ +theorem Fits.equiv_of_forall_birthday_le {x y : IGame} [Numeric x] (hx : x.Fits y) + (H : ∀ z, Numeric z → z.Fits y → x.birthday ≤ z.birthday) : x ≈ y := + hx.equiv_of_forall_not_fits + fun _ z hz h ↦ (birthday_lt_of_mem_moves hz).not_ge <| H z (.of_mem_moves hz) h + +/-- A specialization of the simplicity theorem to `0`. -/ +@[simp] +theorem fits_zero_iff_equiv {x : IGame} : Fits 0 x ↔ x ≈ 0 := + ⟨fun hx ↦ (hx.equiv_of_forall_not_fits <| by simp).symm, fun h ↦ fits_of_equiv h.symm⟩ + +/-- A specialization of the simplicity theorem to `1`. -/ +theorem equiv_one_of_fits {x : IGame} (hx : Fits 1 x) (h : ¬ x ≈ 0) : x ≈ 1 := by + apply (hx.equiv_of_forall_not_fits _).symm + simpa + +end IGame + +/-! ### Surreal numbers -/ + +open IGame + +/-- The type of surreal numbers. These are the numeric games quotiented by the antisymmetrization +relation `x ≈ y ↔ x ≤ y ∧ y ≤ x`. In the quotient, the order becomes a total order. -/ +def Surreal : Type (u + 1) := + Antisymmetrization (Subtype Numeric) (· ≤ ·) + +namespace Surreal + +/-- The quotient map from the subtype of numeric `IGame`s into `ConwayGame`. -/ +def mk (x : IGame) [h : Numeric x] : Surreal := Quotient.mk _ ⟨x, h⟩ +theorem mk_eq_mk {x y : IGame} [Numeric x] [Numeric y] : mk x = mk y ↔ x ≈ y := Quotient.eq + +alias ⟨_, mk_eq⟩ := mk_eq_mk + +@[cases_eliminator] +theorem ind {motive : Surreal → Prop} (mk : ∀ y [Numeric y], motive (mk y)) (x : Surreal) : + motive x := Quotient.ind (fun h ↦ @mk _ h.2) x + +/-- Choose an element of the equivalence class using the axiom of choice. -/ +@[no_expose] def out (x : Surreal) : IGame := (Quotient.out x).1 +@[simp] instance (x : Surreal) : Numeric x.out := (Quotient.out x).2 +@[simp] theorem out_eq (x : Surreal) : mk x.out = x := Quotient.out_eq x + +theorem mk_out_equiv (x : IGame) [h : Numeric x] : (mk x).out ≈ x := + Quotient.mk_out (s := AntisymmRel.setoid (Subtype _) (· ≤ ·)) ⟨x, h⟩ + +theorem equiv_mk_out (x : IGame) [Numeric x] : x ≈ (mk x).out := + (mk_out_equiv x).symm + +instance : Zero Surreal := ⟨mk 0⟩ +instance : One Surreal := ⟨mk 1⟩ +instance : Inhabited Surreal := ⟨0⟩ + +instance : Add Surreal where + add := Quotient.map₂ (fun a b ↦ ⟨a.1 + b.1, inferInstance⟩) fun _ _ h₁ _ _ h₂ ↦ add_congr h₁ h₂ + +instance : Neg Surreal where + neg := Quotient.map (fun a ↦ ⟨-a.1, inferInstance⟩) fun _ _ ↦ neg_congr + +instance : PartialOrder Surreal := + inferInstanceAs (PartialOrder (Antisymmetrization ..)) + +instance : LinearOrder Surreal where + le_total := by rintro ⟨x⟩ ⟨y⟩; exact Numeric.le_total x y + toDecidableLE := Classical.decRel _ + +instance : AddCommGroup Surreal where + zero_add := by rintro ⟨x⟩; change mk (0 + x) = mk x; simp_rw [zero_add] + add_zero := by rintro ⟨x⟩; change mk (x + 0) = mk x; simp_rw [add_zero] + add_comm := by rintro ⟨x⟩ ⟨y⟩; change mk (x + y) = mk (y + x); simp_rw [add_comm] + add_assoc := by rintro ⟨x⟩ ⟨y⟩ ⟨z⟩; change mk (x + y + z) = mk (x + (y + z)); simp_rw [add_assoc] + neg_add_cancel := by rintro ⟨a⟩; exact mk_eq (neg_add_equiv _) + nsmul := nsmulRec + zsmul := zsmulRec + +instance : AddGroupWithOne Surreal where + +instance : IsOrderedAddMonoid Surreal where + add_le_add_left := by rintro ⟨a⟩ ⟨b⟩ h ⟨c⟩; exact add_le_add_left (α := IGame) h _ + +@[simp] theorem mk_zero : mk 0 = 0 := rfl +@[simp] theorem mk_one : mk 1 = 1 := rfl +@[simp] theorem mk_add (x y : IGame) [Numeric x] [Numeric y] : mk (x + y) = mk x + mk y := rfl +@[simp] theorem mk_neg (x : IGame) [Numeric x] : mk (-x) = -mk x := rfl +@[simp] theorem mk_sub (x y : IGame) [Numeric x] [Numeric y] : mk (x - y) = mk x - mk y := rfl + +@[simp] theorem mk_le_mk {x y : IGame} [Numeric x] [Numeric y] : mk x ≤ mk y ↔ x ≤ y := Iff.rfl +@[simp] theorem mk_lt_mk {x y : IGame} [Numeric x] [Numeric y] : mk x < mk y ↔ x < y := Iff.rfl + +@[simp] +theorem mk_natCast : ∀ n : ℕ, mk n = n + | 0 => rfl + | n + 1 => by simp_rw [Nat.cast_add_one, mk_add, mk_one, mk_natCast n] + +@[simp] +theorem mk_intCast (n : ℤ) : mk n = n := by + cases n <;> simp + +instance : ZeroLEOneClass Surreal where + zero_le_one := zero_le_one (α := IGame) + +instance : NeZero (1 : Surreal) where + out := by apply ne_of_gt; exact IGame.zero_lt_one + +instance : Nontrivial Surreal := + ⟨_, _, zero_ne_one⟩ + +/-- Casts a `Surreal` number into a `ConwayGame`. -/ +def toGame : Surreal ↪o ConwayGame where + toFun := Quotient.lift (fun x ↦ .mk x) fun _ _ ↦ ConwayGame.mk_eq + inj' x y := by + cases x; cases y; + change ConwayGame.mk _ = ConwayGame.mk _ → _ + simp [ConwayGame.mk_eq_mk, mk_eq_mk] + map_rel_iff' := by rintro ⟨_⟩ ⟨_⟩; rfl + +@[simp] theorem toGame_mk (x : IGame) [Numeric x] : toGame (mk x) = .mk x := rfl +@[simp] theorem toGame_zero : toGame 0 = 0 := rfl +@[simp] theorem toGame_one : toGame 1 = 1 := rfl + +@[simp] +theorem gameMk_out (x : Surreal) : ConwayGame.mk x.out = x.toGame := by + conv_rhs => rw [← out_eq x, toGame_mk] + +theorem toGame_le_iff {a b : Surreal} : toGame a ≤ toGame b ↔ a ≤ b := by simp +theorem toGame_lt_iff {a b : Surreal} : toGame a < toGame b ↔ a < b := by simp +theorem toGame_inj {a b : Surreal} : toGame a = toGame b ↔ a = b := by simp + +/-- `Surreal.toGame` as an `OrderAddMonoidHom` -/ +@[simps] +def toGameAddHom : Surreal →+o ConwayGame where + toFun := toGame + map_zero' := rfl + map_add' := by rintro ⟨_⟩ ⟨_⟩; rfl + monotone' := toGame.monotone + +@[simp] +theorem toGame_add (x y : Surreal) : toGame (x + y) = toGame x + toGame y := + toGameAddHom.map_add x y + +@[simp] +theorem toGame_neg (x : Surreal) : toGame (-x) = -toGame x := + toGameAddHom.map_neg x + +@[simp] +theorem toGame_sub (x y : Surreal) : toGame (x - y) = toGame x - toGame y := + toGameAddHom.map_sub x y + +@[simp] theorem toGame_natCast (n : ℕ) : toGame n = n := map_natCast' toGameAddHom rfl n +@[simp] theorem toGame_intCast (n : ℤ) : toGame n = n := map_intCast' toGameAddHom rfl n + +/-- Construct a `Surreal` from its left and right sets, and a proof that all elements from the left +set are less than all the elements of the right set. + +Note that although this function is well-defined, this function isn't injective, nor do equivalence +classes in Surreal have a canonical representative. (Note however that every short numeric game has +a unique "canonical" form!) -/ +instance : OfSets Surreal.{u} (fun st ↦ ∀ x ∈ st left, ∀ y ∈ st right, x < y) where + ofSets st H _ _ := by + refine @mk !{fun p ↦ out '' st p} (.mk ?_ (by simp)) + rw [moves_ofSets, moves_ofSets] + rintro - ⟨x, hx, rfl⟩ - ⟨y, hy, rfl⟩ + rw [← Surreal.mk_lt_mk, out_eq, out_eq] + exact H x hx y hy + +theorem toGame_ofSets' (st : Player → Set Surreal.{u}) [Small.{u} (st left)] [Small.{u} (st right)] + {H : ∀ x ∈ st left, ∀ y ∈ st right, x < y} : + toGame !{st} = !{fun p ↦ toGame '' st p} := by + change toGame (@mk _ (_)) = _ + simp_rw [toGame_mk, ConwayGame.mk_ofSets', Set.image_image, gameMk_out] + +@[simp] +theorem toGame_ofSets (s t : Set Surreal.{u}) [Small.{u} s] [Small.{u} t] + {H : ∀ x ∈ s, ∀ y ∈ t, x < y} : + toGame !{s | t} = !{toGame '' s | toGame '' t} := by + rw [toGame_ofSets'] + congr; aesop + +theorem mk_ofSets' {st : Player → Set IGame.{u}} + [Small.{u} (st left)] [Small.{u} (st right)] {H : Numeric !{st}} : + mk !{st} = + !{fun p ↦ .range fun x : st p ↦ mk x (h := H.of_mem_moves (p := p) (by simp))}' + (by have := @H.left_lt_right; aesop) := by + change _ = @mk _ (_) + simp_rw [← toGame_inj, toGame_mk, ConwayGame.mk_ofSets'] + congr; aesop + +theorem mk_ofSets {s t : Set IGame.{u}} [Small.{u} s] [Small.{u} t] {H : Numeric !{s | t}} : + mk !{s | t} = + !{.range fun x : s ↦ mk x (h := H.of_mem_moves (p := left) (by simp)) | + .range fun x : t ↦ mk x (h := H.of_mem_moves (p := right) (by simp))}' + (by have := @H.left_lt_right; aesop) := by + rw [mk_ofSets'] + congr!; aesop + +@[aesop apply safe] +theorem lt_ofSets_of_mem_left {s t : Set Surreal.{u}} [Small.{u} s] [Small.{u} t] + {H : ∀ x ∈ s, ∀ y ∈ t, x < y} {x : Surreal} (hx : x ∈ s) : + x < !{s | t} := by + rw [lt_iff_not_ge, ← toGame_le_iff, toGame_ofSets] + exact ConwayGame.lf_ofSets_of_mem_left (Set.mem_image_of_mem _ hx) + +@[aesop apply safe] +theorem ofSets_lt_of_mem_right {s t : Set Surreal.{u}} [Small.{u} s] [Small.{u} t] + {H : ∀ x ∈ s, ∀ y ∈ t, x < y} {x : Surreal} (hx : x ∈ t) : + !{s | t} < x := by + rw [lt_iff_not_ge, ← toGame_le_iff, toGame_ofSets] + exact ConwayGame.ofSets_lf_of_mem_right (Set.mem_image_of_mem _ hx) + +theorem zero_def : (0 : Surreal) = !{fun _ ↦ ∅} := by apply (mk_ofSets' ..).trans; congr!; simp +theorem one_def : (1 : Surreal) = !{{0} | ∅} := by apply (mk_ofSets ..).trans; congr! <;> aesop + +instance : DenselyOrdered Surreal where + dense a b hab := ⟨!{{a} | {b}}, + lt_ofSets_of_mem_left (Set.mem_singleton a), ofSets_lt_of_mem_right (Set.mem_singleton b)⟩ + +end Surreal +end diff --git a/LeanPool/ConwayRefinement/CombinatorialGames/Surreal/Birthday.lean b/LeanPool/ConwayRefinement/CombinatorialGames/Surreal/Birthday.lean new file mode 100644 index 0000000000..e2d3141adf --- /dev/null +++ b/LeanPool/ConwayRefinement/CombinatorialGames/Surreal/Birthday.lean @@ -0,0 +1,11 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.CombinatorialGames.Surreal.Birthday.Basic + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/CombinatorialGames/Surreal/Birthday/Basic.lean b/LeanPool/ConwayRefinement/CombinatorialGames/Surreal/Birthday/Basic.lean new file mode 100644 index 0000000000..5cf9edfb11 --- /dev/null +++ b/LeanPool/ConwayRefinement/CombinatorialGames/Surreal/Birthday/Basic.lean @@ -0,0 +1,156 @@ +/- +Copyright (c) 2025 Aaron Liu. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Aaron Liu +-/ +module + +public import LeanPool.ConwayRefinement.CombinatorialGames.Game.Birthday +public import LeanPool.ConwayRefinement.CombinatorialGames.Surreal.Ordinal + +import Mathlib.Algebra.Order.Group.OrderIso + +/-! +# Birthday of a surreal number + +TODO: write a better docstring +-/ + +universe u + +public noncomputable section + +namespace Surreal +open IGame NatOrdinal Order Set + +/-- The birthday of a surreal number is defined as the least birthday +among all *numeric* pre-games that define it. + +The numeric condition can be removed, see `Surreal.birthday_toGame`. -/ +def birthday (x : Surreal.{u}) : NatOrdinal.{u} := + sInf (IGame.birthday '' {c | ∃ _ : Numeric c, mk c = x}) + +theorem birthday_eq_iGameBirthday (x : Surreal) : + ∃ (y : IGame) (_ : Numeric y), mk y = x ∧ y.birthday = birthday x := by + simp_rw [exists_and_right] + refine csInf_mem (image_nonempty.2 ?_) + exact ⟨_, _, x.out_eq⟩ + +theorem birthday_mk_le (x : IGame) [Numeric x] : birthday (mk x) ≤ x.birthday := + csInf_le' ⟨x, ⟨_, rfl⟩, rfl⟩ + +@[simp] +theorem birthday_zero : birthday 0 = 0 := by + simpa using birthday_mk_le 0 + +@[simp] +theorem birthday_eq_zero {x : Surreal} : birthday x = 0 ↔ x = 0 := by + obtain ⟨_, _, _, _⟩ := birthday_eq_iGameBirthday x + refine ⟨fun _ ↦ ?_, ?_⟩ <;> simp_all + +private theorem birthday_neg_le (x : Surreal) : (-x).birthday ≤ x.birthday := by + obtain ⟨y, _, rfl, hy⟩ := birthday_eq_iGameBirthday x + rw [← hy, ← IGame.birthday_neg] + exact birthday_mk_le _ + +@[simp] +theorem birthday_neg (x : Surreal) : (-x).birthday = x.birthday := by + apply (birthday_neg_le x).antisymm + simpa using birthday_neg_le (-x) + +theorem le_toSurreal_birthday (x : Surreal) : x ≤ x.birthday.toSurreal := by + obtain ⟨y, _, rfl, hy⟩ := birthday_eq_iGameBirthday x + rw [← hy] + exact y.le_toIGame_birthday + +theorem neg_toSurreal_birthday_le (x : Surreal) : -x.birthday.toSurreal ≤ x := by + simpa [neg_le] using le_toSurreal_birthday (-x) + +@[simp] +theorem birthday_toSurreal (o : NatOrdinal) : birthday o.toSurreal = o := by + apply le_antisymm + · simpa using birthday_mk_le o.toIGame + · simpa using o.toSurreal.le_toSurreal_birthday + +@[simp, norm_cast] +theorem birthday_natCast (n : ℕ) : birthday n = n := by + simpa using birthday_toSurreal n + +@[simp] +theorem birthday_ofNat (n : ℕ) [n.AtLeastTwo] : birthday ofNat(n) = n := + birthday_natCast n + +@[simp] +theorem birthday_one : birthday 1 = 1 := by + simpa using birthday_natCast 1 + +theorem birthday_ofSets_le {s t : Set Surreal.{u}} + [Small.{u} s] [Small.{u} t] {H : ∀ x ∈ s, ∀ y ∈ t, x < y} : + !{s | t}.birthday ≤ max (sSup (succ ∘ birthday '' s)) (sSup (succ ∘ birthday '' t)) := by + choose f hf using birthday_eq_iGameBirthday + have : Numeric !{f '' s | f '' t} := by + rw [numeric_def] + simp_rw [moves_ofSets] + refine ⟨?_, ?_⟩ + · rintro _ ⟨x, hx, rfl⟩ _ ⟨y, hy, rfl⟩ + obtain ⟨a, hx', _⟩ := hf x + obtain ⟨b, hy', _⟩ := hf y + rw [← mk_lt_mk, hx', hy'] + exact H x hx y hy + rintro (_ | _) _ ⟨y, hy, rfl⟩ + all_goals + obtain ⟨hy, _, _⟩ := hf y + exact hy + have : !{s | t} = mk !{f '' s | f '' t} := by + rw [← toGame_inj, toGame_ofSets, toGame_mk, ConwayGame.mk_ofSets] + simp_rw [image_image] + congr! with a ha a ha + all_goals + · obtain ⟨_, ha', _⟩ := hf a + rw [← toGame_mk, toGame_inj, ha'] + rw [this] + apply (birthday_mk_le _).trans + simp_rw [IGame.birthday_ofSets, image_comp] + congr! <;> aesop + +theorem birthday_add_le (x y : Surreal) : (x + y).birthday ≤ x.birthday + y.birthday := by + obtain ⟨a, _, ha, ha'⟩ := birthday_eq_iGameBirthday x + obtain ⟨b, _, hb, hb'⟩ := birthday_eq_iGameBirthday y + rw [← ha', ← hb', ← ha, ← hb, ← IGame.birthday_add] + exact birthday_mk_le _ + +theorem birthday_sub_le (x y : Surreal) : (x - y).birthday ≤ x.birthday + y.birthday := by + simpa [sub_eq_add_neg] using birthday_add_le x (-y) + +/- This is currently an open problem, see https://mathoverflow.net/a/476829/147705. -/ +proof_wanted birthday_mul_le (x y : Surreal) : (x * y).birthday ≤ x.birthday * y.birthday + +/-- The birthday of a surreal number is at least the birthday of the corresponding game. -/ +theorem birthday_toGame_le (x : Surreal) : x.toGame.birthday ≤ x.birthday := by + obtain ⟨c, _, rfl, h⟩ := birthday_eq_iGameBirthday x + rw [← h, toGame_mk] + exact ConwayGame.birthday_mk_le c + +/-- Surreals with a bounded birthday form a small set. -/ +instance small_setOf_birthday_le (o : NatOrdinal.{u}) : Small.{u} {x | birthday x ≤ o} := by + have h₁ : {x | birthday x ≤ o} ⊆ toGame ⁻¹' {x | x.birthday ≤ o} := by + intro x hx + exact x.birthday_toGame_le.trans hx + have h₂ := Set.restrictPreimage_injective {x | x.birthday ≤ o} toGame.injective + have : Small.{u} (toGame ⁻¹' {x | x.birthday ≤ o}) := small_of_injective h₂ + exact small_subset h₁ + +/-- Surreals with a bounded birthday form a small set. -/ +instance small_setOf_birthday_lt (o : NatOrdinal.{u}) : Small.{u} {x | birthday x < o} := by + refine small_subset (?_ : {x : Surreal | x.birthday < o} ⊆ {x : Surreal | x.birthday ≤ o}) + simp +contextual [le_of_lt] + +/-- A variant of `small_setOf_birthday_le` in simp-normal form -/ +instance small_subtype_birthday_le (o : NatOrdinal.{u}) : Small.{u} {x // birthday x ≤ o} := + small_setOf_birthday_le o + +/-- A variant of `small_setOf_birthday_lt` in simp-normal form -/ +instance small_subtype_birthday_lt (o : NatOrdinal.{u}) : Small.{u} {x // birthday x < o} := + small_setOf_birthday_lt o + +end Surreal diff --git a/LeanPool/ConwayRefinement/CombinatorialGames/Surreal/Division.lean b/LeanPool/ConwayRefinement/CombinatorialGames/Surreal/Division.lean new file mode 100644 index 0000000000..84d7c3a505 --- /dev/null +++ b/LeanPool/ConwayRefinement/CombinatorialGames/Surreal/Division.lean @@ -0,0 +1,531 @@ +/- +Copyright (c) 2025 Violeta Hernández Palacios. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Violeta Hernández Palacios, Theodore Hwa +-/ +module + +public import LeanPool.ConwayRefinement.CombinatorialGames.Surreal.Multiplication +public import Mathlib.Algebra.Field.Defs +public import Mathlib.Algebra.Order.Ring.Unbundled.Rat + +import Mathlib.Algebra.Order.Field.Basic +import Mathlib.Data.Rat.Cast.Order +import Mathlib.Tactic.Abel +import Mathlib.Tactic.Ring + +/-! +# Surreal division + +In this file, we prove that if `x` is a positive numeric game, then `x⁻¹` (defined in +`CombinatorialGames.Game.IGame`) is a number and is a multiplicative inverse for `x`. We use +that +to define the field structure on `Surreal`. + +This is Theorem 1.10 in ONAG, and we follow the broad strokes of the proof. We prove +by simultaneous induction that if `x` is positive and numeric, then (ii) `x⁻¹` is numeric, and (iv) +`x * x⁻¹ ≈ 1`. We do this by showing the inductive hypothesis implies that (i) `x * y < 1` for +`y ∈ x⁻¹ᴸ` and `1 < x * y` for `y ∈ x⁻¹ᴿ`, and that (iv) `y < 1` for +`y ∈ (x * x⁻¹)ᴸ` and `1 < y` for `y ∈ (x * x⁻¹ᴿ)`. + +An important difference is that Conway assumes that `x` has no negative left options, while we don't +make use of this assumption. This is because our definition of the inverse is tweaked to ensure that +only positive left options of `x` generate the options for `x⁻¹`. To make sure the induction checks +out, we require two small extra arithmetic lemmas `mulOption_le` and `le_mulOption`. + +Once we have defined the inverse for positive `x`, it is extended in the obvious way to negative +numbers. +-/ + +universe u + +open IGame + +instance {x y : IGame} [Numeric x] [Numeric y⁻¹] : Numeric (x / y) := .mul .. + +instance {x y a : IGame} [Numeric x] [Numeric y] [Numeric y⁻¹] [Numeric a] : + Numeric (invOption x y a) := + .mul .. + +private theorem inv_pos' {x : IGame} [Numeric x⁻¹] (hx : 0 < x) : 0 < x⁻¹ := + Numeric.left_lt (zero_mem_leftMoves_inv hx) + +private theorem mk_div' (x y : IGame) [Numeric x] [Numeric y⁻¹] : + Surreal.mk (x / y) = Surreal.mk x * Surreal.mk y⁻¹ := + rfl + +/-! ### Arithmetic lemmas -/ + +private lemma one_neg_mul_invOption (x : IGame) {y : IGame} (hy : y * y⁻¹ ≈ 1) (a : IGame) + [Numeric x] [Numeric y] [Numeric y⁻¹] [Numeric a] : + 1 - x * invOption x y a ≈ (1 - x * a) * (y - x) / y := by + rw [← Surreal.mk_eq_mk] at * + dsimp [invOption, mk_div'] at * + simp only [one_mul, sub_eq_add_neg, add_mul, hy] + ring + +private lemma mulOption_self_inv (x : IGame) {y : IGame} (hy : y * y⁻¹ ≈ 1) (a : IGame) + [Numeric x] [Numeric x⁻¹] [Numeric y] [Numeric y⁻¹] [Numeric a] : + mulOption x x⁻¹ y a ≈ 1 + (x⁻¹ - invOption x y a) * y := by + rw [mul_comm] at hy + rw [← Surreal.mk_eq_mk] at * + dsimp [mulOption, invOption, mk_div'] at * + simp only [sub_eq_add_neg, add_mul, neg_mul, mul_assoc, hy] + ring + +private lemma mulOption_le (x y : IGame) {a b : IGame} [Numeric y] [Numeric a] [Numeric b] + (ha : a ≤ 0) (hb : b ≤ y) : mulOption x y a b ≤ x * b := by + rw [mulOption, ← ConwayGame.mk_le_mk] + dsimp + have : ConwayGame.mk (a * y) - ConwayGame.mk (a * b) ≤ 0 := by + rw [← ConwayGame.mk_mul_sub] + apply Numeric.mul_nonpos_of_nonpos_of_nonneg ha + rwa [IGame.sub_nonneg] + rw [← add_le_add_iff_left (ConwayGame.mk (x * b))] at this + convert this using 1 <;> abel + +private theorem le_mulOption (x y : IGame) {a b : IGame} [Numeric y] [Numeric a] [Numeric b] + (ha : a ≤ 0) (hb : y ≤ b) : x * b ≤ mulOption x y a b := by + rw [mulOption, ← ConwayGame.mk_le_mk] + dsimp + have : 0 ≤ ConwayGame.mk (a * y) - ConwayGame.mk (a * b) := by + rw [← ConwayGame.mk_mul_sub] + apply Numeric.mul_nonneg_of_nonpos_of_nonpos ha + rwa [IGame.sub_nonpos] + rw [← add_le_add_iff_left (ConwayGame.mk (x * b))] at this + convert this using 1 <;> abel + +/-! ### Inductive proof -/ + +private lemma numeric_option_inv {x : IGame} [Numeric x] (hx : 0 < x) + (hl : ∀ y ∈ xᴸ, 0 < y → Numeric y⁻¹) (hr : ∀ y ∈ xᴿ, Numeric y⁻¹) : + (∀ p, ∀ y ∈ x⁻¹.moves p, Numeric y) := by + refine invRec hx Numeric.zero fun p₁ p₂ y hy hyx _ _ _ ↦ ?_ + numeric + cases p₁ <;> cases p₂ + all_goals + first + | have := hl _ hyx hy + | have := hr _ hyx + infer_instance + +private lemma mul_inv_option_mem {x : IGame} [Numeric x] (hx : 0 < x) + (hl : ∀ y ∈ xᴸ, 0 < y → Numeric y⁻¹) (hr : ∀ y ∈ xᴿ, Numeric y⁻¹) + (hl' : ∀ y ∈ xᴸ, 0 < y → y * y⁻¹ ≈ 1) (hr' : ∀ y ∈ xᴿ, y * y⁻¹ ≈ 1) : + (∀ y ∈ x⁻¹ᴸ, x * y < 1) ∧ (∀ y ∈ x⁻¹ᴿ, 1 < x * y) := by + suffices ∀ p y, y ∈ x⁻¹.moves p → p.cases (x * y < 1) (1 < x * y) by + exact ⟨this left, this right⟩ + apply invRec (P := fun p y hy ↦ p.cases (x * y < 1) (1 < x * y)) hx + · simp + rintro (_ | _) (_ | _) y hy hyx a ha h <;> dsimp + · numeric + have := hr y hyx + have := numeric_option_inv hx hl hr left a ha + rw [← IGame.sub_pos] + grw [one_neg_mul_invOption x (hr' y hyx) a] + apply Numeric.mul_pos (Numeric.mul_pos _ _) (inv_pos' hy) + · rwa [IGame.sub_pos] + · rw [IGame.sub_pos] + exact Numeric.lt_right hyx + · numeric + have := hl y hyx hy + have := numeric_option_inv hx hl hr left a ha + rw [← IGame.sub_neg] + grw [one_neg_mul_invOption x (hl' y hyx hy) a] + apply Numeric.mul_neg_of_neg_of_pos (Numeric.mul_neg_of_pos_of_neg _ _) (inv_pos' hy) + · rwa [IGame.sub_pos] + · rw [IGame.sub_neg] + exact Numeric.left_lt hyx + · numeric + have := hl y hyx hy + have := numeric_option_inv hx hl hr right a ha + rw [← IGame.sub_pos] + grw [one_neg_mul_invOption x (hl' y hyx hy) a] + apply Numeric.mul_pos (Numeric.mul_pos_of_neg_of_neg _ _) (inv_pos' hy) + · rwa [IGame.sub_neg] + · rw [IGame.sub_neg] + exact Numeric.left_lt hyx + · numeric + have := hr y hyx + have := numeric_option_inv hx hl hr right a ha + rw [← IGame.sub_neg] + grw [one_neg_mul_invOption x (hr' y hyx) a] + apply Numeric.mul_neg_of_neg_of_pos (Numeric.mul_neg_of_neg_of_pos _ _) (inv_pos' hy) + · rwa [IGame.sub_neg] + · rw [IGame.sub_pos] + exact Numeric.lt_right hyx + +private lemma numeric_inv {x : IGame} [Numeric x] (hx : 0 < x) + (hl : ∀ y ∈ xᴸ, 0 < y → Numeric y⁻¹) (hr : ∀ y ∈ xᴿ, Numeric y⁻¹) + (hl' : ∀ y ∈ xᴸ, 0 < y → y * y⁻¹ ≈ 1) (hr' : ∀ y ∈ xᴿ, y * y⁻¹ ≈ 1) : + Numeric x⁻¹ := by + obtain ⟨Hl, Hr⟩ := mul_inv_option_mem hx hl hr hl' hr' + have H' := numeric_option_inv hx hl hr + refine Numeric.mk (fun y hy z hz ↦ ?_) H' + have := H' _ y hy + have := H' _ z hz + exact (Numeric.mul_lt_mul_iff_right hx).1 <| (Hl y hy).trans (Hr z hz) + +private lemma option_mul_inv_lt {x : IGame} [Numeric x] (hx : 0 < x) + (hl : ∀ y ∈ xᴸ, 0 < y → Numeric y⁻¹) (hr : ∀ y ∈ xᴿ, Numeric y⁻¹) + (hl' : ∀ y ∈ xᴸ, 0 < y → y * y⁻¹ ≈ 1) (hr' : ∀ y ∈ xᴿ, y * y⁻¹ ≈ 1) : + (∀ y ∈ (x * x⁻¹)ᴸ, y < 1) ∧ (∀ y ∈ (x * x⁻¹)ᴿ, 1 < y) := by + have := numeric_inv hx hl hr hl' hr' + obtain H := numeric_option_inv hx hl hr + rw [forall_moves_mul, forall_moves_mul] + refine ⟨?_, ?_⟩ <;> rintro (_ | _) + all_goals + intro y hyx a ha + numeric + have := H _ a ha + try (have := hr y hyx; have hy := hx.trans (Numeric.lt_right hyx)) + · obtain hy | hy := Numeric.lt_or_ge 0 y + · have := hl y hyx hy + grw [mulOption_self_inv x (hl' y hyx hy) a] + rw [add_comm, ← IGame.lt_sub_iff_add_lt] + grw [IGame.sub_self_equiv] + apply Numeric.mul_neg_of_neg_of_pos _ hy + rw [IGame.sub_neg] + exact Numeric.lt_right (invOption_mem_moves_inv (p₁ := left) hx hy hyx ha) + · apply (mulOption_le _ _ hy (Numeric.left_lt ha).le).trans_lt + exact (mul_inv_option_mem hx hl hr hl' hr').1 a ha + · grw [mulOption_self_inv x (hr' y hyx) a] + rw [add_comm, ← IGame.lt_sub_iff_add_lt] + grw [IGame.sub_self_equiv] + apply Numeric.mul_neg_of_neg_of_pos _ hy + rw [IGame.sub_neg] + exact Numeric.lt_right (invOption_mem_moves_inv (p₁ := right) hx hy hyx ha) + · obtain hy | hy := Numeric.lt_or_ge 0 y + · have := hl y hyx hy + grw [mulOption_self_inv x (hl' y hyx hy) a] + rw [add_comm, ← IGame.sub_lt_iff_lt_add] + grw [IGame.sub_self_equiv] + apply Numeric.mul_pos _ hy + rw [IGame.sub_pos] + apply Numeric.left_lt (invOption_mem_moves_inv (p₁ := right) hx hy hyx ha) + · apply ((mul_inv_option_mem hx hl hr hl' hr').2 a ha).trans_le + exact le_mulOption _ _ hy (Numeric.lt_right ha).le + · grw [mulOption_self_inv x (hr' y hyx) a] + rw [add_comm, ← IGame.sub_lt_iff_lt_add] + grw [IGame.sub_self_equiv] + apply Numeric.mul_pos _ hy + rw [IGame.sub_pos] + exact Numeric.left_lt (invOption_mem_moves_inv (p₁ := left) hx hy hyx ha) + +private lemma mul_inv_self {x : IGame} [Numeric x] (hx : 0 < x) + (hl : ∀ y ∈ xᴸ, 0 < y → Numeric y⁻¹) (hr : ∀ y ∈ xᴿ, Numeric y⁻¹) + (hl' : ∀ y ∈ xᴸ, 0 < y → y * y⁻¹ ≈ 1) (hr' : ∀ y ∈ xᴿ, y * y⁻¹ ≈ 1) : + x * x⁻¹ ≈ 1 := by + obtain ⟨Hl, Hr⟩ := option_mul_inv_lt hx hl hr hl' hr' + have := numeric_inv hx hl hr hl' hr' + apply equiv_one_of_fits ⟨fun z hz ↦ (Hl z hz).not_ge, fun z hz ↦ (Hr z hz).not_ge⟩ + rw [Numeric.mul_equiv_zero, not_or] + exact ⟨hx.not_antisymmRel_symm, (inv_pos' hx).not_antisymmRel_symm⟩ + +private theorem main {x : IGame} [Numeric x] (hx : 0 < x) : Numeric x⁻¹ ∧ x * x⁻¹ ≈ 1 := by + have IHl : ∀ y ∈ xᴸ, 0 < y → Numeric y⁻¹ ∧ y * y⁻¹ ≈ 1 := + fun y hy hy' ↦ have := Numeric.of_mem_moves hy; main hy' + have IHr : ∀ y ∈ xᴿ, Numeric y⁻¹ ∧ y * y⁻¹ ≈ 1 := + fun y hy ↦ have := Numeric.of_mem_moves hy; main (hx.trans (Numeric.lt_right hy)) + have hl := fun y hy hy' ↦ (IHl y hy hy').1 + have hr := fun y hy ↦ (IHr y hy).1 + have hl' := fun y hy hy' ↦ (IHl y hy hy').2 + have hr' := fun y hy ↦ (IHr y hy).2 + exact ⟨numeric_inv hx hl hr hl' hr', mul_inv_self hx hl hr hl' hr'⟩ +termination_by x +decreasing_by igame_wf + +/-! ### Instances and corollaries -/ + +public section + +namespace IGame.Numeric + +protected instance inv (x : IGame) [Numeric x] : Numeric x⁻¹ := by + obtain h | h | h := Numeric.lt_or_equiv_or_gt x 0 + · rw [← IGame.zero_lt_neg] at h + simpa using (main h).1 + · simp [inv_of_equiv_zero h] + · exact (main h).1 + +protected instance div (x y : IGame) [Numeric x] [Numeric y] : Numeric (x / y) := .mul .. +protected instance ratCast (q : ℚ) : Numeric q := .div .. + +protected instance invOption (x y a : IGame) [Numeric x] [Numeric y] [Numeric a] : + Numeric (invOption x y a) := + .div .. + +protected theorem mul_inv_cancel {x : IGame} [Numeric x] (hx : ¬ x ≈ 0) : x * x⁻¹ ≈ 1 := by + obtain h | h | h := Numeric.lt_or_equiv_or_gt x 0 + · rw [← IGame.zero_lt_neg] at h + simpa using (main h).2 + · contradiction + · exact (main h).2 + +protected theorem inv_mul_cancel {x : IGame} [Numeric x] (hx : ¬ x ≈ 0) : x⁻¹ * x ≈ 1 := by + rw [mul_comm] + exact Numeric.mul_inv_cancel hx + +theorem inv_congr {x y : IGame} [Numeric x] [Numeric y] (he : x ≈ y) : x⁻¹ ≈ y⁻¹ := by + by_cases hy : y ≈ 0 + · rw [inv_of_equiv_zero hy, inv_of_equiv_zero (he.trans hy)] + · have hx := (hy <| he.symm.trans ·) + have := (Numeric.mul_inv_cancel hx).trans (Numeric.mul_inv_cancel hy).symm + rw [← (Numeric.mul_congr_left he).antisymmRel_congr_right] at this + exact Numeric.mul_left_cancel hx this + +theorem div_congr_left {x₁ x₂ y : IGame} [Numeric x₁] [Numeric x₂] [Numeric y] (he : x₁ ≈ x₂) : + x₁ / y ≈ x₂ / y := + mul_congr_left he + +theorem div_congr_right {x y₁ y₂ : IGame} [Numeric x] [Numeric y₁] [Numeric y₂] (he : y₁ ≈ y₂) : + x / y₁ ≈ x / y₂ := + mul_congr_right (inv_congr he) + +theorem div_congr {x₁ x₂ y₁ y₂ : IGame} [Numeric x₁] [Numeric x₂] [Numeric y₁] [Numeric y₂] + (hx : x₁ ≈ x₂) (hy : y₁ ≈ y₂) : x₁ / y₁ ≈ x₂ / y₂ := + (div_congr_left hx).trans (div_congr_right hy) + +end IGame.Numeric + +namespace Surreal + +noncomputable instance : Field Surreal where + inv := Quotient.map (fun x ↦ ⟨x⁻¹, by infer_instance⟩) fun _ _ ↦ Numeric.inv_congr + mul_inv_cancel := by rintro ⟨a⟩ h; exact mk_eq (Numeric.mul_inv_cancel (mk_eq_mk.not.1 h)) + inv_zero := by change mk 0⁻¹ = _; simp + qsmul := _ + nnqsmul := _ + +@[simp] theorem mk_inv (x : IGame) [Numeric x] : mk x⁻¹ = (mk x)⁻¹ := rfl +@[simp] theorem mk_div (x y : IGame) [Numeric x] [Numeric y] : mk (x / y) = mk x / mk y := rfl + +@[simp] +theorem mk_ratCast (q : ℚ) : mk q = q := by + conv_rhs => rw [← q.num_div_den] + simp [ratCast_def] + +@[simp] +theorem toGame_ratCast (q : ℚ) : toGame q = q := by + rw [← mk_ratCast, toGame_mk, ConwayGame.mk_ratCast] + +end Surreal + +namespace IGame +namespace Numeric + +@[simp] +protected theorem inv_pos {x : IGame} [Numeric x] : 0 < x⁻¹ ↔ 0 < x := by + simp [← Surreal.mk_lt_mk] + +@[simp] +protected theorem inv_neg {x : IGame} [Numeric x] : x⁻¹ < 0 ↔ x < 0 := by + simp [← Surreal.mk_lt_mk] + +@[simp] +protected theorem inv_nonneg {x : IGame} [Numeric x] : 0 ≤ x⁻¹ ↔ 0 ≤ x := by + simp [← Surreal.mk_le_mk] + +@[simp] +protected theorem inv_nonpos {x : IGame} [Numeric x] : x⁻¹ ≤ 0 ↔ x ≤ 0 := by + simp [← Surreal.mk_le_mk] + +theorem inv_equiv_of_mul_eq_one {x y : IGame} [Numeric x] [Numeric y] + (he : x * y ≈ 1) : x⁻¹ ≈ y := by + rw [← Surreal.mk_eq_mk] at * + exact inv_eq_of_mul_eq_one_right (a := Surreal.mk x) he + +theorem equiv_inv_of_mul_eq_one {x y : IGame} [Numeric x] [Numeric y] + (he : x * y ≈ 1) : x ≈ y⁻¹ := + (Numeric.inv_equiv_of_mul_eq_one (mul_comm x y ▸ he)).symm + +protected theorem lt_div_iff {x y z : IGame} [Numeric x] [Numeric y] [Numeric z] (hz : 0 < z) : + x < y / z ↔ x * z < y := by + simp_all [← Surreal.mk_lt_mk, lt_div_iff₀] + +protected theorem lt_div_iff' {x y z : IGame} [Numeric x] [Numeric y] [Numeric z] (hz : 0 < z) : + x < y / z ↔ z * x < y := by + simp_all [← Surreal.mk_lt_mk, lt_div_iff₀'] + +protected theorem div_lt_iff {x y z : IGame} [Numeric x] [Numeric y] [Numeric z] (hy : 0 < y) : + x / y < z ↔ x < z * y := by + simp_all [← Surreal.mk_lt_mk, div_lt_iff₀] + +protected theorem div_lt_iff' {x y z : IGame} [Numeric x] [Numeric y] [Numeric z] (hz : 0 < y) : + x / y < z ↔ x < y * z := by + simp_all [← Surreal.mk_lt_mk, div_lt_iff₀'] + +protected theorem lt_div_iff_of_neg {x y z : IGame} [Numeric x] [Numeric y] [Numeric z] + (hz : z < 0) : x < y / z ↔ y < x * z := by + simp_all [← Surreal.mk_lt_mk, lt_div_iff_of_neg] + +protected theorem div_lt_iff_of_neg {x y z : IGame} [Numeric x] [Numeric y] [Numeric z] + (hy : y < 0) : x / y < z ↔ z * y < x := by + simp_all [← Surreal.mk_lt_mk, div_lt_iff_of_neg] + +end Numeric + +@[simp, norm_cast] +theorem ratCast_le {m n : ℚ} : (m : IGame) ≤ n ↔ m ≤ n := by + simp [← Surreal.mk_le_mk] + +@[simp, norm_cast] +theorem ratCast_lt {m n : ℚ} : (m : IGame) < n ↔ m < n := by + simp [← Surreal.mk_lt_mk] + +theorem ratCast_strictMono : StrictMono ((↑) : ℚ → IGame) := + fun _ _ h ↦ ratCast_lt.2 h + +@[simp, norm_cast] +theorem ratCast_inj {m n : ℚ} : (m : IGame) = n ↔ m = n := + ratCast_strictMono.injective.eq_iff + +@[simp, norm_cast] +theorem ratCast_equiv {m n : ℚ} : (m : IGame) ≈ n ↔ m = n := by + simp [AntisymmRel, le_antisymm_iff] + +theorem ratCast_natCast_equiv (n : ℕ) : ((n : ℚ) : IGame) ≈ n := by + simp [← Surreal.mk_eq_mk] + +theorem ratCast_intCast_equiv (n : ℤ) : ((n : ℚ) : IGame) ≈ n := by + simp [← Surreal.mk_eq_mk] + +theorem ratCast_add_equiv (m n : ℚ) : ((m + n : ℚ) : IGame) ≈ m + n := by + simp [← Surreal.mk_eq_mk] + +theorem ratCast_sub_equiv (m n : ℚ) : ((m - n : ℚ) : IGame) ≈ m - n := by + simp [← Surreal.mk_eq_mk] + +theorem ratCast_mul_equiv (m n : ℚ) : ((m * n : ℚ) : IGame) ≈ m * n := by + simp [← Surreal.mk_eq_mk] + +theorem ratCast_inv_equiv (m : ℚ) : ((m⁻¹ : ℚ) : IGame) ≈ m⁻¹ := by + simp [← Surreal.mk_eq_mk] + +theorem ratCast_div_equiv (m n : ℚ) : ((m / n : ℚ) : IGame) ≈ m / n := by + simp [← Surreal.mk_eq_mk] + +@[simp, norm_cast] +theorem zero_lt_ratCast {q : ℚ} : 0 < (q : IGame) ↔ 0 < q := by + simpa using ratCast_lt (m := 0) + +@[simp, norm_cast] +theorem ratCast_lt_zero {q : ℚ} : (q : IGame) < 0 ↔ q < 0 := by + simpa using ratCast_lt (n := 0) + +@[simp, norm_cast] +theorem zero_le_ratCast {q : ℚ} : 0 ≤ (q : IGame) ↔ 0 ≤ q := by + simpa using ratCast_le (m := 0) + +@[simp, norm_cast] +theorem ratCast_le_zero {q : ℚ} : (q : IGame) ≤ 0 ↔ q ≤ 0 := by + simpa using ratCast_le (n := 0) + +private theorem equiv_ratCast_of_mem_move_inv_natCast {n : ℕ} : + (∀ p, ∀ x ∈ moves.{u} p n⁻¹, ∃ q : ℚ, x ≈ q) := by + cases n with + | zero => simp + | succ n => + refine invRec (mod_cast n.succ_pos) ⟨0, by simp⟩ ?_ + rintro (_ | _) (_ | _) <;> try (· simp) + all_goals + dsimp + simp_rw [Nat.cast_add, Nat.cast_one, leftMoves_natCast_succ, forall_exists_index] + rintro _ hn rfl x hx q hq + use (1 + -q) / n + numeric + simp_all [invOption, ← Surreal.mk_eq_mk] + +private theorem equiv_ratCast_of_mem_move_ratCast {q : ℚ} : + (∀ x ∈ (q : IGame.{u})ᴸ, ∃ r : ℚ, x ≈ r) ∧ (∀ x ∈ (q : IGame.{u})ᴿ, ∃ r : ℚ, x ≈ r) := by + constructor + all_goals + rw [ratCast_def] + simp only [IGame.div_eq_mul_inv, forall_moves_mul, forall_moves_mul] + obtain ⟨m, n, hn, _⟩ := q + rintro (_ | _) + all_goals + · intro x hx y hy + first | + obtain ⟨k, _, rfl⟩ := eq_intCast_of_mem_leftMoves_intCast hx | + obtain ⟨k, _, rfl⟩ := eq_intCast_of_mem_rightMoves_intCast hx + obtain ⟨q, hq⟩ := equiv_ratCast_of_mem_move_inv_natCast _ _ hy + use k * (n : ℚ)⁻¹ + m * q - k * q + numeric + simp_all [mulOption, ← Surreal.mk_eq_mk] + +/-- Every left option of a rational number is equivalent to a smaller rational number. -/ +theorem equiv_ratCast_of_mem_leftMoves_ratCast {q : ℚ} {x : IGame} (hx : x ∈ qᴸ) : + ∃ r : ℚ, r < q ∧ x ≈ r := by + obtain ⟨r, hr⟩ := equiv_ratCast_of_mem_move_ratCast.1 x hx + refine ⟨r, ?_, hr⟩ + rw [← ratCast_lt] + grw [← hr] + simpa using Numeric.left_lt hx + +/-- Every right option of a rational number is equivalent to a larger rational number. -/ +theorem equiv_ratCast_of_mem_rightMoves_ratCast {q : ℚ} {x : IGame} (hx : x ∈ qᴿ) : + ∃ r : ℚ, q < r ∧ x ≈ r := by + obtain ⟨r, hr⟩ := equiv_ratCast_of_mem_move_ratCast.2 x hx + refine ⟨r, ?_, hr⟩ + rw [← ratCast_lt] + grw [← hr] + simpa using Numeric.lt_right hx + +@[simp] +theorem mk_half : Surreal.mk ½ = 2⁻¹ := by + rw [← mul_left_inj' two_ne_zero, mul_two, inv_mul_cancel₀ two_ne_zero] + exact Surreal.mk_eq half_add_half_equiv_one + +end IGame + +namespace ConwayGame + +@[simp, norm_cast] +theorem ratCast_le {m n : ℚ} : (m : ConwayGame) ≤ n ↔ m ≤ n := + IGame.ratCast_le + +@[simp, norm_cast] +theorem ratCast_lt {m n : ℚ} : (m : ConwayGame) < n ↔ m < n := + IGame.ratCast_lt + +theorem ratCast_strictMono : StrictMono ((↑) : ℚ → ConwayGame) := + fun _ _ h ↦ ratCast_lt.2 h + +@[simp, norm_cast] +theorem ratCast_inj {m n : ℚ} : (m : ConwayGame) = n ↔ m = n := + ratCast_strictMono.injective.eq_iff + +@[simp, norm_cast] +theorem ratCast_natCast (n : ℕ) : ((n : ℚ) : ConwayGame) = n := by + simpa using ConwayGame.mk_eq (IGame.ratCast_natCast_equiv n) + +@[simp, norm_cast] +theorem ratCast_intCast (n : ℤ) : ((n : ℚ) : ConwayGame) = n := by + simpa using ConwayGame.mk_eq (IGame.ratCast_intCast_equiv n) + +@[simp, norm_cast] +theorem ratCast_add (m n : ℚ) : ((m + n : ℚ) : ConwayGame) = m + n := + ConwayGame.mk_eq (IGame.ratCast_add_equiv m n) + +@[simp, norm_cast] +theorem ratCast_sub (m n : ℚ) : ((m - n : ℚ) : ConwayGame) = m - n := + ConwayGame.mk_eq (IGame.ratCast_sub_equiv m n) + +@[simp, norm_cast] +theorem zero_lt_ratCast {q : ℚ} : 0 < (q : ConwayGame) ↔ 0 < q := + IGame.zero_lt_ratCast + +@[simp, norm_cast] +theorem ratCast_lt_zero {q : ℚ} : (q : ConwayGame) < 0 ↔ q < 0 := + IGame.ratCast_lt_zero + +@[simp, norm_cast] +theorem zero_le_ratCast {q : ℚ} : 0 ≤ (q : ConwayGame) ↔ 0 ≤ q := + IGame.zero_le_ratCast + +@[simp, norm_cast] +theorem ratCast_le_zero {q : ℚ} : (q : ConwayGame) ≤ 0 ↔ q ≤ 0 := + IGame.ratCast_le_zero + +end ConwayGame diff --git a/LeanPool/ConwayRefinement/CombinatorialGames/Surreal/Dyadic.lean b/LeanPool/ConwayRefinement/CombinatorialGames/Surreal/Dyadic.lean new file mode 100644 index 0000000000..7e83fe02ed --- /dev/null +++ b/LeanPool/ConwayRefinement/CombinatorialGames/Surreal/Dyadic.lean @@ -0,0 +1,650 @@ +/- +Copyright (c) 2025 Violeta Hernández Palacios. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Violeta Hernández Palacios +-/ +module + +public import LeanPool.ConwayRefinement.CombinatorialGames.Game.Classes +public import LeanPool.ConwayRefinement.CombinatorialGames.Mathlib.Dyadic +public import LeanPool.ConwayRefinement.CombinatorialGames.Surreal.Division + +import Mathlib.Data.Finset.DenselyOrdered + +/-! +# Dyadic games + +A combinatorial game that is both `Short` and `Numeric` is called dyadic. We show that the dyadic +games are in correspondence with the `Dyadic` rationals, in the sense that there exists a map +`Dyadic.toIGame` such that: + +- `Dyadic.toIGame x` is always a dyadic game. +- For any dyadic game `y`, there exists `x` with `Dyadic.toIGame x ≈ y`. +- The game `Dyadic.toGame x` is equivalent to the `RatCast` of `x`. + +## Future projects + +Since dyadic rationals are easy to do computations with, there are some projects we could pursue in +the future: + +- Define the birthday of a dyadic number computably, prove that `x.birthday = x.toIGame.birthday`. +- Define the simplest dyadic number between two others computably, use that to define + `IGame.toDyadic`. +-/ + +universe u +open IGame + +@[expose] public section + +namespace Dyadic + +/-! ### Upper and lower dyadic fractions -/ + +/-- For a dyadic number `m / n`, returns `(m - 1) / n`. -/ +def lower (x : Dyadic) : Dyadic := + .mkRat (x.num - 1) x.den_mem_powers + +/-- For a dyadic number `m / n`, returns `(m + 1) / n`. -/ +def upper (x : Dyadic) : Dyadic := + .mkRat (x.num + 1) x.den_mem_powers + +theorem den_lower_lt {x : Dyadic} (h : x.den ≠ 1) : (lower x).den < x.den := by + rw [den, lower, coe_mkRat] + exact den_mkRat_lt ((odd_num h).sub_odd odd_one).two_dvd h + +theorem den_upper_lt {x : Dyadic} (h : x.den ≠ 1) : (upper x).den < x.den := by + rw [den, upper, coe_mkRat] + exact den_mkRat_lt ((odd_num h).add_odd odd_one).two_dvd h + +/-- An auxiliary tactic for inducting on the denominator of a `Dyadic`. -/ +macro (name := dyadicWf) "dyadic_wf" : tactic => + `(tactic| all_goals first | solve_by_elim + [Prod.Lex.left, Prod.Lex.right, den_lower_lt, den_upper_lt] | decreasing_tactic) + +@[simp] +theorem lower_neg (x : Dyadic) : lower (-x) = -upper x := by + unfold lower upper + ext + simp [Rat.neg_mkRat, ← sub_eq_neg_add] + +@[simp] +theorem upper_neg (x : Dyadic) : upper (-x) = -lower x := by + unfold lower upper + ext + simp [Rat.neg_mkRat, ← sub_eq_neg_add] + +theorem le_lower_of_lt {x y : Dyadic} (hd : x.den ≤ y.den) (h : x < y) : x ≤ y.lower := by + obtain ⟨m, rfl⟩ := eq_mkRat_of_den_le hd y.den_mem_powers + conv_rhs at h => rw [← y.mkRat_self] + rw [mkRat_lt_mkRat] at h + rwa [lower, mkRat_le_mkRat, Int.le_sub_one_iff] + +theorem upper_le_of_lt {x y : Dyadic} (hd : y.den ≤ x.den) (h : x < y) : x.upper ≤ y := by + have hd' : (-y).den ≤ (-x).den := by simpa using hd + simpa using le_lower_of_lt hd' (neg_lt_neg h) + +theorem lower_eq_of_den_eq_one {x : Dyadic} (h : x.den = 1) : lower x = x.num - 1 := by + simp [lower, h] + +theorem upper_eq_of_den_eq_one {x : Dyadic} (h : x.den = 1) : upper x = x.num + 1 := by + simp [upper, h] + +@[simp] +theorem lower_lt (x : Dyadic) : lower x < x := by + conv_rhs => rw [← x.mkRat_self] + rw [lower, mkRat_lt_mkRat] + exact sub_one_lt x.num + +@[simp] +theorem lt_upper (x : Dyadic) : x < upper x := by + simpa using lower_lt (-x) + +theorem lower_lt_upper (x : Dyadic) : lower x < upper x := + (lower_lt x).trans (lt_upper x) + +theorem coe_lower (x : Dyadic) : lower x = x - (x.den : ℚ)⁻¹ := by + simp [lower, Rat.mkRat_eq_div, sub_div, Rat.num_div_den] + +theorem coe_upper (x : Dyadic) : upper x = x + (x.den : ℚ)⁻¹ := by + simp [upper, Rat.mkRat_eq_div, add_div, Rat.num_div_den] + +theorem lower_add_le_of_den_le {x y : Dyadic} (h : x.den ≤ y.den) : + lower (x + y) ≤ x + lower y := by + rw [← Dyadic.coe_le_coe] + suffices (y.den : ℚ)⁻¹ ≤ ((x + y).den : ℚ)⁻¹ by simpa [coe_lower, Rat.add_assoc, sub_eq_add_neg] + rw [inv_le_inv₀ (mod_cast y.den_pos) (mod_cast den_pos _)] + exact_mod_cast den_add_le_den_right h + +theorem lower_add_le_of_den_ge {x y : Dyadic} (h : y.den ≤ x.den) : + lower (x + y) ≤ lower x + y := by + simpa [add_comm] using lower_add_le_of_den_le h + +theorem le_upper_add_of_den_le {x y : Dyadic} (h : x.den ≤ y.den) : + x + upper y ≤ upper (x + y) := by + simpa only [← neg_add, lower_neg, neg_le_neg_iff] using + @lower_add_le_of_den_le (-x) (-y) (by simpa using h) + +theorem le_upper_add_of_den_ge {x y : Dyadic} (h : y.den ≤ x.den) : + upper x + y ≤ upper (x + y) := by + simpa [add_comm] using le_upper_add_of_den_le h + +/-! ### Dyadic numbers to games -/ + +/-- Converts a dyadic rational into an `IGame`. This map is defined so that: + +* If `x : ℤ`, then `toIGame x = ↑x`. +* Otherwise, if `x = m / n` with `n` even, then `toIGame x = !{(m - 1) / n | (m + 1) / n}`. Note + that both options will have smaller denominators. -/ +@[coe] +noncomputable def toIGame (x : Dyadic) : IGame := + if _ : x.den = 1 then x.num else !{{toIGame (lower x)} | {toIGame (upper x)}} +termination_by x.den +decreasing_by dyadic_wf + +noncomputable instance : Coe Dyadic IGame := ⟨toIGame⟩ + +theorem toIGame_of_den_eq_one {x : Dyadic} (hx : x.den = 1) : (x : IGame) = x.num := by + rw [toIGame, dite_eq_left hx] + +@[simp] theorem toIGame_intCast (n : ℤ) : ((n : Dyadic) : IGame) = n := by + simpa using toIGame_of_den_eq_one (Dyadic.den_intCast n) +@[simp] theorem toIGame_natCast (n : ℕ) : ((n : Dyadic) : IGame) = n := toIGame_intCast n + +@[simp] theorem toIGame_zero : ((0 : Dyadic) : IGame) = 0 := toIGame_natCast 0 +@[simp] theorem toIGame_one : ((1 : Dyadic) : IGame) = 1 := by simpa using toIGame_natCast 1 + +theorem toIGame_of_den_ne_one {x : Dyadic} (hx : x.den ≠ 1) : + x = !{{(lower x : IGame)} | {(upper x : IGame)}} := + by rw [toIGame, dite_eq_right hx] + +@[simp] +theorem toIGame_half : half = ½ := by + rw [toIGame_of_den_ne_one (by decide)] + suffices uh : upper half = 1 by + rw [show lower half = 0 from rfl, uh]; ext p; cases p <;> simp + rw [← Dyadic.coe_inj, upper, Dyadic.coe_mkRat] + rfl + +@[simp] +theorem toIGame_neg (x : Dyadic) : (-x : Dyadic) = -(x : IGame) := by + unfold toIGame + rw [den_neg] + split_ifs with h + · simp + · simpa using ⟨toIGame_neg _, toIGame_neg _⟩ +termination_by x.den +decreasing_by dyadic_wf + +theorem eq_lower_of_mem_leftMoves_toIGame {x : Dyadic} {y : IGame} (h : y ∈ xᴸ) : + y = lower x := by + by_cases hx : x.den = 1 + · rw [toIGame_of_den_eq_one hx] at h + rw [lower_eq_of_den_eq_one hx, eq_sub_one_of_mem_leftMoves_intCast h, + ← Int.cast_one (R := Dyadic), ← Int.cast_sub, toIGame_intCast] + · simpa [toIGame_of_den_ne_one hx] using h + +theorem eq_upper_of_mem_rightMoves_toIGame {x : Dyadic} {y : IGame} (h : y ∈ xᴿ) : + y = upper x := by + have : -y ∈ (-x : Dyadic)ᴸ := by simpa + simpa using eq_lower_of_mem_leftMoves_toIGame this + +/-- A dyadic number `x` is always equivalent to `!{lower x | upper x}`, though this may not +necessarily be the canonical form. -/ +theorem toIGame_equiv_lower_upper (x : Dyadic) : + (x : IGame) ≈ !{{(lower x : IGame)} | {(upper x : IGame)}} := by + rw [toIGame] + split_ifs with h + · unfold lower upper + simp only [h, mkRat_one, toIGame_intCast] + apply Fits.equiv_of_forall_moves + · simp [Fits] + · intro m hm + obtain ⟨m, hm', rfl⟩ := eq_sub_one_of_mem_leftMoves_intCast hm + simp + · intro m hm + obtain ⟨m, hm', rfl⟩ := eq_add_one_of_mem_rightMoves_intCast hm + simp + · rfl + +instance _root_.IGame.Short.dyadic (x : Dyadic) : Short x := by + rw [toIGame] + split_ifs with h + · exact .intCast _ + · rw [short_def] + simpa using ⟨.dyadic _, .dyadic _⟩ +termination_by x.den +decreasing_by dyadic_wf + +private theorem numeric_lower (x : Dyadic) [hx : Numeric (x : IGame.{u})] : + Numeric (lower x : IGame.{u}) := by + by_cases h : x.den = 1 + · rw [lower_eq_of_den_eq_one h, ← Int.cast_one, ← Int.cast_sub, toIGame_intCast] + infer_instance + · apply hx.of_mem_moves (p := left) + simp [toIGame_of_den_ne_one h] + +private theorem numeric_upper (x : Dyadic) [hx : Numeric (x : IGame.{u})] : + Numeric (toIGame.{u} (upper x)) := by + have : Numeric (-x : Dyadic) := by simpa + simpa using numeric_lower (-x) + +private theorem lower_lt_aux (x : Dyadic) [hx : Numeric (x : IGame.{u})] : + (lower x : IGame.{u}) < x := by + by_cases h : x.den = 1 + · rw [lower_eq_of_den_eq_one h, ← Int.cast_one, ← Int.cast_sub, toIGame_intCast, + toIGame_of_den_eq_one h] + simp + · apply hx.left_lt + simp [toIGame_of_den_ne_one h] + +private theorem lt_upper_aux (x : Dyadic) [hx : Numeric (x : IGame.{u})] : + x < (upper x : IGame.{u}) := by + have : Numeric (-x : Dyadic) := by simpa + simpa using lower_lt_aux (-x) + +private theorem toIGame_lt_toIGame_aux {x y : Dyadic} + [Numeric (x : IGame.{u})] [Numeric (toIGame.{u} y)] (h : x < y) : (x : IGame.{u}) < y := by + by_cases H : x.den = 1 ∧ y.den = 1 + · rwa [toIGame_of_den_eq_one H.1, toIGame_of_den_eq_one H.2, intCast_lt, + ← Int.cast_lt (R := Dyadic), intCast_num_eq_self_of_den_eq_one H.1, + intCast_num_eq_self_of_den_eq_one H.2] + · obtain hd | hd := le_total x.den y.den + · have := numeric_lower y + have hy := lower_lt_aux y + by_cases hy' : y.den = 1 + · rw [hy', den_le_one_iff_eq_one] at hd + exact (H ⟨hd, hy'⟩).elim + · exact (le_of_le_of_lt_of_lt toIGame_lt_toIGame_aux (le_lower_of_lt hd h)).trans_lt hy + · have := numeric_upper x + have hx := lt_upper_aux x + by_cases hx' : x.den = 1 + · rw [hx', den_le_one_iff_eq_one] at hd + exact (H ⟨hx', hd⟩).elim + · exact hx.trans_le (le_of_le_of_lt_of_lt toIGame_lt_toIGame_aux (upper_le_of_lt hd h)) +termination_by (x.den, y.den) +decreasing_by dyadic_wf + +instance _root_.IGame.Numeric.dyadic (x : Dyadic) : Numeric x := by + by_cases h : x.den = 1 + · rw [toIGame_of_den_eq_one h] + infer_instance + · rw [numeric_def, toIGame_of_den_ne_one h] + have := IGame.Numeric.dyadic (lower x) + have := IGame.Numeric.dyadic (upper x) + have := toIGame_lt_toIGame_aux (lower_lt_upper x) + simp_all +termination_by x.den +decreasing_by dyadic_wf + +/-- `Dyadic.toIGame` as an `OrderEmbedding`. -/ +@[simps!] +noncomputable def toIGameEmbedding : Dyadic ↪o IGame := + .ofStrictMono toIGame fun _ _ ↦ by exact toIGame_lt_toIGame_aux + +@[simp, norm_cast] +theorem toIGame_le_toIGame {x y : Dyadic} : (x : IGame) ≤ y ↔ x ≤ y := + toIGameEmbedding.le_iff_le + +@[simp, norm_cast] +theorem toIGame_lt_toIGame {x y : Dyadic} : (x : IGame) < y ↔ x < y := + toIGameEmbedding.lt_iff_lt + +@[simp, norm_cast] +theorem toIGame_equiv_toIGame {x y : Dyadic} : (x : IGame) ≈ y ↔ x = y := by + simp [AntisymmRel, le_antisymm_iff] + +@[simp, norm_cast] +theorem toIGame_inj {x y : Dyadic} : (x : IGame) = y ↔ x = y := + toIGameEmbedding.inj + +theorem toIGame_add_equiv (x y : Dyadic) : ((x + y : Dyadic) : IGame.{u}) ≈ x + y := by + by_cases H : x.den = 1 ∧ y.den = 1 + · rw [← intCast_num_eq_self_of_den_eq_one H.1, ← intCast_num_eq_self_of_den_eq_one H.2] + simpa [← Int.cast_add] using intCast_add_equiv .. + apply Fits.equiv_of_forall_moves ?_ (fun z hz ↦ ?_) (fun z hz ↦ ?_) + · rw [Fits, forall_moves_add, forall_moves_add] + refine ⟨⟨?_, ?_⟩, ⟨?_, ?_⟩⟩ + all_goals + intro z hz + first + | obtain rfl := eq_lower_of_mem_leftMoves_toIGame hz + | obtain rfl := eq_upper_of_mem_rightMoves_toIGame hz + grw [← toIGame_add_equiv] + simp + · obtain rfl := eq_lower_of_mem_leftMoves_toIGame hz + obtain h | h := le_or_gt x.den y.den + · by_cases hy : y.den = 1; · simp_all + use x + lower y + have hy := toIGame_of_den_ne_one hy + have : (lower y : IGame) ∈ yᴸ := by rw [hy]; simp + rw [← (toIGame_add_equiv ..).le_congr_right, hy] + simpa using lower_add_le_of_den_le h + · use lower x + y + have hx := toIGame_of_den_ne_one (den_ne_one_of_den_lt h) + have : (lower x : IGame) ∈ xᴸ := by rw [hx]; simp + rw [← (toIGame_add_equiv ..).le_congr_right, hx] + simpa using lower_add_le_of_den_ge h.le + · obtain rfl := eq_upper_of_mem_rightMoves_toIGame hz + obtain h | h := le_or_gt x.den y.den + · by_cases hy : y.den = 1; · simp_all + use x + upper y + have hy := toIGame_of_den_ne_one hy + have : (upper y : IGame) ∈ yᴿ := by rw [hy]; simp + grw [← (toIGame_add_equiv ..).le_congr_left, hy] + simpa using le_upper_add_of_den_le h + · use upper x + y + have hx := toIGame_of_den_ne_one (den_ne_one_of_den_lt h) + have : (upper x : IGame) ∈ xᴿ := by rw [hx]; simp + rw [← (toIGame_add_equiv ..).le_congr_left, hx] + simpa using le_upper_add_of_den_ge h.le +termination_by ((x : IGame.{u}), (y : IGame.{u})) +decreasing_by igame_wf + +theorem toIGame_sub_equiv (x y : Dyadic) : ((x - y : Dyadic) : IGame) ≈ x - y := by + simpa [sub_eq_add_neg] using toIGame_add_equiv x (-y) + +theorem toIGame_equiv (x : Dyadic) : (x : IGame) ≈ (x : ℚ) := by + by_cases h : x.den = 1 + · rw [toIGame_of_den_eq_one h, ← (ratCast_intCast_equiv _).antisymmRel_congr_left, + Rat.coe_int_num_of_den_eq_one h] + · have := den_add_self_lt h + have := (toIGame_add_equiv x x).symm.trans (toIGame_equiv (x + x)) + simp_all [← Surreal.mk_eq_mk, ← two_mul] +termination_by x.den + +@[simp] +theorem _root_.ConwayGame.mk_dyadic (x : Dyadic) : ConwayGame.mk x = x := + ConwayGame.mk_eq x.toIGame_equiv + +@[simp] +theorem _root_.Surreal.mk_dyadic (x : Dyadic) : Surreal.mk x = x := by + simpa using Surreal.mk_eq x.toIGame_equiv + +theorem toIGame_mul_equiv (x y : Dyadic) : ((x * y : Dyadic) : IGame) ≈ x * y := by + simp [← Surreal.mk_eq_mk] + +/-! ### Simp lemmas -/ + +/-! #### ℚ -/ + +@[simp, norm_cast] +theorem toIGame_lt_ratCast {x : Dyadic} {y : ℚ} : (x : IGame) < y ↔ x < y := by + simp [(toIGame_equiv x).lt_congr_left] +@[simp, norm_cast] +theorem toIGame_le_ratCast {x : Dyadic} {y : ℚ} : (x : IGame) ≤ y ↔ x ≤ y := by + simp [(toIGame_equiv x).le_congr_left] + +@[simp, norm_cast] +theorem ratCast_lt_toIGame {x : ℚ} {y : Dyadic} : (x : IGame) < y ↔ x < y := by + simp [(toIGame_equiv y).lt_congr_right] +@[simp, norm_cast] +theorem ratCast_le_toIGame {x : ℚ} {y : Dyadic} : (x : IGame) ≤ y ↔ x ≤ y := by + simp [(toIGame_equiv y).le_congr_right] + +@[simp, norm_cast] +theorem toIGame_equiv_ratCast {x : Dyadic} {y : ℚ} : (x : IGame) ≈ y ↔ x = y := by + simp [AntisymmRel, le_antisymm_iff] +@[simp, norm_cast] +theorem ratCast_equiv_toIGame {x : ℚ} {y : Dyadic} : (x : IGame) ≈ y ↔ x = y := by + simp [AntisymmRel, le_antisymm_iff] + +/-! #### ℤ -/ + +@[simp, norm_cast] +theorem toIGame_lt_intCast {x : Dyadic} {y : ℤ} : (x : IGame) < y ↔ x < y := by + simp [← (ratCast_intCast_equiv y).lt_congr_right] +@[simp, norm_cast] +theorem toIGame_le_intCast {x : Dyadic} {y : ℤ} : (x : IGame) ≤ y ↔ x ≤ y := by + simp [← (ratCast_intCast_equiv y).le_congr_right] + +@[simp, norm_cast] +theorem intCast_lt_toIGame {x : ℤ} {y : Dyadic} : (x : IGame) < y ↔ x < y := by + simp [← (ratCast_intCast_equiv x).lt_congr_left] +@[simp, norm_cast] +theorem intCast_le_toIGame {x : ℤ} {y : Dyadic} : (x : IGame) ≤ y ↔ x ≤ y := by + simp [← (ratCast_intCast_equiv x).le_congr_left] + +@[simp, norm_cast] +theorem toIGame_equiv_intCast {x : Dyadic} {y : ℤ} : (x : IGame) ≈ y ↔ x = y := by + simp [AntisymmRel, le_antisymm_iff] +@[simp, norm_cast] +theorem intCast_equiv_toIGame {x : ℤ} {y : Dyadic} : (x : IGame) ≈ y ↔ x = y := by + simp [AntisymmRel, le_antisymm_iff] + +@[simp, norm_cast] +theorem toIGame_eq_intCast {x : Dyadic} {y : ℤ} : (x : IGame) = y ↔ x = y := + ⟨fun h ↦ toIGame_equiv_intCast.1 h.antisymmRel, by simp_all⟩ +@[simp, norm_cast] +theorem intCast_eq_toIGame {x : ℤ} {y : Dyadic} : (x : IGame) = y ↔ x = y := by + simp [eq_comm] + +/-! #### ℕ -/ + +@[simp, norm_cast] +theorem toIGame_lt_natCast {x : Dyadic} {y : ℕ} : (x : IGame) < y ↔ x < y := + toIGame_lt_intCast (y := y) +@[simp, norm_cast] +theorem toIGame_le_natCast {x : Dyadic} {y : ℕ} : (x : IGame) ≤ y ↔ x ≤ y := + toIGame_le_intCast (y := y) + +@[simp, norm_cast] +theorem natCast_lt_toIGame {x : ℕ} {y : Dyadic} : (x : IGame) < y ↔ x < y := + intCast_lt_toIGame (x := x) +@[simp, norm_cast] +theorem natCast_le_toIGame {x : ℕ} {y : Dyadic} : (x : IGame) ≤ y ↔ x ≤ y := + intCast_le_toIGame (x := x) + +@[simp, norm_cast] +theorem toIGame_equiv_natCast {x : Dyadic} {y : ℕ} : (x : IGame) ≈ y ↔ x = y := + toIGame_equiv_intCast (y := y) +@[simp, norm_cast] +theorem natCast_equiv_toIGame {x : ℕ} {y : Dyadic} : (x : IGame) ≈ y ↔ x = y := + intCast_equiv_toIGame (x := x) + +@[simp, norm_cast] +theorem toIGame_eq_natCast {x : Dyadic} {y : ℕ} : (x : IGame) = y ↔ x = y := + toIGame_eq_intCast (y := y) +@[simp, norm_cast] +theorem natCast_eq_toIGame {x : ℕ} {y : Dyadic} : (x : IGame) = y ↔ x = y := + intCast_eq_toIGame (x := x) + +/-! #### 0 -/ + +@[simp, norm_cast] +theorem toIGame_lt_zero {x : Dyadic} : (x : IGame) < 0 ↔ x < 0 := + toIGame_lt_natCast (y := 0) +@[simp, norm_cast] +theorem toIGame_le_zero {x : Dyadic} : (x : IGame) ≤ 0 ↔ x ≤ 0 := + toIGame_le_natCast (y := 0) + +@[simp, norm_cast] +theorem zero_lt_toIGame {x : Dyadic} : 0 < (x : IGame) ↔ 0 < x := + natCast_lt_toIGame (x := 0) +@[simp, norm_cast] +theorem zero_le_toIGame {x : Dyadic} : 0 ≤ (x : IGame) ↔ 0 ≤ x := + natCast_le_toIGame (x := 0) + +@[simp, norm_cast] +theorem toIGame_equiv_zero {x : Dyadic} : (x : IGame) ≈ 0 ↔ x = 0 := + toIGame_equiv_natCast (y := 0) +@[simp, norm_cast] +theorem zero_equiv_toIGame {x : Dyadic} : 0 ≈ (x : IGame) ↔ 0 = x := + natCast_equiv_toIGame (x := 0) + +@[simp, norm_cast] +theorem toIGame_eq_zero {x : Dyadic} : (x : IGame) = 0 ↔ x = 0 := + toIGame_eq_natCast (y := 0) +@[simp, norm_cast] +theorem zero_eq_toIGame {x : Dyadic} : 0 = (x : IGame) ↔ 0 = x := + natCast_eq_toIGame (x := 0) + +/-! #### 1 -/ + +@[simp, norm_cast] +theorem toIGame_lt_one {x : Dyadic} : (x : IGame) < 1 ↔ x < 1 := by + simpa using toIGame_lt_natCast (y := 1) +@[simp, norm_cast] +theorem toIGame_le_one {x : Dyadic} : (x : IGame) ≤ 1 ↔ x ≤ 1 := by + simpa using toIGame_le_natCast (y := 1) + +@[simp, norm_cast] +theorem one_lt_toIGame {x : Dyadic} : 1 < (x : IGame) ↔ 1 < x := by + simpa using natCast_lt_toIGame (x := 1) +@[simp, norm_cast] +theorem one_le_toIGame {x : Dyadic} : 1 ≤ (x : IGame) ↔ 1 ≤ x := by + simpa using natCast_le_toIGame (x := 1) + +@[simp, norm_cast] +theorem toIGame_equiv_one {x : Dyadic} : (x : IGame) ≈ 1 ↔ x = 1 := by + simpa using toIGame_equiv_natCast (y := 1) +@[simp, norm_cast] +theorem one_equiv_toIGame {x : Dyadic} : 1 ≈ (x : IGame) ↔ 1 = x := by + simpa using natCast_equiv_toIGame (x := 1) + +@[simp, norm_cast] +theorem toIGame_eq_one {x : Dyadic} : (x : IGame) = 1 ↔ x = 1 := by + simpa using toIGame_eq_natCast (y := 1) +@[simp, norm_cast] +theorem one_eq_toIGame {x : Dyadic} : 1 = (x : IGame) ↔ 1 = x := by + simpa using natCast_eq_toIGame (x := 1) + +end Dyadic + +/-! ### Dyadic games as numbers -/ + +namespace IGame + +private theorem equiv_dyadic (x : IGame) [Short x] [Numeric x] : ∃ y : Dyadic, x ≈ y.toIGame := by + have H₁ (y : xᴸ) : ∃ z : Dyadic, y.1 ≈ z.toIGame := by + have := Numeric.of_mem_moves y.2 + have := Short.of_mem_moves y.2 + exact IGame.equiv_dyadic _ + have H₂ (y : xᴿ) : ∃ z : Dyadic, y.1 ≈ z.toIGame := by + have := Numeric.of_mem_moves y.2 + have := Short.of_mem_moves y.2 + exact IGame.equiv_dyadic _ + choose f hf using H₁ + choose g hg using H₂ + obtain ⟨y, hy₁, hy₂⟩ := by + refine (Set.finite_range f).exists_between' (Set.finite_range g) (fun x hx y hy ↦ ?_) + obtain ⟨a, rfl⟩ := hx + obtain ⟨b, rfl⟩ := hy + rw [← Dyadic.toIGame_lt_toIGame] + grw [← hf, ← hg] + exact Numeric.left_lt_right a.2 b.2 + have : ∃ y, Fits (Dyadic.toIGame y) x := by + use y + constructor <;> intro z hz + · have := hy₁ _ (Set.mem_range_self ⟨z, hz⟩) + rw [← Dyadic.toIGame_lt_toIGame] at this + grw [← hf] at this + exact this.not_ge + · have := hy₂ _ (Set.mem_range_self ⟨z, hz⟩) + rw [← Dyadic.toIGame_lt_toIGame] at this + grw [← hg] at this + exact this.not_ge + obtain ⟨z, H⟩ := exists_minimalFor_of_wellFoundedLT _ (birthday ∘ Dyadic.toIGame) this + use z + refine (Fits.equiv_of_forall_not_fits H.1 fun p _ hz' hz ↦ ?_).symm + cases p + · obtain rfl := Dyadic.eq_lower_of_mem_leftMoves_toIGame hz' + have hz' := birthday_lt_of_mem_moves hz' + exact (H.2 hz hz'.le).not_gt hz' + · obtain rfl := Dyadic.eq_upper_of_mem_rightMoves_toIGame hz' + have hz' := birthday_lt_of_mem_moves hz' + exact (H.2 hz hz'.le).not_gt hz' +termination_by x +decreasing_by igame_wf + +/-- Any dyadic game (meaning a game that is `Short` and `Numeric`) is equivalent to a `Dyadic` +rational number. + +TODO: it should be possible to compute this value explicitly, given the finsets of `Dyadic` +rationals corresponding to the left and right moves. -/ +@[no_expose] +noncomputable def toDyadic (x : IGame) [Short x] [Numeric x] : Dyadic := + Classical.choose x.equiv_dyadic + +@[simp] +theorem equiv_toIGame_toDyadic (x : IGame) [Short x] [Numeric x] : x ≈ x.toDyadic := + Classical.choose_spec x.equiv_dyadic + +@[simp] +theorem toIGame_toDyadic_equiv (x : IGame) [Short x] [Numeric x] : (x.toDyadic : IGame) ≈ x := + (equiv_toIGame_toDyadic x).symm + +@[simp] +theorem _root_.ConwayGame.ratCast_toDyadic (x : IGame) [Short x] [Numeric x] : + x.toDyadic = ConwayGame.mk x := by + simpa using ConwayGame.mk_eq (toIGame_toDyadic_equiv x) + +@[simp] +theorem _root_.Surreal.ratCast_toDyadic (x : IGame) [Short x] [Numeric x] : + x.toDyadic = Surreal.mk x := by + simpa using Surreal.mk_eq (toIGame_toDyadic_equiv x) + +theorem equiv_toIGame_iff_toDyadic_eq {x : IGame} [Short x] [Numeric x] {y : Dyadic} : + x ≈ y ↔ x.toDyadic = y := by + constructor + · intro h + simpa using (equiv_toIGame_toDyadic x).symm.trans h + · rintro rfl + exact equiv_toIGame_toDyadic x + +theorem toIGame_equiv_iff_eq_toDyadic {x : IGame} [Short x] [Numeric x] {y : Dyadic} : + (y : IGame) ≈ x ↔ y = x.toDyadic := by + rw [antisymmRel_comm, eq_comm, equiv_toIGame_iff_toDyadic_eq] + +@[simp] +theorem toDyadic_toIGame (x : Dyadic) : toDyadic x = x := by + simp [← equiv_toIGame_iff_toDyadic_eq] + +@[simp] +theorem toDyadic_zero : toDyadic 0 = 0 := by + simp [← equiv_toIGame_iff_toDyadic_eq] + +@[simp] +theorem toDyadic_one : toDyadic 1 = 1 := by + simp [← equiv_toIGame_iff_toDyadic_eq] + +@[simp] +theorem toDyadic_half : toDyadic ½ = .half := by + simp [← equiv_toIGame_iff_toDyadic_eq] + +@[simp] +theorem toDyadic_natCast (n : ℕ) : toDyadic n = n := by + simp [← equiv_toIGame_iff_toDyadic_eq] + +@[simp] +theorem toDyadic_ofNat (n : ℕ) [n.AtLeastTwo] : toDyadic ofNat(n) = n := + toDyadic_natCast n + +@[simp] +theorem toDyadic_intCast (n : ℤ) : toDyadic n = n := by + simp [← equiv_toIGame_iff_toDyadic_eq] + +@[simp] +theorem toDyadic_neg (x : IGame) [Short x] [Numeric x] : toDyadic (-x) = -toDyadic x := by + simp [← equiv_toIGame_iff_toDyadic_eq] + +@[simp] +theorem toDyadic_add (x y : IGame) [Short x] [Numeric x] [Short y] [Numeric y] : + toDyadic (x + y) = toDyadic x + toDyadic y := by + rw [← equiv_toIGame_iff_toDyadic_eq, ← Surreal.mk_eq_mk] + simp + +@[simp] +theorem toDyadic_sub (x y : IGame) [Short x] [Numeric x] [Short y] [Numeric y] : + toDyadic (x - y) = toDyadic x - toDyadic y := by + rw [← equiv_toIGame_iff_toDyadic_eq, ← Surreal.mk_eq_mk] + simp + +@[simp] +theorem toDyadic_mul (x y : IGame) [Short x] [Numeric x] [Short y] [Numeric y] : + toDyadic (x * y) = toDyadic x * toDyadic y := by + rw [← equiv_toIGame_iff_toDyadic_eq, ← Surreal.mk_eq_mk] + simp + +end IGame +end diff --git a/LeanPool/ConwayRefinement/CombinatorialGames/Surreal/HahnSeries.lean b/LeanPool/ConwayRefinement/CombinatorialGames/Surreal/HahnSeries.lean new file mode 100644 index 0000000000..182e3b6f09 --- /dev/null +++ b/LeanPool/ConwayRefinement/CombinatorialGames/Surreal/HahnSeries.lean @@ -0,0 +1,11 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.CombinatorialGames.Surreal.HahnSeries.Basic + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/CombinatorialGames/Surreal/HahnSeries/Basic.lean b/LeanPool/ConwayRefinement/CombinatorialGames/Surreal/HahnSeries/Basic.lean new file mode 100644 index 0000000000..33754a9b04 --- /dev/null +++ b/LeanPool/ConwayRefinement/CombinatorialGames/Surreal/HahnSeries/Basic.lean @@ -0,0 +1,535 @@ +/- +Copyright (c) 2026 Violeta Hernández Palacios. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Violeta Hernández Palacios +-/ +module + +public import LeanPool.ConwayRefinement.CombinatorialGames.Surreal.Pow +public import Mathlib.Order.Shrink +public import Mathlib.RingTheory.HahnSeries.Lex + +import Mathlib.Algebra.Field.Subfield.Basic +import Mathlib.Algebra.Ring.Subring.Order +import Mathlib.RingTheory.HahnSeries.Cardinal + +/-! +# Surreal Hahn series + +Hahn series are a generalization of power series and Puiseux series. A Hahn series `R⟦Γ⟧` is defined +as a function `Γ → R` whose support is well-founded. This condition is sufficient to define addition +and multiplication as with polynomials, so that under suitable conditions, `R⟦Γ⟧` has the structure +of an ordered field. + +The aphorism goes that surreals are real Hahn series over themselves. However, there are a few +technicalities. Hahn series are conventionally defined so that the support has well-founded `<`, +whereas for surreals it's more natural to assume well-founded `>`. Moreover, the Hahn series that +correspond to surreals must have a `Small` support. Because of this, we often prefer to identify +these surreal Hahn series with ordinal-indexed sequences of surreal exponents and their +coefficients. + +This file provides the translation layer between Hahn series as they're implemented in Mathlib, and +the Hahn series relevant to surreal numbers, by defining the type `SurrealHahnSeries` for the +latter. +-/ + +universe u + +public noncomputable section + +/-! ### For Mathlib -/ + +attribute [aesop simp] Pi.single_apply + +theorem Set.IsWF.to_subtype {α : Type*} [LT α] {s : Set α} (h : IsWF s) : WellFoundedLT s := h + +/-- This is like `RelIso.cast` with better def-eqs. -/ +def RelIso.subrel {α : Type*} (r : α → α → Prop) {p q : α → Prop} (H : ∀ x, p x ↔ q x) : + Subrel r p ≃r Subrel r q where + map_rel_iff' := .rfl + __ := Equiv.subtypeEquiv (Equiv.refl _) H + +private def toLexRingEquiv {R : Type*} [Ring R] : R ≃+* Lex R where + toFun := toLex + invFun := ofLex + map_add' _ _ := rfl + map_mul' _ _ := rfl + +open Order Set + +/-! ### Basic defs and instances -/ + +/-- `SurrealHahnSeries` as a subfield. -/ +private def surrealHahnSeriesSubfield : Subfield (Lex <| HahnSeries Surrealᵒᵈ ℝ) := + have : Fact (_ < _) := ⟨Cardinal.aleph0_lt_univ.{u, u}⟩ + (HahnSeries.cardSuppLTSubfield Surrealᵒᵈ ℝ .univ).comap toLexRingEquiv.toRingHom + +/-- The type of `u`-small Hahn series over `Surrealᵒᵈ`, endowed with the lexicographic ordering. We +will show that this type is isomorphic as an ordered field to the surreals themselves. -/ +def SurrealHahnSeries : Type (u + 1) := + surrealHahnSeriesSubfield + +namespace SurrealHahnSeries + +@[no_expose] +instance : Field SurrealHahnSeries := + inferInstanceAs (Field surrealHahnSeriesSubfield) + +@[no_expose] +instance : LinearOrder SurrealHahnSeries := + inferInstanceAs (LinearOrder surrealHahnSeriesSubfield) + +instance : IsStrictOrderedRing SurrealHahnSeries := + inferInstanceAs (IsStrictOrderedRing surrealHahnSeriesSubfield) + +open Cardinal in +/-- A constructor for `SurrealHahnSeries` which hides various implementation details. -/ +def mk (f : Surreal.{u} → ℝ) (small : Small.{u} (Function.support f)) + (wf : (Function.support f).WellFoundedOn (· > ·)) : SurrealHahnSeries where + val := toLex ⟨f ∘ OrderDual.ofDual, IsWF.isPWO wf⟩ + property := by rwa [small_iff_lift_mk_lt_univ, lift_id, univ_umax.{u, u}] at small + +/-! #### `coeff` -/ + +/-- Returns the coefficient for `X ^ i`. -/ +def coeff (x : SurrealHahnSeries) (i : Surreal) : ℝ := + x.1.coeff <| OrderDual.toDual i + +@[simp, grind =] theorem coeff_mk (f small wf) : coeff (mk f small wf) = f := (rfl) +@[simp, grind =] theorem coeff_zero : coeff 0 = 0 := (rfl) + +@[simp, grind =] +theorem coeff_neg (x : SurrealHahnSeries) : (-x).coeff = -x.coeff := (rfl) + +@[simp, grind =] +theorem coeff_add (x y : SurrealHahnSeries) : (x + y).coeff = x.coeff + y.coeff := (rfl) + +@[simp, grind =] +theorem coeff_sub (x y : SurrealHahnSeries) : (x - y).coeff = x.coeff - y.coeff := (rfl) + +theorem coeff_add_apply (x y : SurrealHahnSeries) (i : Surreal) : + (x + y).coeff i = x.coeff i + y.coeff i := (rfl) + +theorem coeff_sub_apply (x y : SurrealHahnSeries) (i : Surreal) : + (x - y).coeff i = x.coeff i - y.coeff i := (rfl) + +@[ext] +theorem ext {x y : SurrealHahnSeries} (h : x.coeff = y.coeff) : x = y := + Subtype.ext <| HahnSeries.ext h + +/-! #### `support` -/ + +/-- The support of the Hahn series. -/ +@[expose] +def support (x : SurrealHahnSeries) : Set Surreal := + Function.support x.coeff + +@[simp] +theorem support_coeff (x : SurrealHahnSeries) : Function.support x.coeff = x.support := (rfl) + +@[simp] +theorem support_mk (f small wf) : support (mk f small wf) = Function.support f := (rfl) + +@[simp, grind =] +theorem mem_support_iff {x : SurrealHahnSeries} {i : Surreal} : i ∈ x.support ↔ x.coeff i ≠ 0 := + .rfl + +@[simp] +theorem support_eq_empty {x : SurrealHahnSeries} : support x = ∅ ↔ x = 0 := by + aesop (add simp [Set.eq_empty_iff_forall_notMem]) + +@[simp] +theorem support_zero : support 0 = ∅ := + support_eq_empty.2 rfl + +theorem support_add_subset {x y : SurrealHahnSeries} : (x + y).support ⊆ x.support ∪ y.support := + Function.support_add .. + +theorem wellFoundedOn_support (x : SurrealHahnSeries) : x.support.WellFoundedOn (· > ·) := + x.1.isWF_support + +instance (x : SurrealHahnSeries) : WellFoundedGT x.support := + x.1.isWF_support.to_subtype + +instance (x : SurrealHahnSeries) : + IsWellOrder x.support (Subrel (· > ·) (· ∈ x.support)) := + inferInstanceAs (IsWellOrder x.support (· > ·)) + +instance small_support (x : SurrealHahnSeries.{u}) : Small.{u} x.support := by + rw [Cardinal.small_iff_lift_mk_lt_univ, Cardinal.lift_id] + exact lt_of_lt_of_eq x.2 Cardinal.univ_umax.symm + +@[simp] +theorem mk_coeff (x : SurrealHahnSeries) : mk x.coeff x.small_support x.wellFoundedOn_support = x := + (rfl) + +theorem lt_def {x y : SurrealHahnSeries} : x < y ↔ toColex x.coeff < toColex y.coeff := .rfl +theorem le_def {x y : SurrealHahnSeries} : x ≤ y ↔ toColex x.coeff ≤ toColex y.coeff := .rfl + +/-! #### `single` -/ + +/-- The Hahn series with a single entry. -/ +def single (x : Surreal) (r : ℝ) : SurrealHahnSeries := + mk (Pi.single x r) (small_subset Pi.support_single_subset) + (WellFoundedOn.subset wellFoundedOn_singleton Pi.support_single_subset) + +@[aesop simp] +theorem coeff_single (x : Surreal) (r : ℝ) : (single x r).coeff = Pi.single x r := (rfl) + +@[simp, grind =] +theorem coeff_single_self (x : Surreal) (r : ℝ) : (single x r).coeff x = r := by + aesop + +@[grind =] +theorem coeff_single_of_ne {x y : Surreal} (h : x ≠ y) (r : ℝ) : (single x r).coeff y = 0 := by + aesop + +@[simp] +theorem single_zero (x : Surreal) : single x 0 = 0 := by + aesop + +theorem support_single_subset {x : Surreal} {r : ℝ} : support (single x r) ⊆ {x} := by + aesop + +/-! #### `trunc` -/ + +/-- Zeroes out any terms of the Hahn series less than or equal to `i`. -/ +def trunc (x : SurrealHahnSeries) (i : Surreal) : SurrealHahnSeries := + let g j := if i < j then x.coeff j else 0 + have hg : Function.support g ⊆ x.support := by simp [g] + mk _ (small_subset hg) (WellFoundedOn.subset x.wellFoundedOn_support hg) + +@[aesop simp] +theorem coeff_trunc (x : SurrealHahnSeries) (i : Surreal) : + (x.trunc i).coeff = fun j ↦ if i < j then x.coeff j else 0 := + (rfl) + +@[simp, grind =] +theorem support_trunc (x : SurrealHahnSeries) (i : Surreal) : + (x.trunc i).support = x.support ∩ Ioi i := by + aesop + +theorem support_trunc_subset (x : SurrealHahnSeries) (i : Surreal) : + (x.trunc i).support ⊆ x.support := by + simp + +theorem support_trunc_anti {x : SurrealHahnSeries} : Antitone fun i ↦ (trunc x i).support := + fun _ _ _ _ ↦ by aesop (add safe tactic (by order)) + +@[simp] +theorem coeff_trunc_of_lt {x : SurrealHahnSeries} {i j : Surreal} (h : i < j) : + (x.trunc i).coeff j = x.coeff j := + ite_eq_left h + +@[simp] +theorem coeff_trunc_of_le {x : SurrealHahnSeries} {i j : Surreal} (h : j ≤ i) : + (x.trunc i).coeff j = 0 := + ite_eq_right h.not_gt + +theorem coeff_trunc_eq_zero {x : SurrealHahnSeries} {i j : Surreal} (h : x.coeff i = 0) : + (x.trunc j).coeff i = 0 := by + aesop + +theorem coeff_trunc_of_mem {x : SurrealHahnSeries} {i j : Surreal} (h : j ∈ (x.trunc i).support) : + (x.trunc i).coeff j = x.coeff j := by + aesop + +@[simp] +theorem trunc_add (x y : SurrealHahnSeries) (i : Surreal) : + (x + y).trunc i = x.trunc i + y.trunc i := by + aesop + +@[simp] +theorem trunc_sub (x y : SurrealHahnSeries) (i : Surreal) : + (x - y).trunc i = x.trunc i - y.trunc i := by + aesop + +@[simp] +theorem trunc_single_of_le {i j : Surreal} {r : ℝ} (h : i ≤ j) : + (single i r).trunc j = 0 := by + aesop (add safe tactic (by order)) + +@[simp] +theorem trunc_single_of_lt {i j : Surreal} {r : ℝ} (h : j < i) : + (single i r).trunc j = single i r := by + aesop (add safe tactic (by order)) + +@[simp] +theorem trunc_trunc (x : SurrealHahnSeries) (i j : Surreal) : + (x.trunc i).trunc j = x.trunc (max i j) := by + ext k + obtain hi | hi := lt_or_ge i k + · obtain hj | hj := lt_or_ge j k + · rw [coeff_trunc_of_lt hj, coeff_trunc_of_lt hi, coeff_trunc_of_lt (max_lt hi hj)] + · rw [coeff_trunc_of_le hj, coeff_trunc_of_le (le_max_of_le_right hj)] + · rw [coeff_trunc_eq_zero (coeff_trunc_of_le hi), coeff_trunc_of_le (le_max_of_le_left hi)] + +theorem trunc_eq_self_iff {x : SurrealHahnSeries} {i : Surreal} : + x.trunc i = x ↔ ∀ j ∈ x.support, i < j := by + refine ⟨fun hx j hj ↦ ?_, fun _ ↦ ?_⟩ + · by_contra! hi + apply_fun (coeff · j) at hx + rw [coeff_trunc_of_le hi] at hx + exact hj hx.symm + · ext j + by_cases j ∈ x.support <;> aesop + +alias ⟨_, trunc_eq_self⟩ := trunc_eq_self_iff + +theorem trunc_eq_trunc {x : SurrealHahnSeries} {i j : Surreal} (h : i ≤ j) + (H : ∀ k, i < k → k ≤ j → x.coeff k = 0) : x.trunc i = x.trunc j := by + ext k + obtain hi | hi := le_or_gt k i + · rw [coeff_trunc_of_le hi, coeff_trunc_of_le (hi.trans h)] + · rw [coeff_trunc_of_lt hi] + obtain hj | hj := lt_or_ge j k + · rw [coeff_trunc_of_lt hj] + · rw [coeff_trunc_of_le hj] + exact H _ hi hj + +theorem trunc_add_single {x : SurrealHahnSeries} {i : Surreal} (hi : i ∈ lowerBounds x.support) : + x.trunc i + single i (x.coeff i) = x := by + ext j + have := @hi j + aesop (add simp [le_iff_lt_or_eq']) + +/-! ### Indexing the support by ordinals -/ + +open Ordinal + +local instance (x : SurrealHahnSeries.{u}) : IsWellOrder (Shrink.{u} x.support) (· > ·) := + (orderIsoShrink x.support).dual.symm.toRelIsoLT.toRelEmbedding.isWellOrder + +/-! #### `length` -/ + +/-- The length of a surreal Hahn series is the order type of its support. -/ +def length (x : SurrealHahnSeries.{u}) : Ordinal.{u} := + type (α := Shrink.{u} x.support) (· > ·) + +@[simp] +theorem type_support (x : SurrealHahnSeries.{u}) : + type (α := x.support) (· > ·) = lift.{u + 1} x.length := + ((orderIsoShrink x.support).dual.toRelIsoLT.trans + (RelIso.preimage Equiv.ulift _).symm).ordinalType_congr + +@[simp] +theorem length_eq_zero {x : SurrealHahnSeries} : length x = 0 ↔ x = 0 := by + rw [← lift_inj, ← type_support, lift_zero, type_eq_zero_iff_isEmpty] + aesop + +@[simp] +theorem length_zero : length 0 = 0 := + length_eq_zero.2 rfl + +theorem length_mono {x y : SurrealHahnSeries} (h : x.support ⊆ y.support) : + x.length ≤ y.length := by + rw [← lift_le, ← type_support, ← type_support] + exact (Subrel.inclusionEmbedding (· > ·) h).ordinal_type_le + +/-! #### `exp` -/ + +/-- Returns the `i`-th largest exponent with a non-zero coefficient. + +This is registered as a `RelIso` between `Iio x.length` and `x.support`, so that `x.exp.symm` can be +used to return the index of an element in the support. -/ +def exp (x : SurrealHahnSeries) : (· < · : Iio x.length → _ → _) ≃r (· > · : x.support → _ → _) := + (Ordinal.enum _).trans (orderIsoShrink x.support).dual.toRelIsoLT.symm + +@[simp] +theorem symm_exp_lt {x : SurrealHahnSeries} (i) : x.exp.symm i < x.length := + (x.exp.symm i).2 + +theorem exp_strictAnti {x : SurrealHahnSeries} : StrictAnti x.exp := + fun _ _ ↦ x.exp.map_rel_iff'.2 + +theorem exp_anti {x : SurrealHahnSeries} : Antitone x.exp := + x.exp_strictAnti.antitone + +@[simp] +theorem exp_lt_exp_iff {x : SurrealHahnSeries} {i j : Iio x.length} : + x.exp i < x.exp j ↔ j < i := + x.exp_strictAnti.lt_iff_gt + +@[simp] +theorem exp_le_exp_iff {x : SurrealHahnSeries} {i j : Iio x.length} : + x.exp i ≤ x.exp j ↔ j ≤ i := + x.exp_strictAnti.le_iff_ge + +@[simp] +theorem symm_exp_lt_symm_exp_iff {x : SurrealHahnSeries} {i j : x.support} : + x.exp.symm i < x.exp.symm j ↔ j < i := by + simp [← exp_lt_exp_iff] + +@[simp] +theorem symm_exp_le_symm_exp_iff {x : SurrealHahnSeries} {i j : x.support} : + x.exp.symm i ≤ x.exp.symm j ↔ j ≤ i := by + simp [← exp_le_exp_iff] + +theorem eq_exp_of_mem_support {x : SurrealHahnSeries} {i : Surreal} (h : i ∈ x.support) : + ∃ j, x.exp j = i := by + use x.exp.symm ⟨i, h⟩ + simp + +/-- This lemma is useful for rewriting. -/ +theorem exp_congr {x y : SurrealHahnSeries} (h : x = y) (i : Iio x.length) : + (x.exp i).1 = (y.exp ⟨i.1, h ▸ i.2⟩).1 := by + congr! + +@[simp] +theorem typein_support {x : SurrealHahnSeries.{u}} (i : x.support) : + typein (· > ·) i = lift.{u + 1} (x.exp.symm i) := by + unfold exp length + rw [typein, RelEmbedding.ofMonotone_coe, ← lift_id'.{u, u + 1} (type _)] + apply RelIso.ordinal_lift_type_eq + use Equiv.subtypeEquiv (equivShrink _) (fun a ↦ (orderIsoShrink _).toRelIsoLT.map_rel_iff.symm) + intro a b + exact (orderIsoShrink x.support).lt_iff_lt + +/-! #### `coeffIdx` -/ + +/-- Returns the coefficient which corresponds to the `i`-th largest exponent, or `0` if no such +coefficient exists. -/ +def coeffIdx (x : SurrealHahnSeries) (i : Ordinal) : ℝ := + if h : i < x.length then x.coeff (x.exp ⟨i, h⟩) else 0 + +theorem coeffIdx_of_lt {x : SurrealHahnSeries} {i : Ordinal} (h : i < x.length) : + x.coeffIdx i = x.coeff (x.exp ⟨i, h⟩) := by + rw [coeffIdx, dite_eq_left] + +theorem coeffIdx_of_le {x : SurrealHahnSeries} {i : Ordinal} (h : x.length ≤ i) : + x.coeffIdx i = 0 := by + rw [coeffIdx, dite_eq_right h.not_gt] + +@[simp] +theorem coeffIdx_zero : coeffIdx 0 = 0 := by + ext j; simp [coeffIdx] + +@[simp] +theorem coeff_exp (x : SurrealHahnSeries) (i) : x.coeff (x.exp i) = x.coeffIdx i := + (coeffIdx_of_lt _).symm + +@[simp] +theorem coeffIdx_symm_exp (x : SurrealHahnSeries) (i) : x.coeffIdx (x.exp.symm i) = x.coeff i := by + rw [coeffIdx_of_lt (x.exp.symm i).property] + exact congrArg (fun a : x.support ↦ x.coeff a) (x.exp.apply_symm_apply i) + +@[simp] +theorem coeffIdx_eq_zero_iff {x : SurrealHahnSeries} {i : Ordinal} : + x.coeffIdx i = 0 ↔ x.length ≤ i where + mp h := by + contrapose! h + rw [coeffIdx_of_lt h] + exact (x.exp _).2 + mpr := coeffIdx_of_le + +/-! #### `truncIdx` -/ + +/-- Truncates the series at the `i`-th largest exponent, or returns it unchanged if no such +coefficient exists. -/ +def truncIdx (x : SurrealHahnSeries) (i : Ordinal.{u}) : SurrealHahnSeries := + if h : i < x.length then x.trunc (x.exp ⟨i, h⟩) else x + +@[aesop simp] +theorem support_truncIdx (x : SurrealHahnSeries) (i : Ordinal) : + (truncIdx x i).support = + if hi : i < x.length then x.support ∩ Ioi (x.exp ⟨i, hi⟩) else x.support := by + unfold truncIdx + aesop + +theorem truncIdx_of_lt {x : SurrealHahnSeries} {i : Ordinal} (h : i < x.length) : + x.truncIdx i = x.trunc (x.exp ⟨i, h⟩) := by + rw [truncIdx, dite_eq_left] + +theorem truncIdx_of_le {x : SurrealHahnSeries} {i : Ordinal} (h : x.length ≤ i) : + x.truncIdx i = x := by + rw [truncIdx, dite_eq_right h.not_gt] + +@[simp] +theorem truncIdx_zero : truncIdx 0 = 0 := by + ext j; simp [truncIdx] + +@[simp, grind =] +theorem trunc_exp (x : SurrealHahnSeries) (i) : x.trunc (x.exp i) = x.truncIdx i := + (truncIdx_of_lt _).symm + +@[simp] +theorem truncIdx_symm_exp (x : SurrealHahnSeries) (i) : x.truncIdx (x.exp.symm i) = x.trunc i := by + rw [truncIdx_of_lt (x.exp.symm i).property] + exact congrArg (fun a : x.support ↦ x.trunc a) (x.exp.apply_symm_apply i) + +theorem support_truncIdx_ssubset {x : SurrealHahnSeries} {i : Ordinal} (h : i < x.length) : + support (truncIdx x i) ⊂ support x := by + rw [truncIdx_of_lt h] + refine ⟨support_trunc_subset .., ?_⟩ + rw [not_subset] + use x.exp ⟨i, h⟩ + aesop + +theorem support_truncIdx_subset (x : SurrealHahnSeries) (i : Ordinal) : + support (truncIdx x i) ⊆ support x := by + obtain h | h := lt_or_ge i x.length + · exact (support_truncIdx_ssubset h).le + · rw [truncIdx_of_le h] + +@[simp, grind =] +theorem length_truncIdx (x : SurrealHahnSeries) (i : Ordinal) : + (x.truncIdx i).length = min i x.length := by + obtain hi | hi := lt_or_ge i x.length + · rw [← lift_inj, ← type_support] + trans type (Subrel (· > · : x.support → _) (· > x.exp ⟨i, hi⟩)) + · apply ((RelIso.subrel (q := fun y ↦ ∃ h : y ∈ x.support, ⟨y, h⟩ ∈ Ioi (x.exp ⟨i, hi⟩)) + (· > ·) _).trans _).ordinalType_congr + · rw [truncIdx_of_lt hi, support_trunc] + aesop + · use (Equiv.subtypeSubtypeEquivSubtypeExists ..).symm + aesop + · simpa using hi.le + · rw [truncIdx_of_le hi, min_eq_right hi] + +theorem length_trunc_lt {x : SurrealHahnSeries} {i : Surreal} (h : i ∈ x.support) : + (x.trunc i).length < x.length := by + obtain ⟨⟨i, hi⟩, rfl⟩ := eq_exp_of_mem_support h + rwa [trunc_exp, length_truncIdx, min_eq_left hi.le] + +theorem truncIdx_ne {x : SurrealHahnSeries} {i : Ordinal} (h : i < x.length) : + x.truncIdx i ≠ x := by + apply_fun length + simpa + +theorem coeff_truncIdx_of_mem {x : SurrealHahnSeries} {i : Ordinal} {j k : Surreal} + (hjk : j ≤ k) (h : j ∈ (x.truncIdx i).support) : (x.truncIdx i).coeff k = x.coeff k := by + obtain hi | hi := lt_or_ge i x.length + · by_cases hk : k ∈ (x.truncIdx i).support + · rw [truncIdx_of_lt hi, coeff_trunc_of_mem] + rwa [trunc_exp] + · rw [mem_support_iff, not_ne_iff] at hk + rw [hk, eq_comm] + rwa [truncIdx_of_lt hi, coeff_trunc_of_lt] at hk + apply hjk.trans_lt' + aesop + · rw [truncIdx_of_le hi] + +theorem trunc_truncIdx_of_mem {x : SurrealHahnSeries} {i : Ordinal} {a b : Surreal} + (hab : a ≤ b) (ha : a ∈ (x.truncIdx i).support) : (x.truncIdx i).trunc b = x.trunc b := by + ext k + obtain h | h := lt_or_ge b k + · rw [coeff_trunc_of_lt h, coeff_trunc_of_lt h, coeff_truncIdx_of_mem (hab.trans h.le) ha] + · rw [coeff_trunc_of_le h, coeff_trunc_of_le h] + +/-! #### `term` -/ + +/-- Returns the `i`-th largest term of the sum, or `0` if it doesn't exist. -/ +def term (x : SurrealHahnSeries) (i : Ordinal) : Surreal := + if hi : i < x.length then x.coeffIdx i * ω^ (x.exp ⟨i, hi⟩).1 else 0 + +theorem term_of_lt {x : SurrealHahnSeries} {i : Ordinal} (hi : i < x.length) : + x.term i = x.coeffIdx i * ω^ (x.exp ⟨i, hi⟩).1 := + dite_eq_left hi + +@[simp] +theorem term_eq_zero {x : SurrealHahnSeries} {i : Ordinal} : x.term i = 0 ↔ x.length ≤ i := by + simp [term, ← not_le] + +alias ⟨_, term_of_le⟩ := term_eq_zero + +end SurrealHahnSeries diff --git a/LeanPool/ConwayRefinement/CombinatorialGames/Surreal/Leading.lean b/LeanPool/ConwayRefinement/CombinatorialGames/Surreal/Leading.lean new file mode 100644 index 0000000000..60cb51f27e --- /dev/null +++ b/LeanPool/ConwayRefinement/CombinatorialGames/Surreal/Leading.lean @@ -0,0 +1,310 @@ +/- +Copyright (c) 2025 Violeta Hernández Palacios. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Violeta Hernández Palacios +-/ +module + +public import LeanPool.ConwayRefinement.CombinatorialGames.Surreal.Pow +public import Mathlib.Algebra.Order.Ring.StandardPart + +/-! +# Leading term and coefficient + +We define `Surreal.leadingCoeff` and `Surreal.leadingTerm` for the leading coefficient/term of a +surreal's Hahn series. + +We don't yet prove this characterization; rather, these functions are a key ingredient in defining +the map from surreals into Hahn series. +-/ + +@[expose] public noncomputable section +namespace Surreal + +open ArchimedeanClass + +/-! ### Leading coefficient -/ + +/-- The leading coefficient of a surreal's Hahn series. -/ +def leadingCoeff (x : Surreal) : ℝ := + stdPart (x / ω^ x.wlog) + +@[simp] +theorem leadingCoeff_realCast (r : ℝ) : leadingCoeff r = r := by + rw [leadingCoeff, wlog_realCast, wpow_zero, div_one] + exact stdPart_map_real Real.toSurrealRingHom r + +@[simp] +theorem leadingCoeff_ratCast (q : ℚ) : leadingCoeff q = q := + mod_cast leadingCoeff_realCast q + +@[simp] +theorem leadingCoeff_intCast (n : ℤ) : leadingCoeff n = n := + mod_cast leadingCoeff_realCast n + +@[simp] +theorem leadingCoeff_natCast (n : ℕ) : leadingCoeff n = n := + mod_cast leadingCoeff_realCast n + +@[simp] +theorem leadingCoeff_zero : leadingCoeff 0 = 0 := + mod_cast leadingCoeff_natCast 0 + +@[simp] +theorem leadingCoeff_one : leadingCoeff 1 = 1 := + mod_cast leadingCoeff_natCast 1 + +@[simp] +theorem leadingCoeff_neg (x : Surreal) : leadingCoeff (-x) = -leadingCoeff x := by + simp [leadingCoeff, neg_div] + +@[simp] +theorem leadingCoeff_mul (x y : Surreal) : + leadingCoeff (x * y) = leadingCoeff x * leadingCoeff y := by + unfold leadingCoeff + by_cases hx : x = 0; · simp [hx] + by_cases hy : y = 0; · simp [hy] + rw [wlog_mul hx hy, wpow_add, ← stdPart_mul, mul_div_mul_comm] + all_goals + rw [archimedeanClassMk_div_wpow_wlog, + LinearOrderedAddCommGroupWithTop.sub_self_eq_zero_of_ne_top] + simpa + +@[simp] +theorem leadingCoeff_inv (x : Surreal) : leadingCoeff x⁻¹ = (leadingCoeff x)⁻¹ := by + obtain rfl | hx := eq_or_ne x 0; · simp + apply eq_inv_of_mul_eq_one_left + rw [← leadingCoeff_mul, inv_mul_cancel₀ hx, leadingCoeff_one] + +@[simp] +theorem leadingCoeff_div (x y : Surreal) : + leadingCoeff (x / y) = leadingCoeff x / leadingCoeff y := by + simp [div_eq_mul_inv] + +@[simp] +theorem leadingCoeff_wpow (x : Surreal) : leadingCoeff (ω^ x) = 1 := by + simp [leadingCoeff] + +@[simp] +theorem leadingCoeff_eq_zero {x : Surreal} : leadingCoeff x = 0 ↔ x = 0 := by + simp [leadingCoeff] + +private theorem leadingCoeff_nonneg {x : Surreal} (h : 0 ≤ x) : 0 ≤ leadingCoeff x := + stdPart_nonneg <| div_nonneg h (wpow_nonneg _) + +private theorem leadingCoeff_nonpos {x : Surreal} (h : x ≤ 0) : leadingCoeff x ≤ 0 := + stdPart_nonpos <| div_nonpos_of_nonpos_of_nonneg h (wpow_nonneg _) + +@[simp] +theorem leadingCoeff_nonneg_iff {x : Surreal} : 0 ≤ leadingCoeff x ↔ 0 ≤ x := by + refine ⟨?_, leadingCoeff_nonneg⟩ + contrapose! + refine fun h ↦ (leadingCoeff_nonpos h.le).lt_of_ne ?_ + rw [ne_eq, leadingCoeff_eq_zero] + exact h.ne + +@[simp] +theorem leadingCoeff_nonpos_iff {x : Surreal} : leadingCoeff x ≤ 0 ↔ x ≤ 0 := by + simpa using leadingCoeff_nonneg_iff (x := -x) + +@[simp] +theorem leadingCoeff_pos_iff {x : Surreal} : 0 < leadingCoeff x ↔ 0 < x := by + simp [← not_le] + +@[simp] +theorem leadingCoeff_neg_iff {x : Surreal} : leadingCoeff x < 0 ↔ x < 0 := by + simp [← not_le] + +theorem leadingCoeff_monotoneOn (x : Surreal) : MonotoneOn leadingCoeff (wlog ⁻¹' {x}) := by + rintro y rfl z (hw : wlog _ = _) h + obtain rfl | hy := eq_or_ne y 0; · simpa + obtain rfl | hz := eq_or_ne z 0; · simpa + · rw [leadingCoeff, leadingCoeff, hw] + apply stdPart_monotoneOn + · simp + · rw [← hw]; simp + · simpa [div_eq_mul_inv] + +private theorem stdPart_eq' {x y : Surreal} {r : ℝ} + (hL : ∀ s < r, s * ω^ y ≤ x) (hR : ∀ s > r, x ≤ s * ω^ y) : stdPart (x / ω^ y) = r := by + apply stdPart_eq Real.toSurrealRingHom <;> intro s hs + · rw [le_div_iff₀ (wpow_pos _)] + exact hL s hs + · rw [div_le_iff₀ (wpow_pos _)] + exact hR s hs + +theorem wlog_eq {x y : Surreal} {r : ℝ} (hr : r ≠ 0) + (hL : ∀ s < r, s * ω^ y ≤ x) (hR : ∀ s > r, x ≤ s * ω^ y) : x.wlog = y := by + apply wlog_eq_of_wpow_veq + rw [veq_def, eq_comm, ← LinearOrderedAddCommGroupWithTop.sub_eq_zero (by simp), + ← ArchimedeanClass.mk_div, ← stdPart_eq_zero.ne_left] + exact (stdPart_eq' hL hR).trans_ne hr + +theorem leadingCoeff_eq {x y : Surreal} {r : ℝ} (hr : r ≠ 0) + (hL : ∀ s < r, s * ω^ y ≤ x) (hR : ∀ s > r, x ≤ s * ω^ y) : leadingCoeff x = r := by + rw [leadingCoeff, wlog_eq hr hL hR, stdPart_eq' hL hR] + +theorem leadingCoeff_add_eq_left {x y : Surreal} (h : y <ᵥ x) : + leadingCoeff (x + y) = leadingCoeff x := by + rw [leadingCoeff, leadingCoeff, add_div, wlog_add_eq_left h, stdPart_add_eq_left] + rw [ArchimedeanClass.mk_div, LinearOrderedAddCommGroupWithTop.sub_pos] + left + rwa [veq_def.1 (wpow_wlog_veq h.ne_zero), ← vlt_def] + +theorem leadingCoeff_add_eq_right {x y : Surreal} (h : y <ᵥ x) : + leadingCoeff (y + x) = leadingCoeff x := by + rw [add_comm, leadingCoeff_add_eq_left h] + +theorem leadingCoeff_sub_eq_left {x y : Surreal} : y <ᵥ x → + leadingCoeff (x - y) = leadingCoeff x := by + simpa [sub_eq_add_neg] using @leadingCoeff_add_eq_left x (-y) + +theorem leadingCoeff_sub_eq_right {x y : Surreal} : y <ᵥ x → + leadingCoeff (y - x) = -leadingCoeff x := by + simpa [sub_eq_add_neg] using @leadingCoeff_add_eq_right (-x) y + +/-! ### Leading term -/ + +/-- The leading term of a surreal's Hahn series. -/ +def leadingTerm (x : Surreal) : Surreal := + x.leadingCoeff * ω^ x.wlog + +@[simp] +theorem leadingTerm_realCast (r : ℝ) : leadingTerm r = r := by + simp [leadingTerm] + +@[simp] +theorem leadingTerm_ratCast (q : ℚ) : leadingTerm q = q := + mod_cast leadingTerm_realCast q + +@[simp] +theorem leadingTerm_intCast (n : ℤ) : leadingTerm n = n := + mod_cast leadingTerm_realCast n + +@[simp] +theorem leadingTerm_natCast (n : ℕ) : leadingTerm n = n := + mod_cast leadingTerm_realCast n + +@[simp] +theorem leadingTerm_zero : leadingTerm 0 = 0 := + mod_cast leadingTerm_natCast 0 + +@[simp] +theorem leadingTerm_one : leadingTerm 1 = 1 := + mod_cast leadingTerm_natCast 1 + +@[simp] +theorem leadingTerm_neg (x : Surreal) : leadingTerm (-x) = -leadingTerm x := by + simp [leadingTerm] + +@[simp] +theorem leadingTerm_mul (x y : Surreal) : leadingTerm (x * y) = leadingTerm x * leadingTerm y := by + obtain rfl | hx := eq_or_ne x 0; · simp + obtain rfl | hy := eq_or_ne y 0; · simp + simp [leadingTerm, wlog_mul hx hy, mul_mul_mul_comm] + +@[simp] +theorem leadingTerm_inv (x : Surreal) : leadingTerm x⁻¹ = (leadingTerm x)⁻¹ := by + obtain rfl | hx := eq_or_ne x 0; · simp + apply eq_inv_of_mul_eq_one_left + rw [← leadingTerm_mul, inv_mul_cancel₀ hx, leadingTerm_one] + +@[simp] +theorem leadingTerm_div (x y : Surreal) : leadingTerm (x / y) = leadingTerm x / leadingTerm y := by + simp [div_eq_mul_inv] + +@[simp] +theorem leadingTerm_wpow (x : Surreal) : leadingTerm (ω^ x) = ω^ x := by + simp [leadingTerm] + +@[simp] +theorem leadingTerm_eq_zero {x : Surreal} : leadingTerm x = 0 ↔ x = 0 := by + simp [leadingTerm] + +@[simp] +theorem leadingTerm_nonneg_iff {x : Surreal} : 0 ≤ leadingTerm x ↔ 0 ≤ x := by + simp [leadingTerm] + +@[simp] +theorem leadingTerm_nonpos_iff {x : Surreal} : leadingTerm x ≤ 0 ↔ x ≤ 0 := by + simp [leadingTerm, mul_nonpos_iff] + +@[simp] +theorem leadingTerm_pos_iff {x : Surreal} : 0 < leadingTerm x ↔ 0 < x := by + simp [← not_le] + +@[simp] +theorem leadingTerm_neg_iff {x : Surreal} : leadingTerm x < 0 ↔ x < 0 := by + simp [← not_le] + +theorem mk_lt_mk_sub_leadingTerm {x : Surreal} (hx : x ≠ 0) : + ArchimedeanClass.mk x < .mk (x - x.leadingTerm) := by + rw [← LinearOrderedAddCommGroupWithTop.sub_lt_sub_iff_left_of_ne_top + (a := .mk <| ω^ x.wlog) (by simp)] + simp_rw [← ArchimedeanClass.mk_div, sub_div, mk_div_wpow_wlog_of_ne_zero hx] + convert mk_sub_stdPart_pos Real.toSurrealRingHom _ + · simp [leadingTerm, leadingCoeff] + · rw [mk_div_wpow_wlog_of_ne_zero hx] + +@[simp] +theorem mk_leadingTerm (x : Surreal) : ArchimedeanClass.mk x.leadingTerm = .mk x := by + obtain rfl | hx := eq_or_ne x 0; · simp + simpa using mk_sub_eq_mk_left (mk_lt_mk_sub_leadingTerm hx) + +theorem leadingTerm_veq (x : Surreal) : x.leadingTerm =ᵥ x := + veq_def.2 (mk_leadingTerm x) + +@[simp] +theorem wlog_leadingTerm (x : Surreal) : x.leadingTerm.wlog = x.wlog := + wlog_congr x.leadingTerm_veq + +@[simp] +theorem leadingCoeff_leadingTerm (x : Surreal) : x.leadingTerm.leadingCoeff = x.leadingCoeff := by + simp [leadingTerm] + +@[simp] +theorem leadingTerm_leadingTerm (x : Surreal) : x.leadingTerm.leadingTerm = x.leadingTerm := by + apply (leadingTerm_mul ..).trans + simp [leadingTerm] + +private theorem leadingTerm_mono' {x y : Surreal} (hx : 0 ≤ x) (h : x ≤ y) : + x.leadingTerm ≤ y.leadingTerm := by + have hy := hx.trans h + obtain hxy | hxy := (mk_antitoneOn hx hy h).eq_or_lt + · have hxy' := wlog_congr (veq_def.2 hxy) + unfold leadingTerm + rw [hxy', mul_le_mul_iff_left₀ (wpow_pos _), Real.toSurreal_le_iff] + exact leadingCoeff_monotoneOn _ rfl hxy' h + · apply (lt_of_mk_lt_mk_of_nonneg ..).le <;> simpa + +theorem leadingTerm_mono : Monotone leadingTerm := by + intro x y h + obtain hx | hx := le_total 0 x + · exact leadingTerm_mono' hx h + · obtain hy | hy := le_total 0 y + · exact (leadingTerm_nonpos_iff.2 hx).trans (leadingTerm_nonneg_iff.2 hy) + · rw [← neg_le_neg_iff, ← leadingTerm_neg, ← leadingTerm_neg] + apply leadingTerm_mono' <;> simpa + +theorem leadingTerm_eq {x y : Surreal} {r : ℝ} (hr : r ≠ 0) + (hL : ∀ s < r, s * ω^ y ≤ x) (hR : ∀ s > r, x ≤ s * ω^ y) : leadingTerm x = r * ω^ y := by + rw [leadingTerm, leadingCoeff_eq hr hL hR, wlog_eq hr hL hR] + +theorem leadingTerm_add_eq_left {x y : Surreal} (h : y <ᵥ x) : + leadingTerm (x + y) = leadingTerm x := by + rw [leadingTerm, leadingTerm, leadingCoeff_add_eq_left h, wlog_add_eq_left h] + +theorem leadingTerm_add_eq_right {x y : Surreal} (h : y <ᵥ x) : + leadingTerm (y + x) = leadingTerm x := by + rw [add_comm, leadingTerm_add_eq_left h] + +theorem leadingTerm_sub_eq_left {x y : Surreal} : y <ᵥ x → + leadingTerm (x - y) = leadingTerm x := by + simpa [sub_eq_add_neg] using @leadingTerm_add_eq_left x (-y) + +theorem leadingTerm_sub_eq_right {x y : Surreal} : y <ᵥ x → + leadingTerm (y - x) = -leadingTerm x := by + simpa [sub_eq_add_neg] using @leadingTerm_add_eq_right (-x) y + +end Surreal +end diff --git a/LeanPool/ConwayRefinement/CombinatorialGames/Surreal/Multiplication.lean b/LeanPool/ConwayRefinement/CombinatorialGames/Surreal/Multiplication.lean new file mode 100644 index 0000000000..1dde5da147 --- /dev/null +++ b/LeanPool/ConwayRefinement/CombinatorialGames/Surreal/Multiplication.lean @@ -0,0 +1,652 @@ +/- +Copyright (c) 2024 Theodore Hwa. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Mario Carneiro, Kim Morrison, Violeta Hernández Palacios, Junyan Xu, Theodore Hwa +-/ +module + +public import LeanPool.ConwayRefinement.CombinatorialGames.Surreal.Basic + +import Mathlib.Logic.Hydra +import Mathlib.Tactic.Abel + +/-! +# Surreal multiplication + +In this file, we show that multiplication of surreal numbers is well-defined, and thus the surreal +numbers form a linear ordered commutative ring. This is Theorem 8 in [Conway2001], or Theorem 3.8 in +[SchleicherStoll]. + +An inductive argument proves the following three main theorems: + +* P1: being numeric is closed under multiplication, +* P2: multiplying a numeric pregame by equivalent numeric pregames results in equivalent pregames, +* P3: the product of two positive numeric pregames is positive (`mul_pos`). + +P1 allows us to define multiplication as an operation on numeric pregames, P2 says that this is +well-defined as an operation on the quotient by `IGame.Equiv`, namely the surreal numbers, and P3 is +an axiom that needs to be satisfied for the surreals to be a `OrderedRing`. + +We follow the proof in [SchleicherStoll], except that we use the well-foundedness of the hydra +relation `CutExpand` on `Multiset IGame` instead of the argument based on a depth function in the +paper. As in said argument, P3 is proven by proxy of an auxiliary P4, which states that for +`x₁ < x₂` and `y`, then `x₁ * y + x₂ * a < x₁ * a + x₂ * y` when `a ∈ yᴸ`, and +`x₁ * b + x₂ * y < x₁ * y + x₂ * b` when `b ∈ yᴿ`. + +## Reducing casework + +This argument is very casework heavy in a way that's difficult to automate. For instance, in P1, we +have to prove four different inequalities of the form +`a ∈ (x * y)ᴸ → b ∈ (x * y)ᴿ → a < b`, and depending on what form the options of +`x * y` take, we have to apply different instantiations of the inductive hypothesis. + +To greatly simplify things, we work uniquely in terms of left options, which we achieve by rewriting +`a ∈ xᴿ` as `-a ∈ (-x)ᴸ`. We then show that our distinct lemmas and inductive +hypotheses are invariant under the appropriate sign changes. In the P1 example, this makes it so +that one case (`mulOption_lt_of_lt`) is enough to conclude the others (`mulOption_lt`), and the same +goes for the other parts of the proof. + +Note also that we express all inequalities in terms of `ConwayGame` instead of `IGame`; this +allows us to +make use of `abel` and all of the theorems on `OrderedAddCommGroup`. +-/ + +universe u + +open ConwayGame IGame Relation WellFounded + +/-- A characterization of left moves of `x * y` in terms only of left moves. -/ +private lemma forall_leftMoves_mul' {P : IGame → Prop} {x y : IGame} : + (∀ a ∈ (x * y)ᴸ, P a) ↔ + (∀ a ∈ xᴸ, ∀ b ∈ yᴸ, P (mulOption x y a b)) ∧ + (∀ a ∈ (-x)ᴸ, ∀ b ∈ (-y)ᴸ, P (mulOption (-x) (-y) a b)) := by + rw [forall_moves_mul] + simp [mulOption_neg] + +/-- A characterization of right moves of `x * y` in terms only of left moves. -/ +private lemma forall_rightMoves_mul' {P : IGame → Prop} {x y : IGame} : + (∀ a ∈ (x * y)ᴿ, P a) ↔ + (∀ a ∈ xᴸ, ∀ b ∈ (-y)ᴸ, P (-mulOption x (-y) a b)) ∧ + (∀ a ∈ (-x)ᴸ, ∀ b ∈ yᴸ, P (-mulOption (-x) y a b)) := by + rw [forall_moves_mul] + simp [mulOption_neg_right, mulOption_neg_left] + +/-! ### Predicates P1 – P4 -/ + +/-- `P1 x y a b c d` means that `mulOption x y a b < mulOption x y c d`. This is the general form +of the statements needed to prove that `x * y` is numeric. -/ +private def P1 (x y a b c d : IGame) := + ConwayGame.mk (mulOption x y a b) < ConwayGame.mk (mulOption x y c d) + +/-- `P2 x₁ x₂ y` states that if `x₁ ≈ x₂`, then `x₁ * y ≈ x₂ * y`. The RHS is stated in terms of +`ConwayGame.mk` for rewriting convenience. -/ +private def P2 (x₁ x₂ y : IGame) := x₁ ≈ x₂ → ConwayGame.mk (x₁ * y) = ConwayGame.mk (x₂ * y) + +/-- `P3 x₁ x₂ y₁ y₂` states that `x₁ * y₂ + x₂ * y₁ < x₁ * y₁ + x₂ * y₂`. Using distributivity, this +is equivalent to `(x₁ - x₂) * (y₁ - y₂) > 0`. -/ +private def P3 (x₁ x₂ y₁ y₂ : IGame) := + ConwayGame.mk (x₁ * y₂) + ConwayGame.mk (x₂ * y₁) < + ConwayGame.mk (x₁ * y₁) + ConwayGame.mk (x₂ * y₂) + +/-- `P4 x₁ x₂ y` states that if `x₁ < x₂`, then `P3 x₁ x₂ a y` when `a ∈ yᴸ`, and +`P3 x₁ x₂ b y` when `b ∈ yᴿ`. + +Note that we instead write this second part as `P3 x₁ x₂ b (-y)` when `b ∈ (-y)ᴸ`. See the +module docstring for an explanation. -/ +private def P4 (x₁ x₂ y : IGame) := + x₁ < x₂ → (∀ a ∈ yᴸ, P3 x₁ x₂ a y) ∧ (∀ b ∈ (-y)ᴸ, P3 x₁ x₂ b (-y)) + +/-- The conjunction of `P2` and `P4`. Both statements have the same amount of arguments and satisfy +similar symmetry properties, so we can slightly simplify the argument by merging them. -/ +private def P24 (x₁ x₂ y : IGame) : Prop := P2 x₁ x₂ y ∧ P4 x₁ x₂ y + +variable {x x₁ x₂ x₃ x' y y₁ y₂ y₃ y' a b c d : IGame.{u}} + +/-! #### Symmetry properties of P1 – P4 -/ + +private lemma P3_comm : P3 x₁ x₂ y₁ y₂ ↔ P3 y₁ y₂ x₁ x₂ := by + simp [P3, add_comm, mul_comm] + +private lemma P3.trans (h₁ : P3 x₁ x₂ y₁ y₂) (h₂ : P3 x₂ x₃ y₁ y₂) : P3 x₁ x₃ y₁ y₂ := by + rw [P3, ← add_lt_add_iff_left (ConwayGame.mk (x₂ * y₁) + ConwayGame.mk (x₂ * y₂))] + convert add_lt_add h₁ h₂ using 1 <;> abel + +private lemma P3_neg : P3 (-x₂) (-x₁) y₁ y₂ ↔ P3 x₁ x₂ y₁ y₂ := by + simp_rw [P3, neg_mul, ConwayGame.mk_neg] + rw [← _root_.neg_lt_neg_iff] + abel_nf + +private lemma P2_neg_left : P2 (-x₂) (-x₁) y ↔ P2 x₁ x₂ y := by + simp [P2, AntisymmRel, eq_comm] + +private lemma P2_neg_right : P2 x₁ x₂ (-y) ↔ P2 x₁ x₂ y := by + simp [P2] + +private lemma P4_neg_left : P4 (-x₂) (-x₁) y ↔P4 x₁ x₂ y := by + simp_rw [P4, IGame.neg_lt_neg_iff, P3_neg] + +private lemma P4_neg_right : P4 x₁ x₂ (-y) ↔ P4 x₁ x₂ y := by + rw [P4, P4, neg_neg, and_comm] + +private lemma P24_neg_left : P24 (-x₂) (-x₁) y ↔ P24 x₁ x₂ y := by + rw [P24, P24, P2_neg_left, P4_neg_left] +private lemma P24_neg_right : P24 x₁ x₂ (-y) ↔ P24 x₁ x₂ y := by + rw [P24, P24, P2_neg_right, P4_neg_right] + +/-! ### Inductive setup -/ + +/-- The type of lists of arguments for `P1`, `P2`, and `P4`. -/ +private inductive Args : Type (u + 1) + | P1 (x y : IGame.{u}) : Args + | P24 (x₁ x₂ y : IGame.{u}) : Args + +/-- The multiset associated to a list of arguments. -/ +private def Args.toMultiset : Args → Multiset IGame + | (Args.P1 x y) => {x, y} + | (Args.P24 x₁ x₂ y) => {x₁, x₂, y} + +@[simp] private lemma Args.toMultiset_P1 {x y} : (Args.P1 x y).toMultiset = {x, y} := rfl +@[simp] private lemma Args.toMultiset_P24 {x₁ x₂ y} : (Args.P24 x₁ x₂ y).toMultiset = {x₁, x₂, y} := + rfl + +/-- A list of arguments is numeric if all the arguments are. -/ +private def Args.Numeric (a : Args) := ∀ x ∈ a.toMultiset, x.Numeric + +private lemma Args.numeric_P1 {x y} : (Args.P1 x y).Numeric ↔ x.Numeric ∧ y.Numeric := by + simp [Args.Numeric, Args.toMultiset] + +private lemma Args.numeric_P24 {x₁ x₂ y} : + (Args.P24 x₁ x₂ y).Numeric ↔ x₁.Numeric ∧ x₂.Numeric ∧ y.Numeric := by + simp [Args.Numeric, Args.toMultiset] + +/-- The well-founded relation specifying when a list of game arguments is considered simpler than +another: `ArgsRel a₁ a₂` is true if `a₁`, considered as a multiset, can be obtained from `a₂` by +repeatedly removing a game from `a₂` and adding back one or two options of the game. + +See also `WellFounded.CutExpand`. -/ +private def ArgsRel := + InvImage (TransGen <| CutExpand fun x y => ∃ p, x ∈ y.moves p) Args.toMultiset + +/-- `ArgsRel` is well-founded. -/ +private lemma argsRel_wf : WellFounded ArgsRel := + InvImage.wf _ (Subrelation.wf (fun h => h.elim fun _ => Subposition.of_mem_moves) + subposition_wf).cutExpand.transGen +instance : WellFounded ArgsRel := argsRel_wf + +/-- The property that all arguments are numeric is leftward-closed under `ArgsRel`. -/ +private lemma ArgsRel.numeric_closed {a' a} : ArgsRel a' a → a.Numeric → a'.Numeric := + TransGen.closed' <| @cutExpand_closed _ _ + ⟨fun _ h => (h.elim fun _ => Subposition.of_mem_moves).irrefl⟩ _ fun h h' ↦ + h'.subposition (h.elim fun _ => Subposition.of_mem_moves) + +/-- The statement that we will show by induction for all `Numeric` args, using the well-founded +relation `ArgsRel`. + +The inductive hypothesis in the proof will be `∀ a', ArgsRel a' a → P124 a`. -/ +private def P124 : Args → Prop + | (Args.P1 x y) => Numeric (x * y) + | (Args.P24 x₁ x₂ y) => P24 x₁ x₂ y + +/-! ### P1 follows from the inductive hypothesis -/ + +private lemma numeric_move_mul_of_IH {p : Player} (IH : ∀ a, ArgsRel a (Args.P1 x y) → P124 a) + (h : x' ∈ x.moves p) : (x' * y).Numeric := + IH (Args.P1 x' y) (TransGen.single <| cutExpand_pair_left ⟨p, h⟩) + +private lemma numeric_mul_move_of_IH {p : Player} (IH : ∀ a, ArgsRel a (Args.P1 x y) → P124 a) + (h : y' ∈ y.moves p) : (x * y').Numeric := + IH (Args.P1 x y') (TransGen.single <| cutExpand_pair_right ⟨p, h⟩) + +private lemma numeric_move_mul_move_of_IH {p q : Player} + (IH : ∀ a, ArgsRel a (Args.P1 x y) → P124 a) + (hx : x' ∈ x.moves p) (hy : y' ∈ y.moves q) : (x' * y').Numeric := + IH (Args.P1 x' y') + ((TransGen.single (cutExpand_pair_right ⟨q, hy⟩)).tail (cutExpand_pair_left ⟨p, hx⟩)) + +/-- A specialization of the inductive hypothesis used to prove `P1`. -/ +private def IH1 (x y : IGame) : Prop := + ∀ ⦃p q x₁ x₂ y'⦄, x₁ ∈ x.moves p → x₂ ∈ x.moves q → (y' = y ∨ ∃ u, y' ∈ y.moves u) → P24 x₁ x₂ y' + +/-- `IH1 x y` follows from the inductive hypothesis for `P1 x y`. -/ +private lemma IH1_of_IH (IH : ∀ a, ArgsRel a (Args.P1 x y) → P124 a) : IH1 x y := by + rintro p q x₁ x₂ y' h₁ h₂ (rfl | hy) <;> apply IH (.P24 ..) + on_goal 2 => refine .tail ?_ (cutExpand_pair_right hy) + all_goals exact .single (cutExpand_double_left ⟨p, h₁⟩ ⟨q, h₂⟩) + +/-- `IH1 y x` follows from the inductive hypothesis for `P1 x y`. -/ +private lemma IH1_swap_of_IH (IH : ∀ a, ArgsRel a (Args.P1 x y) → P124 a) : IH1 y x := + IH1_of_IH <| by + simpa [-Multiset.insert_eq_cons, ArgsRel, InvImage, Multiset.pair_comm] using IH + +private lemma IH1_neg_left : IH1 x y → IH1 (-x) y := by + intro h p q x₁ x₂ y' h₁ h₂ hy + rw [moves_neg] at h₁ h₂ + exact P24_neg_left.1 (h h₂ h₁ hy) + +private lemma IH1_neg_right : IH1 x y → IH1 x (-y) := by + intro h p q x₁ x₂ y' h₁ h₂ hy + rw [← P24_neg_right] + apply h h₁ h₂ + simpa [neg_eq_iff_eq_neg, or_comm] using hy + +private lemma P1_of_equiv (he : x₁ ≈ x₃) (h₁ : P2 x₁ x₃ y₁) (h₃ : P2 x₁ x₃ y₃) + (h3 : P3 x₁ x₂ y₂ y₃) : + P1 x₂ y₁ x₁ y₂ x₃ y₃ := by + rw [P1, mk_mulOption, mk_mulOption, ← h₁ he, ← h₃ he, sub_lt_sub_iff] + convert add_lt_add_left h3 (.mk (x₁ * y₁)) using 1 <;> abel + +private lemma P1_of_P3 (h₁ : P3 x₃ x₂ y₂ y₃) (h₂ : P3 x₁ x₃ y₂ y₁) : P1 x₂ y₁ x₁ y₂ x₃ y₃ := by + rw [P1, mk_mulOption, mk_mulOption, sub_lt_sub_iff, ← add_lt_add_iff_left (.mk (x₃ * y₂))] + convert add_lt_add h₁ h₂ using 1 <;> abel + +private lemma P3_of_IH1 [Numeric y] (ihyx : IH1 y x) + (ha : a ∈ xᴸ) (hb : b ∈ yᴸ) (hd : d ∈ (-y)ᴸ) : P3 a x b (-d) := by + rw [P3_comm] + rw [moves_neg] at hd + refine ((ihyx hb hd (.inl rfl)).2 ?_).1 a ha + exact Numeric.left_lt_right hb hd + +private lemma P24_of_IH1 (ihxy : IH1 x y) (ha : a ∈ xᴸ) (hb : b ∈ xᴸ) : P24 a b y := + ihxy ha hb (Or.inl rfl) + +private lemma mulOption_lt_iff_P1 : + ConwayGame.mk (mulOption x y a b) < -ConwayGame.mk (mulOption x (-y) c d) ↔ + P1 x y a b c (-d) := by + simp [P1, mulOption, sub_eq_add_neg, add_comm] + +private lemma mulOption_lt_of_lt [Numeric y] (ihxy : IH1 x y) (ihyx : IH1 y x) {a b c d} (h : a < c) + (ha : a ∈ xᴸ) (hb : b ∈ yᴸ) (hc : c ∈ xᴸ) (hd : d ∈ (-y)ᴸ) : + ConwayGame.mk (mulOption x y a b) < -ConwayGame.mk (mulOption x (-y) c d) := by + rw [mulOption_lt_iff_P1] + exact P1_of_P3 (P3_of_IH1 ihyx hc hb hd) <| ((P24_of_IH1 ihxy ha hc).2 h).1 b hb + +private lemma mulOption_lt [Numeric x] [Numeric y] (ihxy : IH1 x y) (ihyx : IH1 y x) {a b c d} + (ha : a ∈ xᴸ) (hb : b ∈ yᴸ) (hc : c ∈ xᴸ) (hd : d ∈ (-y)ᴸ) : + ConwayGame.mk (mulOption x y a b) < -ConwayGame.mk (mulOption x (-y) c d) := by + numeric + obtain (h | h | h) := Numeric.lt_or_equiv_or_gt a c + · exact mulOption_lt_of_lt ihxy ihyx h ha hb hc hd + · exact mulOption_lt_iff_P1.2 (P1_of_equiv h (P24_of_IH1 ihxy ha hc).1 + (ihxy ha hc <| .inr ⟨right, by simpa using hd⟩).1 <| P3_of_IH1 ihyx ha hb hd) + · rw [← neg_neg y] at hb + simpa [lt_neg] using mulOption_lt_of_lt (IH1_neg_right ihxy) (IH1_neg_left ihyx) h hc hd ha hb + +/-- `P1` follows from the induction hypothesis. -/ +private lemma P1_of_IH (IH : ∀ a, ArgsRel a (Args.P1 x y) → P124 a) [Numeric x] [Numeric y] : + (x * y).Numeric := by + have ihxy := IH1_of_IH IH + have ihyx := IH1_swap_of_IH IH + have ihxyn := IH1_neg_left (IH1_neg_right ihxy) + have ihyxn := IH1_neg_left (IH1_neg_right ihyx) + refine .mk ?_ ?_ + · simp_rw [forall_leftMoves_mul', forall_rightMoves_mul'] + constructor <;> intro a ha b hb <;> constructor <;> intro c hc d hd + · exact mulOption_lt ihxy ihyx ha hb hc hd + · simpa [mulOption_comm, ← mk_lt_mk] using mulOption_lt ihyx ihxy hb ha hd hc + · rw [← neg_neg x] at hc + simpa [mulOption_comm, ← mk_lt_mk] using mulOption_lt ihyxn ihxyn hb ha hd hc + · rw [← neg_neg y] at hd + simpa [← mk_lt_mk] using mulOption_lt ihxyn ihyxn ha hb hc hd + · intro p + simp only [moves_mul, moves_mul, mulOption, Set.mem_image, Prod.exists, + forall_exists_index, and_imp] + rintro _ a b (⟨ha, hb⟩ | ⟨ha, hb⟩) rfl + all_goals + have := numeric_move_mul_of_IH IH ha + have := numeric_mul_move_of_IH IH hb + have := numeric_move_mul_move_of_IH IH ha hb + infer_instance + +/-! ### P2 follows from the inductive hypothesis -/ + +private lemma numeric_of_IH (IH : ∀ a, ArgsRel a (Args.P24 x₁ x₂ y) → P124 a) : + (x₁ * y).Numeric ∧ (x₂ * y).Numeric := by + constructor <;> refine IH (.P1 ..) (.single ?_) + · exact (cutExpand_add_right {y}).2 <| (cutExpand_add_left {x₁}).2 cutExpand_zero + · exact (cutExpand_add_right {x₂, y}).2 cutExpand_zero + +/-- A specialization of the inductive hypothesis used to prove `P2` and `P4`. -/ +private def IH24 (x₁ x₂ y : IGame) : Prop := + ∀ ⦃p z⦄, + (z ∈ x₁.moves p → P24 z x₂ y) ∧ + (z ∈ x₂.moves p → P24 x₁ z y) ∧ + (z ∈ y.moves p → P24 x₁ x₂ z) + +/-- A specialization of the induction hypothesis used to prove `P4`. -/ +private def IH4 (x₁ x₂ y : IGame) : Prop := + ∀ ⦃p q z w⦄, w ∈ y.moves p → (z ∈ x₁.moves q → P2 z x₂ w) ∧ (z ∈ x₂.moves q → P2 x₁ z w) + +/-- `IH24 x₁ x₂ y` follows from the inductive hypothesis for `P24 x₁ x₂ y`. -/ +private lemma IH24_of_IH (IH : ∀ a, ArgsRel a (Args.P24 x₁ x₂ y) → P124 a) : IH24 x₁ x₂ y := by + rw [IH24] + refine fun p z ↦ ⟨?_, ?_, ?_⟩ <;> refine fun h ↦ IH (.P24 ..) (.single ?_) + · exact (cutExpand_add_right {y}).2 (cutExpand_pair_left ⟨p, h⟩) + · exact (cutExpand_add_left {x₁}).2 (cutExpand_pair_left ⟨p, h⟩) + · exact (cutExpand_add_left {x₁}).2 (cutExpand_pair_right ⟨p, h⟩) + +/-- `IH24 x₂ x₁ y` follows from the inductive hypothesis for `P24 x₁ x₂ y`. -/ +private lemma IH24_swap_of_IH (IH : ∀ a, ArgsRel a (Args.P24 x₁ x₂ y) → P124 a) : IH24 x₂ x₁ y := by + apply IH24_of_IH + convert IH using 2 + dsimp [ArgsRel, InvImage, Multiset.insert_eq_cons, ← Multiset.singleton_add] + abel_nf + +/-- `IH4 x₁ x₂ y` follows from the inductive hypothesis for `P24 x₁ x₂ y`. -/ +private lemma IH4_of_IH (IH : ∀ a, ArgsRel a (Args.P24 x₁ x₂ y) → P124 a) : IH4 x₁ x₂ y := by + refine fun p q a b h ↦ ⟨?_, ?_⟩ <;> + refine fun h' ↦ (IH (.P24 ..) <| (TransGen.single ?_).tail <| + (cutExpand_add_left {x₁}).2 <| cutExpand_pair_right ⟨p, h⟩).1 + · exact (cutExpand_add_right {b}).2 <| cutExpand_pair_left ⟨q, h'⟩ + · exact (cutExpand_add_right {b}).2 <| cutExpand_pair_right ⟨q, h'⟩ + +private lemma IH24_neg : IH24 x₁ x₂ y → IH24 (-x₂) (-x₁) y ∧ IH24 x₁ x₂ (-y) := by + simp_rw [IH24, P24_neg_right, moves_neg] + refine fun h ↦ ⟨fun p z ↦ ⟨?_, ?_, ?_⟩, + fun p z ↦ ⟨(@h p z).1, (@h p z).2.1, P24_neg_right.1 ∘ (@h (-p) (-z)).2.2⟩⟩ + all_goals + rw [← P24_neg_left] + simp only [neg_neg] + · exact (@h (-p) (-z)).2.1 + · exact (@h (-p) (-z)).1 + · exact (@h p z).2.2 + +private lemma IH4_neg : IH4 x₁ x₂ y → IH4 (-x₂) (-x₁) y ∧ IH4 x₁ x₂ (-y) := by + simp_rw [IH4, moves_neg, Set.mem_neg] + refine fun h ↦ ⟨fun p q z w h' ↦ ?_, fun p q z w h' ↦ ?_⟩ + · convert (h h').symm using 2 <;> rw [← P2_neg_left, neg_neg] + · convert h h' using 2 <;> rw [P2_neg_right] + +private lemma mulOption_lt_mul_of_equiv [Numeric x₁] (h : IH24 x₁ x₂ y) (he : x₁ ≈ x₂) + (hi : a ∈ x₁ᴸ) (hj : b ∈ yᴸ) : + ConwayGame.mk (mulOption x₁ y a b) < ConwayGame.mk (x₂ * y) := by + convert sub_lt_iff_lt_add'.2 (((h.1 hi).2 _).1 b hj) using 1 + · rw [← (h.2.2 hj).1 he] + rfl + · grw [← he] + exact Numeric.left_lt hi + +private lemma mul_right_le_of_equiv [Numeric x₁] [Numeric x₂] + (ih₁₂ : IH24 x₁ x₂ y) (ih₂₁ : IH24 x₂ x₁ y) (he : x₁ ≈ x₂) : x₁ * y ≤ x₂ * y := by + have he' := neg_equiv_neg_iff.2 he + rw [IGame.le_iff_forall_lf] + simp_rw [← ConwayGame.mk_le_mk] + constructor + · rw [forall_leftMoves_mul'] + constructor <;> intro a ha b hb + · exact (mulOption_lt_mul_of_equiv ih₁₂ he ha hb).not_ge + · simpa using (mulOption_lt_mul_of_equiv (IH24_neg <| (IH24_neg ih₂₁).1).2 he' ha hb).not_ge + · rw [forall_rightMoves_mul'] + constructor <;> intro a ha b hb + · simpa [neg_le] using (mulOption_lt_mul_of_equiv (IH24_neg ih₂₁).2 he.symm ha hb).not_ge + · simpa [neg_le] using (mulOption_lt_mul_of_equiv (IH24_neg ih₁₂).1 he'.symm ha hb).not_ge + +/-- `P2` follows from the induction hypothesis. -/ +private lemma P2_of_IH (IH : ∀ a, ArgsRel a (Args.P24 x₁ x₂ y) → P124 a) [Numeric x₁] [Numeric x₂] + (he : x₁ ≈ x₂) : x₁ * y ≈ x₂ * y := + ⟨mul_right_le_of_equiv (IH24_of_IH IH) (IH24_swap_of_IH IH) he, + mul_right_le_of_equiv (IH24_swap_of_IH IH) (IH24_of_IH IH) he.symm⟩ + +/-! ### P4 follows from the inductive hypothesis -/ + +private lemma mulOption_lt_mul_iff_P3 : mulOption x y a b < x * y ↔ P3 a x b y := + @sub_lt_iff_lt_add' ConwayGame _ _ _ (.mk _) (.mk _) (.mk _) + +/-- A specialization of the induction hypothesis used to prove `P3`. -/ +private def IH3 (x₁ x' x₂ y₁ y₂ : IGame) : Prop := + P2 x₁ x' y₁ ∧ P2 x₁ x' y₂ ∧ P3 x' x₂ y₁ y₂ ∧ (x₁ < x' → P3 x₁ x' y₁ y₂) + +/-- `IH3` follows from the induction hypothesis for `P24 x₁ x₂ y`. -/ +private lemma IH3_of_IH (ih24 : IH24 x₁ x₂ y) (ih4 : IH4 x₁ x₂ y) + (hi : a ∈ x₂ᴸ) (hb : b ∈ yᴸ) (hl : mulOption x₂ y a b < x₂ * y) : + IH3 x₁ a x₂ b y := + have h24 := ih24.2.1 hi + ⟨(ih4 hb).2 hi, h24.1, + mulOption_lt_mul_iff_P3.1 hl, fun l ↦ (h24.2 l).1 b hb⟩ + +private lemma P3_of_le_left {y₁ y₂} (i) (h : IH3 x₁ i x₂ y₁ y₂) (hl : x₁ ≤ i) : P3 x₁ x₂ y₁ y₂ := by + obtain (hl | he) := le_iff_lt_or_antisymmRel.1 hl + · exact (h.2.2.2 hl).trans h.2.2.1 + · rw [P3, h.1 he, h.2.1 he] + exact h.2.2.1 + +/-- P3 follows from `IH3`, so P4 (with `y₁` a left option of `y₂`) follows from the induction +hypothesis. -/ +private lemma P3_of_IH3 {y₁ y₂} (h : ∀ i ∈ x₂ᴸ, IH3 x₁ i x₂ y₁ y₂) + (hs : ∀ i ∈ (-x₁)ᴸ, IH3 (-x₂) i (-x₁) y₁ y₂) (hl : x₁ < x₂) : P3 x₁ x₂ y₁ y₂ := by + obtain (⟨i, hi, hi'⟩ | ⟨i, hi, hi'⟩) := lf_iff_exists_le.1 hl.not_ge + · exact P3_of_le_left i (h i hi) hi' + · refine P3_neg.1 <| P3_of_le_left _ (hs (-i) ?_) ?_ <;> simpa + +/-- `P4` follows from the induction hypothesis. -/ +private lemma P4_of_IH (IH : ∀ a, ArgsRel a (.P24 x₁ x₂ y) → P124 a) : P4 x₁ x₂ y := by + have h₁₂ := IH24_of_IH IH + have h4 := IH4_of_IH IH + obtain ⟨h₁₂x, h₁₂y⟩ := IH24_neg h₁₂ + obtain ⟨h4x, h4y⟩ := IH4_neg h4 + have := (IH24_neg h₁₂y).1 + have := (IH4_neg h4y).1 + obtain ⟨hn₁, hn₂⟩ := numeric_of_IH IH + have : (-x₁ * y).Numeric := by simpa + have : (-x₁ * -y).Numeric := by simpa + have : (x₂ * -y).Numeric := by simpa + refine fun hl ↦ ⟨?_, ?_⟩ <;> + refine fun a ha ↦ P3_of_IH3 ?_ ?_ hl <;> + intro b hb <;> + apply IH3_of_IH + assumption' + all_goals + exact Numeric.left_lt (mulOption_mem_moves_mul hb ha) + +/-- We tie everything together to complete the induction. -/ +private theorem main (a : Args) : a.Numeric → P124 a := by + apply argsRel_wf.induction a + intro a IH ha + replace ih : ∀ a', ArgsRel a' a → P124 a' := fun a' hr ↦ IH a' hr (hr.numeric_closed ha) + cases a with + | P1 x y => + obtain ⟨_, _⟩ := Args.numeric_P1.1 ha + exact P1_of_IH ih + | P24 x₁ x₂ y => + obtain ⟨_, _, _⟩ := Args.numeric_P24.1 ha + constructor + · exact (ConwayGame.mk_eq <| P2_of_IH ih ·) + · exact P4_of_IH ih + +private lemma main_P24 (x₁ x₂ y : IGame) [hx₁ : Numeric x₁] [hx₂ : Numeric x₂] [hy : Numeric y] : + P24 x₁ x₂ y := + main _ <| Args.numeric_P24.mpr ⟨hx₁, hx₂, hy⟩ + +/-- One additional inductive argument proves `P3`. -/ +private lemma P3_of_lt_of_lt {x₁ x₂ y₁ y₂} [Numeric x₁] [Numeric x₂] [Numeric y₁] [Numeric y₂] + (hx : x₁ < x₂) (hy : y₁ < y₂) : P3 x₁ x₂ y₁ y₂ := by + refine P3_of_IH3 ?_ ?_ hx + all_goals + intro i hi + numeric + refine ⟨(main_P24 ..).1, (main_P24 ..).1, P3_comm.2 ?_, fun h ↦ ?_⟩ + · exact ((main_P24 y₁ y₂ x₂).2 hy).1 _ hi + · exact P3_of_lt_of_lt h hy + · exact ((main_P24 y₁ y₂ x₁).2 hy).2 _ hi + · rw [IGame.neg_lt] at h + rw [← P3_neg, neg_neg] + exact P3_of_lt_of_lt h hy +termination_by (x₁, x₂) +decreasing_by all_goals (try rw [moves_neg] at *); igame_wf + +/-! ### Instances and corollaries -/ + +public section + +namespace IGame.Numeric + +variable {x x₁ x₂ y y₁ y₂ : IGame} + +instance mul (x y : IGame) [hx : Numeric x] [hy : Numeric y] : Numeric (x * y) := + main _ <| Args.numeric_P1.mpr ⟨hx, hy⟩ + +protected instance mulOption (x y a b : IGame) [Numeric x] [Numeric y] [Numeric a] [Numeric b] : + Numeric (mulOption x y a b) := + .sub .. + +theorem mul_congr_left [Numeric x₁] [Numeric x₂] [Numeric y] (he : x₁ ≈ x₂) : x₁ * y ≈ x₂ * y := + ConwayGame.mk_eq_mk.1 ((main_P24 ..).1 he) + +theorem mul_congr_right [Numeric x] [Numeric y₁] [Numeric y₂] (he : y₁ ≈ y₂) : x * y₁ ≈ x * y₂ := by + rw [mul_comm, mul_comm x]; exact Numeric.mul_congr_left he + +theorem mul_congr [Numeric x₁] [Numeric x₂] [Numeric y₁] [Numeric y₂] + (hx : x₁ ≈ x₂) (hy : y₁ ≈ y₂) : x₁ * y₁ ≈ x₂ * y₂ := + (mul_congr_left hx).trans (mul_congr_right hy) + +protected theorem mul_pos [Numeric x₁] [Numeric x₂] (h₁ : 0 < x₁) (h₂ : 0 < x₂) : 0 < x₁ * x₂ := by + simpa [P3, ← mk_lt_mk] using P3_of_lt_of_lt h₁ h₂ + +end IGame.Numeric + +namespace Surreal + +noncomputable instance : CommRing Surreal where + mul := Quotient.map₂ (fun a b ↦ ⟨a.1 * b.1, inferInstance⟩) fun _ _ h _ _ ↦ Numeric.mul_congr h + zero_mul := by rintro ⟨x⟩; change mk (0 * x) = mk 0; simp_rw [zero_mul] + mul_zero := by rintro ⟨x⟩; change mk (x * 0) = mk 0; simp_rw [mul_zero] + one_mul := by rintro ⟨x⟩; change mk (1 * x) = mk x; simp_rw [one_mul] + mul_one := by rintro ⟨x⟩; change mk (x * 1) = mk x; simp_rw [mul_one] + left_distrib := by rintro ⟨x⟩ ⟨y⟩ ⟨z⟩; exact mk_eq (mul_add_equiv ..) + right_distrib := by rintro ⟨x⟩ ⟨y⟩ ⟨z⟩; exact mk_eq (add_mul_equiv ..) + mul_comm := by rintro ⟨x⟩ ⟨y⟩; change mk (x * y) = mk (y * x); simp_rw [mul_comm] + mul_assoc := by rintro ⟨x⟩ ⟨y⟩ ⟨z⟩; exact mk_eq (mul_assoc_equiv ..) + +instance : IsStrictOrderedRing Surreal := + .of_mul_pos (by rintro ⟨x⟩ ⟨y⟩; exact Numeric.mul_pos) + +@[simp] +theorem mk_mul (x y : IGame) [Numeric x] [Numeric y] : + Surreal.mk (x * y) = Surreal.mk x * Surreal.mk y := + rfl + +end Surreal + +namespace IGame.Numeric + +protected theorem mul_neg_of_pos_of_neg {x y : IGame} [Numeric x] [Numeric y] + (hx : 0 < x) (hy : y < 0) : x * y < 0 := + @mul_neg_of_pos_of_neg Surreal _ (.mk x) (.mk y) _ _ hx hy + +protected theorem mul_neg_of_neg_of_pos {x y : IGame} [Numeric x] [Numeric y] + (hx : x < 0) (hy : 0 < y) : x * y < 0 := + @mul_neg_of_neg_of_pos Surreal _ (.mk x) (.mk y) _ _ hx hy + +protected theorem mul_pos_of_neg_of_neg {x y : IGame} [Numeric x] [Numeric y] + (hx : x < 0) (hy : y < 0) : 0 < x * y := + @mul_pos_of_neg_of_neg Surreal _ _ _ _ _ _ (.mk x) (.mk y) hx hy + +protected theorem mul_nonneg {x y : IGame} [Numeric x] [Numeric y] + (hx : 0 ≤ x) (hy : 0 ≤ y) : 0 ≤ x * y := + @mul_nonneg Surreal _ (.mk x) (.mk y) _ _ hx hy + +protected theorem mul_nonpos_of_nonneg_of_nonpos {x y : IGame} [Numeric x] [Numeric y] + (hx : 0 ≤ x) (hy : y ≤ 0) : x * y ≤ 0 := + @mul_nonpos_of_nonneg_of_nonpos Surreal _ (.mk x) (.mk y) _ _ hx hy + +protected theorem mul_nonpos_of_nonpos_of_nonneg {x y : IGame} [Numeric x] [Numeric y] + (hx : x ≤ 0) (hy : 0 ≤ y) : x * y ≤ 0 := + @mul_nonpos_of_nonpos_of_nonneg Surreal _ (.mk x) (.mk y) _ _ hx hy + +protected theorem mul_nonneg_of_nonpos_of_nonpos {x y : IGame} [Numeric x] [Numeric y] + (hx : x ≤ 0) (hy : y ≤ 0) : 0 ≤ x * y := + @mul_nonneg_of_nonpos_of_nonpos Surreal _ _ (.mk x) (.mk y) _ _ _ _ hx hy + +protected theorem mul_left_cancel {x y z : IGame} [Numeric x] [Numeric y] [Numeric z] + (hx : ¬ x ≈ 0) (h : x * y ≈ x * z) : y ≈ z := by + rw [← Surreal.mk_eq_mk] at * + exact mul_left_cancel₀ hx h + +protected theorem mul_right_cancel {x y z : IGame} [Numeric x] [Numeric y] [Numeric z] + (hx : ¬ x ≈ 0) (h : y * x ≈ z * x) : y ≈ z := by + rw [← Surreal.mk_eq_mk] at * + exact mul_right_cancel₀ hx h + +@[simp] +protected theorem mul_le_mul_iff_left {x y z : IGame} [Numeric x] [Numeric y] [Numeric z] + (hx : 0 < x) : y * x ≤ z * x ↔ y ≤ z := + mul_le_mul_iff_left₀ (a := Surreal.mk x) (b := Surreal.mk y) (c := Surreal.mk z) hx + +@[simp] +protected theorem mul_le_mul_iff_right {x y z : IGame} [Numeric x] [Numeric y] [Numeric z] + (hx : 0 < x) : x * y ≤ x * z ↔ y ≤ z := + mul_le_mul_iff_right₀ (a := Surreal.mk x) (b := Surreal.mk y) (c := Surreal.mk z) hx + +@[simp] +protected theorem mul_lt_mul_iff_left {x y z : IGame} [Numeric x] [Numeric y] [Numeric z] + (hx : 0 < x) : y * x < z * x ↔ y < z := + mul_lt_mul_iff_left₀ (a := Surreal.mk x) (b := Surreal.mk y) (c := Surreal.mk z) hx + +@[simp] +protected theorem mul_lt_mul_iff_right {x y z : IGame} [Numeric x] [Numeric y] [Numeric z] + (hx : 0 < x) : x * y < x * z ↔ y < z := + mul_lt_mul_iff_right₀ (a := Surreal.mk x) (b := Surreal.mk y) (c := Surreal.mk z) hx + +@[simp] +protected theorem mul_le_mul_left_of_neg {x y z : IGame} [Numeric x] [Numeric y] [Numeric z] + (hz : z < 0) : z * x ≤ z * y ↔ y ≤ x := + mul_le_mul_left_of_neg (a := Surreal.mk x) (b := Surreal.mk y) (c := Surreal.mk z) hz + +@[simp] +protected theorem mul_le_mul_right_of_neg {x y z : IGame} [Numeric x] [Numeric y] [Numeric z] + (hz : z < 0) : x * z ≤ y * z ↔ y ≤ x := + mul_le_mul_right_of_neg (a := Surreal.mk x) (b := Surreal.mk y) (c := Surreal.mk z) hz + +@[simp] +protected theorem mul_lt_mul_left_of_neg {x y z : IGame} [Numeric x] [Numeric y] [Numeric z] + (hz : z < 0) : z * x < z * y ↔ y < x := + mul_lt_mul_left_of_neg (a := Surreal.mk x) (b := Surreal.mk y) (c := Surreal.mk z) hz + +@[simp] +protected theorem mul_lt_mul_right_of_neg {x y z : IGame} [Numeric x] [Numeric y] [Numeric z] + (hz : z < 0) : x * z < y * z ↔ y < x := + mul_lt_mul_right_of_neg (a := Surreal.mk x) (b := Surreal.mk y) (c := Surreal.mk z) hz + +protected theorem mul_le_mul {a b c d : IGame} [Numeric a] [Numeric b] [Numeric c] [Numeric d] : + a ≤ b → c ≤ d → 0 ≤ c → 0 ≤ b → a * c ≤ b * d := + mul_le_mul (a := Surreal.mk a) (b := Surreal.mk b) (c := Surreal.mk c) (d := Surreal.mk d) + +protected theorem mul_lt_mul {a b c d : IGame} [Numeric a] [Numeric b] [Numeric c] [Numeric d] : + a < b → c ≤ d → 0 < c → 0 ≤ b → a * c < b * d := + mul_lt_mul (a := Surreal.mk a) (b := Surreal.mk b) (c := Surreal.mk c) (d := Surreal.mk d) + +@[simp] +protected theorem mul_pos_iff_of_pos_left {a b : IGame} [Numeric a] [Numeric b] : + 0 < a → (0 < a * b ↔ 0 < b) := + mul_pos_iff_of_pos_left (a := Surreal.mk a) (b := Surreal.mk b) + +@[simp] +protected theorem mul_pos_iff_of_pos_right {a b : IGame} [Numeric a] [Numeric b] : + 0 < b → (0 < a * b ↔ 0 < a) := + mul_pos_iff_of_pos_right (a := Surreal.mk a) (b := Surreal.mk b) + +theorem mul_equiv_zero {x y : IGame} [Numeric x] [Numeric y] : x * y ≈ 0 ↔ x ≈ 0 ∨ y ≈ 0 := by + repeat rw [← Surreal.mk_eq_mk] + exact @mul_eq_zero Surreal _ _ (.mk x) (.mk y) + +theorem mulOption_congr₁ {x₁ x₂ y a b : IGame} + [Numeric x₁] [Numeric x₂] [Numeric y] [Numeric a] [Numeric b] (he : x₁ ≈ x₂) : + mulOption x₁ y a b ≈ mulOption x₂ y a b := by + simp_all [← Surreal.mk_eq_mk, mulOption] + +theorem mulOption_congr₂ {x y₁ y₂ a b : IGame} + [Numeric x] [Numeric y₁] [Numeric y₂] [Numeric a] [Numeric b] (he : y₁ ≈ y₂) : + mulOption x y₁ a b ≈ mulOption x y₂ a b := by + simp_all [← Surreal.mk_eq_mk, mulOption] + +theorem mulOption_congr₃ {x y a₁ a₂ b : IGame} + [Numeric x] [Numeric y] [Numeric a₁] [Numeric a₂] [Numeric b] (he : a₁ ≈ a₂) : + mulOption x y a₁ b ≈ mulOption x y a₂ b := by + simp_all [← Surreal.mk_eq_mk, mulOption] + +theorem mulOption_congr₄ {x y a b₁ b₂ : IGame} + [Numeric x] [Numeric y] [Numeric a] [Numeric b₁] [Numeric b₂] (he : b₁ ≈ b₂) : + mulOption x y a b₁ ≈ mulOption x y a b₂ := by + simp_all [← Surreal.mk_eq_mk, mulOption] + +end IGame.Numeric +end diff --git a/LeanPool/ConwayRefinement/CombinatorialGames/Surreal/Ordinal.lean b/LeanPool/ConwayRefinement/CombinatorialGames/Surreal/Ordinal.lean new file mode 100644 index 0000000000..076f304f69 --- /dev/null +++ b/LeanPool/ConwayRefinement/CombinatorialGames/Surreal/Ordinal.lean @@ -0,0 +1,78 @@ +/- +Copyright (c) 2022 Violeta Hernández Palacios. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Violeta Hernández Palacios +-/ +module + +public import LeanPool.ConwayRefinement.CombinatorialGames.Game.Ordinal +public import LeanPool.ConwayRefinement.CombinatorialGames.Surreal.Multiplication +public import Mathlib.Algebra.Order.Hom.Ring + +/-! +# Ordinals as surreals + +We define the canonical map `NatOrdinal → Surreal` in terms of the map `NatOrdinal.toIGame`. +-/ + +open IGame Set Surreal + +@[expose] public noncomputable section + +/-- Ordinal games are numeric. -/ +instance IGame.Numeric.toIGame (o : NatOrdinal) : Numeric o.toIGame := by + rw [numeric_def] + simpa using fun a ha ↦ IGame.Numeric.toIGame a +termination_by o + +namespace NatOrdinal + +/-- Converts an ordinal into the corresponding surreal. -/ +def toSurreal : NatOrdinal ↪o Surreal := + .ofStrictMono (fun o ↦ .mk o.toIGame) fun _ _ h ↦ toIGame.strictMono h + +instance : Coe NatOrdinal Surreal where + coe x := toSurreal x + +@[simp] +theorem _root_.Surreal.mk_natOrdinal_toIGame (o : NatOrdinal) : .mk o.toIGame = o.toSurreal := + rfl + +@[simp] +theorem _root_.Surreal.toGame_toSurreal (o : NatOrdinal) : o.toSurreal.toGame = o.toGame := + rfl + +theorem toSurreal_def (o : NatOrdinal) : o.toSurreal = !{toSurreal '' Iio o | ∅} := by + simp_rw [← Surreal.mk_natOrdinal_toIGame, toIGame_def o, Surreal.mk_ofSets] + congr! <;> aesop + +@[simp] theorem toSurreal_zero : toSurreal 0 = 0 := by simp [← Surreal.mk_natOrdinal_toIGame] +@[simp] theorem toSurreal_one : toSurreal 1 = 1 := by simp [← Surreal.mk_natOrdinal_toIGame] + +theorem toSurreal_nonneg (a : NatOrdinal) : 0 ≤ a.toGame := + toIGame_nonneg a + +@[simp] +theorem toSurreal_add (a b : NatOrdinal) : (a + b).toSurreal = a.toSurreal + b.toSurreal := + mk_eq (toIGame_add a b) + +@[simp] +theorem toSurreal_mul (a b : NatOrdinal) : (a * b).toSurreal = a.toSurreal * b.toSurreal := + mk_eq (toIGame_mul a b) + +/-- `NatOrdinal.toGame` as an `OrderRingHom`. -/ +@[simps] +def toSurrealRingHom : NatOrdinal →+*o Surreal where + toFun := toSurreal + map_zero' := toSurreal_zero + map_one' := toSurreal_one + map_add' := toSurreal_add + map_mul' := toSurreal_mul + monotone' := toSurreal.monotone + +@[simp] +theorem toSurreal_natCast : ∀ n : ℕ, toSurreal n = n := + map_natCast' toSurrealRingHom toSurreal_one + +end NatOrdinal +end diff --git a/LeanPool/ConwayRefinement/CombinatorialGames/Surreal/Pow.lean b/LeanPool/ConwayRefinement/CombinatorialGames/Surreal/Pow.lean new file mode 100644 index 0000000000..59b899e38f --- /dev/null +++ b/LeanPool/ConwayRefinement/CombinatorialGames/Surreal/Pow.lean @@ -0,0 +1,861 @@ +/- +Copyright (c) 2025 Violeta Hernández Palacios. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Violeta Hernández Palacios +-/ +module + +public import LeanPool.ConwayRefinement.CombinatorialGames.Surreal.Ordinal +public import LeanPool.ConwayRefinement.CombinatorialGames.Surreal.Real +public import LeanPool.ConwayRefinement.CombinatorialGames.NatOrdinal.Pow +public import Mathlib.Algebra.Order.Ring.Archimedean +public import Mathlib.RingTheory.Valuation.ValuativeRel.Basic + +/-! +# Surreal exponentiation + +We define here the ω-map on games and on surreal numbers, representing exponentials with base `ω`. + +Among other things, we prove that every non-zero surreal number is commensurate to some unique +`ω^ x`. We express this using `ArchimedeanClass`. There's two important things to note: + +- The definition of `ArchimedeanClass` involves absolute values, such that e.g. + `-ω` is commensurate to `ω`. +- The order in `ArchimedeanClass` is defined so that the equivalence class of `0` is the **largest** + equivalence class, rather than the smallest. + +## Todo + +- Define the normal form of a surreal number. +-/ + +universe u + +open Set + +public section + +/-! ## For Mathlib -/ + +-- TODO: upstream +theorem Set.image2_eq_range {α β γ : Type*} (f : α → β → γ) (s : Set α) (t : Set β) : + Set.image2 f s t = Set.range (fun x : s × t ↦ f x.1 x.2) := by + aesop + +namespace ArchimedeanClass + +theorem mk_le_mk_iff_dyadic {x y : Surreal} : + mk x ≤ mk y ↔ ∃ q : Dyadic, 0 < q ∧ q * |y| ≤ |x| := by + convert! mk_le_mk_iff_denselyOrdered ((Rat.castHom _).comp Dyadic.coeRingHom) (x := x) ?_ + · simp + · exact Rat.cast_strictMono.comp fun x y ↦ Dyadic.coe_lt_coe.mpr + +end ArchimedeanClass + +/-! ### ω-map on `IGame` -/ + +noncomputable section +namespace IGame + +/-- The ω-map on games, which is defined so that `ω^ !{s | t} = {0, r * ω^ a | r * ω^ b}` for +`a ∈ s`, `b ∈ t`, and `r` ranging over positive dyadic rationals. + +The standard definition in the literature instead has `r` ranging over positive reals, +but this makes no difference as to the equivalence class of the games. -/ +private def wpow (x : IGame.{u}) : IGame.{u} := + !{insert 0 (range (fun y : Ioi (0 : Dyadic) × xᴸ ↦ y.1 * wpow y.2)) | + range (fun y : Ioi (0 : Dyadic) × xᴿ ↦ y.1 * wpow y.2)} +termination_by x +decreasing_by igame_wf + +#adaptation_note /-- noncomputable is now needed -/ in +@[no_expose] +noncomputable instance : Wpow IGame where + wpow := wpow + +theorem wpow_def (x : IGame.{u}) : ω^ x = + !{insert 0 (image2 (fun r y ↦ ↑r * ω^ (y : IGame)) (Ioi (0 : Dyadic)) xᴸ) | + image2 (fun r y ↦ ↑r * ω^ y) (Ioi (0 : Dyadic)) xᴿ} := by + change wpow _ = _ + rw [wpow] + simp_rw [Set.image2_eq_range] + rfl + +theorem leftMoves_wpow (x : IGame) : (ω^ x)ᴸ = + insert 0 (image2 (fun r y ↦ ↑r * ω^ (y : IGame)) (Ioi (0 : Dyadic)) xᴸ) := by + rw [wpow_def, leftMoves_ofSets, Set.image2_eq_range] + +theorem rightMoves_wpow (x : IGame) : (ω^ x)ᴿ = + image2 (fun r y ↦ ↑r * ω^ (y : IGame)) (Ioi (0 : Dyadic)) xᴿ := by + rw [wpow_def, rightMoves_ofSets, Set.image2_eq_range] + +@[simp] +theorem forall_leftMoves_wpow {x : IGame} {P : IGame → Prop} : (∀ y ∈ (ω^ x)ᴸ, P y) ↔ + P 0 ∧ ∀ r : Dyadic, 0 < r → ∀ y ∈ xᴸ, P (r * ω^ y) := by + rw [leftMoves_wpow, forall_mem_insert, forall_mem_image2] + rfl + +@[simp] +theorem forall_rightMoves_wpow {x : IGame} {P : IGame → Prop} : (∀ y ∈ (ω^ x)ᴿ, P y) ↔ + ∀ r : Dyadic, 0 < r → ∀ y ∈ xᴿ, P (r * ω^ y) := by + rw [rightMoves_wpow] + exact forall_mem_image2 + +@[simp] +theorem exists_leftMoves_wpow {x : IGame} {P : IGame → Prop} : (∃ y ∈ (ω^ x)ᴸ, P y) ↔ + P 0 ∨ ∃ r : Dyadic, 0 < r ∧ ∃ y ∈ xᴸ, P (r * ω^ y) := by + rw [leftMoves_wpow, exists_mem_insert, exists_mem_image2] + rfl + +@[simp] +theorem exists_rightMoves_wpow {x : IGame} {P : IGame → Prop} : (∃ y ∈ (ω^ x)ᴿ, P y) ↔ + ∃ r : Dyadic, 0 < r ∧ ∃ y ∈ xᴿ, P (r * ω^ y) := by + rw [rightMoves_wpow] + exact exists_mem_image2 + +@[simp] +theorem zero_mem_leftMoves_wpow (x : IGame) : 0 ∈ (ω^ x)ᴸ := by + simp [leftMoves_wpow] + +theorem mul_wpow_mem_leftMoves_wpow {x y : IGame} {r : Dyadic} (hr : 0 ≤ r) + (hy : y ∈ xᴸ) : r * ω^ y ∈ (ω^ x)ᴸ := by + obtain rfl | hr := hr.eq_or_lt + · simp + · rw [leftMoves_wpow] + apply mem_insert_of_mem + use r, hr, y + +theorem mul_wpow_mem_rightMoves_wpow {x y : IGame} {r : Dyadic} (hr : 0 < r) + (hy : y ∈ xᴿ) : r * ω^ y ∈ (ω^ x)ᴿ := by + rw [rightMoves_wpow] + use r, hr, y + +theorem natCast_mul_wpow_mem_leftMoves_wpow {x y : IGame} (n : ℕ) (hy : y ∈ xᴸ) : + n * ω^ y ∈ (ω^ x)ᴸ := by + simpa using mul_wpow_mem_leftMoves_wpow n.cast_nonneg hy + +theorem natCast_mul_wpow_mem_rightMoves_wpow {x y : IGame} {n : ℕ} (hn : 0 < n) + (hy : y ∈ xᴿ) : n * ω^ y ∈ (ω^ x)ᴿ := by + simpa using mul_wpow_mem_rightMoves_wpow (n.cast_pos.2 hn) hy + +theorem wpow_mem_leftMoves_wpow {x y : IGame} (hy : y ∈ xᴸ) : + ω^ y ∈ (ω^ x)ᴸ := by + simpa using natCast_mul_wpow_mem_leftMoves_wpow 1 hy + +theorem wpow_mem_rightMoves_wpow {x y : IGame} (hy : y ∈ xᴿ) : + ω^ y ∈ (ω^ x)ᴿ := by + simpa using natCast_mul_wpow_mem_rightMoves_wpow one_pos hy + +theorem zero_lf_wpow (x : IGame) : 0 ⧏ ω^ x := + left_lf (zero_mem_leftMoves_wpow x) + +private theorem wpow_pos' (x : IGame) [Numeric (ω^ x)] : 0 < ω^ x := by + simpa using zero_lf_wpow x + +@[simp] +theorem wpow_zero : ω^ (0 : IGame) = 1 := by + ext p; cases p <;> simp [leftMoves_wpow, rightMoves_wpow] + +namespace Numeric + +variable {x y z w : IGame} [Numeric x] [Numeric y] [Numeric z] [Numeric w] + +private theorem wpow_strictMono_aux {x y : IGame} [Numeric x] [Numeric y] + [Numeric (ω^ x)] [Numeric (ω^ y)] : + (x < y → ∀ {r : ℝ}, 0 < r → r * ω^ x < ω^ y) ∧ (x ≤ y → ω^ x ≤ ω^ y) := by + refine ⟨fun hxy r hr ↦ ?_, fun hxy ↦ ?_⟩ + · obtain (⟨z, hz, hxz⟩ | ⟨z, hz, hzy⟩) := lf_iff_exists_le.1 hxy.not_ge + · have := wpow_mem_leftMoves_wpow hz + numeric + apply ((Numeric.mul_le_mul_iff_right (mod_cast hr)).2 (wpow_strictMono_aux.2 hxz)).trans_lt + obtain ⟨n, hn⟩ := exists_nat_gt r + exact ((Numeric.mul_lt_mul_iff_left (wpow_pos' z)).2 (mod_cast hn)).trans + (Numeric.left_lt (natCast_mul_wpow_mem_leftMoves_wpow n hz)) + · have := wpow_mem_rightMoves_wpow hz + numeric + apply (wpow_strictMono_aux.2 hzy).trans_lt' + rw [← Numeric.lt_div_iff' (mod_cast hr), IGame.div_eq_mul_inv, mul_comm] + grw [← Numeric.mul_congr_left r.toIGame_inv_equiv] + obtain ⟨q, hq, hq'⟩ := exists_dyadic_btwn (inv_pos.2 hr) + apply (Numeric.lt_right (mul_wpow_mem_rightMoves_wpow (mod_cast hq) hz)).trans + rw [Numeric.mul_lt_mul_iff_left (wpow_pos' z)] + simpa + · rw [le_iff_forall_lf, forall_leftMoves_wpow, forall_rightMoves_wpow] + refine ⟨⟨zero_lf_wpow _, ?_⟩, ?_⟩ <;> intro r hr z hz + · have := wpow_mem_leftMoves_wpow hz + numeric + grw [← Numeric.mul_congr_left (Real.toIGame_dyadic_equiv r)] + exact (wpow_strictMono_aux.1 ((Numeric.left_lt hz).trans_le hxy) (mod_cast hr)).not_ge + · have := wpow_mem_rightMoves_wpow hz + numeric + have hr' : 0 < (r : ℝ)⁻¹ := by simpa + rw [← Surreal.mk_le_mk, Surreal.mk_mul, ← le_div_iff₀' (by simpa), div_eq_inv_mul] + simpa [← Surreal.mk_lt_mk] using + wpow_strictMono_aux.1 (hxy.trans_lt (Numeric.lt_right hz)) hr' +termination_by (x, y) +decreasing_by igame_wf + +protected instance wpow (x : IGame) [Numeric x] : Numeric (ω^ x) := by + rw [numeric_def] + simp_rw [Player.forall, forall_leftMoves_wpow, forall_rightMoves_wpow] + refine ⟨⟨fun r hr y hy ↦ ?_, fun r hr y hy s hs z hz ↦ ?_⟩, + ⟨.zero, fun r hr y hy ↦ ?_⟩, fun r hr y hy ↦ ?_⟩ + all_goals numeric; have := Numeric.wpow y + · exact Numeric.mul_pos (mod_cast hr) (wpow_pos' y) + · have := Numeric.wpow z + rw [← Numeric.div_lt_iff' (mod_cast hs), ← Surreal.mk_lt_mk] + dsimp + simp_rw [div_eq_inv_mul, ← mul_assoc, Surreal.mk_dyadic, + ← Real.toSurreal_ratCast, ← Real.toSurreal_inv, ← Real.toSurreal_mul] + apply wpow_strictMono_aux.1 (Numeric.left_lt_right hy hz) (mul_pos ..) <;> simpa + all_goals infer_instance +termination_by x +decreasing_by igame_wf + +@[simp] theorem wpow_pos (x : IGame) [Numeric x] : 0 < ω^ x := wpow_pos' x +@[simp] theorem wpow_nonneg (x : IGame) [Numeric x] : 0 ≤ ω^ x := (wpow_pos x).le + +theorem mul_wpow_lt_wpow (r : ℝ) (h : x < y) : r * ω^ x < ω^ y := by + obtain hr | hr := le_or_gt r 0 + · apply (Numeric.mul_nonpos_of_nonpos_of_nonneg _ (wpow_nonneg x)).trans_lt (wpow_pos y) + exact Real.toIGame_le_zero.mpr hr + · exact wpow_strictMono_aux.1 h hr + +/-- A version of `mul_wpow_lt_wpow` stated using dyadic rationals. -/ +theorem mul_wpow_lt_wpow' (r : Dyadic) (h : x < y) : r * ω^ x < ω^ y := by + simpa [← Surreal.mk_lt_mk] using mul_wpow_lt_wpow r h + +theorem wpow_lt_mul_wpow {r : ℝ} (hr : 0 < r) (h : x < y) : ω^ x < r * ω^ y := by + rw [← Numeric.div_lt_iff' (mod_cast hr), IGame.div_eq_mul_inv, mul_comm] + simpa [← Surreal.mk_lt_mk] using mul_wpow_lt_wpow (r⁻¹) h + +/-- A version of `wpow_lt_mul_wpow` stated using dyadic rationals. -/ +theorem wpow_lt_mul_wpow' {r : Dyadic} (hr : 0 < r) (h : x < y) : ω^ x < r * ω^ y := by + have hr : (0 : ℝ) < r := by simpa + simpa [← Surreal.mk_lt_mk] using wpow_lt_mul_wpow hr h + +theorem mul_wpow_lt_mul_wpow (r : ℝ) {s : ℝ} (hs : 0 < s) (h : x < y) : r * ω^ x < s * ω^ y := by + rw [← Numeric.div_lt_iff' (mod_cast hs), ← Surreal.mk_lt_mk] + dsimp + rw [div_eq_mul_inv, mul_comm, ← mul_assoc, ← Real.toSurreal_inv, ← Real.toSurreal_mul] + exact mul_wpow_lt_wpow _ h + +/-- A version of `mul_wpow_lt_mul_wpow` stated using dyadic rationals. -/ +theorem mul_wpow_lt_mul_wpow' (r : Dyadic) {s : Dyadic} (hs : 0 < s) (h : x < y) : + r * ω^ x < s * ω^ y := by + have hs : (0 : ℝ) < s := by simpa + simpa [← Surreal.mk_lt_mk] using mul_wpow_lt_mul_wpow r hs h + +theorem mul_wpow_add_mul_wpow_lt_mul_wpow (r s : ℝ) {t : ℝ} (ht : 0 < t) + (hx : x < z) (hy : y < z) : r * ω^ x + s * ω^ y < t * ω^ z := by + have h : 0 < t / 2 := by simpa + apply (add_lt_add (mul_wpow_lt_mul_wpow r h hx) (mul_wpow_lt_mul_wpow s h hy)).trans_le + simp [← Surreal.mk_le_mk, ← add_mul] + +/-- A version of `mul_wpow_add_mul_wpow_lt_mul_wpow` stated using dyadic rationals. -/ +theorem mul_wpow_add_mul_wpow_lt_mul_wpow' (r s : Dyadic) {t : Dyadic} (ht : 0 < t) + (hx : x < z) (hy : y < z) : r * ω^ x + s * ω^ y < t * ω^ z := by + have ht : (0 : ℝ) < t := by simpa + simpa [← Surreal.mk_lt_mk] using mul_wpow_add_mul_wpow_lt_mul_wpow r s ht hx hy + +theorem mul_wpow_lt_mul_wpow_add_mul_wpow (r : ℝ) {s t : ℝ} (hs : 0 < s) (ht : 0 < t) + (hx : x < y) (hy : x < z) : r * ω^ x < s * ω^ y + t * ω^ z := by + apply (add_lt_add (mul_wpow_lt_mul_wpow (r/2) hs hx) (mul_wpow_lt_mul_wpow (r/2) ht hy)).trans_le' + simp [← Surreal.mk_le_mk, ← add_mul] + +/-- A version of `mul_wpow_lt_mul_wpow_add_mul_wpow` stated using dyadic rationals. -/ +theorem mul_wpow_lt_mul_wpow_add_mul_wpow' (r : Dyadic) {s t : Dyadic} (hs : 0 < s) (ht : 0 < t) + (hx : x < y) (hy : x < z) : r * ω^ x < s * ω^ y + t * ω^ z := by + have hs : (0 : ℝ) < s := by simpa + have ht : (0 : ℝ) < t := by simpa + simpa [← Surreal.mk_lt_mk] using mul_wpow_lt_mul_wpow_add_mul_wpow r hs ht hx hy + +@[simp] +theorem wpow_lt_wpow : ω^ x < ω^ y ↔ x < y := by + constructor + · contrapose + repeat rw [Numeric.not_lt] + exact wpow_strictMono_aux.2 + · simpa using mul_wpow_lt_wpow' 1 + +@[simp] +theorem wpow_le_wpow : ω^ x ≤ ω^ y ↔ x ≤ y := by + rw [← Numeric.not_lt, wpow_lt_wpow, Numeric.not_lt] + +theorem wpow_congr (h : x ≈ y) : ω^ x ≈ ω^ y := by + simpa [AntisymmRel] using h + +private theorem mulOption_lt_wpow {r s : Dyadic} (hr : 0 < r) (hs : 0 < s) + (h₁ : x < z) (h₂ : y < w) (IH₁ : ω^ (x + w) ≈ ω^ x * ω^ w) + (IH₂ : ω^ (z + y) ≈ ω^ z * ω^ y) (IH₃ : ω^ (z + w) ≈ ω^ z * ω^ w) : + mulOption (ω^ x) (ω^ y) (r * ω^ z) (s * ω^ w) < ω^ (x + y) := by + apply IGame.sub_lt_iff_lt_add.2 + have H : r * ω^ (z + y) + s * ω^ (x + w) < ω^ (x + y) + ↑(r * s) * ω^ (z + w) := by + apply (mul_wpow_add_mul_wpow_lt_mul_wpow' ..).trans (lt_add_of_pos_left ..) <;> simp_all + rw [← Surreal.mk_lt_mk, ← Surreal.mk_eq_mk] at * + convert H using 1 <;> simp_all <;> ring_nf + +private theorem mulOption_lt_wpow' {r s : Dyadic} (hr : 0 < r) (hs : 0 < s) + (h₁ : z < x) (h₂ : w < y) (IH₁ : ω^ (x + w) ≈ ω^ x * ω^ w) + (IH₂ : ω^ (z + y) ≈ ω^ z * ω^ y) (IH₃ : ω^ (z + w) ≈ ω^ z * ω^ w) : + mulOption (ω^ x) (ω^ y) (r * ω^ z) (s * ω^ w) < ω^ (x + y) := by + apply IGame.sub_lt_iff_lt_add.2 + have H : r * ω^ (z + y) + s * ω^ (x + w) < (1 : Dyadic) * ω^ (x + y) + (r * s) * ω^ (z + w) := by + apply (mul_wpow_add_mul_wpow_lt_mul_wpow' ..).trans (lt_add_of_pos_right ..) <;> simp_all + rw [← Surreal.mk_lt_mk, ← Surreal.mk_eq_mk] at * + convert H using 1 <;> simp_all <;> ring_nf + +private theorem wpow_lt_mulOption {r s : Dyadic} (hr : 0 < r) (hs : 0 < s) + (h₁ : x < z) (h₂ : w < y) (IH₁ : ω^ (z + y) ≈ ω^ z * ω^ y) (IH₂ : ω^ (z + w) ≈ ω^ z * ω^ w) : + ω^(x + y) < mulOption (ω^ x) (ω^ y) (r * ω^ z) (s * ω^ w) := by + apply IGame.lt_sub_iff_add_lt.2 + have H : (1 : Dyadic) * ω^ (x + y) + ↑(r * s) * ω^ (z + w) + < r * ω^ (z + y) + s * ω^ x * ω^ w := by + apply (mul_wpow_add_mul_wpow_lt_mul_wpow' ..).trans (lt_add_of_pos_right ..) <;> simp_all + rw [← Surreal.mk_lt_mk, ← Surreal.mk_eq_mk] at * + convert H using 1 <;> simp_all <;> ring_nf + +theorem wpow_add_equiv (x y : IGame) [Numeric x] [Numeric y] : ω^ (x + y) ≈ ω^ x * ω^ y := by + rw [AntisymmRel, le_iff_forall_lf, le_iff_forall_lf] + simp only [forall_leftMoves_wpow, forall_rightMoves_wpow, forall_and, + forall_moves_add, forall_moves_mul, Player.forall, + Player.left_mul, Player.right_mul, Player.neg_left, Player.neg_right] + repeat any_goals constructor + on_goal 1 => exact (Numeric.mul_pos (wpow_pos _) (wpow_pos _)).not_ge + on_goal 7 => simp + all_goals intro r hr z hz + any_goals intro s hs w hw + all_goals numeric; apply not_le_of_gt + · grw [mul_congr_right (wpow_add_equiv ..), ← mul_assoc_equiv] + rw [Numeric.mul_lt_mul_iff_left (wpow_pos _)] + exact mul_wpow_lt_wpow' r (Numeric.left_lt hz) + · grw [mul_congr_right (wpow_add_equiv ..), mul_comm (r : IGame), mul_assoc_equiv] + rw [Numeric.mul_lt_mul_iff_right (wpow_pos _), mul_comm] + exact mul_wpow_lt_wpow' r (Numeric.left_lt hz) + · rw [mulOption_zero_left, mul_comm (r : IGame)] + grw [← mul_assoc_equiv, mul_comm, ← mul_congr_right (wpow_add_equiv ..)] + exact wpow_lt_mul_wpow' hr (add_right_strictMono (Numeric.lt_right hz)) + · rw [mulOption_comm, add_comm] + apply wpow_lt_mulOption hs hr (Numeric.lt_right hw) (Numeric.left_lt hz) <;> + rw [add_comm, mul_comm] <;> exact wpow_add_equiv .. + · rw [mulOption_zero_right] + grw [mul_assoc_equiv, ← mul_congr_right (wpow_add_equiv ..)] + exact wpow_lt_mul_wpow' hr (add_left_strictMono (Numeric.lt_right hz)) + · exact wpow_lt_mulOption hr hs (Numeric.lt_right hz) (Numeric.left_lt hw) + (wpow_add_equiv ..) (wpow_add_equiv ..) + · rw [mulOption_zero_right] + grw [mul_assoc_equiv, ← mul_congr_right (wpow_add_equiv ..)] + exact mul_wpow_lt_wpow' r (add_left_strictMono (Numeric.left_lt hz)) + · rw [mulOption_zero_left, mul_comm] + grw [mul_assoc_equiv, mul_comm (ω^ z), ← mul_congr_right (wpow_add_equiv ..)] + exact mul_wpow_lt_wpow' _ (add_right_strictMono (Numeric.left_lt hz)) + · exact mulOption_lt_wpow' hr hs (Numeric.left_lt hz) (Numeric.left_lt hw) + (wpow_add_equiv ..) (wpow_add_equiv ..) (wpow_add_equiv ..) + · exact mulOption_lt_wpow hr hs (Numeric.lt_right hz) (Numeric.lt_right hw) + (wpow_add_equiv ..) (wpow_add_equiv ..) (wpow_add_equiv ..) + · grw [mul_congr_right (wpow_add_equiv ..), ← mul_assoc_equiv] + rw [Numeric.mul_lt_mul_iff_left (wpow_pos _)] + exact wpow_lt_mul_wpow' hr (Numeric.lt_right hz) + · grw [mul_congr_right (wpow_add_equiv ..), mul_comm (r : IGame), mul_assoc_equiv] + rw [Numeric.mul_lt_mul_iff_right (wpow_pos _), mul_comm] + exact wpow_lt_mul_wpow' hr (Numeric.lt_right hz) +termination_by (x, y) +decreasing_by igame_wf + +theorem wpow_neg_equiv (x : IGame) [Numeric x] : ω^ -x ≈ (ω^ x)⁻¹ := by + apply equiv_inv_of_mul_eq_one ((wpow_add_equiv ..).symm.trans _) + rw [← wpow_zero] + exact wpow_congr (neg_add_equiv x) + +theorem wpow_sub_equiv (x y : IGame) [Numeric x] [Numeric y] : ω^ (x - y) ≈ ω^ x / ω^ y := + (wpow_add_equiv ..).trans (mul_congr_right (wpow_neg_equiv _)) + +end Numeric + +open NatOrdinal in +theorem toIGame_wpow_equiv (x : NatOrdinal) : (ω^ x).toIGame ≈ ω^ x.toIGame := by + have H {y} (h : y < x) (n : ℕ) : toIGame (ω^ y * n) ≈ ω^ y.toIGame * n := + (toIGame_mul ..).trans <| Numeric.mul_congr (toIGame_wpow_equiv y) (toIGame_natCast_equiv n) + obtain rfl | hx := eq_or_ne x 0; · simp + constructor <;> refine le_iff_forall_lf.2 ⟨?_, ?_⟩ + · simp_rw [forall_leftMoves_toIGame, lt_wpow_iff hx] + intro z ⟨y, hy, n, hz⟩ + apply ((toIGame.strictMono hz).trans_le _).not_ge + grw [H hy n] + rw [mul_comm] + simpa using (Numeric.mul_wpow_lt_wpow' n (toIGame.strictMono hy)).le + · simp + · simp_rw [forall_leftMoves_wpow, forall_leftMoves_toIGame] + constructor + · rw [← toIGame_zero, toIGame.le_iff_le] + simp + · intro r hr y hy + obtain ⟨n, hn⟩ := exists_nat_gt r + rw [mul_comm] + apply ((toIGame.strictMono <| wpow_mul_natCast_lt hy n).trans' _).not_ge + grw [H hy n] + rw [Numeric.mul_lt_mul_iff_right] + · exact_mod_cast hn + · exact Numeric.wpow_pos _ + · simp +termination_by x + +end IGame + +/-! ### ω-pow on `Surreal` -/ + +namespace Surreal +open IGame + +variable {x y : Surreal} + +instance : Wpow Surreal where + wpow := Quotient.lift (fun x ↦ mk (ω^ x)) fun _ _ h ↦ mk_eq (Numeric.wpow_congr h) + +@[simp] +theorem mk_wpow (x : IGame) [Numeric x] : mk (ω^ x) = ω^ (mk x) := + rfl + +@[simp] +theorem wpow_zero : ω^ (0 : Surreal) = 1 := + mk_eq IGame.wpow_zero.antisymmRel + +@[simp] +theorem wpow_pos : ∀ x : Surreal, 0 < ω^ x := by + rintro ⟨x, _⟩ + exact Numeric.wpow_pos x + +@[simp] +theorem wpow_nonneg (x : Surreal) : 0 ≤ ω^ x := + (wpow_pos x).le + +@[simp] +theorem wpow_ne_zero (x : Surreal) : ω^ x ≠ 0 := + (wpow_pos x).ne' + +@[simp] +theorem wpow_abs (x : Surreal) : |ω^ x| = ω^ x := + abs_of_pos (wpow_pos x) + +theorem strictMono_wpow : StrictMono (ω^ · : Surreal → _) := by + rintro ⟨x, _⟩ ⟨y, _⟩ + exact Numeric.wpow_lt_wpow.2 + +@[simp] +theorem wpow_lt_wpow : ω^ x < ω^ y ↔ x < y := + strictMono_wpow.lt_iff_lt + +@[simp] +theorem wpow_le_wpow : ω^ x ≤ ω^ y ↔ x ≤ y := + strictMono_wpow.le_iff_le + +@[simp] +theorem wpow_inj : ω^ x = ω^ y ↔ x = y := + strictMono_wpow.injective.eq_iff + +@[simp] +theorem wpow_add : ∀ x y : Surreal, ω^ (x + y) = ω^ x * ω^ y := by + rintro ⟨x, _⟩ ⟨y, _⟩ + exact mk_eq (Numeric.wpow_add_equiv x y) + +@[simp] +theorem wpow_neg : ∀ x : Surreal, ω^ -x = (ω^ x)⁻¹ := by + rintro ⟨x, _⟩ + exact mk_eq (Numeric.wpow_neg_equiv x) + +@[simp] +theorem wpow_sub : ∀ x y : Surreal, ω^ (x - y) = ω^ x / ω^ y := by + rintro ⟨x, _⟩ ⟨y, _⟩ + exact mk_eq (Numeric.wpow_sub_equiv x y) + +theorem mul_wpow_lt_wpow (r : ℝ) (h : x < y) : r * ω^ x < ω^ y := by + cases x; cases y; exact IGame.Numeric.mul_wpow_lt_wpow r h + +theorem wpow_lt_mul_wpow {r : ℝ} (hr : 0 < r) (h : x < y) : ω^ x < r * ω^ y := by + cases x; cases y; exact IGame.Numeric.wpow_lt_mul_wpow hr h + +theorem mul_wpow_lt_mul_wpow (r : ℝ) {s : ℝ} (hs : 0 < s) (h : x < y) : r * ω^ x < s * ω^ y := by + cases x; cases y; exact IGame.Numeric.mul_wpow_lt_mul_wpow r hs h + +/-! ### Archimedean classes -/ + +open ArchimedeanClass + +@[simp] +theorem mk_realCast {r : ℝ} (hr : r ≠ 0) : ArchimedeanClass.mk (r : Surreal) = 0 := + mk_map_of_archimedean' Real.toSurrealRingHom hr + +/-- We define a `ValuativeRel` instance on `Surreal` which is compatible with +`ArchimedeanClass.addValuation`. In particular, you can write `x =ᵥ y` to mean that `x` is +commensurate with `y`. -/ +instance : ValuativeRel Surreal := + .ofValuation (ArchimedeanClass.addValuation _) + +instance : (ArchimedeanClass.addValuation Surreal).Compatible where + vle_iff_le _ _ := .rfl + +theorem vle_def {x y : Surreal} : x ≤ᵥ y ↔ ArchimedeanClass.mk y ≤ .mk x := + .rfl + +theorem vlt_def {x y : Surreal} : x <ᵥ y ↔ ArchimedeanClass.mk y < .mk x := + (ArchimedeanClass.addValuation _).vlt_iff_lt + +theorem veq_def {x y : Surreal} : x =ᵥ y ↔ ArchimedeanClass.mk x = .mk y := + (ArchimedeanClass.addValuation _).veq_iff_eq + +@[simp] theorem neg_veq {x y : Surreal} : -x =ᵥ y ↔ x =ᵥ y := by simp [veq_def] +@[simp] theorem veq_neg {x y : Surreal} : x =ᵥ -y ↔ x =ᵥ y := by simp [veq_def] +@[simp] theorem vle_neg {x y : Surreal} : x ≤ᵥ -y ↔ x ≤ᵥ y := by simp [vle_def] +@[simp] theorem neg_vle {x y : Surreal} : -x ≤ᵥ y ↔ x ≤ᵥ y := by simp [vle_def] +@[simp] theorem vlt_neg {x y : Surreal} : x <ᵥ -y ↔ x <ᵥ y := by simp [vlt_def] +@[simp] theorem neg_vlt {x y : Surreal} : -x <ᵥ y ↔ x <ᵥ y := by simp [vlt_def] + +theorem archimedeanClassMk_wpow_strictAnti : + StrictAnti fun x : Surreal ↦ ArchimedeanClass.mk (ω^ x) := by + refine fun x y h ↦ (mk_antitoneOn (wpow_nonneg _) (wpow_nonneg _) + (wpow_le_wpow.2 h.le)).lt_of_not_ge fun ⟨n, hn⟩ ↦ hn.not_gt ?_ + simpa using mul_wpow_lt_wpow n h + +@[simp] +theorem wpow_vlt_wpow_iff : ω^ x <ᵥ ω^ y ↔ x < y := + vlt_def.trans archimedeanClassMk_wpow_strictAnti.lt_iff_gt + +@[simp] +theorem wpow_vle_wpow_iff : ω^ x ≤ᵥ ω^ y ↔ x ≤ y := + vle_def.trans archimedeanClassMk_wpow_strictAnti.le_iff_ge + +/-- `ω^ x` and `ω^ y` are commensurate iff `x = y`. -/ +@[simp] +theorem wpow_veq_wpow_iff : ω^ x =ᵥ ω^ y ↔ x = y := + veq_def.trans archimedeanClassMk_wpow_strictAnti.injective.eq_iff + +private theorem mk_lt_mk_of_ne {x : IGame} [Numeric x] (h : 0 < x) + (Hl : ∀ y (h : y ∈ xᴸ), 0 < y → have := Numeric.of_mem_moves h; + ArchimedeanClass.mk (mk y) ≠ .mk (mk x)) : + ∀ y (h : y ∈ xᴸ), 0 < y → have := Numeric.of_mem_moves h; + ArchimedeanClass.mk (mk x) < .mk (mk y) := + fun y hy hy' ↦ lt_of_le_of_ne' (mk_antitoneOn hy'.le h.le (Numeric.left_lt hy).le) (Hl y hy hy') + +private theorem mk_lt_mk_of_ne' {x : IGame} [Numeric x] (h : 0 < x) + (Hr : ∀ y (h : y ∈ xᴿ), have := Numeric.of_mem_moves h; + ArchimedeanClass.mk (mk y) ≠ .mk (mk x)) : + ∀ y (h : y ∈ xᴿ), have := Numeric.of_mem_moves h; + ArchimedeanClass.mk (mk y) < .mk (mk x) := + fun y hy ↦ have hy' := (Numeric.lt_right hy); + lt_of_le_of_ne (mk_antitoneOn h.le (h.trans hy').le hy'.le) (Hr y hy) + +local instance (x : IGame) [Numeric x] (y : (xᴸ ∩ Ioi 0 :)) : Numeric y := + .of_mem_moves y.2.1 + +private theorem numeric_of_forall_mk_ne_mk' {x : IGame} [Numeric x] (h : 0 < x) + {f : (xᴸ ∩ Ioi 0 :) → Subtype Numeric.{u}} {g : xᴿ → Subtype Numeric.{u}} + (hf : ∀ y, ArchimedeanClass.mk (ω^ (mk (f y).1)) = .mk (mk y.1)) + (hg : ∀ y, ArchimedeanClass.mk (ω^ (mk (g y).1)) = .mk (mk y.1)) + (Hl : ∀ y (h : y ∈ xᴸ), 0 < y → have := Numeric.of_mem_moves h; + ArchimedeanClass.mk (mk y) ≠ .mk (mk x)) + (Hr : ∀ y (h : y ∈ xᴿ), have := Numeric.of_mem_moves h; + ArchimedeanClass.mk (mk y) ≠ .mk (mk x)) : + Numeric !{range (Subtype.val ∘ f) | range (Subtype.val ∘ g)} := by + apply Numeric.mk + · simp_rw [leftMoves_ofSets, rightMoves_ofSets] + rintro _ ⟨a, rfl⟩ _ ⟨b, rfl⟩ + simp_rw [Function.comp_apply, ← mk_lt_mk, ← wpow_vlt_wpow_iff, vlt_def, hf, hg] + exact (mk_lt_mk_of_ne' h Hr _ b.2).trans (mk_lt_mk_of_ne h Hl _ a.2.1 a.2.2) + · aesop (add simp [Subtype.prop]) + +private theorem wpow_equiv_of_forall_mk_ne_mk' {x : IGame.{u}} [Numeric x] (h : 0 < x) + {f : (xᴸ ∩ Ioi 0 :) → Subtype Numeric.{u}} {g : xᴿ → Subtype Numeric.{u}} + (hf : ∀ y, ArchimedeanClass.mk (ω^ (mk (f y).1)) = .mk (mk y.1)) + (hg : ∀ y, ArchimedeanClass.mk (ω^ (mk (g y).1)) = .mk (mk y.1)) + (Hl : ∀ y (h : y ∈ xᴸ), 0 < y → have := Numeric.of_mem_moves h; + ArchimedeanClass.mk (mk y) ≠ .mk (mk x)) + (Hr : ∀ y (h : y ∈ xᴿ), have := Numeric.of_mem_moves h; + ArchimedeanClass.mk (mk y) ≠ .mk (mk x)) : + ω^ !{range (Subtype.val ∘ f) | range (Subtype.val ∘ g)} ≈ x := by + have Hl' := mk_lt_mk_of_ne h Hl + have Hr' := mk_lt_mk_of_ne' h Hr + have := numeric_of_forall_mk_ne_mk' h hf hg Hl Hr + apply (Fits.equiv_of_forall_moves ..).symm + · constructor + · simp_rw [forall_leftMoves_wpow, leftMoves_ofSets, forall_mem_range, + Function.comp_apply, ← Surreal.mk_le_mk] + refine ⟨h.not_ge, fun r hr y ↦ (lt_of_mk_lt_mk_of_nonneg ?_ h.le).not_ge⟩ + simpa [hr.ne', hf] using Hl' _ y.2.1 y.2.2 + · simp_rw [forall_rightMoves_wpow, rightMoves_ofSets, forall_mem_range, + Function.comp_apply, ← Surreal.mk_le_mk] + refine fun r hr y ↦ (lt_of_mk_lt_mk_of_nonneg ?_ ?_).not_ge + · simpa [hr.ne', hg] using Hr' _ y.2 + · simpa using hr.le + all_goals + intro y hy + numeric + simp only [exists_rightMoves_wpow, exists_leftMoves_wpow] + · refine or_iff_not_imp_left.2 fun hy' ↦ ?_ + rw [Numeric.not_le] at hy' + obtain ⟨(_ | n), hn⟩ := (hf ⟨y, hy, hy'⟩).le + · apply (hy'.not_antisymmRel_symm _).elim + simpa [← mk_eq_mk] using hn + · refine ⟨n + 1, mod_cast n.succ_pos, ?_⟩ + simp_rw [leftMoves_ofSets, exists_range_iff, Function.comp_apply, ← Surreal.mk_le_mk] + use ⟨y, hy, hy'⟩ + convert ←hn + · exact abs_of_pos hy' + · simp + · obtain ⟨r, hr, hr'⟩ := mk_le_mk_iff_dyadic.1 (hg ⟨y, hy⟩).ge + refine ⟨r, hr, ?_⟩ + simp_rw [rightMoves_ofSets, exists_range_iff, Function.comp_apply, ← Surreal.mk_le_mk] + use ⟨y, hy⟩ + convert ←hr' using 1 + · simp + · exact abs_of_pos <| h.trans (Numeric.lt_right hy) + +private theorem exists_mk_wpow_eq {x : IGame.{u}} [Numeric x] (h : 0 < x) : + ∃ y : Subtype Numeric, ArchimedeanClass.mk (ω^ mk y) = .mk (mk x) := by + have IHl (y : (xᴸ ∩ Ioi 0 :)) : + ∃ z : Subtype Numeric, ArchimedeanClass.mk (ω^ mk z) = .mk (mk y) := + have := y.2.1; exists_mk_wpow_eq y.2.2 + have IHr (y : xᴿ) : + ∃ z : Subtype Numeric, ArchimedeanClass.mk (ω^ mk z) = .mk (mk y) := + exists_mk_wpow_eq (h.trans (Numeric.lt_right y.2)) + choose f hf using IHl + choose g hg using IHr + by_contra! H + have Hf (y : IGame) (h : y ∈ xᴸ) (hy : 0 < y) : + have := Numeric.of_mem_moves h; ArchimedeanClass.mk (mk y) ≠ ArchimedeanClass.mk (mk x) := by + dsimp + rw [← hf ⟨y, h, hy⟩] + exact H _ + have Hg (y : IGame) (h : y ∈ xᴿ) : + have := Numeric.of_mem_moves h; ArchimedeanClass.mk (mk y) ≠ ArchimedeanClass.mk (mk x) := by + dsimp + rw [← hg ⟨y, h⟩] + exact H _ + have := numeric_of_forall_mk_ne_mk' h hf hg Hf Hg + apply H ⟨_, this⟩ + congr + rw [← mk_wpow, mk_eq_mk] + exact wpow_equiv_of_forall_mk_ne_mk' h hf hg Hf Hg +termination_by x +decreasing_by igame_wf + +/-- Every non-zero surreal is commensurate to some `ω^ x`. -/ +theorem exists_wpow_veq (h : x ≠ 0) : ∃ y, ω^ y =ᵥ x := by + simp_rw [veq_def] + obtain h | h := h.lt_or_gt <;> cases x + · obtain ⟨⟨y, _⟩, hy⟩ := exists_mk_wpow_eq (IGame.zero_lt_neg.2 h) + use .mk y + simpa using hy + · obtain ⟨⟨y, _⟩, hy⟩ := exists_mk_wpow_eq h + exact ⟨_, hy⟩ + +/-! ### ω-logarithm -/ + +/-- The ω-logarithm of a positive surreal `x` is the unique surreal `y` such that `x` is +commensurate with `ω^ y`. + +As with `Real.log`, we set junk values `wlog 0 = 0` and `wlog (-x) = wlog x`. -/ +def wlog (x : Surreal) : Surreal := + if h : x = 0 then 0 else Classical.choose (exists_wpow_veq h) + +/-- Returns an arbitrary representative for `Surreal.wlog`. -/ +def _root_.IGame.wlog (x : IGame) : IGame := by + classical exact if _ : Numeric x then (Surreal.mk x).wlog.out else 0 + +instance _root_.IGame.Numeric.wlog (x : IGame) : Numeric x.wlog := by + rw [IGame.wlog] + split_ifs <;> infer_instance + +@[simp] +theorem mk_wlog (x : IGame) [h : Numeric x] : mk x.wlog = (mk x).wlog := by + simp_rw [IGame.wlog, dite_eq_left h, Surreal.out_eq] + +@[simp] +theorem wlog_zero : wlog 0 = 0 := + dite_eq_left rfl + +theorem wpow_wlog_veq (h : x ≠ 0) : ω^ wlog x =ᵥ x := by + rw [wlog, dite_eq_right h] + exact Classical.choose_spec (exists_wpow_veq h) + +@[simp] +theorem archimedeanClassMk_wpow_wlog (h : x ≠ 0) : ArchimedeanClass.mk (ω^ x.wlog) = .mk x := + veq_def.1 (wpow_wlog_veq h) + +theorem wlog_eq_of_wpow_veq (h : ω^ y =ᵥ x) : wlog x = y := by + obtain rfl | hx := eq_or_ne x 0 + · simp at h + · grw [← wpow_wlog_veq hx, wpow_veq_wpow_iff] at h + rwa [eq_comm] at h + +@[simp] +theorem wlog_eq_iff (h : x ≠ 0) : wlog x = y ↔ ω^ y =ᵥ x := + ⟨fun hy ↦ hy ▸ wpow_wlog_veq h, wlog_eq_of_wpow_veq⟩ + +theorem wlog_congr (h : x =ᵥ y) : wlog x = wlog y := by + obtain rfl | hy := eq_or_ne y 0; · simp_all + apply wlog_eq_of_wpow_veq + grw [wpow_wlog_veq hy] + rwa [ValuativeRel.veq_comm] + +@[simp] +theorem wlog_wpow (x : Surreal) : wlog (ω^ x) = x := by + simp + +@[simp] +theorem wlog_neg (x : Surreal) : wlog (-x) = wlog x := by + obtain rfl | hx := eq_or_ne x 0 + · simp + · apply wlog_eq_of_wpow_veq + simpa using wpow_wlog_veq hx + +@[simp] +theorem wlog_abs (x : Surreal) : wlog |x| = wlog x := + abs_by_cases (wlog · = _) rfl (wlog_neg _) + +theorem wlog_surjective : Function.Surjective wlog := + fun _ ↦ ⟨_, wlog_wpow _⟩ + +theorem wlog_monotoneOn : MonotoneOn wlog (Ioi 0) := by + intro a ha b hb h + grw [← wpow_vle_wpow_iff, wpow_wlog_veq ha.ne', wpow_wlog_veq hb.ne'] + apply mk_antitoneOn ha.le hb.le h + +theorem wlog_antitoneOn : AntitoneOn wlog (Iio 0) := by + intro a ha b hb h + rw [← neg_le_neg_iff] at h + convert wlog_monotoneOn _ _ h using 1 <;> simp_all + +theorem wlog_add_eq_left {x y : Surreal} (h : y <ᵥ x) : wlog (x + y) = wlog x := by + apply wlog_congr + rw [veq_def, mk_add_eq_mk_left (vlt_def.1 h)] + +theorem wlog_add_eq_right {x y : Surreal} (h : y <ᵥ x) : wlog (y + x) = wlog x := by + rw [add_comm, wlog_add_eq_left h] + +theorem wlog_sub_eq_left {x y : Surreal} : y <ᵥ x → wlog (x - y) = wlog x := by + simpa [sub_eq_add_neg] using @wlog_add_eq_left x (-y) + +theorem wlog_sub_eq_right {x y : Surreal} : y <ᵥ x → wlog (y - x) = wlog x := by + simpa [sub_eq_add_neg] using @wlog_add_eq_right (-x) y + +theorem wlog_le_wlog_iff (hx : x ≠ 0) (hy : y ≠ 0) : wlog x ≤ wlog y ↔ x ≤ᵥ y := by + rw [← wpow_vle_wpow_iff] + -- TODO: why does `grw` not work on the iff? + constructor + · intro h + grw [wpow_wlog_veq hx, wpow_wlog_veq hy] at h + exact h + · intro h + grw [wpow_wlog_veq hx, wpow_wlog_veq hy] + exact h + +theorem wlog_le_wlog_of_vle (hx : x ≠ 0) (h : x ≤ᵥ y) : wlog x ≤ wlog y := by + obtain rfl | hy := eq_or_ne y 0; · simp_all + rwa [wlog_le_wlog_iff hx hy] + +theorem wlog_lt_wlog_iff (hx : x ≠ 0) (hy : y ≠ 0) : wlog x < wlog y ↔ x <ᵥ y := by + rw [← not_le, wlog_le_wlog_iff hy hx, ValuativeRel.not_vle] + +theorem wlog_lt_wlog_of_vlt (hx : x ≠ 0) (h : x <ᵥ y) : wlog x < wlog y := by + obtain rfl | hy := eq_or_ne y 0; · simp at h + rwa [wlog_lt_wlog_iff hx hy] + +@[simp] +theorem wlog_mul {x y : Surreal} (hx : x ≠ 0) (hy : y ≠ 0) : wlog (x * y) = wlog x + wlog y := by + apply wlog_eq_of_wpow_veq + rw [wpow_add] + apply ValuativeRel.mul_veq_mul <;> exact wpow_wlog_veq ‹_› + +@[simp] +theorem wlog_realCast (r : ℝ) : wlog r = 0 := by + obtain rfl | hr := eq_or_ne r 0 + · simp + · rw [wlog_eq_iff (mod_cast hr), veq_def, mk_realCast hr, wpow_zero, ArchimedeanClass.mk_one] + +@[simp] theorem wlog_ratCast (q : ℚ) : wlog q = 0 := by simpa using wlog_realCast q +@[simp] theorem wlog_intCast (n : ℤ) : wlog n = 0 := by simpa using wlog_realCast n +@[simp] theorem wlog_natCast (n : ℕ) : wlog n = 0 := by simpa using wlog_realCast n +@[simp] theorem wlog_one : wlog 1 = 0 := mod_cast wlog_natCast 1 + +@[simp] +theorem wlog_inv (x : Surreal) : x⁻¹.wlog = -x.wlog := by + obtain rfl | hx := eq_or_ne x 0; · simp + rw [← add_eq_zero_iff_eq_neg, ← wlog_mul (inv_ne_zero hx) hx, inv_mul_cancel₀ hx, wlog_one] + +@[simp] +theorem wlog_pow (x : Surreal) (n : ℕ) : wlog (x ^ n) = n * wlog x := by + obtain rfl | hx := eq_or_ne x 0 + · cases n <;> simp + · induction n with + | zero => simp + | succ n IH => rw [pow_succ, wlog_mul (pow_ne_zero n hx) hx, IH, Nat.cast_add_one, add_one_mul] + +@[simp] +theorem wlog_zpow (x : Surreal) (n : ℤ) : wlog (x ^ n) = n * wlog x := by + obtain ⟨n, rfl | rfl⟩ := n.eq_nat_or_neg <;> simp + +@[simp high] -- This should fire before `ArchimedeanClass.mk_div` +theorem archimedeanClassMk_div_wpow_wlog (x : Surreal) : + ArchimedeanClass.mk (x / ω^ x.wlog) = .mk x - .mk x := by + obtain rfl | hx := eq_or_ne x 0 <;> simp_all + +theorem mk_div_wpow_wlog_of_ne_zero {x : Surreal} (hx : x ≠ 0) : + ArchimedeanClass.mk (x / ω^ x.wlog) = 0 := by + rw [archimedeanClassMk_div_wpow_wlog, LinearOrderedAddCommGroupWithTop.sub_self_eq_zero_of_ne_top] + simpa + +private theorem ofSets_wlog_eq {x : IGame} : + !{IGame.wlog '' {y ∈ xᴸ | 0 < y} | IGame.wlog '' xᴿ} = + !{range (Subtype.val ∘ fun x : (xᴸ ∩ Ioi 0 :) ↦ ⟨_, Numeric.wlog x⟩) | + range (Subtype.val ∘ fun x : xᴿ ↦ ⟨_, Numeric.wlog x⟩)} := by + congr! <;> exact image_eq_range .. + +private theorem mk_wpow_wlog_left {x : IGame} [Numeric x] : + ∀ y : (xᴸ ∩ Ioi 0 :), ArchimedeanClass.mk (ω^ mk y.1.wlog) = .mk (mk y) := by + intro ⟨y, hy, hy'⟩ + numeric + rw [mk_wlog, ← veq_def] + exact wpow_wlog_veq hy'.ne' + +private theorem mk_wpow_wlog_right {x : IGame} [Numeric x] (h : 0 < x) : + ∀ y : xᴿ, ArchimedeanClass.mk (ω^ mk y.1.wlog) = .mk (mk y) := by + intro ⟨y, hy⟩ + numeric + rw [mk_wlog, ← veq_def] + apply wpow_wlog_veq + simpa [← mk_eq_mk] using (h.trans (Numeric.lt_right hy)).not_antisymmRel_symm + +theorem numeric_of_forall_mk_ne_mk {x : IGame} [Numeric x] (h : 0 < x) + (Hl : ∀ y (hy : y ∈ xᴸ), 0 < y → + ArchimedeanClass.mk (@mk y (Numeric.of_mem_moves hy)) ≠ .mk (mk x)) + (Hr : ∀ y (hy : y ∈ xᴿ), + ArchimedeanClass.mk (@mk y (Numeric.of_mem_moves hy)) ≠ .mk (mk x)) : + Numeric !{IGame.wlog '' {y ∈ xᴸ | 0 < y} | IGame.wlog '' xᴿ} := by + rw [ofSets_wlog_eq] + exact numeric_of_forall_mk_ne_mk' h mk_wpow_wlog_left (mk_wpow_wlog_right h) Hl Hr + +theorem wpow_equiv_of_forall_mk_ne_mk {x : IGame} [Numeric x] (h : 0 < x) + (Hl : ∀ y (hy : y ∈ xᴸ), 0 < y → + ArchimedeanClass.mk (@mk y (Numeric.of_mem_moves hy)) ≠ .mk (mk x)) + (Hr : ∀ y (hy : y ∈ xᴿ), + ArchimedeanClass.mk (@mk y (Numeric.of_mem_moves hy)) ≠ .mk (mk x)) : + ω^ !{IGame.wlog '' {y ∈ xᴸ | 0 < y} | IGame.wlog '' xᴿ} ≈ x := by + rw [ofSets_wlog_eq] + exact wpow_equiv_of_forall_mk_ne_mk' h mk_wpow_wlog_left (mk_wpow_wlog_right h) Hl Hr + +/-- A game not commensurate with its positive options is a power of `ω`. -/ +theorem mem_range_wpow_of_forall_mk_ne_mk {x : IGame} [Numeric x] (h : 0 < x) + (Hl : ∀ y (hy : y ∈ xᴸ), 0 < y → + ArchimedeanClass.mk (@mk y (Numeric.of_mem_moves hy)) ≠ .mk (mk x)) + (Hr : ∀ y (hy : y ∈ xᴿ), + ArchimedeanClass.mk (@mk y (Numeric.of_mem_moves hy)) ≠ .mk (mk x)) : + mk x ∈ range (ω^ ·) := by + have hn := numeric_of_forall_mk_ne_mk h Hl Hr + exact ⟨@mk _ hn, mk_eq (wpow_equiv_of_forall_mk_ne_mk h Hl Hr)⟩ + +@[simp] +theorem toSurreal_wpow (x : NatOrdinal) : (ω^ x).toSurreal = ω^ x.toSurreal := + Surreal.mk_eq (toIGame_wpow_equiv x) + +end Surreal +end diff --git a/LeanPool/ConwayRefinement/CombinatorialGames/Surreal/Real.lean b/LeanPool/ConwayRefinement/CombinatorialGames/Surreal/Real.lean new file mode 100644 index 0000000000..0577c1e65d --- /dev/null +++ b/LeanPool/ConwayRefinement/CombinatorialGames/Surreal/Real.lean @@ -0,0 +1,746 @@ +/- +Copyright (c) 2025 Violeta Hernández Palacios. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Violeta Hernández Palacios +-/ +module + +public import LeanPool.ConwayRefinement.CombinatorialGames.Surreal.Dyadic +public import Mathlib.Algebra.Order.Archimedean.Defs +public import Mathlib.Algebra.Order.Hom.Ring + +/-! +# Real numbers as games + +We define the function `Real.toIGame`, casting a real number to its Dedekind cut, and prove that +it's an order embedding. We then define the `ConwayGame` and `Surreal` versions of this map, +and prove +that they are ring and field homomorphisms respectively. + +## TODO + +Prove that every real number has birthday at most `ω`. +-/ + +universe u + +open IGame + +@[expose] public noncomputable section + +theorem exists_dyadic_btwn {K : Type*} [Field K] [LinearOrder K] [IsStrictOrderedRing K] + [Archimedean K] {x y : K} (h : x < y) : ∃ q : Dyadic, x < q.toRat ∧ q.toRat < y := by + obtain ⟨n, nh⟩ := exists_nat_gt (y - x)⁻¹ + have := nh.trans (Nat.cast_lt.2 Nat.lt_two_pow_self) + obtain ⟨z, hz, hz'⟩ := exists_div_btwn h (nh.trans (Nat.cast_lt.2 Nat.lt_two_pow_self)) + have hnPower : 2 ^ n ∈ Submonoid.powers (2 : ℕ) := + Submonoid.pow_mem _ (Submonoid.mem_powers _) _ + have hcast : ((Dyadic.mkRat z (n := 2 ^ n) hnPower).toRat : K) = + (z : K) / (2 ^ n : ℕ) := by + rw [Dyadic.coe_mkRat] + simp only [Rat.mkRat_eq_div, Rat.cast_div, Rat.cast_intCast, + Rat.cast_pow, Rat.cast_ofNat, Nat.cast_pow, Nat.cast_ofNat] + refine ⟨.mkRat z (n := 2 ^ n) hnPower, ?_⟩ + rw [hcast] + exact ⟨hz, hz'⟩ + +namespace Real + +/-! ### `ℝ` to `IGame` -/ + +/-- The canonical map from `ℝ` to `IGame`, sending a real number to its Dedekind cut of dyadic +rationals. -/ +@[coe, match_pattern] def toIGame (x : ℝ) : IGame.{u} := + !{(↑) '' {q : Dyadic | q.toRat < x} | (↑) '' {q : Dyadic | x < q.toRat}} + +instance : Coe ℝ IGame := ⟨toIGame⟩ + +instance Numeric.toIGame (x : ℝ) : Numeric x := by + rw [Real.toIGame] + apply Numeric.mk + · simp only [leftMoves_ofSets, rightMoves_ofSets, Set.forall_mem_image, Set.mem_ofPred] + intro x hx y hy + simpa using hx.trans hy + · aesop (add simp [Numeric.dyadic]) + +@[simp] +theorem leftMoves_toIGame (x : ℝ) : xᴸ = (↑) '' {q : Dyadic | q.toRat < x} := + leftMoves_ofSets .. + +@[simp] +theorem rightMoves_toIGame (x : ℝ) : xᴿ = (↑) '' {q : Dyadic | x < q.toRat} := + rightMoves_ofSets .. + +theorem forall_leftMoves_toIGame {P : IGame → Prop} {x : ℝ} : + (∀ y ∈ xᴸ, P y) ↔ ∀ q : Dyadic, q.toRat < x → P q := by + aesop + +theorem exists_leftMoves_toIGame {P : IGame → Prop} {x : ℝ} : + (∃ y ∈ xᴸ, P y) ↔ ∃ q : Dyadic, q.toRat < x ∧ P q := by + aesop + +theorem forall_rightMoves_toIGame {P : IGame → Prop} {x : ℝ} : + (∀ y ∈ xᴿ, P y) ↔ ∀ q : Dyadic, x < q.toRat → P q := by + aesop + +theorem exists_rightMoves_toIGame {P : IGame → Prop} {x : ℝ} : + (∃ y ∈ xᴿ, P y) ↔ ∃ q : Dyadic, x < q.toRat ∧ P q := by + aesop + +theorem mem_leftMoves_toIGame_of_lt {q : Dyadic} {x : ℝ} (h : q.toRat < x) : + (q : IGame) ∈ xᴸ := by + simpa + +theorem mem_rightMoves_toIGame_of_lt {q : Dyadic} {x : ℝ} (h : x < q.toRat) : + (q : IGame) ∈ xᴿ := by + simpa + +/-- `Real.toIGame` as an `OrderEmbedding`. -/ +@[simps!] +def toIGameEmbedding : ℝ ↪o IGame := by + refine .ofStrictMono toIGame fun x y h ↦ ?_ + obtain ⟨q, hx, hy⟩ := exists_dyadic_btwn h + trans (q : IGame) + · apply Numeric.lt_right + simpa [toIGame] + · apply Numeric.left_lt + simpa [toIGame] + +@[simp, norm_cast] +theorem toIGame_le_iff {x y : ℝ} : (x : IGame) ≤ y ↔ x ≤ y := + toIGameEmbedding.le_iff_le + +@[simp, norm_cast] +theorem toIGame_lt_iff {x y : ℝ} : (x : IGame) < y ↔ x < y := + toIGameEmbedding.lt_iff_lt + +@[simp, norm_cast] +theorem toIGame_equiv_iff {x y : ℝ} : (x : IGame) ≈ y ↔ x = y := by + simp [AntisymmRel, le_antisymm_iff] + +@[simp, norm_cast] +theorem toIGame_inj {x y : ℝ} : (x : IGame) = y ↔ x = y := + toIGameEmbedding.inj + +@[simp, norm_cast] +theorem toIGame_neg (x : ℝ) : toIGame (-x) = -toIGame x := by + simp_rw [toIGame, neg_ofSets, ofSets_inj, + ← Set.image_neg_of_apply_neg_eq_neg (fun _ _ ↦ Dyadic.toIGame_neg _)] + aesop (add simp [lt_neg, neg_lt]) + +theorem toIGame_ratCast_equiv (q : ℚ) : toIGame q ≈ q := by + rw [AntisymmRel, le_iff_forall_lf, le_iff_forall_lf] + refine ⟨⟨?_, fun x hx ↦ ?_⟩, ⟨fun x hx ↦ ?_, ?_⟩⟩ + · aesop + · obtain ⟨r, hr, hr'⟩ := equiv_ratCast_of_mem_rightMoves_ratCast hx + obtain ⟨s, hs, hs'⟩ := exists_dyadic_btwn hr + rw [← IGame.ratCast_lt] at hs' + grw [← hr'] at hs' + apply lf_of_right_le (z := s) + · rw [Rat.cast_eq_id, id] at hs' + grw [← s.toIGame_equiv] at hs' + exact hs'.le + · simpa + · obtain ⟨r, hr, hr'⟩ := equiv_ratCast_of_mem_leftMoves_ratCast hx + obtain ⟨s, hs, hs'⟩ := exists_dyadic_btwn hr + rw [← IGame.ratCast_lt] at hs + grw [← hr'] at hs + apply lf_of_le_left (z := s) + · rw [Rat.cast_eq_id, id] at hs + grw [← s.toIGame_equiv] at hs + exact hs.le + · simpa + · aesop + +theorem toIGame_dyadic_equiv (q : Dyadic) : toIGame q.toRat ≈ q := by + rw [q.toIGame_equiv.antisymmRel_congr_right] + exact toIGame_ratCast_equiv _ + +theorem toIGame_natCast_equiv (n : ℕ) : toIGame n ≈ n := by + rw [← Rat.cast_natCast] + simpa using toIGame_dyadic_equiv n + +theorem toIGame_intCast_equiv (n : ℤ) : toIGame n ≈ n := by + rw [← Rat.cast_intCast] + simpa using toIGame_dyadic_equiv n + +theorem toIGame_zero_equiv : toIGame 0 ≈ 0 := by simpa using toIGame_natCast_equiv 0 +theorem toIGame_one_equiv : toIGame 1 ≈ 1 := by simpa using toIGame_natCast_equiv 1 + +@[simp, norm_cast] +theorem ratCast_lt_toIGame {q : ℚ} {x : ℝ} : q < (x : IGame) ↔ q < x := by + rw [← (toIGame_ratCast_equiv q).lt_congr_left, toIGame_lt_iff] +@[simp, norm_cast] +theorem toIGame_lt_ratCast {q : ℚ} {x : ℝ} : (x : IGame) < q ↔ x < q := by + rw [← (toIGame_ratCast_equiv q).lt_congr_right, toIGame_lt_iff] + +@[simp, norm_cast] +theorem ratCast_le_toIGame {q : ℚ} {x : ℝ} : q ≤ (x : IGame) ↔ q ≤ x := by + simp [← not_lt, ← Numeric.not_lt] +@[simp, norm_cast] +theorem toIGame_le_ratCast {q : ℚ} {x : ℝ} : (x : IGame) ≤ q ↔ x ≤ q := by + simp [← not_lt, ← Numeric.not_lt] + +@[simp, norm_cast] +theorem ratCast_equiv_toIGame {q : ℚ} {x : ℝ} : (q : IGame) ≈ (x : IGame) ↔ q = x := by + simp [AntisymmRel, le_antisymm_iff] +@[simp, norm_cast] +theorem toIGame_equiv_ratCast {q : ℚ} {x : ℝ} : (x : IGame) ≈ q ↔ x = q := by + simp [AntisymmRel, le_antisymm_iff] + +theorem toIGame_add_ratCast_equiv (x : ℝ) (q : ℚ) : toIGame (x + q) ≈ x + q := by + rw [AntisymmRel, le_iff_forall_lf, le_iff_forall_lf, forall_moves_add, forall_moves_add] + simp_rw [forall_leftMoves_toIGame, forall_rightMoves_toIGame, Numeric.not_le] + refine ⟨⟨fun r hr ↦ ?_, ⟨fun r hr ↦ ?_, ?_⟩⟩, ⟨⟨fun r hr ↦ ?_, ?_⟩, fun r hr ↦ ?_⟩⟩ + · grw [r.toIGame_equiv] + rw [← IGame.sub_lt_iff_lt_add] + grw [← IGame.ratCast_sub_equiv] + simpa [sub_lt_iff_lt_add] + · grw [r.toIGame_equiv, ← IGame.ratCast_add_equiv] + simpa + · intro y hy + obtain ⟨r, hr, hy⟩ := equiv_ratCast_of_mem_rightMoves_ratCast hy + grw [hy] + rw [← ratCast_lt, ← add_lt_add_iff_left x] at hr + obtain ⟨s, hs, hs'⟩ := exists_rat_btwn hr + apply (lt_trans (b := (s : IGame)) _ _).not_ge + · simpa + · rw [← IGame.sub_lt_iff_lt_add] + grw [← IGame.ratCast_sub_equiv] + simpa [sub_lt_iff_lt_add] + · grw [r.toIGame_equiv, ← IGame.ratCast_add_equiv] + simpa + · intro y hy + obtain ⟨r, hr, hy⟩ := equiv_ratCast_of_mem_leftMoves_ratCast hy + grw [hy] + rw [← ratCast_lt, ← add_lt_add_iff_left x] at hr + obtain ⟨s, hs, hs'⟩ := exists_rat_btwn hr + apply (lt_trans (b := (s : IGame)) _ _).not_ge + · rw [← IGame.lt_sub_iff_add_lt] + grw [← IGame.ratCast_sub_equiv] + simpa [lt_sub_iff_add_lt] + · simpa + · grw [r.toIGame_equiv] + rw [← IGame.lt_sub_iff_add_lt] + grw [← IGame.ratCast_sub_equiv] + simpa [lt_sub_iff_add_lt] + +theorem toIGame_ratCast_add_equiv (q : ℚ) (x : ℝ) : toIGame (q + x) ≈ q + x := by + simpa [add_comm] using toIGame_add_ratCast_equiv x q + +theorem toIGame_add_dyadic_equiv (x : ℝ) (q : Dyadic) : toIGame (x + q.toRat) ≈ x + q := + (toIGame_add_ratCast_equiv _ _).trans (add_congr_right q.toIGame_equiv.symm) + +theorem toIGame_dyadic_add_equiv (q : Dyadic) (x : ℝ) : toIGame (q.toRat + x) ≈ q + x := by + simpa [add_comm] using toIGame_add_dyadic_equiv x q + +theorem toIGame_add_equiv (x y : ℝ) : toIGame (x + y) ≈ x + y := by + rw [AntisymmRel, le_iff_forall_lf, le_iff_forall_lf, forall_moves_add, forall_moves_add] + simp_rw [forall_leftMoves_toIGame, forall_rightMoves_toIGame, Numeric.not_le] + refine ⟨⟨?_, ⟨?_, ?_⟩⟩, ⟨⟨?_, ?_⟩, ?_⟩⟩ <;> intro q hq + · rw [← sub_lt_iff_lt_add] at hq + obtain ⟨r, hr, hr'⟩ := exists_rat_btwn hq + rw [sub_lt_comm] at hr + obtain ⟨s, hs, hs'⟩ := exists_rat_btwn hr + trans r + s + · rw [add_comm, q.toIGame_equiv.lt_congr_left, ← IGame.sub_lt_iff_lt_add, + ← (ratCast_sub_equiv ..).lt_congr_left] + simp_all [← Rat.cast_sub] + · apply add_lt_add <;> simpa + on_goal 5 => + rw [← lt_sub_iff_add_lt] at hq + obtain ⟨r, hr, hr'⟩ := exists_rat_btwn hq + rw [lt_sub_comm] at hr' + obtain ⟨s, hs, hs'⟩ := exists_rat_btwn hr' + trans r + s + · apply add_lt_add <;> simpa + · grw [q.toIGame_equiv] + rw [add_comm, ← IGame.lt_sub_iff_add_lt] + grw [← ratCast_sub_equiv] + simp_all [← Rat.cast_sub] + all_goals + first | grw [← toIGame_dyadic_add_equiv] | grw [← toIGame_add_dyadic_equiv] + simpa + +theorem toIGame_sub_ratCast_equiv (x : ℝ) (q : ℚ) : toIGame (x - q) ≈ x - q := by + simpa [sub_eq_add_neg] using toIGame_add_ratCast_equiv x (-q) + +theorem toIGame_ratCast_sub_equiv (q : ℚ) (x : ℝ) : toIGame (q - x) ≈ q - x := by + simpa [sub_eq_add_neg] using toIGame_ratCast_add_equiv q (-x) + +theorem toIGame_sub_dyadic_equiv (x : ℝ) (q : Dyadic) : toIGame (x - q.toRat) ≈ x - q := by + simpa [sub_eq_add_neg] using toIGame_add_dyadic_equiv x (-q) + +theorem toIGame_dyadic_sub_equiv (q : Dyadic) (x : ℝ) : toIGame (q.toRat - x) ≈ q - x := by + simpa [sub_eq_add_neg] using toIGame_dyadic_add_equiv q (-x) + +theorem toIGame_sub_equiv (x y : ℝ) : toIGame (x - y) ≈ x - y := by + simpa [sub_eq_add_neg] using toIGame_add_equiv x (-y) + +/-! ### `ℝ` to `ConwayGame` -/ + +/-- The canonical map from `ℝ` to `ConwayGame`, sending a real number to its Dedekind cut. -/ +@[coe, match_pattern] def toGame (x : ℝ) : ConwayGame := .mk x + +instance : Coe ℝ ConwayGame := ⟨toGame⟩ + +@[simp] theorem _root_.ConwayGame.mk_real_toIGame (x : ℝ) : .mk x.toIGame = x.toGame := rfl + +theorem toGame_def (x : ℝ) : + toGame x = !{(fun q => q.toRat) '' {q : Dyadic | q.toRat < x} | + (fun q => q.toRat) '' {q : Dyadic | x < q.toRat}} := by + rw [← ConwayGame.mk_real_toIGame, toIGame] + simp [Set.image_image] + +/-- `Real.toGame` as an `OrderEmbedding`. -/ +@[simps!] +def toGameEmbedding : ℝ ↪o ConwayGame := + .ofStrictMono toGame fun _ _ h ↦ toIGameEmbedding.strictMono h + +@[simp, norm_cast] +theorem toGame_le_iff {x y : ℝ} : (x : ConwayGame) ≤ y ↔ x ≤ y := + toGameEmbedding.le_iff_le + +@[simp, norm_cast] +theorem toGame_lt_iff {x y : ℝ} : (x : ConwayGame) < y ↔ x < y := + toGameEmbedding.lt_iff_lt + +@[norm_cast] +theorem toGame_equiv_iff {x y : ℝ} : (x : ConwayGame) ≈ y ↔ x = y := by + simp [AntisymmRel, le_antisymm_iff] + +@[simp, norm_cast] +theorem toGame_inj {x y : ℝ} : (x : ConwayGame) = y ↔ x = y := + toGameEmbedding.inj + +@[simp, norm_cast] +theorem toGame_ratCast (q : ℚ) : toGame q = q := ConwayGame.mk_eq (toIGame_ratCast_equiv q) + +@[simp, norm_cast] +theorem toGame_natCast (n : ℕ) : toGame n = n := by simpa using toGame_ratCast n + +@[simp, norm_cast] +theorem toGame_intCast (n : ℤ) : toGame n = n := by simpa using toGame_ratCast n + +@[simp] theorem toGame_zero : toGame 0 = 0 := by simpa using toGame_natCast 0 +@[simp] theorem toGame_one : toGame 1 = 1 := by simpa using toGame_natCast 1 + +@[simp] +theorem toGame_add (x y : ℝ) : toGame (x + y) = toGame x + toGame y := by + simpa using ConwayGame.mk_eq (toIGame_add_equiv x y) + +@[simp] +theorem toGame_sub (x y : ℝ) : toGame (x - y) = toGame x - toGame y := by + simpa using ConwayGame.mk_eq (toIGame_sub_equiv x y) + +/-- `Real.toGame` as an `OrderAddMonoidHom`. -/ +@[simps] +def toGameAddHom : ℝ →+o ConwayGame where + toFun := toGame + map_zero' := toGame_zero + map_add' := toGame_add + monotone' := toGameEmbedding.monotone + +/-! ### `ℝ` to `Surreal` -/ + +/-- The canonical map from `ℝ` to `Surreal`, sending a real number to its Dedekind cut. -/ +@[coe, match_pattern] def toSurreal (x : ℝ) : Surreal := .mk x + +instance : Coe ℝ Surreal := ⟨toSurreal⟩ + +@[simp] theorem _root_.Surreal.mk_real_toIGame (x : ℝ) : .mk x.toIGame = x.toSurreal := rfl + +private theorem toSurreal_def_aux {x : ℝ} : + ∀ y ∈ ((fun q => q.toRat) '' {q : Dyadic | q.toRat < x} : Set Surreal), + ∀ z ∈ (fun q => q.toRat) '' {q : Dyadic | x < q.toRat}, y < z := by + rintro - ⟨q, hq, rfl⟩ - ⟨r, hr, rfl⟩ + dsimp at * + exact_mod_cast hq.trans hr + +@[simp] theorem toGame_toSurreal (x : ℝ) : x.toSurreal.toGame = x.toGame := rfl + +theorem toSurreal_def (x : ℝ) : toSurreal x = + !{(fun q => q.toRat) '' {q : Dyadic | q.toRat < x} | + ((fun q => q.toRat) '' {q : Dyadic | x < q.toRat})}'(by exact toSurreal_def_aux) := by + rw [← Surreal.toGame_inj, toGame_toSurreal, Surreal.toGame_ofSets, toGame_def] + congr! <;> aesop + +/-- `Real.toSurreal` as an `OrderEmbedding`. -/ +@[simps!] +def toSurrealEmbedding : ℝ ↪o Surreal := + .ofStrictMono toSurreal fun _ _ h ↦ toIGameEmbedding.strictMono h + +@[simp, norm_cast] +theorem toSurreal_le_iff {x y : ℝ} : (x : Surreal) ≤ y ↔ x ≤ y := + toSurrealEmbedding.le_iff_le + +@[simp, norm_cast] +theorem toSurreal_lt_iff {x y : ℝ} : (x : Surreal) < y ↔ x < y := + toSurrealEmbedding.lt_iff_lt + +@[norm_cast] +theorem toSurreal_equiv_iff {x y : ℝ} : (x : Surreal) ≈ y ↔ x = y := by + simp [AntisymmRel, le_antisymm_iff] + +@[simp, norm_cast] +theorem toSurreal_inj {x y : ℝ} : (x : Surreal) = y ↔ x = y := + toSurrealEmbedding.inj + +@[simp, norm_cast] +theorem toSurreal_ratCast (q : ℚ) : toSurreal q = q := by + simpa using Surreal.mk_eq (toIGame_ratCast_equiv q) + +@[simp, norm_cast] theorem toSurreal_natCast (n : ℕ) : toSurreal n = n := by + simpa using toSurreal_ratCast n +@[simp] theorem toSurreal_ofNat (n : ℕ) [n.AtLeastTwo] : toSurreal ofNat(n) = n := + toSurreal_natCast n +@[simp, norm_cast] theorem toSurreal_intCast (n : ℤ) : toSurreal n = n := by + simpa using toSurreal_ratCast n + +@[simp, norm_cast] theorem toSurreal_zero : toSurreal 0 = 0 := by simpa using toSurreal_natCast 0 +@[simp, norm_cast] theorem toSurreal_one : toSurreal 1 = 1 := by simpa using toSurreal_natCast 1 + +@[simp] theorem toSurreal_eq_zero_iff {x : ℝ} : (x : Surreal) = 0 ↔ x = 0 := by norm_cast +@[simp] theorem zero_eq_toSurreal_iff {x : ℝ} : 0 = (x : Surreal) ↔ 0 = x := by norm_cast + +@[simp] theorem toSurreal_eq_one_iff {x : ℝ} : (x : Surreal) = 1 ↔ x = 1 := by norm_cast +@[simp] theorem one_eq_toSurreal_iff {x : ℝ} : 1 = (x : Surreal) ↔ 1 = x := by norm_cast + +@[simp] theorem toSurreal_nonneg_iff {x : ℝ} : 0 ≤ (x : Surreal) ↔ 0 ≤ x := by norm_cast +@[simp] theorem toSurreal_nonpos_iff {x : ℝ} : (x : Surreal) ≤ 0 ↔ x ≤ 0 := by norm_cast + +@[simp] theorem toSurreal_pos_iff {x : ℝ} : 0 < (x : Surreal) ↔ 0 < x := by norm_cast +@[simp] theorem toSurreal_neg_iff {x : ℝ} : (x : Surreal) < 0 ↔ x < 0 := by norm_cast + +@[simp] +theorem toSurreal_neg (x : ℝ) : toSurreal (-x) = -toSurreal x := + Surreal.mk_eq (toIGame_neg _).antisymmRel + +@[simp] +theorem toSurreal_add (x y : ℝ) : toSurreal (x + y) = x + y := + Surreal.mk_eq (toIGame_add_equiv x y) + +@[simp] +theorem toSurreal_sub (x y : ℝ) : toSurreal (x - y) = x - y := + Surreal.mk_eq (toIGame_sub_equiv x y) + +@[simp] +theorem toSurreal_max (x y : ℝ) : max x y = max (toSurreal x) (toSurreal y) := by + have := le_total x y + aesop + +@[simp] +theorem toSurreal_min (x y : ℝ) : min x y = min (toSurreal x) (toSurreal y) := by + have := le_total x y + aesop + +@[simp, norm_cast] +theorem toSurreal_abs (x : ℝ) : |x| = |toSurreal x| := by + simp [abs] + +/-! For convenience, we deal with multiplication after defining `Real.toSurreal`. -/ + +private theorem exists_rat_mul_btwn {a b x : ℝ} (h : a * x < b) : + ∃ q : ℚ, a * x ≤ q * x ∧ q * x < b := by + obtain hx | rfl | hx := lt_trichotomy x 0 + · rw [← div_lt_iff_of_neg hx] at h + obtain ⟨q, hq, hq'⟩ := exists_rat_btwn h + use q, mul_le_mul_of_nonpos_right hq'.le hx.le + rwa [← div_lt_iff_of_neg hx] + · use 0 + simp_all + · rw [← lt_div_iff₀ hx] at h + obtain ⟨q, hq, hq'⟩ := exists_rat_btwn h + use q, mul_le_mul_of_nonneg_right hq.le hx.le + rwa [← lt_div_iff₀ hx] + +private theorem exists_rat_mul_btwn' {a b x : ℝ} (h : a < b * x) : + ∃ q : ℚ, a < q * x ∧ q * x ≤ b * x := by + have : -b * x < -a := by simpa + obtain ⟨q, hq, hq'⟩ := exists_rat_mul_btwn this + use -q + simp_all [lt_neg, neg_le] + +private theorem toIGame_mul_le_mul {x : ℝ} {q r : ℚ} (h : x * r ≤ q * r) : + toIGame x * r ≤ q * r := by + obtain hr | rfl | hr := lt_trichotomy r 0 <;> simp_all + +private theorem toIGame_mul_le_mul' {x : ℝ} {q r : ℚ} (h : q * r ≤ x * r) : + q * r ≤ toIGame x * r := by + obtain hr | rfl | hr := lt_trichotomy r 0 <;> simp_all + +private theorem mulOption_lt_toIGame {x : ℝ} {q r s : ℚ} (h : x * s < x * q - r * q + r * s) : + mulOption (toIGame x) q r s < toIGame.{u} (x * q) := by + obtain ⟨t, ht, ht'⟩ := exists_rat_mul_btwn h + apply lt_of_le_of_lt (b := ((r * q + t * s - r * s :) : IGame)) + · have := toIGame_mul_le_mul.{u} ht + simp_all [mulOption, ← Surreal.mk_le_mk] + · rw [← sub_lt_iff_lt_add, lt_sub_iff_add_lt] at ht' + convert ht' + simp only [ratCast_lt_toIGame, Rat.cast_sub, Rat.cast_add, Rat.cast_mul] + abel_nf + +private theorem toIGame_lt_mulOption {x : ℝ} {q r s : ℚ} (h : x * q - r * q + r * s < x * s) : + toIGame.{u} (x * q) < mulOption (toIGame x) q r s := by + obtain ⟨t, ht, ht'⟩ := exists_rat_mul_btwn' h + apply lt_of_lt_of_le (b := ((r * q + t * s - r * s :) : IGame)) + · rw [← lt_sub_iff_add_lt, sub_lt_iff_lt_add] at ht + convert ht + simp only [toIGame_lt_ratCast, Rat.cast_sub, Rat.cast_add, Rat.cast_mul] + abel_nf + · have := toIGame_mul_le_mul'.{u} ht' + simp_all [mulOption, ← Surreal.mk_le_mk] + +theorem toIGame_mul_ratCast_equiv (x : ℝ) (q : ℚ) : (x * q).toIGame ≈ x * q := by + rw [AntisymmRel, le_iff_forall_lf, le_iff_forall_lf, forall_moves_mul, forall_moves_mul, + Player.forall, Player.forall] + simp_rw [forall_leftMoves_toIGame, forall_rightMoves_toIGame, Numeric.not_le] + refine ⟨⟨fun r h ↦ ?_, ⟨?_, ?_⟩⟩, ⟨⟨?_, ?_⟩, fun r h ↦ ?_⟩⟩ + any_goals intro r hr y hy; numeric + · grw [r.toIGame_equiv] + obtain hq | rfl | hq := lt_trichotomy q 0 + · rw [← lt_div_iff_of_neg (mod_cast hq)] at h + rw [← Numeric.lt_div_iff_of_neg (by simpa)] + grw [← ratCast_div_equiv] + simpa + · simp_all + · rw [← div_lt_iff₀ (mod_cast hq)] at h + rw [← Numeric.div_lt_iff (by simpa)] + grw [← ratCast_div_equiv] + simpa + · obtain ⟨s, hs, hy⟩ := equiv_ratCast_of_mem_rightMoves_ratCast hy + grw [Numeric.mulOption_congr₃ r.toIGame_equiv, Numeric.mulOption_congr₄ hy] + apply (toIGame_lt_mulOption _).not_ge + have : 0 < (x - r.toRat) * (s - q) := by apply mul_pos <;> simpa [sub_pos] + simp_all [sub_mul, mul_sub, lt_sub_iff_add_lt] + · obtain ⟨s, hs, hy⟩ := equiv_ratCast_of_mem_leftMoves_ratCast hy + grw [Numeric.mulOption_congr₃ r.toIGame_equiv, Numeric.mulOption_congr₄ hy] + apply (toIGame_lt_mulOption _).not_ge + have : 0 < (x - r.toRat) * (s - q) := by apply mul_pos_of_neg_of_neg <;> simpa [sub_pos] + simp_all [sub_mul, mul_sub, lt_sub_iff_add_lt] + · obtain ⟨s, hs, hy⟩ := equiv_ratCast_of_mem_leftMoves_ratCast hy + grw [Numeric.mulOption_congr₃ r.toIGame_equiv, Numeric.mulOption_congr₄ hy] + apply (mulOption_lt_toIGame _).not_ge + have : 0 < (x - r.toRat) * (q - s) := by apply mul_pos <;> simpa [sub_pos] + simp_all [sub_mul, mul_sub, sub_lt_iff_lt_add] + · obtain ⟨s, hs, hy⟩ := equiv_ratCast_of_mem_rightMoves_ratCast hy + grw [Numeric.mulOption_congr₃ r.toIGame_equiv, Numeric.mulOption_congr₄ hy] + apply (mulOption_lt_toIGame _).not_ge + have : 0 < (x - r.toRat) * (q - s) := by apply mul_pos_of_neg_of_neg <;> simpa [sub_pos] + simp_all [sub_mul, mul_sub, sub_lt_iff_lt_add] + · rw [r.toIGame_equiv.lt_congr_right] + obtain hq | rfl | hq := lt_trichotomy q 0 + · rw [← div_lt_iff_of_neg (mod_cast hq)] at h + rw [← Numeric.div_lt_iff_of_neg (by simpa)] + grw [← ratCast_div_equiv] + simpa + · simp_all + · rw [← lt_div_iff₀ (mod_cast hq)] at h + rw [← Numeric.lt_div_iff (by simpa)] + grw [← ratCast_div_equiv] + simpa + +theorem toIGame_ratCast_mul_equiv (q : ℚ) (x : ℝ) : (q * x).toIGame ≈ q * x := by + simpa [mul_comm] using toIGame_mul_ratCast_equiv x q + +private theorem dyadic_lt_mul_toIGame' {x y : ℝ} {q : Dyadic} + (hx : 0 < x) (hy : 0 < y) (h : q.toRat < x * y) : (q : IGame) < x * y := by + rw [← div_lt_iff₀ hy] at h + obtain ⟨r, hr, hr'⟩ := exists_rat_btwn (max_lt h hx) + obtain ⟨hr, hr₀⟩ := max_lt_iff.1 hr + rw [div_lt_comm₀ hy hr₀] at hr + obtain ⟨s, hs, hs'⟩ := exists_rat_btwn (max_lt hr hy) + trans r * s + · grw [mul_comm, q.toIGame_equiv, ← IGame.Numeric.div_lt_iff, ← ratCast_div_equiv] <;> + simp_all [← Rat.cast_div] + · simp_rw [← Surreal.mk_lt_mk] + dsimp + apply mul_lt_mul _ (le_of_lt _) _ (le_of_lt _) <;> + simp_all [← toSurreal_zero, ← toSurreal_ratCast] + +private theorem mul_toIGame_lt_dyadic' {x y : ℝ} {q : Dyadic} + (hx : 0 < x) (hy : 0 < y) (h : x * y < q.toRat) : x * y < (q : IGame) := by + rw [← lt_div_iff₀ hy] at h + obtain ⟨r, hr, hr'⟩ := exists_rat_btwn h + have hr₀ := hx.trans hr + rw [lt_div_comm₀ hr₀ hy] at hr' + obtain ⟨s, hs, hs'⟩ := exists_rat_btwn hr' + trans r * s + · simp_rw [← Surreal.mk_lt_mk] + dsimp + apply mul_lt_mul _ (le_of_lt _) _ (le_of_lt _) <;> + simp_all [← toSurreal_zero, ← toSurreal_ratCast] + · grw [mul_comm, q.toIGame_equiv, ← IGame.Numeric.lt_div_iff, ← ratCast_div_equiv] <;> + simp_all [← Rat.cast_div] + +private theorem dyadic_lt_mul_toIGame {x y : ℝ} (q : Dyadic) (h : q.toRat < x * y) : + (q : IGame.{u}) < x * y := by + obtain hx | rfl | hx := lt_trichotomy x 0 + · obtain hy | rfl | hy := lt_trichotomy y 0 + · have := @dyadic_lt_mul_toIGame'.{u} (-x) (-y) q + simp_all + · grw [Numeric.mul_congr_right toIGame_zero_equiv] + simp_all + · have := @mul_toIGame_lt_dyadic'.{u} (-x) y (-q) + simp_all + · grw [Numeric.mul_congr_left toIGame_zero_equiv] + simp_all + · obtain hy | rfl | hy := lt_trichotomy y 0 + · have := @mul_toIGame_lt_dyadic'.{u} x (-y) (-q) + simp_all + · grw [Numeric.mul_congr_right toIGame_zero_equiv] + simp_all + · exact dyadic_lt_mul_toIGame' hx hy h + +private theorem mul_toIGame_lt_dyadic {x y : ℝ} (q : Dyadic) (h : x * y < q.toRat) : + x * y < (q : IGame.{u}) := by + have := @dyadic_lt_mul_toIGame.{u} (-x) y (-q) + simp_all + +private theorem toSurreal_mul_ratCast (x : ℝ) (q : ℚ) : toSurreal (x * q) = x * q := by + simpa using Surreal.mk_eq (toIGame_mul_ratCast_equiv x q) + +private theorem mulOption_toIGame_equiv {x y : ℝ} {q r : Dyadic} : + mulOption (toIGame x) (toIGame y) q r ≈ + toIGame (q.toRat * y + x * r.toRat - q.toRat * r.toRat) := by + simp [← Surreal.mk_eq_mk, mulOption, mul_comm, toSurreal_mul_ratCast] + +theorem toIGame_mul_equiv (x y : ℝ) : (x * y).toIGame ≈ x * y := by + rw [AntisymmRel, le_iff_forall_lf, le_iff_forall_lf, forall_moves_mul, forall_moves_mul, + Player.forall, Player.forall] + dsimp + simp_rw [forall_leftMoves_toIGame, forall_rightMoves_toIGame, Numeric.not_le] + refine ⟨⟨dyadic_lt_mul_toIGame, ⟨?_, ?_⟩⟩, ⟨⟨?_, ?_⟩, mul_toIGame_lt_dyadic⟩⟩ <;> + (intro q hq r hr; grw [mulOption_toIGame_equiv]; rw [toIGame_lt_iff]) + · have : 0 < (x - q.toRat) * (r.toRat - y) := by apply mul_pos <;> simpa [sub_pos] + simp_all [sub_mul, mul_sub, sub_lt_iff_lt_add', add_sub_assoc] + · have : 0 < (x - q.toRat) * (r.toRat - y) := by apply mul_pos_of_neg_of_neg <;> simpa [sub_pos] + simp_all [sub_mul, mul_sub, sub_lt_iff_lt_add', add_sub_assoc] + · have : 0 < (x - q.toRat) * (y - r.toRat) := by apply mul_pos <;> simpa [sub_pos] + simp_all [sub_mul, mul_sub, lt_sub_iff_add_lt', add_sub_assoc] + · have : 0 < (x - q.toRat) * (y - r.toRat) := by apply mul_pos_of_neg_of_neg <;> simpa [sub_pos] + simp_all [sub_mul, mul_sub, lt_sub_iff_add_lt', add_sub_assoc] + +@[simp, norm_cast] +theorem toSurreal_mul (x y : ℝ) : (x * y).toSurreal = x * y := + Surreal.mk_eq (toIGame_mul_equiv x y) + +/-- `Real.toSurreal` as an `OrderRingHom`. -/ +@[simps] +def toSurrealRingHom : ℝ →+*o Surreal where + toFun := toSurreal + map_zero' := toSurreal_zero + map_one' := toSurreal_one + map_add' := toSurreal_add + map_mul' := toSurreal_mul + monotone' := toSurrealEmbedding.monotone + +@[simp, norm_cast] +theorem toSurreal_inv (x : ℝ) : x⁻¹.toSurreal = x.toSurreal⁻¹ := + map_inv₀ toSurrealRingHom x + +@[simp, norm_cast] +theorem toSurreal_div (x y : ℝ) : (x / y).toSurreal = x / y := + map_div₀ toSurrealRingHom x y + +theorem toIGame_inv_equiv (x : ℝ) : x⁻¹.toIGame ≈ x.toIGame⁻¹ := by + simp [← Surreal.mk_eq_mk] + +theorem toIGame_div_equiv (x y : ℝ) : (x / y).toIGame ≈ x / y := by + simp [← Surreal.mk_eq_mk] + +/-! ### Simp lemmas -/ + +/-! #### Dyadic -/ + +@[simp, norm_cast] +theorem dyadic_lt_toIGame {q : Dyadic} {x : ℝ} : q < (x : IGame) ↔ q.toRat < x := by + rw [← (toIGame_dyadic_equiv q).lt_congr_left, toIGame_lt_iff] +@[simp, norm_cast] +theorem toIGame_lt_dyadic {q : Dyadic} {x : ℝ} : (x : IGame) < q ↔ x < q.toRat := by + rw [← (toIGame_dyadic_equiv q).lt_congr_right, toIGame_lt_iff] + +@[simp, norm_cast] +theorem dyadic_le_toIGame {q : Dyadic} {x : ℝ} : q ≤ (x : IGame) ↔ q.toRat ≤ x := by + simp [← not_lt, ← Numeric.not_lt] +@[simp, norm_cast] +theorem toIGame_le_dyadic {q : Dyadic} {x : ℝ} : (x : IGame) ≤ q ↔ x ≤ q.toRat := by + simp [← not_lt, ← Numeric.not_lt] + +@[simp, norm_cast] +theorem dyadic_equiv_toIGame {q : Dyadic} {x : ℝ} : (q : IGame) ≈ x ↔ q.toRat = x := by + simp [AntisymmRel, le_antisymm_iff] +@[simp, norm_cast] +theorem toIGame_equiv_dyadic {q : Dyadic} {x : ℝ} : (x : IGame) ≈ q ↔ x = q.toRat := by + simp [AntisymmRel, le_antisymm_iff] + +/-! #### ℤ -/ + +@[simp, norm_cast] +theorem toIGame_lt_intCast {x : ℝ} {y : ℤ} : (x : IGame) < y ↔ x < y := by + simp [← (ratCast_intCast_equiv y).lt_congr_right] +@[simp, norm_cast] +theorem toIGame_le_intCast {x : ℝ} {y : ℤ} : (x : IGame) ≤ y ↔ x ≤ y := by + simp [← (ratCast_intCast_equiv y).le_congr_right] + +@[simp, norm_cast] +theorem intCast_lt_toIGame {x : ℤ} {y : ℝ} : (x : IGame) < y ↔ x < y := by + simp [← (ratCast_intCast_equiv x).lt_congr_left] +@[simp, norm_cast] +theorem intCast_le_toIGame {x : ℤ} {y : ℝ} : (x : IGame) ≤ y ↔ x ≤ y := by + simp [← (ratCast_intCast_equiv x).le_congr_left] + +@[simp, norm_cast] +theorem toIGame_equiv_intCast {x : ℝ} {y : ℤ} : (x : IGame) ≈ y ↔ x = y := by + simp [AntisymmRel, le_antisymm_iff] +@[simp, norm_cast] +theorem intCast_equiv_toIGame {x : ℤ} {y : ℝ} : (x : IGame) ≈ y ↔ x = y := by + simp [AntisymmRel, le_antisymm_iff] + +/-! #### ℕ -/ + +@[simp, norm_cast] +theorem toIGame_lt_natCast {x : ℝ} {y : ℕ} : (x : IGame) < y ↔ x < y := + toIGame_lt_intCast (y := y) +@[simp, norm_cast] +theorem toIGame_le_natCast {x : ℝ} {y : ℕ} : (x : IGame) ≤ y ↔ x ≤ y := + toIGame_le_intCast (y := y) + +@[simp, norm_cast] +theorem natCast_lt_toIGame {x : ℕ} {y : ℝ} : (x : IGame) < y ↔ x < y := + intCast_lt_toIGame (x := x) +@[simp, norm_cast] +theorem natCast_le_toIGame {x : ℕ} {y : ℝ} : (x : IGame) ≤ y ↔ x ≤ y := + intCast_le_toIGame (x := x) + +@[simp, norm_cast] +theorem toIGame_equiv_natCast {x : ℝ} {y : ℕ} : (x : IGame) ≈ y ↔ x = y := + toIGame_equiv_intCast (y := y) +@[simp, norm_cast] +theorem natCast_equiv_toIGame {x : ℕ} {y : ℝ} : (x : IGame) ≈ y ↔ x = y := + intCast_equiv_toIGame (x := x) + +/-! #### 0 -/ + +@[simp] theorem toIGame_lt_zero {x : ℝ} : (x : IGame) < 0 ↔ x < 0 := by norm_cast +@[simp] theorem toIGame_le_zero {x : ℝ} : (x : IGame) ≤ 0 ↔ x ≤ 0 := by norm_cast + +@[simp] theorem zero_lt_toIGame {x : ℝ} : 0 < (x : IGame) ↔ 0 < x := by norm_cast +@[simp] theorem zero_le_toIGame {x : ℝ} : 0 ≤ (x : IGame) ↔ 0 ≤ x := by norm_cast + +@[simp] theorem toIGame_equiv_zero {x : ℝ} : (x : IGame) ≈ 0 ↔ x = 0 := by norm_cast +@[simp] theorem zero_equiv_toIGame {x : ℝ} : 0 ≈ (x : IGame) ↔ 0 = x := by norm_cast + +/-! #### 1 -/ + +@[simp] theorem toIGame_lt_one {x : ℝ} : (x : IGame) < 1 ↔ x < 1 := by norm_cast +@[simp] theorem toIGame_le_one {x : ℝ} : (x : IGame) ≤ 1 ↔ x ≤ 1 := by norm_cast + +@[simp] theorem one_lt_toIGame {x : ℝ} : 1 < (x : IGame) ↔ 1 < x := by norm_cast +@[simp] theorem one_le_toIGame {x : ℝ} : 1 ≤ (x : IGame) ↔ 1 ≤ x := by norm_cast + +@[simp] theorem toIGame_equiv_one {x : ℝ} : (x : IGame) ≈ 1 ↔ x = 1 := by norm_cast +@[simp] theorem one_equiv_toIGame {x : ℝ} : 1 ≈ (x : IGame) ↔ 1 = x := by norm_cast + +end Real +end diff --git a/LeanPool/ConwayRefinement/CombinatorialGames/Tactic.lean b/LeanPool/ConwayRefinement/CombinatorialGames/Tactic.lean new file mode 100644 index 0000000000..d1bfa3230f --- /dev/null +++ b/LeanPool/ConwayRefinement/CombinatorialGames/Tactic.lean @@ -0,0 +1,14 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.CombinatorialGames.Tactic.AddInstances +public import LeanPool.ConwayRefinement.CombinatorialGames.Tactic.GameCmp +public import LeanPool.ConwayRefinement.CombinatorialGames.Tactic.OrdinalAlias +public import LeanPool.ConwayRefinement.CombinatorialGames.Tactic.Register + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/CombinatorialGames/Tactic/AddInstances.lean b/LeanPool/ConwayRefinement/CombinatorialGames/Tactic/AddInstances.lean new file mode 100644 index 0000000000..b6f8912456 --- /dev/null +++ b/LeanPool/ConwayRefinement/CombinatorialGames/Tactic/AddInstances.lean @@ -0,0 +1,41 @@ +/- +Copyright (c) 2025 Aaron Liu. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Aaron Liu, František Silváši +-/ +module + +public meta import Lean.Elab.Tactic.Basic +public meta import Lean.Meta.Tactic.Assert + +/-! +# Eagerly add instances + +Many definitions in game theory are hereditary. For instance, all options of a `Numeric` game are +`Numeric`, all options of an `Impartial` game are `Impartial`, etc. + +The definition `addInstances` provides a tactic which will eagerly apply all passed functions to all +of the hypotheses, creating new ones in the process. The intended usage of this is to, for instance, +apply `Numeric.of_mem_moves` to all hypotheses, and thus build all possible `Numeric` instances. +-/ + +open Lean Meta Elab Tactic + +meta def instances (constants : Array Name) (goal : MVarId) : MetaM (Option MVarId) := + goal.withContext do + let mut goal := goal + for h in ← getLCtx do + if h.isImplementationDetail then continue + ⟨_, goal⟩ ← goal.assertHypotheses =<< constants.filterMapM fun c => do + let hc ← try mkAppM c #[h.toExpr] catch _ => return none + return some { + userName := ← mkFreshUserName `inst + type := ← inferType hc + value := hc + } + return goal + +/-- A tactic that eagerly adds instances by applying the functions in `constants` to every +hypothesis. -/ +public meta def addInstances (constants : Array Name) : TacticM Unit := + liftMetaTactic1 (instances constants) diff --git a/LeanPool/ConwayRefinement/CombinatorialGames/Tactic/GameCmp.lean b/LeanPool/ConwayRefinement/CombinatorialGames/Tactic/GameCmp.lean new file mode 100644 index 0000000000..21ed1b3eec --- /dev/null +++ b/LeanPool/ConwayRefinement/CombinatorialGames/Tactic/GameCmp.lean @@ -0,0 +1,74 @@ +/- +Copyright (c) 2025 Violeta Hernández Palacios. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Violeta Hernández Palacios +-/ +module + +public import LeanPool.ConwayRefinement.CombinatorialGames.Game.IGame + +meta import LeanPool.ConwayRefinement.CombinatorialGames.Tactic.Register + +/-! +# Tactic for game inequalities + +This file defines the `game_cmp` tactic, capable of proving inequalities between games. See its +docstring for more info. + +Tests for the tactic are found in the `CombinatorialGames.Test` file. +-/ + +/-- Proves simple inequalities on concrete games. + +This tactic works by repeatedly unfolding the definition of `≤` and applying `simp` lemmas tagged +with `game_cmp` until the goal is solved. It is effective on any game whose moves can be +"enumerated" by `simp`, in the sense that a quantifier over its moves can be written in a +quantifier-less way. For instance, `∀ y ∈ leftMoves !{{0, 1} | {2, 3}}, P y` can be simplified into +`P 0 ∧ P 1`. + +## Which lemmas to tag + +Lemmas which are safe to tag with `game_cmp` are the following: + +* Lemmas of the form `(∀ y ∈ leftMoves (f x), P y) ↔ _` and analogous, as long as any quantifiers + in the simplified form are over left or right moves of simpler games. +* Lemmas of the form `leftMoves (f x) = _` and analogous, as long as the simplified set is of the + form `{x₁, x₂, …}`, listing out all elements explicitly. +* Lemmas which directly replace games by other simpler games. + +Tagging any other lemmas might lead to `simp` failing to eliminate all quantifiers, and getting +stuck in a goal that it can't solve. +-/ +macro (name := gameCmp) "game_cmp" : tactic => + `(tactic| { + try simp only [lt_iff_le_not_ge, ge_iff_le, gt_iff_lt, AntisymmRel, Relation.SymmGen, IncompRel] + repeat + rw [IGame.le_iff_forall_lf] + simp only [game_cmp]}) + +/-! ### Extra tagged lemmas -/ + +public section + +variable {α : Type*} {P : α → Prop} + +attribute [game_cmp] Set.forall_mem_empty +@[game_cmp] theorem Set.gameCmp_exists_mem_empty : (∃ x ∈ (∅ : Set α), P x) ↔ False := by simp + +@[game_cmp] theorem Set.forall_singleton {x : α} : (∀ y ∈ ({x} : Set α), P y) ↔ P x := by simp +@[game_cmp] theorem Set.exists_singleton {x : α} : (∃ y ∈ ({x} : Set α), P y) ↔ P x := by simp + +@[game_cmp] theorem forall_lt_zero {P : ℕ → Prop} : (∀ n < 0, P n) ↔ True := by simp +@[game_cmp] theorem exists_lt_zero {P : ℕ → Prop} : (∃ n < 0, P n) ↔ False := by simp +@[game_cmp] theorem forall_lt_one {P : ℕ → Prop} : (∀ n < 1, P n) ↔ P 0 := by simp +@[game_cmp] theorem exists_lt_one {P : ℕ → Prop} : (∃ n < 1, P n) ↔ P 0 := by simp + +attribute [game_cmp] le_rfl + zero_add add_zero zero_mul mul_zero one_mul mul_one neg_zero sub_eq_add_neg + Nat.cast_zero Nat.cast_one Nat.forall_lt_succ_left Nat.exists_lt_succ_left + not_not not_true not_false_eq_true not_forall true_and and_true false_and and_false + false_implies implies_true forall_const and_imp forall_exists_index + Player.neg_left Player.neg_right Player.left_mul Player.right_mul Player.forall Player.exists + Set.forall_mem_image Set.exists_mem_image Set.forall_mem_insert Set.exists_mem_insert Set.mem_Iio + +end diff --git a/LeanPool/ConwayRefinement/CombinatorialGames/Tactic/OrdinalAlias.lean b/LeanPool/ConwayRefinement/CombinatorialGames/Tactic/OrdinalAlias.lean new file mode 100644 index 0000000000..eb9e65f7b6 --- /dev/null +++ b/LeanPool/ConwayRefinement/CombinatorialGames/Tactic/OrdinalAlias.lean @@ -0,0 +1,206 @@ +/- +Copyright (c) 2025 Violeta Hernández Palacios. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Violeta Hernández Palacios +-/ +module + +public import Mathlib.SetTheory.Ordinal.Family + +/-! +# Declare type aliases of `Ordinal` + +This repository contains two type aliases of `Ordinal`, each preserving the order structure but with +distinct arithmetic defined on it, namely `NatOrdinal` and `Nimber`. We define a `ordinal_alias!` +macro which contains all the boilerplate required to set up these types. This also ensures that the +API between both stays consistent. +-/ + +open Lean + +/-! ### Auxiliary defs -/ + +/-- Doc-comment allowing antiquotation. -/ +meta def mkDocComment (s : String) : TSyntax `Lean.Parser.Command.docComment := + .mk <| mkNode ``Parser.Command.docComment #[mkAtom "/--", mkAtom (s ++ "-/")] + +/-- `Alias.of` -/ +meta def mkOf (Alias : TSyntax `ident) : TSyntax `ident := + .mk <| mkIdent (Alias.getId ++ `of) + +/-- `Alias.val` -/ +meta def mkVal (Alias : TSyntax `ident) : TSyntax `ident := + .mk <| mkIdent (Alias.getId ++ `val) + +/-! ### Macros -/ + +/-- Declare a type alias of either `Ordinal` or `Nat`, preserving the order structure. -/ +macro "alias!" doc:docComment Alias:ident Source:ident : command => `( +@[expose] public section + +$doc:docComment +def $Alias : Type _ := + $Source deriving Zero, One, Nontrivial, Inhabited, WellFoundedRelation + +namespace $Alias +universe u + +instance : PartialOrder $Alias := inferInstanceAs (PartialOrder $Source) +instance : SuccOrder $Alias := inferInstanceAs (SuccOrder $Source) +instance : OrderBot $Alias := inferInstanceAs (OrderBot $Source) +instance : NoMaxOrder $Alias := inferInstanceAs (NoMaxOrder $Source) +instance : IsBotZeroClass $Alias := inferInstanceAs (IsBotZeroClass $Source) +instance : NeZero (1 : $Alias) := inferInstanceAs (NeZero (1 : $Source)) +instance : WellFoundedLT $Alias := inferInstanceAs (WellFoundedLT $Source) +noncomputable instance : ConditionallyCompleteLinearOrderBot $Alias := + inferInstanceAs (ConditionallyCompleteLinearOrderBot $Source) + +theorem $(mkIdent `lt_wf) : @WellFounded $Alias (· < ·) := wellFounded_lt + +$(mkDocComment s!" The identity function between `{Source.getId}` and `{Alias.getId}`."):docComment +@[match_pattern] +def $(mkIdent `of) : $Source ≃o $Alias := .refl _ + +$(mkDocComment s!" The identity function between `{Alias.getId}` and `{Source.getId}`."):docComment +@[match_pattern] +def $(mkIdent `val) : $Alias ≃o $Source := .refl _ + +@[simp] theorem $(mkIdent `of_symm) : .symm $(mkOf Alias) = $(mkVal Alias) := rfl +@[simp] theorem $(mkIdent `val_symm) : .symm $(mkVal Alias) = $(mkOf Alias) := rfl + +@[simp] theorem $(mkIdent `of_val) (a) : $(mkOf Alias) ($(mkVal Alias) a) = a := rfl +@[simp] theorem $(mkIdent `val_of) (a) : $(mkVal Alias) ($(mkOf Alias) a) = a := rfl + +theorem $(mkIdent `val_le_iff) {a b} : $(mkVal Alias) a ≤ b ↔ a ≤ $(mkOf Alias) b := .rfl +theorem $(mkIdent `val_lt_iff) {a b} : $(mkVal Alias) a < b ↔ a < $(mkOf Alias) b := .rfl +theorem $(mkIdent `val_eq_iff) {a b} : $(mkVal Alias) a = b ↔ a = $(mkOf Alias) b := .rfl + +theorem $(mkIdent `of_le_iff) {a b} : $(mkOf Alias) a ≤ b ↔ a ≤ $(mkVal Alias) b := .rfl +theorem $(mkIdent `of_lt_iff) {a b} : $(mkOf Alias) a < b ↔ a < $(mkVal Alias) b := .rfl +theorem $(mkIdent `of_eq_iff) {a b} : $(mkOf Alias) a = b ↔ a = $(mkVal Alias) b := .rfl + +@[simp] theorem $(mkIdent `bot_eq_zero) : (⊥ : $Alias) = 0 := rfl +@[simp] theorem $(mkIdent `bot_eq_zero_withTop) : (⊥ : WithTop $Alias) = 0 := rfl + +@[simp] theorem $(mkIdent `of_zero) : $(mkOf Alias) 0 = 0 := rfl +@[simp] theorem $(mkIdent `val_zero) : $(mkVal Alias) 0 = 0 := rfl + +@[simp] theorem $(mkIdent `of_one) : $(mkOf Alias) 1 = 1 := rfl +@[simp] theorem $(mkIdent `val_one) : $(mkVal Alias) 1 = 1 := rfl + +@[simp] theorem $(mkIdent `of_eq_zero) {a} : $(mkOf Alias) a = 0 ↔ a = 0 := .rfl +@[simp] theorem $(mkIdent `val_eq_zero) {a} : $(mkVal Alias) a = 0 ↔ a = 0 := .rfl +theorem $(mkIdent `of_ne_zero) {a} : $(mkOf Alias) a ≠ 0 ↔ a ≠ 0 := .rfl +theorem $(mkIdent `val_ne_zero) {a} : $(mkVal Alias) a ≠ 0 ↔ a ≠ 0 := .rfl + +@[simp] theorem $(mkIdent `of_eq_one) {a} : $(mkOf Alias) a = 1 ↔ a = 1 := .rfl +@[simp] theorem $(mkIdent `val_eq_one) {a} : $(mkVal Alias) a = 1 ↔ a = 1 := .rfl +theorem $(mkIdent `of_ne_one) {a} : $(mkOf Alias) a ≠ 1 ↔ a ≠ 1 := .rfl +theorem $(mkIdent `val_ne_one) {a} : $(mkVal Alias) a ≠ 1 ↔ a ≠ 1 := .rfl +@[simp] theorem $(mkIdent `of_le_one) {a} : $(mkOf Alias) a ≤ 1 ↔ a ≤ 1 := .rfl +@[simp] theorem $(mkIdent `val_le_one) {a} : $(mkVal Alias) a ≤ 1 ↔ a ≤ 1 := .rfl +theorem $(mkIdent `one_le_of) {a} : 1 ≤ $(mkOf Alias) a ↔ 1 ≤ a := .rfl +@[simp] theorem $(mkIdent `one_le_val) {a} : 1 ≤ $(mkVal Alias) a ↔ 1 ≤ a := .rfl +theorem $(mkIdent `of_lt_one) {a} : $(mkOf Alias) a < 1 ↔ a < 1 := .rfl +theorem $(mkIdent `val_lt_one) {a} : $(mkVal Alias) a < 1 ↔ a < 1 := .rfl +@[simp] theorem $(mkIdent `one_lt_of) {a} : 1 < $(mkOf Alias) a ↔ 1 < a := .rfl +@[simp] theorem $(mkIdent `one_lt_val) {a} : 1 < $(mkVal Alias) a ↔ 1 < a := .rfl + +theorem $(mkIdent `succ_def) (a : $Alias) : Order.succ a = $(mkOf Alias) ($(mkVal Alias) a + 1) := + rfl + +@[simp] +theorem $(mkIdent `succ_of) (a : $Source) : Order.succ ($(mkOf Alias) a) = $(mkOf Alias) (a + 1) := + rfl + +theorem $(mkIdent `succ_ne_zero) (a : $Alias) : Order.succ a ≠ 0 := Order.succ_ne_bot a + +$(mkDocComment s!" A recursor for `{Alias.getId}`. Use as `cases x`. "):docComment +@[elab_as_elim, cases_eliminator, induction_eliminator] +protected def $(mkIdent `ind) {motive : $Alias → Sort*} + ($(mkIdent `of) : ∀ a, motive ($(mkOf Alias) a)) (a) : motive a := + $(mkIdent `of) ($(mkVal Alias) a) + +$(mkDocComment s!" Well-founded induction for `{Alias.getId}`. "):docComment +theorem $(mkIdent `induction) {p : $Alias → Prop} : ∀ i (_ : ∀ j, (∀ k, k < j → p k) → p j), p i := + WellFoundedLT.induction + +end $Alias +end +) + +/-- Declare a type alias of `Ordinal`, preserving the order structure. -/ +macro "ordinal_alias!" doc:docComment Alias:ident : command => `( + +alias! $doc $Alias Ordinal + +@[expose] public section +namespace $Alias +universe u + +instance : Uncountable $Alias := Ordinal.uncountable + +theorem $(mkIdent `lt_one_iff) {a : $Alias} : a < 1 ↔ a = 0 := + Order.lt_one_iff (α := Ordinal) +theorem $(mkIdent `le_one_iff) {a : $Alias} : a ≤ 1 ↔ a = 0 ∨ a = 1 := + Order.le_one_iff (α := Ordinal) + +@[simp] +theorem $(mkIdent `one_le_iff_ne_zero) {a : $Alias} : 1 ≤ a ↔ a ≠ 0 := + Order.one_le_iff_ne_zero (α := Ordinal) + +theorem $(mkIdent `succ_zero) : Order.succ (0 : $Alias) = 1 := zero_add (1 : Ordinal) + +theorem $(mkIdent `Iio_zero) : Set.Iio (0 : $Alias) = ∅ := Set.Iio_bot (α := Ordinal) +theorem $(mkIdent `Iio_one) : Set.Iio (1 : $Alias) = {0} := Order.Iio_one (α := Ordinal) + +theorem $(mkIdent `eq_natCast_of_le_natCast) {a : $Alias} {b : ℕ} (h : a ≤ $(mkOf Alias) b) : + ∃ c : ℕ, a = $(mkOf Alias) c := + Ordinal.eq_natCast_of_le_natCast h + +instance (a : $Alias.{u}) : Small.{u} (Set.Iio a) := Ordinal.small_Iio a +instance (a : $Alias.{u}) : Small.{u} (Set.Iic a) := Ordinal.small_Iic a +instance (a b : $Alias.{u}) : Small.{u} (Set.Ico a b) := Ordinal.small_Ico a b +instance (a b : $Alias.{u}) : Small.{u} (Set.Icc a b) := Ordinal.small_Icc a b +instance (a b : $Alias.{u}) : Small.{u} (Set.Ioo a b) := Ordinal.small_Ioo a b +instance (a b : $Alias.{u}) : Small.{u} (Set.Ioc a b) := Ordinal.small_Ioc a b + +instance : IsEmpty (Set.Iio (0 : $Alias)) := Set.isEmpty_Iio_zero (α := Ordinal) +instance : Unique (Set.Iio (1 : $Alias)) := Ordinal.uniqueIioOne + +@[simp] +theorem $(mkIdent `Iio_one_default_eq) : + (default : Set.Iio (1 : $Alias)) = ⟨0, zero_lt_one' $Alias⟩ := + rfl + +theorem $(mkIdent `bddAbove_iff_small) {s : Set $Alias.{u}} : BddAbove s ↔ Small.{u} s := + Ordinal.bddAbove_iff_small + +theorem $(mkIdent `bddAbove_of_small) (s : Set $Alias.{u}) [hs : Small.{u} s] : BddAbove s := + @Ordinal.bddAbove_of_small s hs + +theorem $(mkIdent `not_bddAbove_compl_of_small) (s : Set $Alias.{u}) [hs : Small.{u} s] : + ¬BddAbove sᶜ := + @Ordinal.not_bddAbove_compl_of_small s hs + +theorem $(mkIdent `le_iSup) {ι : Type*} (f : ι → $Alias.{u}) [Small.{u} ι] (i : ι) : f i ≤ iSup f := + Ordinal.le_iSup f i + +theorem $(mkIdent `iSup_le_iff) {ι : Type*} {f : ι → $Alias.{u}} {a : $Alias.{u}} [Small.{u} ι] : + ⨆ i, f i ≤ a ↔ ∀ i, f i ≤ a := + Ordinal.iSup_le_iff + +theorem $(mkIdent `lt_iSup_iff) {ι : Type*} [Small.{u} ι] (f : ι → $Alias.{u}) {x} : + x < ⨆ i, f i ↔ ∃ i, x < f i := + Ordinal.lt_iSup_iff + +theorem $(mkIdent `iSup_eq_zero_iff) {ι : Type*} [Small.{u} ι] {f : ι → $Alias.{u}} : + ⨆ i, f i = 0 ↔ ∀ i, f i = 0 := + Ordinal.iSup_eq_zero_iff + +end $Alias +end + +-- TODO: how do we name this correctly? +-- theorem not_small_nimber : ¬ Small.{u} $Alias.{max u v} := not_small_ordinal +) diff --git a/LeanPool/ConwayRefinement/CombinatorialGames/Tactic/Register.lean b/LeanPool/ConwayRefinement/CombinatorialGames/Tactic/Register.lean new file mode 100644 index 0000000000..dbc4be836f --- /dev/null +++ b/LeanPool/ConwayRefinement/CombinatorialGames/Tactic/Register.lean @@ -0,0 +1,18 @@ +/- +Copyright (c) 2025 Violeta Hernández Palacios. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Violeta Hernández Palacios +-/ +module + +public import Mathlib.Init +public meta import Lean.LabelAttribute -- TODO: `registerLabelAttr` should be marked `meta` +import Lean.Meta.Tactic.Simp.Attr + +/-! +We register a `simp` attribute for the `game_cmp` tactic. This needs to be done in a separate file +to where the tactic is defined. +-/ + +/-- Simp attribute for lemmas used in `game_cmp`. -/ +register_simp_attr game_cmp diff --git a/LeanPool/ConwayRefinement/ConwayRefinement.lean b/LeanPool/ConwayRefinement/ConwayRefinement.lean new file mode 100644 index 0000000000..1af0423494 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement.lean @@ -0,0 +1,17 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +/-! +# ConwayRefinement + +Intentionally empty. The lakefile's `globs = ["ConwayRefinement.*"]` is authoritative for what is +built and audited: `lake build` builds every module under `ConwayRefinement/` directly, and the +audits enumerate the source tree, so nothing depends on this root re-exporting the library. No +module imports it, and a change to the library never needs to touch this file. + +Start at `ConwayRefinement/Standalone/`, or read the README. +-/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra.lean new file mode 100644 index 0000000000..cf8320542d --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra.lean @@ -0,0 +1,21 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.DirectSum +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Divisibility +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.GeometricIntegrality +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.GradedRing +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.LoweringDerivation +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MonoidAlgebra +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MvPolynomial +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Order +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Ring +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Tests +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/DirectSum.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/DirectSum.lean new file mode 100644 index 0000000000..19b5181b85 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/DirectSum.lean @@ -0,0 +1,20 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.DirectSum.GermChainRule +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.DirectSum.GermFinitePartIdeal +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.DirectSum.GermPolynomial +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.DirectSum.GermSuccessorStep +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.DirectSum.GermSyzygy +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.DirectSum.HomogeneousDivisibility +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.DirectSum.HomogeneousPrime +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.DirectSum.InternalGrading +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.DirectSum.LeadingGrade +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.DirectSum.TrailingGrade + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/DirectSum/GermChainRule.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/DirectSum/GermChainRule.lean new file mode 100644 index 0000000000..c6c6b7a0a3 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/DirectSum/GermChainRule.lean @@ -0,0 +1,153 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.GradedRing.OrdinalGenerators +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.DirectSum.GermPolynomial +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MvPolynomial.OrdinalDerivation + +/-! +# The chain rule for ordinal-graded filter-germ lowering derivations + +This file isolates the successor-degree chain rule from the real-line filter used by the +principal-subring development. +-/ + +universe u v w z q + +open Filter GermPolynomial MvPolynomial + +public noncomputable section + +namespace OrdinalGraded + +variable {K : Type u} {R : Type v} {T : Type q} +variable [Field K] [CommRing R] [Algebra K R] +variable {l : Filter T} +variable (A : NatOrdinal.{z} → Submodule K R) [GradedAlgebra A] +variable {ι : Type w} {wt : ι → NatOrdinal.{z}} {x : ι → R} + +/-- Polynomial representatives of the derivatives of homogeneous coordinates. -/ +structure DerivativeRep (wt : ι → NatOrdinal.{z}) (x : ι → R) + (Δ : Derivation K R (Germ l R)) (g : ι → T → MvPolynomial ι K) : Prop where + /-- In successor degree, the representative has the preceding degree. -/ + homogeneous : ∀ i t, 0 < (wt i).constantCoeff → + IsWeightedHomogeneous wt (g i t) ((wt i).removeNat 1) + /-- When the degree is zero or a limit ordinal, the representative is zero. -/ + eq_zero : ∀ i t, (wt i).constantCoeff = 0 → g i t = 0 + /-- Evaluation of the representatives gives the derivative germ. -/ + map_coordinate : ∀ i, Δ (x i) = ((fun t ↦ aeval x (g i t)) : Germ l R) + +namespace IsMinimalSystem + +variable {A} (hx : OrdinalGraded.IsMinimalSystem A wt x) +variable {Δ : Derivation K R (Germ l R)} (hΔ : GermPolynomial.IsLoweringDerivation A Δ) +include hx hΔ + +omit [GradedAlgebra A] in +/-- Derivative representatives exist for every ordinal minimal system. -/ +theorem exists_derivativeRep (h0 : GradeZeroScalars A) : + ∃ g : ι → T → MvPolynomial ι K, DerivativeRep wt x Δ g := by + classical + have hrep : ∀ i, ∃ g : T → MvPolynomial ι K, + (0 < (wt i).constantCoeff → + ∀ t, IsWeightedHomogeneous wt (g t) ((wt i).removeNat 1)) ∧ + ((wt i).constantCoeff = 0 → ∀ t, g t = 0) ∧ + Δ (x i) = ((fun t ↦ aeval x (g t)) : Germ l R) := by + intro i + by_cases hi : 0 < (wt i).constantCoeff + · obtain ⟨f, hf, hfΔ⟩ := exists_rep_of_mem_germSubmodule _ + (GermPolynomial.IsLoweringDerivation.mem_lower hΔ hi (hx.mem i)) + have hpoly : ∀ t, ∃ p : MvPolynomial ι K, + IsWeightedHomogeneous wt p ((wt i).removeNat 1) ∧ aeval x p = f t := fun t ↦ + OrdinalGraded.IsMinimalSystem.exists_aeval_eq hx h0 _ (f t) (hf t) + choose g hg hgf using hpoly + refine ⟨g, fun _ t ↦ hg t, fun hzero ↦ absurd hzero hi.ne', ?_⟩ + rw [hfΔ] + congr 1 + funext t + exact (hgf t).symm + · refine ⟨fun _ ↦ 0, fun hpos ↦ absurd hpos hi, fun _ _ ↦ rfl, ?_⟩ + rw [GermPolynomial.IsLoweringDerivation.eq_zero hΔ + (Nat.eq_zero_of_not_pos hi) (hx.mem i)] + simp only [map_zero] + rfl + choose g hg hg0 hgΔ using hrep + exact ⟨g, fun i t hi ↦ hg i hi t, fun i t hi ↦ hg0 i hi t, hgΔ⟩ + +end IsMinimalSystem + +namespace DerivativeRep + +variable {A : NatOrdinal.{z} → Submodule K R} +variable [GradedAlgebra A] +variable {Δ : Derivation K R (Germ l R)} +variable {g : ι → T → MvPolynomial ι K} +variable (hg : DerivativeRep (l := l) wt x Δ g) +variable (hΔ : GermPolynomial.IsLoweringDerivation A Δ) +include hg hΔ + +/-- The chain rule for evaluation along homogeneous coordinates. -/ +theorem map_aeval (F : MvPolynomial ι K) : + Δ (aeval x F) = + ((fun t ↦ aeval x (mkDerivation K (fun i ↦ g i t) F)) : Germ l R) := + GermPolynomial.IsHomogeneousCoordinates.map_aeval hΔ g hg.map_coordinate F + +omit hΔ in +/-- Pointwise polynomial derivation lowers every successor degree by one. -/ +theorem mkDerivation_isWeightedHomogeneous (t : T) {F : MvPolynomial ι K} + {δ : NatOrdinal.{z}} (hF : IsWeightedHomogeneous wt F δ) : + IsWeightedHomogeneous wt (mkDerivation K (fun i ↦ g i t) F) (δ.removeNat 1) := + mkDerivation_isWeightedHomogeneous_removeNat wt _ (fun i hi ↦ hg.homogeneous i t hi) + (fun i hi ↦ hg.eq_zero i t hi) hF + +omit hΔ in +/-- A variable occurring in a derivative representative has lower weight than its source. -/ +theorem wt_lt_of_pderiv_ne_zero {i j : ι} {t : T} + (h : pderiv j (g i t) ≠ 0) : + wt j < wt i := by + by_cases hi : 0 < (wt i).constantCoeff + · have hj : j ∈ (g i t).vars := by + by_contra hj + exact h (pderiv_eq_zero_of_notMem_vars hj) + refine ((hg.homogeneous i t hi).wt_le_of_mem_vars wt hj).trans_lt ?_ + have hsucc := NatOrdinal.removeNat_add_natCast (a := wt i) (n := 1) hi + rw [Nat.cast_one] at hsucc + exact lt_of_lt_of_eq (lt_add_one _) hsucc + · exact absurd (by rw [hg.eq_zero i t (Nat.eq_zero_of_not_pos hi), map_zero]) h + +/-- The pointwise derivative of a homogeneous relation of successor degree vanishes eventually. -/ +theorem eventually_mkDerivation_eq_zero {δ : NatOrdinal.{z}} + (hinj : ∀ β < δ, InjectiveAt K wt x β) (hδ : 0 < δ.constantCoeff) + {F : MvPolynomial ι K} (hF : IsWeightedHomogeneous wt F δ) (hF0 : aeval x F = 0) : + ∀ᶠ t in l, mkDerivation K (fun i ↦ g i t) F = 0 := by + have h := hg.map_aeval hΔ F + rw [hF0, map_zero, eq_comm] at h + change ((fun t ↦ aeval x (mkDerivation K (fun i ↦ g i t) F)) : Germ l R) = + ((fun _ : T ↦ (0 : R)) : Germ l R) at h + rw [Germ.coe_eq] at h + have hlt : δ.removeNat 1 < δ := by + have hsucc := NatOrdinal.removeNat_add_natCast (a := δ) (n := 1) hδ + rw [Nat.cast_one] at hsucc + exact lt_of_lt_of_eq (lt_add_one _) hsucc + exact h.mono fun t ht ↦ + (injectiveAt_iff _).mp (hinj _ hlt) _ (hg.mkDerivation_isWeightedHomogeneous t hF) ht + +/-- Differentiating the eventually vanishing pointwise derivative of a relation. -/ +theorem eventually_mkDerivation_pderiv_eq {δ : NatOrdinal.{z}} + (hinj : ∀ β < δ, InjectiveAt K wt x β) (hδ : 0 < δ.constantCoeff) + {F : MvPolynomial ι K} (hF : IsWeightedHomogeneous wt F δ) (hF0 : aeval x F = 0) + (j : ι) : + ∀ᶠ t in l, mkDerivation K (fun i ↦ g i t) (pderiv j F) = + -mkDerivation K (fun i ↦ pderiv j (g i t)) F := by + filter_upwards [hg.eventually_mkDerivation_eq_zero hΔ hinj hδ hF hF0] with t ht + have h := pderiv_mkDerivation (fun i ↦ g i t) j F + rw [ht, map_zero] at h + exact (neg_eq_of_add_eq_zero_right h.symm).symm + +end DerivativeRep + +end OrdinalGraded diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/DirectSum/GermFinitePartIdeal.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/DirectSum/GermFinitePartIdeal.lean new file mode 100644 index 0000000000..23e0c60c49 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/DirectSum/GermFinitePartIdeal.lean @@ -0,0 +1,294 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.DirectSum.GermChainRule +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.GradedRing.HomogeneousSpan +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MvPolynomial.FinitePartVars + +/-! +# The ideal of the partial derivatives carrying the finite part, for germ derivations + +Let `F` be a relation of degree `δ` whose finite part is `n ≥ 1`, under evaluation injective in +every degree below `δ`. The variables of `F` whose own degree has finite part `n` generate an ideal + +`I = (∂F/∂X_B : X_B carries the finite part)`, + +and the claim is that every partial derivative of `F` at a variable of successor degree lies in `I`. + +This file carries the inductive step of that claim from the real line to an arbitrary filter. The +argument is unchanged: the chain rule expresses the derivative of `(∂F/∂X_j)(x)` through the +partial derivatives at variables of strictly larger degree, which lie in `I` by hypothesis, so the +derivative germ takes values in the evaluated ideal; ideal membership from the derivative pulls +`(∂F/∂X_j)(x)` into that ideal; and injectivity below `δ` lifts the resulting relation back to a +polynomial identity. + +The one input not available from the abstract lowering-derivation interface is the passage from a +derivative germ with values in an ideal to membership of the class itself. That is an integration +statement, proved separately in each setting, so it is taken here as the hypothesis +`HasIdealIntegration`. +-/ + +universe u v w z q + +open Filter GermPolynomial MvPolynomial OrdinalGraded + +public noncomputable section + +namespace OrdinalGraded + +variable {K : Type u} {R : Type v} {T : Type q} +variable [Field K] [CommRing R] [Algebra K R] +variable {l : Filter T} +variable (A : NatOrdinal.{z} → Submodule K R) [GradedAlgebra A] +variable {ι : Type w} {wt : ι → NatOrdinal.{z}} {x : ι → R} + +namespace DerivativeRep + +variable {A} +variable {Δ : Derivation K R (Germ l R)} +variable {g : ι → T → MvPolynomial ι K} +variable (hx : OrdinalGraded.IsMinimalSystem A wt x) +variable (hg : DerivativeRep (l := l) wt x Δ g) +variable (hΔ : GermPolynomial.IsLoweringDerivation A Δ) +include hx hg hΔ + +omit [GradedAlgebra A] hx hg hΔ in +/-- Evaluation carries the ideal of the partial derivatives into the ideal generated by their +values. -/ +theorem aeval_mem_span_of_mem_span {δ : NatOrdinal.{z}} {F : MvPolynomial ι K} + {q : ↥(varsOfFinitePart wt F δ) → R} (hqdef : ∀ t, q t = aeval x (pderiv (t : ι) F)) + {G : MvPolynomial ι K} + (hG : G ∈ Ideal.span ((fun t ↦ pderiv t F) '' (varsOfFinitePart wt F δ : Set ι))) : + aeval x G ∈ Ideal.span (Set.range q) := by + have hmap := Ideal.mem_map_of_mem (aeval x : MvPolynomial ι K →ₐ[K] R).toRingHom hG + rw [Ideal.map_span, Set.image_image, Set.image_eq_range] at hmap + simp only [AlgHom.toRingHom_eq_coe, RingHom.coe_coe] at hmap + have hq_eq : q = fun t : ↥(varsOfFinitePart wt F δ) ↦ aeval x (pderiv (t : ι) F) := + funext hqdef + rw [hq_eq] + exact hmap + +omit [GradedAlgebra A] hx hΔ in +/-- The chain-rule representative of the derivative takes values in the evaluated ideal. -/ +theorem mem_span_of_mkDerivation {δ : NatOrdinal.{z}} {F : MvPolynomial ι K} {j : ι} + {q : ↥(varsOfFinitePart wt F δ) → R} (hqdef : ∀ t, q t = aeval x (pderiv (t : ι) F)) + (ih : ∀ i ∈ F.vars, 0 < (wt i).constantCoeff → wt j < wt i → + pderiv i F ∈ Ideal.span ((fun t ↦ pderiv t F) '' (varsOfFinitePart wt F δ : Set ι))) + {t : T} + (ht : mkDerivation K (fun i ↦ g i t) (pderiv j F) = + -mkDerivation K (fun i ↦ pderiv j (g i t)) F) : + aeval x (mkDerivation K (fun i ↦ g i t) (pderiv j F)) ∈ Ideal.span (Set.range q) := by + rw [ht, map_neg, mkDerivation_eq_sum (fun i ↦ pderiv j (g i t)) (S := F.vars) fun _ h ↦ h, + map_sum] + refine (Ideal.neg_mem_iff _).mpr (Ideal.sum_mem _ fun i hi ↦ ?_) + rw [map_mul] + by_cases hz : pderiv j (g i t) = 0 + · rw [hz, map_zero, zero_mul] + exact Ideal.zero_mem _ + · obtain hlt := hg.wt_lt_of_pderiv_ne_zero hz + have his : 0 < (wt i).constantCoeff := by + by_contra hc0 + exact hz (by rw [hg.eq_zero i t (Nat.eq_zero_of_not_pos hc0), map_zero]) + exact Ideal.mul_mem_left _ _ + (aeval_mem_span_of_mem_span hqdef (ih i hi his hlt)) + +omit [GradedAlgebra A] hg hΔ in +/-- A homogeneous value of the decomposition is the evaluation of a homogeneous polynomial, and is +zero when its degree does not precede the target degree in the algebraic order. -/ +theorem exists_polynomial_of_mem (h0 : GradeZeroScalars A) {lamt beta : NatOrdinal.{z}} + {ut : R} (hu : ∀ b, b + lamt = beta → ut ∈ A b) (hu0 : (¬ ∃ b, b + lamt = beta) → ut = 0) : + ∃ U : MvPolynomial ι K, (∀ b, b + lamt = beta → IsWeightedHomogeneous wt U b) ∧ + ((¬ ∃ b, b + lamt = beta) → U = 0) ∧ aeval x U = ut := by + by_cases h : ∃ b, b + lamt = beta + · obtain ⟨b, hb⟩ := h + obtain ⟨U, hU, hUu⟩ := hx.exists_aeval_eq h0 b ut (hu b hb) + refine ⟨U, fun b' hb' ↦ ?_, fun h' ↦ absurd ⟨b, hb⟩ h', hUu⟩ + rwa [add_right_cancel (hb'.trans hb.symm)] + · exact ⟨0, fun b hb ↦ absurd ⟨b, hb⟩ h, fun _ ↦ rfl, by rw [map_zero, hu0 h]⟩ + +open Classical in +/-- **The inductive step.** If `∂F/∂X_i` lies in the ideal generated by the partial derivatives at +the variables carrying the finite part, for every variable `i` of `F` of successor degree with +`wt j < wt i`, then so does `∂F/∂X_j`. -/ +theorem pderiv_mem_span_varsOfFinitePart_of_forall_lt + (h0 : GradeZeroScalars A) + (hint : ∀ {ι' : Type w} [Finite ι'] {q : ι' → R} {c : ι' → NatOrdinal.{z}}, + (∀ j, q j ∈ A (c j)) → (∀ j, (c j).constantCoeff = 0) → + ∀ {b : NatOrdinal.{z}}, 0 < b.constantCoeff → ∀ {y : R}, y ∈ A b → + ∀ {f : T → R}, (∀ t, f t ∈ Ideal.span (Set.range q)) → + Δ y = (f : Germ l R) → y ∈ Ideal.span (Set.range q)) + {δ : NatOrdinal.{z}} (hinj : ∀ β < δ, InjectiveAt K wt x β) (hδ : 0 < δ.constantCoeff) + {F : MvPolynomial ι K} (hF : IsWeightedHomogeneous wt F δ) (hF0 : aeval x F = 0) + {j : ι} (hj : j ∈ F.vars) + (ih : ∀ i ∈ F.vars, 0 < (wt i).constantCoeff → wt j < wt i → + pderiv i F ∈ Ideal.span ((fun t ↦ pderiv t F) '' (varsOfFinitePart wt F δ : Set ι))) : + pderiv j F ∈ Ideal.span ((fun t ↦ pderiv t F) '' (varsOfFinitePart wt F δ : Set ι)) := by + classical + by_cases htop : (wt j).constantCoeff = δ.constantCoeff + · exact Ideal.subset_span ⟨j, mem_varsOfFinitePart_iff.mpr ⟨hj, htop⟩, rfl⟩ + -- the evaluated partial derivatives at the variables carrying the finite part + obtain ⟨lam, hlam⟩ : ∃ lam : ↥(varsOfFinitePart wt F δ) → NatOrdinal.{z}, + ∀ t, lam t + wt t = δ := + ⟨_, fun t ↦ (exists_add_wt_eq_of_mem_vars hF (mem_varsOfFinitePart_iff.mp t.2).1).choose_spec⟩ + obtain ⟨q, hqdef⟩ : ∃ q : ↥(varsOfFinitePart wt F δ) → R, + ∀ t, q t = aeval x (pderiv (t : ι) F) := ⟨_, fun _ ↦ rfl⟩ + have hq : ∀ t, q t ∈ A (lam t) := fun t ↦ by + rw [hqdef] + exact aeval_mem_of_forall_mem hx.mem (isWeightedHomogeneous_pderiv_of_add_wt_eq hF (hlam t)) + have hc : ∀ t, (lam t).constantCoeff = 0 := fun t ↦ + NatOrdinal.constantCoeff_eq_zero_of_add_eq (mem_varsOfFinitePart_iff.mp t.2).2 (hlam t) + -- the degree of `∂F/∂X_j`: a successor below `δ` + obtain ⟨β, hβ⟩ := exists_add_wt_eq_of_mem_vars hF hj + have hΘ : IsWeightedHomogeneous wt (pderiv j F) β := isWeightedHomogeneous_pderiv wt hF j hβ + have hβpos : 0 < β.constantCoeff := by + have h1 := congrArg NatOrdinal.constantCoeff hβ + rw [NatOrdinal.constantCoeff_add] at h1 + obtain h2 := constantCoeff_wt_le_of_mem_vars hF hj + omega + have hβlt : β < δ := by + rw [← hβ] + exact lt_add_of_pos_right β (pos_iff_ne_zero.mpr (hx.ne_zero j)) + have hΘmem : aeval x (pderiv j F) ∈ A β := aeval_mem_of_forall_mem hx.mem hΘ + -- the chain rule holds on a set of the filter; cut the representative down to it + obtain ⟨s, hs, hsdef⟩ : ∃ s : Set T, s ∈ l ∧ ∀ t ∈ s, + mkDerivation K (fun i ↦ g i t) (pderiv j F) = + -mkDerivation K (fun i ↦ pderiv j (g i t)) F := + ⟨_, hg.eventually_mkDerivation_pderiv_eq hΔ hinj hδ hF hF0 j, fun _ h ↦ h⟩ + obtain ⟨f, hfmem, hfeq⟩ : ∃ f : T → R, (∀ t, f t ∈ Ideal.span (Set.range q)) ∧ + ∀ t ∈ s, f t = aeval x (mkDerivation K (fun i ↦ g i t) (pderiv j F)) := by + refine ⟨fun t ↦ if ht : t ∈ s then + aeval x (mkDerivation K (fun i ↦ g i t) (pderiv j F)) else 0, fun t ↦ ?_, + fun t ht ↦ dite_eq_left ht⟩ + beta_reduce + by_cases ht : t ∈ s + · rw [dite_eq_left ht] + exact mem_span_of_mkDerivation hg hqdef ih (hsdef t ht) + · rw [dite_eq_right ht] + exact Ideal.zero_mem _ + have hΔf : Δ (aeval x (pderiv j F)) = (f : Germ l R) := by + rw [hg.map_aeval hΔ] + refine Germ.coe_eq.mpr ?_ + filter_upwards [hs] with t ht + exact (hfeq t ht).symm + -- ideal membership from the derivative, then decompose homogeneously + obtain hmem := hint (ι' := ↥(varsOfFinitePart wt F δ)) (q := q) (c := lam) hq hc + (b := β) hβpos (y := aeval x (pderiv j F)) hΘmem (f := f) hfmem hΔf + obtain ⟨u, hu, hu0, hsum⟩ := exists_eq_sum_mul_of_mem_span (𝒜 := A) hq hΘmem hmem + obtain ⟨U, hU, hU0, hUu⟩ : ∃ U : ↥(varsOfFinitePart wt F δ) → MvPolynomial ι K, + (∀ t β', β' + lam t = β → IsWeightedHomogeneous wt (U t) β') ∧ + (∀ t, (¬ ∃ β', β' + lam t = β) → U t = 0) ∧ ∀ t, aeval x (U t) = u t := by + choose U hU hU0 hUu using fun t ↦ + exists_polynomial_of_mem hx h0 (hu t) (hu0 t) + exact ⟨U, hU, hU0, hUu⟩ + -- the difference is a relation of degree `β < δ`, hence zero + have hsum' : IsWeightedHomogeneous wt + (∑ t : ↥(varsOfFinitePart wt F δ), pderiv (t : ι) F * U t) β := by + refine IsWeightedHomogeneous.sum _ _ _ fun t _ ↦ ?_ + by_cases h : ∃ β', β' + lam t = β + · obtain ⟨β', hβ'⟩ := h + obtain hmul := (isWeightedHomogeneous_pderiv_of_add_wt_eq hF (hlam t)).mul (hU t β' hβ') + rwa [add_comm, hβ'] at hmul + · rw [hU0 t h, mul_zero] + exact isWeightedHomogeneous_zero K wt β + have hG : IsWeightedHomogeneous wt + (pderiv j F - ∑ t : ↥(varsOfFinitePart wt F δ), pderiv (t : ι) F * U t) β := + (mem_weightedHomogeneousSubmodule K wt β _).mp + (sub_mem ((mem_weightedHomogeneousSubmodule K wt β _).mpr hΘ) + ((mem_weightedHomogeneousSubmodule K wt β _).mpr hsum')) + have hG0 : + aeval x (pderiv j F - ∑ t : ↥(varsOfFinitePart wt F δ), pderiv (t : ι) F * U t) = 0 := by + rw [map_sub, map_sum, hsum, sub_eq_zero] + exact Finset.sum_congr rfl fun t _ ↦ by rw [map_mul, hUu, hqdef] + obtain hzero := (injectiveAt_iff _).mp (hinj β hβlt) _ hG hG0 + rw [sub_eq_zero] at hzero + rw [hzero] + exact Ideal.sum_mem _ fun t _ ↦ Ideal.mul_mem_right _ _ (Ideal.subset_span ⟨t, t.2, rfl⟩) + +open Classical in +/-- Under evaluation injective below `δ`, every partial derivative of a relation at a variable of +successor degree lies in the ideal generated by the partial derivatives at the variables carrying +the finite part. + +The induction is downward through the variables of successor degree: a variable with none above it +is handled by the step directly, and otherwise the variables above it are strictly fewer. -/ +theorem pderiv_mem_span_varsOfFinitePart + (h0 : GradeZeroScalars A) + (hint : ∀ {ι' : Type w} [Finite ι'] {q : ι' → R} {c : ι' → NatOrdinal.{z}}, + (∀ j, q j ∈ A (c j)) → (∀ j, (c j).constantCoeff = 0) → + ∀ {b : NatOrdinal.{z}}, 0 < b.constantCoeff → ∀ {y : R}, y ∈ A b → + ∀ {f : T → R}, (∀ t, f t ∈ Ideal.span (Set.range q)) → + Δ y = (f : Germ l R) → y ∈ Ideal.span (Set.range q)) + {δ : NatOrdinal.{z}} (hinj : ∀ β < δ, InjectiveAt K wt x β) (hδ : 0 < δ.constantCoeff) + {F : MvPolynomial ι K} (hF : IsWeightedHomogeneous wt F δ) (hF0 : aeval x F = 0) + {j : ι} (hj : j ∈ F.vars) (hjs : 0 < (wt j).constantCoeff) : + pderiv j F ∈ Ideal.span ((fun t ↦ pderiv t F) '' (varsOfFinitePart wt F δ : Set ι)) := by + classical + set S : Finset ι := F.vars.filter fun i ↦ 0 < (wt i).constantCoeff with hSdef + suffices h : ∀ n : ℕ, ∀ j ∈ S, (S.filter fun i ↦ wt j < wt i).card ≤ n → + pderiv j F ∈ Ideal.span ((fun t ↦ pderiv t F) '' (varsOfFinitePart wt F δ : Set ι)) from + h _ j (Finset.mem_filter.mpr ⟨hj, hjs⟩) le_rfl + intro n + induction n with + | zero => + intro j hj hcard + rw [Nat.le_zero, Finset.card_eq_zero, Finset.filter_eq_empty_iff] at hcard + refine pderiv_mem_span_varsOfFinitePart_of_forall_lt hx hg hΔ h0 hint hinj hδ hF hF0 + (Finset.mem_filter.mp hj).1 fun i hi his hlt ↦ ?_ + exact absurd hlt (hcard (Finset.mem_filter.mpr ⟨hi, his⟩)) + | succ n ihn => + intro j hj hcard + refine pderiv_mem_span_varsOfFinitePart_of_forall_lt hx hg hΔ h0 hint hinj hδ hF hF0 + (Finset.mem_filter.mp hj).1 fun i hi his hlt ↦ ?_ + refine ihn i (Finset.mem_filter.mpr ⟨hi, his⟩) ?_ + have hsub : (S.filter fun t ↦ wt i < wt t) ⊂ S.filter fun t ↦ wt j < wt t := by + rw [Finset.ssubset_def] + refine ⟨fun t ht ↦ ?_, fun hcon ↦ ?_⟩ + · rw [Finset.mem_filter] at ht ⊢ + exact ⟨ht.1, hlt.trans ht.2⟩ + · have hmem := hcon (Finset.mem_filter.mpr ⟨Finset.mem_filter.mpr ⟨hi, his⟩, hlt⟩) + exact lt_irrefl _ (Finset.mem_filter.mp hmem).2 + have hcards := Finset.card_lt_card hsub + omega + +open Classical in +/-- **The relation lies in the ideal of its own partial derivatives.** In characteristic zero, +Euler's identity writes the relation as a combination of the partial derivatives at its variables, +each of which lies in the ideal, and the finite part of the degree is an invertible scalar. -/ +theorem mem_span_varsOfFinitePart [CharZero K] + (h0 : GradeZeroScalars A) + (hint : ∀ {ι' : Type w} [Finite ι'] {q : ι' → R} {c : ι' → NatOrdinal.{z}}, + (∀ j, q j ∈ A (c j)) → (∀ j, (c j).constantCoeff = 0) → + ∀ {b : NatOrdinal.{z}}, 0 < b.constantCoeff → ∀ {y : R}, y ∈ A b → + ∀ {f : T → R}, (∀ t, f t ∈ Ideal.span (Set.range q)) → + Δ y = (f : Germ l R) → y ∈ Ideal.span (Set.range q)) + {δ : NatOrdinal.{z}} (hinj : ∀ β < δ, InjectiveAt K wt x β) (hδ : 0 < δ.constantCoeff) + {F : MvPolynomial ι K} (hF : IsWeightedHomogeneous wt F δ) (hF0 : aeval x F = 0) : + F ∈ Ideal.span ((fun t ↦ pderiv t F) '' (varsOfFinitePart wt F δ : Set ι)) := by + classical + -- naming the ideal keeps the final rewrite of `F` from reaching inside it + set I : Ideal (MvPolynomial ι K) := + Ideal.span ((fun t ↦ pderiv t F) '' (varsOfFinitePart wt F δ : Set ι)) with hIdef + have heuler := hF.sum_constantCoeff_X_mul_pderiv wt (S := F.vars) fun _ h ↦ h + have hk : δ.constantCoeff • F ∈ I := by + rw [← heuler] + refine Ideal.sum_mem _ fun i hi ↦ ?_ + by_cases hpos : 0 < (wt i).constantCoeff + · exact nsmul_mem (Ideal.mul_mem_left _ _ + (pderiv_mem_span_varsOfFinitePart hx hg hΔ h0 hint hinj hδ hF hF0 hi hpos)) _ + · rw [Nat.eq_zero_of_not_pos hpos, zero_smul] + exact zero_mem _ + have hk0 : (δ.constantCoeff : K) ≠ 0 := Nat.cast_ne_zero.mpr hδ.ne' + have hsmul : F = (δ.constantCoeff : K)⁻¹ • (δ.constantCoeff • F) := by + rw [← Nat.cast_smul_eq_nsmul K, smul_smul, inv_mul_cancel₀ hk0, one_smul] + rw [hsmul] + exact I.smul_of_tower_mem _ hk + +end DerivativeRep + +end OrdinalGraded + +end diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/DirectSum/GermPolynomial.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/DirectSum/GermPolynomial.lean new file mode 100644 index 0000000000..8a1855cf30 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/DirectSum/GermPolynomial.lean @@ -0,0 +1,551 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MvPolynomial.Expansion +public import LeanPool.ConwayRefinement.ConwayRefinement.Order.Filter.Germ.LinearMap +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.FinitePart +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.DirectSum.InternalGrading +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.LoweringDerivation.Mu +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.GradedRing.OrdinalGenerators +public import Mathlib.RingTheory.Derivation.Basic + +import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MvPolynomial.WeightedTotalDegree + +/-! +# Finite-degree polynomiality for filter-germ lowering derivations + +Let `A` be an ordinal-graded algebra over a field `K`, and choose positive homogeneous generators +whose images form a basis modulo the decomposable part in each finite degree. Suppose that `A` +has a derivation into filter germs which lowers successor degrees by one, vanishes on degrees that +are limit ordinals, +and is injective on every homogeneous component of successor degree. Then those generators are +algebraically independent. + +The proof represents the derivatives of the generators by homogeneous polynomials. The chain rule +sends a least-degree homogeneous relation to the joint kernel of the resulting pointwise +derivations. Comparing the two highest powers of a variable reduces that kernel calculation to +independence modulo decomposables. This is the finite-degree algebraic-independence argument; the +choice of filter and the universe of the grading play no role. +-/ + +universe u v w z q + +open scoped DirectSum +open Filter MvPolynomial + +public noncomputable section + +namespace GermPolynomial + +export LoweringDerivation (GradeZeroScalars gradeZeroScalars_iff) + +variable {K : Type u} {R : Type v} {T : Type q} +variable [Field K] [CommRing R] [Algebra K R] +variable {l : Filter T} +variable (A : NatOrdinal.{z} → Submodule K R) [GradedAlgebra A] + +/-- Germs whose values eventually lie in a submodule. -/ +def germSubmodule (W : Submodule K R) : Submodule K (Germ l R) := + LinearMap.range (Germ.mapLinear W.subtype) + +/-- Membership in the germ submodule is eventual pointwise membership. -/ +theorem mem_germSubmodule_iff (W : Submodule K R) (f : Germ l R) : + f ∈ germSubmodule (l := l) W ↔ Germ.LiftPred (· ∈ W) f := by + classical + constructor + · rintro ⟨g, rfl⟩ + induction g using Germ.inductionOn with + | h g => + rw [Germ.mapLinear_coe, Germ.liftPred_coe] + exact Filter.Eventually.of_forall fun x ↦ (g x).property + · intro hf + induction f using Germ.inductionOn with + | h f => + rw [Germ.liftPred_coe] at hf + let g : T → W := fun x ↦ if hx : f x ∈ W then ⟨f x, hx⟩ else 0 + refine ⟨(g : Germ l W), ?_⟩ + rw [Germ.mapLinear_coe, Germ.coe_eq] + exact hf.mono fun x hx ↦ by simp [g, hx] + +/-- A germ eventually valued in a submodule has an everywhere-valued representative. -/ +theorem exists_rep_of_mem_germSubmodule (W : Submodule K R) {f : Germ l R} + (hf : f ∈ germSubmodule (l := l) W) : + ∃ g : T → R, (∀ x, g x ∈ W) ∧ f = (g : Germ l R) := by + classical + rw [mem_germSubmodule_iff] at hf + induction f using Germ.inductionOn with + | h f => + rw [Germ.liftPred_coe] at hf + let g : T → R := fun x ↦ if hx : f x ∈ W then f x else 0 + refine ⟨g, fun x ↦ by + by_cases hx : f x ∈ W + · simp [g, hx] + · simp [g, hx], ?_⟩ + rw [Germ.coe_eq] + exact hf.mono fun x hx ↦ by simp [g, hx] + +/-- A derivation valued in germs which lowers every successor degree by one. -/ +structure IsLoweringDerivation (Δ : Derivation K R (Germ l R)) : Prop where + mem_lower : ∀ {α : NatOrdinal.{z}}, 0 < α.constantCoeff → ∀ {x : R}, x ∈ A α → + Δ x ∈ germSubmodule (l := l) (A (α.removeNat 1)) + eq_zero : ∀ {α : NatOrdinal.{z}}, α.constantCoeff = 0 → ∀ {x : R}, x ∈ A α → Δ x = 0 + injective : ∀ {α : NatOrdinal.{z}}, 0 < α.constantCoeff → ∀ {x : R}, + x ∈ A α → Δ x = 0 → x = 0 + +namespace IsLoweringDerivation + +variable {A} {Δ : Derivation K R (Germ l R)} (hΔ : IsLoweringDerivation (l := l) A Δ) + +theorem natCast_removeNat_one (j : ℕ) (hj : 1 ≤ j) : + (j : NatOrdinal.{z}).removeNat 1 = ((j - 1 : ℕ) : NatOrdinal.{z}) := by + have hcoeff : 1 ≤ (j : NatOrdinal.{z}).constantCoeff := by + rwa [NatOrdinal.constantCoeff_natCast] + symm + apply (NatOrdinal.eq_removeNat_iff_add_natCast_eq hcoeff).mpr + rw [← Nat.cast_add, Nat.sub_add_cancel hj] + +theorem natCast_constantCoeff_pos (j : ℕ) (hj : 1 ≤ j) : + 0 < (j : NatOrdinal.{z}).constantCoeff := by + rw [NatOrdinal.constantCoeff_natCast] + exact hj + +include hΔ + +omit [GradedAlgebra A] in +theorem mem_lower_natCast {j : ℕ} (hj : 1 ≤ j) {x : R} + (hx : x ∈ A (j : NatOrdinal.{z})) : + Δ x ∈ germSubmodule (l := l) (A ((j - 1 : ℕ) : NatOrdinal.{z})) := by + rw [← natCast_removeNat_one j hj] + exact IsLoweringDerivation.mem_lower hΔ (natCast_constantCoeff_pos j hj) hx + +end IsLoweringDerivation + +/-- The Leibniz rule with the factors embedded as constant germs. -/ +theorem derivation_leibniz (Δ : Derivation K R (Germ l R)) (x y : R) : + Δ (x * y) = Δ x * (y : Germ l R) + (x : Germ l R) * Δ y := by + rw [Δ.leibniz] + change (x : Germ l R) * Δ y + (y : Germ l R) * Δ x = _ + ac_rfl + + +/-! ### Decomposables -/ + +/-- The decomposables `(A_{<ω})₊² ∩ A_n = ∑_{i+k=n, i,k ≥ 1} A_i A_k` in finite degree `n`. -/ +def decomposable (n : ℕ) : Submodule K R := + ⨆ (i : ℕ) (j : ℕ) (_ : 1 ≤ i) (_ : 1 ≤ j) (_ : i + j = n), + A (i : NatOrdinal.{z}) * A (j : NatOrdinal.{z}) + +omit [GradedAlgebra A] in +theorem decomposable_le {n : ℕ} {N : Submodule K R} + (h : ∀ i j : ℕ, 1 ≤ i → 1 ≤ j → i + j = n → + A (i : NatOrdinal.{z}) * A (j : NatOrdinal.{z}) ≤ N) : + decomposable A n ≤ N := + iSup_le fun i ↦ iSup_le fun j ↦ iSup_le fun hi ↦ iSup_le fun hj ↦ iSup_le fun hij ↦ + h i j hi hj hij + +omit [GradedAlgebra A] in +theorem mul_mem_decomposable {i j : ℕ} (hi : 1 ≤ i) (hj : 1 ≤ j) {a b : R} + (ha : a ∈ A (i : NatOrdinal.{z})) (hb : b ∈ A (j : NatOrdinal.{z})) : + a * b ∈ decomposable A (i + j) := + Submodule.mem_iSup_of_mem i (Submodule.mem_iSup_of_mem j (Submodule.mem_iSup_of_mem hi + (Submodule.mem_iSup_of_mem hj (Submodule.mem_iSup_of_mem rfl (Submodule.mul_mem_mul ha hb))))) + +omit [GradedAlgebra A] in +/-- At a finite ordinal degree, ordinal decomposables are the ordinary finite-degree +decomposables. -/ +theorem decomposableAt_natCast (n : ℕ) : + OrdinalGraded.decomposableAt A (n : NatOrdinal.{z}) = decomposable A n := by + apply le_antisymm + · refine OrdinalGraded.decomposableAt_le A fun i j hi hj hij ↦ ?_ + have hi_lt : i < NatOrdinal.of Ordinal.omega0 := + (le_add_of_nonneg_right (zero_le : 0 ≤ j)).trans_lt + (hij.le.trans_lt (NatOrdinal.natCast_lt_omega0 n)) + have hj_lt : j < NatOrdinal.of Ordinal.omega0 := + (le_add_of_nonneg_left (zero_le : 0 ≤ i)).trans_lt + (hij.le.trans_lt (NatOrdinal.natCast_lt_omega0 n)) + obtain ⟨i, rfl⟩ := NatOrdinal.lt_omega0.mp hi_lt + obtain ⟨j, rfl⟩ := NatOrdinal.lt_omega0.mp hj_lt + rw [← Nat.cast_add] at hij + have hij' : i + j = n := Nat.cast_injective hij + have hi' : 1 ≤ i := Nat.one_le_iff_ne_zero.mpr (Nat.cast_ne_zero.mp hi) + have hj' : 1 ≤ j := Nat.one_le_iff_ne_zero.mpr (Nat.cast_ne_zero.mp hj) + exact fun _ h ↦ Submodule.mem_iSup_of_mem i (Submodule.mem_iSup_of_mem j + (Submodule.mem_iSup_of_mem hi' (Submodule.mem_iSup_of_mem hj' + (Submodule.mem_iSup_of_mem hij' h)))) + · refine decomposable_le A fun i j hi hj hij ↦ ?_ + have hi' : (i : NatOrdinal.{z}) ≠ 0 := Nat.cast_ne_zero.mpr (Nat.ne_of_gt hi) + have hj' : (j : NatOrdinal.{z}) ≠ 0 := Nat.cast_ne_zero.mpr (Nat.ne_of_gt hj) + refine Submodule.mul_le.mpr fun a ha b hb ↦ ?_ + simpa [← hij] using OrdinalGraded.mul_mem_decomposableAt A hi' hj' ha hb + +/-! ### Homogeneous generators of `A_{<ω}` -/ + +variable {ι : Type w} (wt : ι → ℕ) (x : ι → R) + +/-- A family of homogeneous generators of `A_{<ω}`: `x i ∈ A_{wt i}` with `wt i ≥ 1`, the `x i` of +degree `n` linearly independent modulo the decomposables `(A_{<ω})₊² ∩ A_n`, and every element of +`A_n` a polynomial in the `x i` homogeneous of degree `n` for the grading `deg X_i = wt i` +(Mathlib's `IsWeightedHomogeneous wt`). The paper's minimal systems `𝓑` are exactly such families, +and these two properties are all its proofs use. -/ +structure IsHomogeneousCoordinates : Prop where + one_le : ∀ i, 1 ≤ wt i + mem : ∀ i, x i ∈ A (wt i : NatOrdinal.{z}) + independent : ∀ (n : ℕ) (c : ι →₀ K), (∀ i ∈ c.support, wt i = n) → + Finsupp.linearCombination K x c ∈ decomposable A n → c = 0 + surj : ∀ (n : ℕ), ∀ y ∈ A (n : NatOrdinal.{z}), + ∃ F : MvPolynomial ι K, IsWeightedHomogeneous wt F n ∧ aeval x F = y + +variable {A wt x} + +/-- Evaluation of a polynomial homogeneous of degree `n` (for `deg X_i = wt i`) at homogeneous +elements `x i ∈ A_{wt i}` lands in `A_n`. -/ +theorem aeval_mem_of_forall_mem (hmem : ∀ i, x i ∈ A (wt i : NatOrdinal.{z})) + {F : MvPolynomial ι K} {n : ℕ} (hF : IsWeightedHomogeneous wt F n) : + aeval x F ∈ A (n : NatOrdinal.{z}) := + OrdinalGraded.aeval_mem_of_forall_mem hmem + ((isWeightedHomogeneous_natCast_comp_iff wt).mpr hF) + +/-- Evaluation at homogeneous `x i ∈ A_{wt i}` is graded: the degree-`n` component of `F(x)` is +the evaluation of the degree-`n` component of `F`. -/ +theorem decompose_aeval (hmem : ∀ i, x i ∈ A (wt i : NatOrdinal.{z})) (F : MvPolynomial ι K) + (n : ℕ) : + (DirectSum.decompose A (aeval x F) (n : NatOrdinal.{z}) : R) = + aeval x (weightedHomogeneousComponent wt n F) := by + rw [OrdinalGraded.decompose_aeval hmem F (n : NatOrdinal.{z}), + weightedHomogeneousComponent_natCast_comp] + +/-- Homogeneous generators from a generation hypothesis by arbitrary polynomials: the homogeneous +component of the right degree still evaluates to a given homogeneous element. -/ +theorem IsHomogeneousCoordinates.of_surjective (one_le : ∀ i, 1 ≤ wt i) + (hmem : ∀ i, x i ∈ A (wt i : NatOrdinal.{z})) + (independent : ∀ (n : ℕ) (c : ι →₀ K), (∀ i ∈ c.support, wt i = n) → + Finsupp.linearCombination K x c ∈ decomposable A n → c = 0) + (surj : ∀ (n : ℕ), ∀ y ∈ A (n : NatOrdinal.{z}), ∃ F : MvPolynomial ι K, aeval x F = y) : + IsHomogeneousCoordinates A wt x where + one_le := one_le + mem := hmem + independent := independent + surj n y hy := by + obtain ⟨F, hF⟩ := surj n y hy + refine ⟨weightedHomogeneousComponent wt n F, + weightedHomogeneousComponent_isWeightedHomogeneous (w := wt) (n := n) (φ := F), ?_⟩ + rw [← decompose_aeval hmem, hF, DirectSum.decompose_of_mem_same A hy] + +variable (A wt x) in +/-- The paper's minimal system of homogeneous generators of `A_{<ω}`: a family `x i ∈ A_{wt i}` of +homogeneous elements of positive degree `wt i ≥ 1` whose image in `(A_{<ω})₊/(A_{<ω})₊²` is an +`K`-basis; equivalently, for each `n ≥ 1` the `x i` of degree `n` form a basis of a complement of +`(A_{<ω})₊² ∩ A_n = ∑_{i+k=n, i,k ≥ 1} A_i A_k` in `A_n` — they are linearly independent modulo +`(A_{<ω})₊² ∩ A_n` and span `A_n` modulo it. -/ +structure IsMinimalSystem : Prop where + /-- Every generator has positive degree. -/ + one_le : ∀ i, 1 ≤ wt i + /-- `x i` is homogeneous of degree `wt i`. -/ + mem : ∀ i, x i ∈ A (wt i : NatOrdinal.{z}) + /-- The generators of degree `n` are linearly independent modulo `(A_{<ω})₊² ∩ A_n`. -/ + independent : ∀ (n : ℕ) (c : ι →₀ K), (∀ i ∈ c.support, wt i = n) → + Finsupp.linearCombination K x c ∈ decomposable A n → c = 0 + /-- The generators of degree `n` span `A_n` modulo `(A_{<ω})₊² ∩ A_n`, for `n ≥ 1`. -/ + spans : ∀ n : ℕ, 1 ≤ n → ∀ y ∈ A (n : NatOrdinal.{z}), ∃ c : ι →₀ K, + (∀ i ∈ c.support, wt i = n) ∧ y - Finsupp.linearCombination K x c ∈ decomposable A n + +/-- A minimal system generates `A_{<ω}`: evaluation is onto each `A_n`, by induction on `n`, using +`A_0 = K` in degree zero. -/ +theorem IsMinimalSystem.isHomogeneousCoordinates (h0 : GradeZeroScalars A) + (hx : IsMinimalSystem A wt x) : + IsHomogeneousCoordinates A wt x := by + refine IsHomogeneousCoordinates.of_surjective hx.one_le hx.mem hx.independent ?_ + intro n + induction n using Nat.strong_induction_on with + | _ n ih => + intro y hy + rcases Nat.eq_zero_or_pos n with rfl | hn + · obtain ⟨e, rfl⟩ := (gradeZeroScalars_iff A).mp h0 y (by rwa [Nat.cast_zero] at hy) + exact ⟨C e, aeval_C x e⟩ + · obtain ⟨c, -, hc⟩ := hx.spans n hn y hy + have hD : decomposable A n ≤ + Subalgebra.toSubmodule (aeval x : MvPolynomial ι K →ₐ[K] R).range := by + refine decomposable_le A fun i j hi hj hij ↦ Submodule.mul_le.mpr fun a ha b hb ↦ ?_ + obtain ⟨F, hF⟩ := ih i (by omega) a ha + obtain ⟨G, hG⟩ := ih j (by omega) b hb + exact (Subalgebra.mem_toSubmodule _).mpr ((AlgHom.mem_range _).mpr + ⟨F * G, by rw [map_mul, hF, hG]⟩) + obtain ⟨G, hG⟩ := (AlgHom.mem_range _).mp ((Subalgebra.mem_toSubmodule _).mp (hD hc)) + have hlc : aeval x (Finsupp.linearCombination K (X : ι → MvPolynomial ι K) c) = + Finsupp.linearCombination K x c := by + rw [← AlgHom.toLinearMap_apply, Finsupp.apply_linearCombination] + congr 2 + funext i + exact aeval_X x i + exact ⟨G + Finsupp.linearCombination K (X : ι → MvPolynomial ι K) c, + by rw [map_add, hG, hlc, sub_add_cancel]⟩ + +/-- A polynomial homogeneous of degree `n ≥ 1` evaluates at homogeneous generators of positive +degrees to its linear part in the degree-`n` variables plus an element of `(A_{<ω})₊² ∩ A_n`; the +linear coefficients are read off the polynomial. -/ +theorem exists_linear_part (hwt : ∀ i, 1 ≤ wt i) (hmem : ∀ i, x i ∈ A (wt i : NatOrdinal.{z})) + {F : MvPolynomial ι K} {n : ℕ} (hn : 1 ≤ n) (hF : IsWeightedHomogeneous wt F n) : + ∃ c : ι →₀ K, (∀ i ∈ c.support, wt i = n) ∧ + aeval x F - Finsupp.linearCombination K x c ∈ decomposable A n ∧ + ∀ i, c i = F.coeff (Finsupp.single i 1) := by + obtain ⟨c, hcwt, hc, hcoeff⟩ := OrdinalGraded.exists_linear_part + (fun i ↦ Nat.cast_ne_zero.mpr (Nat.one_le_iff_ne_zero.mp (hwt i))) hmem + (Nat.cast_ne_zero.mpr (Nat.one_le_iff_ne_zero.mp hn)) + ((isWeightedHomogeneous_natCast_comp_iff wt).mpr hF) + refine ⟨c, fun i hi ↦ Nat.cast_injective (hcwt i hi), ?_, hcoeff⟩ + rwa [decomposableAt_natCast] at hc + +namespace IsHomogeneousCoordinates + +variable (hx : IsHomogeneousCoordinates A wt x) +include hx + +/-- Evaluation of a polynomial homogeneous of degree `n` lands in `A_n`. -/ +theorem aeval_mem {F : MvPolynomial ι K} {n : ℕ} (hF : IsWeightedHomogeneous wt F n) : + aeval x F ∈ A (n : NatOrdinal.{z}) := + aeval_mem_of_forall_mem hx.mem hF + +/-! ### The chain rule for `∂` -/ + +variable {Δ : Derivation K R (Germ l R)} (hΔ : IsLoweringDerivation A Δ) +include hΔ + +omit hx in +theorem map_algebraMap (e : K) : Δ (algebraMap K R e) = 0 := + hΔ.eq_zero (by rw [NatOrdinal.constantCoeff_zero]) (SetLike.algebraMap_mem_graded A e) + +omit hx in +/-- The chain rule: if `∂(x i)` is represented by `γ ↦ (g i γ)(x)`, then `∂(F(x))` is represented +by `γ ↦ (∂_γ F)(x)`, where `∂_γ = ∑ g i γ ∂/∂X_i` (Lean `mkDerivation K (fun i ↦ g i γ)`). -/ +theorem map_aeval (g : ι → T → MvPolynomial ι K) + (hg : ∀ i, Δ (x i) = ((fun γ ↦ aeval x (g i γ)) : Germ l R)) (F : MvPolynomial ι K) : + Δ (aeval x F) = ((fun γ ↦ aeval x (mkDerivation K (fun i ↦ g i γ) F)) : Germ l R) := by + induction F using MvPolynomial.induction_on with + | C e => + rw [aeval_C, map_algebraMap hΔ] + have : ∀ γ, aeval x (mkDerivation K (fun i ↦ g i γ) (C e)) = 0 := fun γ ↦ by + rw [← MvPolynomial.algebraMap_eq, Derivation.map_algebraMap, map_zero] + simp only [this] + rfl + | add p q hp hq => + rw [map_add, map_add, hp, hq] + simp only [map_add] + rfl + | mul_X p i hp => + rw [map_mul, aeval_X, derivation_leibniz, hp, hg i] + have : ∀ γ, aeval x (mkDerivation K (fun i ↦ g i γ) (p * X i)) = + aeval x (mkDerivation K (fun i ↦ g i γ) p) * x i + aeval x p * aeval x (g i γ) := fun γ ↦ by + rw [Derivation.leibniz, smul_eq_mul, smul_eq_mul, mkDerivation_X, map_add, map_mul, map_mul, + aeval_X, add_comm, mul_comm (x i)] + simp only [this] + rfl + +omit [GradedAlgebra A] in +/-- Polynomial representatives of `∂(x i)`, the paper's `G_B(γ)`: polynomials `g i γ` homogeneous +of degree `wt i - 1` with `γ ↦ (g i γ)(x)` representing `∂(x i)`. -/ +theorem exists_lifts : ∃ g : ι → T → MvPolynomial ι K, + (∀ i γ, IsWeightedHomogeneous wt (g i γ) (wt i - 1)) ∧ + ∀ i, Δ (x i) = ((fun γ ↦ aeval x (g i γ)) : Germ l R) := by + have hrep : ∀ i, ∃ f : T → R, (∀ γ, f γ ∈ A ((wt i - 1 : ℕ) : NatOrdinal.{z})) ∧ + Δ (x i) = (f : Germ l R) := fun i ↦ + exists_rep_of_mem_germSubmodule _ (hΔ.mem_lower_natCast (hx.one_le i) (hx.mem i)) + choose f hf hfΔ using hrep + choose g hg hgf using fun i γ ↦ hx.surj (wt i - 1) (f i γ) (hf i γ) + refine ⟨g, hg, fun i ↦ ?_⟩ + rw [hfΔ i] + congr 1 + funext γ + exact (hgf i γ).symm + +end IsHomogeneousCoordinates + +/-! ### The kernel of the pointwise derivations -/ + +variable {Δ : Derivation K R (Germ l R)} + +omit [GradedAlgebra A] in +/-- Polynomials homogeneous of degree zero (for `deg X_i = wt i ≥ 1`) are constants. -/ +theorem eq_C_of_isWeightedHomogeneous_zero (hwt : ∀ i, 1 ≤ wt i) {p : MvPolynomial ι K} + (hp : IsWeightedHomogeneous wt p 0) : p = C (p.coeff 0) := + OrdinalGraded.eq_C_of_isWeightedHomogeneous_zero (wt := fun i ↦ (wt i : NatOrdinal.{0})) + (fun i ↦ Nat.cast_ne_zero.mpr (Nat.one_le_iff_ne_zero.mp (hwt i))) + ((isWeightedHomogeneous_natCast_comp_iff (M := NatOrdinal.{0}) wt).mpr hp) + +/-- The joint-kernel lemma: no non-zero polynomial homogeneous of positive degree satisfies +`∂_γ F = 0` for all `γ < 0` sufficiently close to `0`, for homogeneous generators of positive +degrees independent modulo the decomposables. Induction on the degree: write a putative kernel +element `F = ∑ c_d X₀^d` in a variable `X₀` of maximal degree and compare the coefficients of +`X₀^D` and `X₀^(D-1)` in `∂_γ F`. The leading coefficient `c_D` is a kernel element of smaller +degree, hence a scalar `a`, and the next coefficient combines with `D·a·X₀` into a polynomial `h` +homogeneous of degree `deg X₀` with `∂(h(x)) = 0`; injectivity of `∂` and independence modulo the +decomposables force `D a = 0`. -/ +theorem eq_zero_of_eventually_mkDerivation_eq_zero [CharZero K] (hwt : ∀ i, 1 ≤ wt i) + (hmem : ∀ i, x i ∈ A (wt i : NatOrdinal.{z})) + (hind : ∀ (n : ℕ) (c : ι →₀ K), (∀ i ∈ c.support, wt i = n) → + Finsupp.linearCombination K x c ∈ decomposable A n → c = 0) + (hΔ : IsLoweringDerivation A Δ) (g : ι → T → MvPolynomial ι K) + (hghom : ∀ i γ, IsWeightedHomogeneous wt (g i γ) (wt i - 1)) + (hg : ∀ i, Δ (x i) = ((fun γ ↦ aeval x (g i γ)) : Germ l R)) (w : ℕ) : + ∀ F : MvPolynomial ι K, 1 ≤ w → IsWeightedHomogeneous wt F w → + (∀ᶠ γ in l, mkDerivation K (fun i ↦ g i γ) F = 0) → F = 0 := by + classical + induction w using Nat.strong_induction_on with + | _ w ih => + intro F hw hF hD + by_contra hF0 + -- a variable `X x₀` of maximal degree `wt x₀`; `F` has positive degree `D` in `X x₀` + have hvars : F.vars.Nonempty := by + rw [Finset.nonempty_iff_ne_empty, Ne, vars_eq_empty_iff_eq_C] + intro hC + exact hF0 (by rw [hC, hF.coeff_eq_zero 0 (by rw [map_zero]; omega), map_zero]) + obtain ⟨x₀, hx₀, hmax⟩ := F.vars.exists_max_image wt hvars + have hn1 : 1 ≤ wt x₀ := hwt x₀ + set D := F.degreeOf x₀ with hDdef + have hD1 : 1 ≤ D := Nat.one_le_iff_ne_zero.mpr (mem_vars_iff_degreeOf_ne_zero.mp hx₀) + -- write `F = ∑ c_d (X x₀)^d` + set c : ℕ → MvPolynomial ι K := fun d ↦ xCoeff x₀ d F with hc + have hexp : F = ∑ d ∈ Finset.range (D + 1), c d * X x₀ ^ d := (sum_xCoeff_mul_X_pow x₀ F).symm + have hcD : c D ≠ 0 := xCoeff_degreeOf_ne_zero x₀ hF0 + have hcD1 : c (D + 1) = 0 := xCoeff_eq_zero_of_degreeOf_lt x₀ (Nat.lt_succ_self D) + have hchom : ∀ d, IsWeightedHomogeneous wt (c d) (w - d * wt x₀) := fun d ↦ + xCoeff_isWeightedHomogeneous wt x₀ hF d + have hcsupp : ∀ d, c d ∈ supported K {x₀}ᶜ := fun d ↦ xCoeff_mem_supported x₀ d F + have hgsupp : ∀ γ, g x₀ γ ∈ supported K {x₀}ᶜ := fun γ ↦ + (hghom x₀ γ).mem_supported_of_lt wt (by omega) + have hDsupp : ∀ γ d, mkDerivation K (fun i ↦ g i γ) (c d) ∈ supported K {x₀}ᶜ := fun γ d ↦ + mkDerivation_mem_supported wt hwt _ (fun i ↦ hghom i γ) (hcsupp d) fun i hi ↦ + hmax i (vars_xCoeff_subset x₀ d F hi) + -- `∂_γ F = ∑_d (∂_γ c_d + (d + 1) c_(d+1) g_(x₀)) (X x₀)^d`; compare coefficients + set q : T → ℕ → MvPolynomial ι K := fun γ d ↦ mkDerivation K (fun i ↦ g i γ) (c d) + + ((d + 1 : ℕ) : MvPolynomial ι K) * (c (d + 1) * g x₀ γ) with hq + have hqsupp : ∀ γ d, q γ d ∈ supported K {x₀}ᶜ := fun γ d ↦ + add_mem (hDsupp γ d) (mul_mem (Subalgebra.natCast_mem _ _) (mul_mem (hcsupp _) (hgsupp γ))) + have hDexp : ∀ γ, mkDerivation K (fun i ↦ g i γ) F = + ∑ d ∈ Finset.range (D + 1), q γ d * X x₀ ^ d := by + intro γ + have hterm : ∀ d, mkDerivation K (fun i ↦ g i γ) (c d * X x₀ ^ d) = + mkDerivation K (fun i ↦ g i γ) (c d) * X x₀ ^ d + + (d : MvPolynomial ι K) * (c d * g x₀ γ) * X x₀ ^ (d - 1) := fun d ↦ by + rw [Derivation.leibniz, Derivation.leibniz_pow, mkDerivation_X] + simp only [smul_eq_mul, nsmul_eq_mul] + ring + conv_lhs => rw [hexp, map_sum, Finset.sum_congr rfl fun d _ ↦ hterm d, Finset.sum_add_distrib] + simp only [hq, add_mul] + rw [Finset.sum_add_distrib] + congr 1 + rw [Finset.sum_range_succ', Finset.sum_range_succ] + simp only [Nat.cast_zero, zero_mul, add_zero, hcD1, mul_zero, Nat.add_sub_cancel] + have hcoeff : ∀ γ, mkDerivation K (fun i ↦ g i γ) F = 0 → ∀ d ≤ D, q γ d = 0 := by + intro γ hγ d hd + have := xCoeff_sum_mul_X_pow x₀ (Finset.range (D + 1)) (q := q γ) (fun d _ ↦ hqsupp γ d) d + rwa [← hDexp γ, hγ, map_zero, ite_eq_left (Finset.mem_range.mpr (by omega)), eq_comm] at this + -- the coefficient of `(X x₀)^D`: `∂_γ c_D = 0`, so `c_D` is a non-zero scalar `a` + have hcD0 : ∀ᶠ γ in l, mkDerivation K (fun i ↦ g i γ) (c D) = 0 := + hD.mono fun γ hγ ↦ by simpa [hq, hcD1] using hcoeff γ hγ D le_rfl + have hwD : w = D * wt x₀ := by + by_contra hne + have hle := le_of_xCoeff_ne_zero wt x₀ hF hcD + have hpos : 0 < D * wt x₀ := Nat.mul_pos hD1 hn1 + exact hcD (ih _ (by omega) (c D) (by omega) (hchom D) hcD0) + have hw0 : w - D * wt x₀ = 0 := by omega + set a := (c D).coeff 0 with ha + have hcDa : c D = C a := eq_C_of_isWeightedHomogeneous_zero hwt (hw0 ▸ hchom D) + have ha0 : a ≠ 0 := fun h ↦ hcD (by rw [hcDa, h, map_zero]) + -- the coefficient of `(X x₀)^(D-1)`: `h := c_(D-1) + D a X x₀` has degree `wt x₀`, `∂_γ h = 0` + set h : MvPolynomial ι K := c (D - 1) + C ((D : K) * a) * X x₀ with hh + have hhhom : IsWeightedHomogeneous wt h (wt x₀) := by + refine IsWeightedHomogeneous.add ?_ ?_ + · have := hchom (D - 1) + have hw' : w - (D - 1) * wt x₀ = wt x₀ := by + rw [hwD] + have : D * wt x₀ = (D - 1) * wt x₀ + wt x₀ := by + conv_lhs => rw [← Nat.sub_add_cancel hD1] + ring + omega + rwa [hw'] at this + · have := (isWeightedHomogeneous_C wt ((D : K) * a)).mul (isWeightedHomogeneous_X K wt x₀) + rwa [zero_add] at this + have hDh : ∀ γ, mkDerivation K (fun i ↦ g i γ) h = q γ (D - 1) := by + intro γ + rw [hh, hq] + simp only [Nat.sub_add_cancel hD1, hcDa] + rw [map_add, ← smul_eq_C_mul, Derivation.map_smul, mkDerivation_X, smul_eq_C_mul, map_mul, + map_natCast] + ring + have hh0 : ∀ᶠ γ in l, mkDerivation K (fun i ↦ g i γ) h = 0 := + hD.mono fun γ hγ ↦ by rw [hDh]; exact hcoeff γ hγ (D - 1) (Nat.sub_le D 1) + -- `∂(h(x)) = 0`, hence `h(x) = 0`, and the linear part of `h` in the variables of degree + -- `wt x₀` vanishes: `D a = 0` + have hΔh : Δ (aeval x h) = 0 := by + rw [IsHomogeneousCoordinates.map_aeval hΔ g hg h] + change _ = ((fun _ ↦ (0 : R) : T → R) : Germ l R) + rw [Filter.Germ.coe_eq] + exact hh0.mono fun γ hγ ↦ by + change aeval x (mkDerivation K (fun i ↦ g i γ) h) = 0 + rw [hγ, map_zero] + have haeval : aeval x h = 0 := + hΔ.injective (IsLoweringDerivation.natCast_constantCoeff_pos (wt x₀) hn1) + (aeval_mem_of_forall_mem hmem hhhom) hΔh + obtain ⟨cf, hcfw, hcf, hcfcoeff⟩ := exists_linear_part hwt hmem hn1 hhhom + rw [haeval, zero_sub, neg_mem_iff] at hcf + have hcx := hcfcoeff x₀ + rw [hind (wt x₀) cf hcfw hcf, Finsupp.coe_zero, Pi.zero_apply, hh, AddMonoidAlgebra.coeff_add, + Finsupp.add_apply, hc, coeff_xCoeff, + ite_eq_right (by simp), zero_add, C_mul_X_eq_monomial, coeff_monomial, ite_eq_left rfl] at hcx + exact ha0 ((mul_eq_zero.mp hcx.symm).resolve_left (Nat.cast_ne_zero.mpr (by omega))) + +/-! ### Algebraic independence -/ + +namespace IsHomogeneousCoordinates + +variable [CharZero K] (hx : IsHomogeneousCoordinates A wt x) (hΔ : IsLoweringDerivation A Δ) +include hx hΔ + +/-- No non-zero polynomial homogeneous of degree `w` vanishes at the generators: induction on +`w`; by the chain rule, a relation of degree `w` has as `∂`-derivative a family of relations of +degree `w - 1`, which vanish by induction, so the relation lies in the joint kernel and +vanishes. -/ +theorem eq_zero_of_aeval_eq_zero_of_isWeightedHomogeneous [Nontrivial R] (w : ℕ) : + ∀ F : MvPolynomial ι K, IsWeightedHomogeneous wt F w → aeval x F = 0 → F = 0 := by + classical + obtain ⟨g, hghom, hg⟩ := hx.exists_lifts hΔ + induction w using Nat.strong_induction_on with + | _ w ih => + intro F hF hF0 + rcases Nat.eq_zero_or_pos w with rfl | hw + · rw [eq_C_of_isWeightedHomogeneous_zero hx.one_le hF] at hF0 ⊢ + rw [aeval_C] at hF0 + rw [(algebraMap K R).injective (hF0.trans (map_zero _).symm), map_zero] + · refine eq_zero_of_eventually_mkDerivation_eq_zero hx.one_le hx.mem hx.independent hΔ g hghom + hg w F hw hF ?_ + have h1 := map_aeval hΔ g hg F + rw [hF0, map_zero] at h1 + change ((fun _ ↦ (0 : R) : T → R) : Germ l R) = _ at h1 + rw [Filter.Germ.coe_eq] at h1 + refine h1.mono fun γ hγ ↦ ?_ + exact ih (w - 1) (by omega) _ (mkDerivation_isWeightedHomogeneous wt _ (fun i ↦ hghom i γ) + hx.one_le hF) hγ.symm + +/-- The homogeneous generators are algebraically independent: evaluation `K[X_B : B ∈ 𝓑] → A` +is injective. -/ +theorem aeval_injective [Nontrivial R] : + Function.Injective (aeval x : MvPolynomial ι K →ₐ[K] R) := by + apply OrdinalGraded.aeval_injective_of_forall_injectiveAt hx.mem + intro β + rw [OrdinalGraded.injectiveAt_iff] + intro F hF hF0 + by_cases hzero : F = 0 + · exact hzero + obtain ⟨n, hn⟩ := hF.exists_degree_eq_natCast hzero + subst β + exact hx.eq_zero_of_aeval_eq_zero_of_isWeightedHomogeneous hΔ n F + ((isWeightedHomogeneous_natCast_comp_iff wt).mp hF) hF0 + +end IsHomogeneousCoordinates + + +end GermPolynomial diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/DirectSum/GermSuccessorStep.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/DirectSum/GermSuccessorStep.lean new file mode 100644 index 0000000000..5cf94918ae --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/DirectSum/GermSuccessorStep.lean @@ -0,0 +1,691 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.DirectSum.GermFinitePartIdeal +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.GradedRing.FinitePartSubstitution +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.DirectSum.GermSyzygy +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MvPolynomial.Syzygy + +/-! +# The successor step over an arbitrary filter + +Evaluation at a minimal system of homogeneous generators is injective in a degree whose finite part +is at least one, given that it is injective in every smaller degree. + +The argument is by contradiction. A nonzero relation of that degree lies in the ideal generated by +its partial derivatives at the variables carrying the finite part; choosing a minimal generating +subset of those derivatives and writing the relation against it produces an evaluated syzygy, which +the syzygy induction places in the span of the derivation-annihilated syzygies. Every entry of that +syzygy then evaluates into the square of the ideal of positive degree, and so does the linear part +of the corresponding cofactor — contradicting the independence of the generators modulo that square. + +The two inputs not supplied by the abstract interface are the integration statements: ideal +membership from a derivative germ, and prescribed values on a set carrying a derivative +representative. Both are proved by their own construction in each setting. +-/ + +universe u v w z q + +open Filter GermPolynomial MvPolynomial OrdinalGraded DirectSum + +public noncomputable section + +namespace OrdinalGraded + +variable {K : Type u} {R : Type v} {T : Type q} +variable [Field K] [CommRing R] [Algebra K R] +variable {l : Filter T} +variable {A : NatOrdinal.{z} → Submodule K R} [GradedAlgebra A] +variable {ι : Type w} {wt : ι → NatOrdinal.{z}} {x : ι → R} +variable {Δ : Derivation K R (Germ l R)} +variable (hx : OrdinalGraded.IsMinimalSystem A wt x) +variable (hΔ : GermPolynomial.IsLoweringDerivation A Δ) +include hx + +open Classical in +/-- Normalized cofactors have a nonzero linear part modulo decomposable homogeneous elements. -/ +private theorem not_forall_aeval_cofactors_mem_decomposable + {δ : NatOrdinal.{z}} (hδ : 0 < δ.constantCoeff) + (T B : Finset ι) (hBT : B ⊆ T) (hBne : B.Nonempty) + (lam : ι → NatOrdinal.{z}) (hlam : ∀ t ∈ T, lam t + wt t = δ) + (hconst : ∀ t ∈ T, (wt t).constantCoeff = δ.constantCoeff) + (V : ι → MvPolynomial ι K) + (hV : ∀ t ∈ T, IsWeightedHomogeneous wt (V t) (wt t) ∧ + V t ∈ supported K {i | (wt i).constantCoeff ≠ δ.constantCoeff}) + (a' : ι → ↥B → MvPolynomial ι K) (ha'one : ∀ b : ↥B, a' b b = 1) + (ha'hom : ∀ t ∈ T, ∀ b : ↥B, ∀ β, β + lam b = lam t → + IsWeightedHomogeneous wt (a' t b) β) + (ha'0 : ∀ t ∈ T, ∀ b : ↥B, (¬ ∃ β, β + lam b = lam t) → a' t b = 0) + (W : ↥B → MvPolynomial ι K) + (hW : ∀ b, W b = ∑ t ∈ T, a' t b * (X t + V t)) : + ¬ ∀ b : ↥B, aeval x (W b) ∈ decomposableAt A (wt b) := by + classical + intro hWdec + -- the linear part `ℓ_b` of `W_b` then lies in `(P̂_+)² ∩ P_{deg b}`, contradicting the linear + -- independence of the generators modulo `(P̂_+)² ∩ P_{deg b}` + obtain ⟨b₀, hb₀⟩ := hBne + obtain ⟨b, hb⟩ : ∃ b : ↥B, (b : ι) = b₀ := ⟨⟨b₀, hb₀⟩, rfl⟩ + obtain ⟨κ', hκ'⟩ : ∃ κ' : ι → K, ∀ t, κ' t = (a' t b).coeff 0 := ⟨_, fun _ ↦ rfl⟩ + obtain ⟨ℓ, hℓ⟩ : ∃ ℓ : MvPolynomial ι K, ℓ = ∑ t ∈ T, C (κ' t) * X t := ⟨_, rfl⟩ + have hdiff : aeval x (W b) - aeval x ℓ ∈ decomposableAt (A) (wt b) := by + rw [hW, hℓ, map_sum, map_sum, ← Finset.sum_sub_distrib] + refine sum_mem fun t ht ↦ ?_ + rw [map_mul, map_mul, map_add, aeval_X, ← algebraMap_eq, AlgHom.commutes] + have hVt : aeval x (V t) ∈ decomposableAt (A) (wt t) := by + refine aeval_mem_decomposableAt_of_mem_supported hx.mem hx.ne_zero ?_ (hV t ht).1 ?_ + · rw [hconst t ht] + exact hδ + · rw [hconst t ht] + exact (hV t ht).2 + by_cases h : ∃ β, β + lam b = lam t + · obtain ⟨β, hβ⟩ := h + have hahom := ha'hom t ht b β hβ + have hdeg : β + wt t = wt b := by + apply add_right_cancel (b := lam b) + rw [add_right_comm, hβ, hlam t ht, add_comm, hlam b (hBT b.2)] + by_cases hβ0 : β = 0 + · -- a scalar coefficient: the difference is `κ' t • V_t(𝓑)` + subst hβ0 + have hC : a' t b = C (κ' t) := by + rw [hκ'] + exact eq_C_of_isWeightedHomogeneous_zero hx.ne_zero hahom + rw [zero_add] at hdeg + rw [hC] + rw [← algebraMap_eq] + rw [AlgHom.commutes] + rw [mul_add] + rw [add_sub_cancel_left] + rw [mul_comm] + rw [← hdeg] + have := mul_mem_decomposableAt_of_mem_decomposableAt hVt + (SetLike.algebraMap_mem_graded (A) (κ' t)) + rwa [add_zero] at this + · have hκ0 : κ' t = 0 := by + rw [hκ'] + exact coeff_zero_eq_zero_of_isWeightedHomogeneous hahom hβ0 + rw [hκ0, map_zero, zero_mul, sub_zero, mul_add, ← hdeg] + refine add_mem (mul_mem_decomposableAt (A) hβ0 (hx.ne_zero t) + (aeval_mem_of_forall_mem hx.mem hahom) (hx.mem t)) ?_ + rw [mul_comm, add_comm] + exact mul_mem_decomposableAt_of_mem_decomposableAt hVt + (aeval_mem_of_forall_mem hx.mem hahom) + · have hκ0 : κ' t = 0 := by + rw [hκ', ha'0 t ht b h, AddMonoidAlgebra.coeff_zero, Finsupp.zero_apply] + rw [ha'0 t ht b h, hκ0] + simp only [map_zero, zero_mul, sub_zero] + exact zero_mem _ + have hℓmem : aeval x ℓ ∈ decomposableAt (A) (wt b) := by + have hub := hWdec b + have := sub_mem hub hdiff + rwa [sub_sub_cancel] at this + -- `ℓ(𝓑)` is a linear combination of the generators of degree `wt b` with coefficient `1` on + -- `x_b` + obtain ⟨f, hf⟩ : ∃ f : ι →₀ K, f = ∑ t ∈ T, Finsupp.single t (κ' t) := ⟨_, rfl⟩ + have hfapply : ∀ i, f i = if i ∈ T then κ' i else 0 := by + intro i + rw [hf, Finsupp.finsetSum_apply] + simp only [Finsupp.single_apply] + exact Finset.sum_ite_eq' T i κ' + have hℓeq : Finsupp.linearCombination K x f = aeval x ℓ := by + rw [hf, map_sum, hℓ, map_sum] + exact Finset.sum_congr rfl fun t _ ↦ by + rw [Finsupp.linearCombination_single, map_mul, aeval_X, ← algebraMap_eq, AlgHom.commutes, + Algebra.smul_def] + have hfsupp : ∀ i ∈ f.support, wt i = wt b := by + intro i hi + rw [Finsupp.mem_support_iff, hfapply] at hi + split_ifs at hi with hiT + · by_cases h : ∃ β, β + lam b = lam i + · obtain ⟨β, hβ⟩ := h + have hahom := ha'hom i hiT b β hβ + by_cases hβ0 : β = 0 + · subst hβ0 + rw [zero_add] at hβ + have := (hlam i hiT).trans (hlam b (hBT b.2)).symm + rw [hβ] at this + exact add_left_cancel this + · refine absurd ?_ hi + rw [hκ'] + exact coeff_zero_eq_zero_of_isWeightedHomogeneous hahom hβ0 + · refine absurd ?_ hi + rw [hκ', ha'0 i hiT b h, AddMonoidAlgebra.coeff_zero, Finsupp.zero_apply] + · exact absurd rfl hi + have hfmem : Finsupp.linearCombination K x f ∈ decomposableAt (A) (wt b) := by + rw [hℓeq] + exact hℓmem + have hf0 := hx.independent (wt b) f hfsupp hfmem + have hfb := congrArg (fun g : ι →₀ K ↦ g b₀) hf0 + simp only [Finsupp.coe_zero, Pi.zero_apply] at hfb + rw [hfapply, ite_eq_left (hBT hb₀)] at hfb + have hκ1 : κ' b₀ = 1 := by + rw [hκ', ← hb, ha'one b, AddMonoidAlgebra.coeff_one_zero] + rw [hκ1] at hfb + exact one_ne_zero hfb + + +open Classical in +omit [GradedAlgebra A] in +/-- Syzygies of a minimal homogeneous generating set have decomposable entries. -/ +private theorem syzygy_entries_mem_decomposable + (hgz : GradeZeroScalars A) {δ : NatOrdinal.{z}} (hδ : 0 < δ.constantCoeff) + (hinj : ∀ β < δ, InjectiveAt K wt x β) (B : Finset ι) + (c : ι → MvPolynomial ι K) (lam : ι → NatOrdinal.{z}) + (hlam : ∀ b : ↥B, lam b + wt b = δ) + (hlamc : ∀ b : ↥B, (lam b).constantCoeff = 0) + (hlamlt : ∀ b : ↥B, lam b < δ) + (hchom : ∀ b : ↥B, IsWeightedHomogeneous wt (c b) (lam b)) + (hBmin' : ∀ b ∈ B, c b ∉ Ideal.span (c '' ((B.erase b : Finset ι) : Set ι))) + (TP : Finset (↥B → R)) (eT : (↥B → R) → NatOrdinal.{z}) + (hTPhom : ∀ w ∈ TP, IsHomogeneousTuple A (fun b : ↥B ↦ lam b) w (eT w)) + (hTPlim : ∀ w ∈ TP, ∀ (b : ↥B) β, w b ∈ A β → w b ≠ 0 → β.constantCoeff = 0) + (hTPsyz : ∀ w ∈ TP, ∑ b : ↥B, aeval x (c b) * w b = 0) + (u : ↥B → R) (a₂ : (↥B → R) → R) + (ha₂ : ∀ w ∈ TP, (∀ ρ, ρ + eT w = δ → a₂ w ∈ A ρ) ∧ + ((¬ ∃ ρ, ρ + eT w = δ) → a₂ w = 0)) + (hu_eq : u = ∑ w ∈ TP, a₂ w • w) : + ∀ b : ↥B, u b ∈ decomposableAt A (wt b) := by + classical + intro b + have hub := congrFun hu_eq b + rw [Finset.sum_apply] at hub + simp only [Pi.smul_apply, smul_eq_mul] at hub + rw [hub] + refine sum_mem fun w hw ↦ ?_ + by_cases hwb : w b = 0 + · rw [hwb, mul_zero] + exact zero_mem _ + by_cases ha0 : a₂ w = 0 + · rw [ha0, zero_mul] + exact zero_mem _ + have hhom := (isHomogeneousTuple_iff.mp (hTPhom w hw)) b + obtain ⟨β, hβ⟩ : ∃ β, β + lam b = eT w := by + by_contra hn + exact hwb (hhom.2 hn) + have hwβ : w b ∈ A β := hhom.1 β hβ + obtain ⟨ρ, hρ⟩ : ∃ ρ, ρ + eT w = δ := by + by_contra hn + exact ha0 ((ha₂ w hw).2 hn) + have haρ : a₂ w ∈ A ρ := (ha₂ w hw).1 ρ hρ + have hρβ : ρ + β = wt b := by + apply add_right_cancel (b := lam b) + rw [add_assoc, hβ, hρ, add_comm] + exact (hlam b).symm + -- `ρ ≠ 0`: its finite part is that of `δ`, `n ≥ 1` + have hβc : β.constantCoeff = 0 := hTPlim w hw b β hwβ hwb + have hρ0 : ρ ≠ 0 := by + intro h0 + have h1 := congrArg NatOrdinal.constantCoeff hρ + rw [NatOrdinal.constantCoeff_add, ← hβ, NatOrdinal.constantCoeff_add, hβc, + hlamc b, h0, NatOrdinal.constantCoeff_zero] at h1 + omega + -- `β ≠ 0`: a scalar entry would put `c_b` in the ideal of the other `c_{b'}` + have hβ0 : β ≠ 0 := by + intro h0 + rw [h0, zero_add] at hβ + rw [h0] at hwβ + obtain ⟨κ, hκ⟩ := (gradeZeroScalars_iff A).mp hgz (w b) hwβ + have hκ0 : κ ≠ 0 := by + rintro rfl + exact hwb (by rw [hκ, map_zero]) + have hP : ∀ b' : ↥B, ∃ P : MvPolynomial ι K, + (∀ β', β' + lam b' = lam b → IsWeightedHomogeneous wt P β') ∧ + ((¬ ∃ β', β' + lam b' = lam b) → P = 0) ∧ aeval x P = w b' := by + intro b' + have hhom' := (isHomogeneousTuple_iff.mp (hTPhom w hw)) b' + rw [← hβ] at hhom' + by_cases h : ∃ β', β' + lam b' = lam b + · obtain ⟨β', hβ'⟩ := h + obtain ⟨P, hPhom, hPw⟩ := hx.exists_aeval_eq hgz β' + (w b') (hhom'.1 β' hβ') + refine ⟨P, fun β'' hβ'' ↦ ?_, fun hn ↦ absurd ⟨β', hβ'⟩ hn, hPw⟩ + rwa [add_right_cancel (hβ''.trans hβ'.symm)] + · exact ⟨0, fun β' hβ' ↦ absurd ⟨β', hβ'⟩ h, fun _ ↦ rfl, by rw [map_zero, hhom'.2 h]⟩ + choose P hPhom hP0 hPw using hP + -- the relation `κ c_b + ∑_{b' ≠ b} c_{b'} P_{b'}` of degree `lam b < δ` + have hG'hom : IsWeightedHomogeneous wt + (C κ * c b + ∑ b' ∈ Finset.univ.erase b, c b' * P b') (lam b) := by + refine ((hchom b).C_mul κ).add (IsWeightedHomogeneous.sum _ _ _ fun b' _ ↦ ?_) + by_cases h : ∃ β', β' + lam b' = lam b + · obtain ⟨β', hβ'⟩ := h + have := (hchom b').mul (hPhom b' β' hβ') + rwa [add_comm, hβ'] at this + · rw [hP0 b' h, mul_zero] + exact isWeightedHomogeneous_zero K wt _ + have hG'0 : aeval x (C κ * c b + ∑ b' ∈ Finset.univ.erase b, c b' * P b') = 0 := by + have hsyzw := hTPsyz w hw + rw [← Finset.add_sum_erase _ _ (Finset.mem_univ b), hκ] at hsyzw + rw [map_add, map_mul, map_sum, ← algebraMap_eq, AlgHom.commutes, Algebra.commutes, + Finset.sum_congr rfl fun b' _ ↦ by rw [map_mul, hPw]] + exact hsyzw + have hG'z := (injectiveAt_iff _).mp (hinj (lam b) (hlamlt b)) _ hG'hom hG'0 + have h2 : C κ * c b = -∑ b' ∈ Finset.univ.erase b, c b' * P b' := + eq_neg_of_add_eq_zero_left hG'z + have h3 : c b = C κ⁻¹ * (C κ * c b) := by + rw [← mul_assoc, ← C_mul, inv_mul_cancel₀ hκ0, C_1, one_mul] + refine hBmin' b b.2 ?_ + rw [h3, h2] + refine Ideal.mul_mem_left _ _ ((Ideal.neg_mem_iff _).mpr (Ideal.sum_mem _ fun b' hb' ↦ ?_)) + refine Ideal.mul_mem_right _ _ (Ideal.subset_span ⟨b', ?_, rfl⟩) + exact Finset.mem_coe.mpr (Finset.mem_erase.mpr + ⟨fun h ↦ (Finset.mem_erase.mp hb').1 (Subtype.ext h), b'.2⟩) + rw [← hρβ] + exact mul_mem_decomposableAt (A) hρ0 hβ0 haρ hwβ + +omit [GradedAlgebra A] in +/-- Injective graded evaluation lifts homogeneous syzygies into the span of evaluated generators. -/ +private theorem evaluated_syzygy_mem_span_of_injective + (hgz : GradeZeroScalars A) {B : Type w} [Fintype B] + (lam : B → NatOrdinal.{z}) (c : B → MvPolynomial ι K) + (hchom : ∀ b, IsWeightedHomogeneous wt (c b) (lam b)) + (L : Finset (B → MvPolynomial ι K)) + (hLspan : ∀ U, (∑ b, c b * U b) = 0 → + U ∈ Submodule.span (MvPolynomial ι K) (L : Set (B → MvPolynomial ι K))) + (TP : Finset (B → R)) (ev : (B → MvPolynomial ι K) → (B → R)) + (hev : ∀ σ b, ev σ b = aeval x (σ b)) + (hev_mem : ∀ σ ∈ L, ev σ ∈ Submodule.span R (TP : Set (B → R))) + (d : NatOrdinal.{z}) (hinj : InjectiveAt K wt x d) (u' : B → R) + (hu' : IsHomogeneousTuple A lam u' d) (hsyz' : ∑ b, aeval x (c b) * u' b = 0) : + u' ∈ Submodule.span R (TP : Set (B → R)) := by + classical + -- polynomial representatives of the entries + have hU : ∀ b : B, ∃ U : MvPolynomial ι K, + (∀ β, β + lam b = d → IsWeightedHomogeneous wt U β) ∧ + ((¬ ∃ β, β + lam b = d) → U = 0) ∧ aeval x U = u' b := by + intro b + have hhom := (isHomogeneousTuple_iff.mp hu') b + by_cases h : ∃ β, β + lam b = d + · obtain ⟨β, hβ⟩ := h + obtain ⟨U, hUhom, hUu⟩ := hx.exists_aeval_eq hgz β + (u' b) (hhom.1 β hβ) + refine ⟨U, fun β' hβ' ↦ ?_, fun hn ↦ absurd ⟨β, hβ⟩ hn, hUu⟩ + rwa [add_right_cancel (hβ'.trans hβ.symm)] + · exact ⟨0, fun β hβ ↦ absurd ⟨β, hβ⟩ h, fun _ ↦ rfl, by rw [map_zero, hhom.2 h]⟩ + choose U hUhom hU0 hUu using hU + -- `∑ c_b U_b` is a relation of degree `d < δ`, hence zero + have hG : IsWeightedHomogeneous wt (∑ b : B, c b * U b) d := by + refine IsWeightedHomogeneous.sum _ _ _ fun b _ ↦ ?_ + by_cases h : ∃ β, β + lam b = d + · obtain ⟨β, hβ⟩ := h + have := (hchom b).mul (hUhom b β hβ) + rwa [add_comm, hβ] at this + · rw [hU0 b h, mul_zero] + exact isWeightedHomogeneous_zero K wt d + have hG0 : aeval x (∑ b : B, c b * U b) = 0 := by + rw [map_sum, ← hsyz'] + exact Finset.sum_congr rfl fun b _ ↦ by rw [map_mul, hUu] + have hGz := (injectiveAt_iff _).mp hinj _ hG hG0 + -- so `U` is a polynomial syzygy, a combination of the generators + obtain ⟨r, _, hr⟩ := Submodule.mem_span_finset.mp (hLspan U hGz) + have hu'eq : u' = ∑ σ ∈ L, aeval x (r σ) • ev σ := by + funext b + rw [Finset.sum_apply] + have hrb := congrFun hr b + rw [Finset.sum_apply] at hrb + simp only [Pi.smul_apply, smul_eq_mul] at hrb ⊢ + rw [← hUu b, ← hrb, map_sum] + exact Finset.sum_congr rfl fun σ _ ↦ by rw [map_mul, hev] + rw [hu'eq] + refine Submodule.sum_mem _ fun σ hσ ↦ Submodule.smul_mem _ _ ?_ + exact hev_mem σ hσ + +include hΔ + +/-- Polynomial syzygies supported in limit degrees admit finitely many homogeneous generators. -/ +private theorem exists_homogeneous_evaluated_syzygies + {B : Type w} [Fintype B] (lam : B → NatOrdinal.{z}) (c : B → MvPolynomial ι K) + (hchom : ∀ b, IsWeightedHomogeneous wt (c b) (lam b)) + (Λ : Set ι) (hΛ : ∀ i ∈ Λ, (wt i).constantCoeff = 0) + (L : Finset (B → MvPolynomial ι K)) + (hL : ∀ σ ∈ L, (∀ b, σ b ∈ supported K Λ) ∧ ∑ b, c b * σ b = 0) + (ev : (B → MvPolynomial ι K) → (B → R)) (hev : ∀ σ b, ev σ b = aeval x (σ b)) : + ∃ (TP : Finset (B → R)) (eT : (B → R) → NatOrdinal.{z}), + (∀ w ∈ TP, IsHomogeneousTuple A lam w (eT w)) ∧ + (∀ w ∈ TP, ∀ b β, w b ∈ A β → w b ≠ 0 → β.constantCoeff = 0) ∧ + (∀ w ∈ TP, ∀ b, Δ (w b) = 0) ∧ + (∀ w ∈ TP, ∑ b, aeval x (c b) * w b = 0) ∧ + ∀ σ ∈ L, ev σ ∈ Submodule.span R (TP : Set (B → R)) := by + classical + obtain ⟨comp, hcomp⟩ : ∃ comp : (B → R) → NatOrdinal → (B → R), + ∀ w e b, comp w e b = if h : ∃ β, β + lam b = e then + (decompose (A) (w b) (Classical.choose h) : R) else 0 := + ⟨fun w e b ↦ if h : ∃ β, β + lam b = e then + (decompose (A) (w b) (Classical.choose h) : R) else 0, + fun _ _ _ ↦ rfl⟩ + have hcomp_hom : ∀ w e, IsHomogeneousTuple A lam (comp w e) e := by + intro w e + rw [isHomogeneousTuple_iff] + intro b + refine ⟨fun β hβ ↦ ?_, fun h ↦ ?_⟩ + · have h : ∃ β, β + lam b = e := ⟨β, hβ⟩ + have hch : ∀ h' : ∃ β, β + lam b = e, Classical.choose h' = β := fun h' ↦ + add_right_cancel ((Classical.choose_spec h').trans hβ.symm) + rw [hcomp, dite_eq_left h, hch] + exact (decompose (A) (w b) β).2 + · rw [hcomp, dite_eq_right h] + have hcomp_syz : ∀ σ ∈ L, ∀ e, ∑ b : B, aeval x (c b) * comp (ev σ) e b = 0 := by + intro σ hσ e + have h1 : ∀ b : B, aeval x (c b) * comp (ev σ) e b = + GradedRing.proj (A) e (aeval x (c b) * aeval x (σ b)) := by + intro b + rw [GradedRing.proj_apply, coe_decompose_mul_of_left_mem (𝒜 := A) + (aeval_mem_of_forall_mem hx.mem (hchom b)) (aeval x (σ b)) e, hcomp, hev] + by_cases h : ∃ β, β + lam b = e + · rw [dite_eq_left h, dite_eq_left h] + · rw [dite_eq_right h, dite_eq_right h, mul_zero] + have h2 : ∑ b : B, aeval x (c b) * aeval x (σ b) = 0 := by + have := congrArg (aeval x) (hL σ hσ).2 + rw [map_sum, map_zero] at this + simpa only [map_mul] using this + rw [Finset.sum_congr rfl fun b _ ↦ h1 b, ← map_sum, h2, map_zero] + have hcomp_lim : ∀ σ ∈ L, ∀ e (b : B) β, comp (ev σ) e b ∈ A β → + comp (ev σ) e b ≠ 0 → β.constantCoeff = 0 := by + intro σ hσ e b β hmem hne + by_contra hβ + apply hne + by_cases h : ∃ β', β' + lam b = e + · rw [hcomp, hev, dite_eq_left h] at hmem hne ⊢ + -- a nonzero element of `P_β` and of `P_{β'}` forces `β = β'` + have hβ' : β = Classical.choose h := by + by_contra hne' + have h0 := decompose_of_mem_ne (A) hmem hne' + rw [decompose_of_mem_same (A) + (decompose (A) (aeval x (σ b)) (Classical.choose h)).2] at h0 + exact hne h0 + rw [hβ'] at hβ + rw [decompose_aeval hx.mem, weightedHomogeneousComponent_eq_zero_of_forall_vars + (fun i hi ↦ hΛ i (mem_supported.mp ((hL σ hσ).1 b) hi)) hβ, map_zero] + · rw [hcomp, dite_eq_right h] at hne + exact absurd rfl hne + -- the degrees occurring, and the sum of the components + set E : Finset NatOrdinal := L.biUnion fun σ ↦ Finset.univ.biUnion fun b : B ↦ + (decompose (A) (ev σ b)).support.image (· + lam b) with hEdef + have hev_sum : ∀ σ ∈ L, ev σ = ∑ e ∈ E, comp (ev σ) e := by + intro σ hσ + funext b + rw [Finset.sum_apply] + have himg : (decompose (A) (ev σ b)).support.image (· + lam b) ⊆ E := by + intro e he + rw [hEdef] + exact Finset.mem_biUnion.mpr ⟨σ, hσ, Finset.mem_biUnion.mpr ⟨b, Finset.mem_univ b, he⟩⟩ + rw [← Finset.sum_subset himg, Finset.sum_image fun β₁ _ β₂ _ h ↦ add_right_cancel h] + · conv_lhs => rw [← sum_support_decompose (A) (ev σ b)] + refine Finset.sum_congr rfl fun β _ ↦ ?_ + have h : ∃ β', β' + lam b = β + lam b := ⟨β, rfl⟩ + have hch : ∀ h' : ∃ β', β' + lam b = β + lam b, Classical.choose h' = β := fun h' ↦ + add_right_cancel (Classical.choose_spec h') + rw [hcomp, dite_eq_left h, hch] + · intro e _ he + rw [hcomp] + split_ifs with h + · have hnot : Classical.choose h ∉ (decompose (A) (ev σ b)).support := + fun hmem ↦ he (Finset.mem_image.mpr ⟨_, hmem, Classical.choose_spec h⟩) + rw [DFinsupp.notMem_support_iff.mp hnot] + rfl + · rfl + -- the finite set `𝒯` of homogeneous ∂-annihilated syzygies + set TP : Finset (B → R) := (L ×ˢ E).image fun p ↦ comp (ev p.1) p.2 with hTPdef + set eT : (B → R) → NatOrdinal := fun w ↦ + if h : ∃ e, IsHomogeneousTuple A lam w e then Classical.choose h else 0 + with heTdef + have hTPmem : ∀ w ∈ TP, ∃ σ ∈ L, ∃ e, w = comp (ev σ) e := by + intro w hw + obtain ⟨⟨σ, e⟩, hp, rfl⟩ := Finset.mem_image.mp hw + exact ⟨σ, (Finset.mem_product.mp hp).1, e, rfl⟩ + have hTPhom : ∀ w ∈ TP, IsHomogeneousTuple A lam w (eT w) := by + intro w hw + obtain ⟨σ, _, e, rfl⟩ := hTPmem w hw + have h : ∃ e', IsHomogeneousTuple A lam (comp (ev σ) e) e' := + ⟨e, hcomp_hom _ _⟩ + have heT : eT (comp (ev σ) e) = Classical.choose h := by + simp only [heTdef] + rw [dite_eq_left h] + rw [heT] + exact Classical.choose_spec h + have hTPlim : ∀ w ∈ TP, ∀ (b : B) β, w b ∈ A β → w b ≠ 0 → + β.constantCoeff = 0 := by + intro w hw b β hmem hne + obtain ⟨σ, hσ, e, rfl⟩ := hTPmem w hw + exact hcomp_lim σ hσ e b β hmem hne + have hTPd : ∀ w ∈ TP, ∀ b, Δ (w b) = 0 := by + intro w hw b + by_cases h0 : w b = 0 + · rw [h0, map_zero] + · have hhom := (isHomogeneousTuple_iff.mp (hTPhom w hw)) b + have hex : ∃ β, β + lam b = eT w := by + by_contra hn + exact h0 (hhom.2 hn) + obtain ⟨β, hβ⟩ := hex + exact hΔ.eq_zero + (hTPlim w hw b β (hhom.1 β hβ) h0) (hhom.1 β hβ) + have hTPsyz : ∀ w ∈ TP, ∑ b : B, aeval x (c b) * w b = 0 := by + intro w hw + obtain ⟨σ, hσ, e, rfl⟩ := hTPmem w hw + exact hcomp_syz σ hσ e + refine ⟨TP, eT, hTPhom, hTPlim, hTPd, hTPsyz, ?_⟩ + intro σ hσ + rw [hev_sum σ hσ] + exact Submodule.sum_mem _ fun e he ↦ Submodule.subset_span + (Finset.mem_image.mpr ⟨(σ, e), Finset.mem_product.mpr ⟨hσ, he⟩, rfl⟩) + + +open Classical in +/-- **The successor step.** Evaluation is injective in a degree of positive finite part when it is +injective in every smaller degree. -/ +theorem injectiveAt_of_forall_lt [CharZero K] (hgz : GradeZeroScalars A) + (hint : ∀ {ι' : Type w} [Finite ι'] {q : ι' → R} {c : ι' → NatOrdinal.{z}}, + (∀ j, q j ∈ A (c j)) → (∀ j, (c j).constantCoeff = 0) → + ∀ {b : NatOrdinal.{z}}, 0 < b.constantCoeff → ∀ {y : R}, y ∈ A b → + ∀ {f : T → R}, (∀ t, f t ∈ Ideal.span (Set.range q)) → + Δ y = (f : Germ l R) → y ∈ Ideal.span (Set.range q)) + (hsyzint : ∀ {B' : Type w} [Fintype B'] (lam' : B' → NatOrdinal.{z}), + HasSyzygyIntegration A Δ lam' (T := T)) + {δ : NatOrdinal.{z}} (hδ : 0 < δ.constantCoeff) + (hinj : ∀ β < δ, InjectiveAt K wt x β) : InjectiveAt K wt x δ := by + classical + rw [injectiveAt_iff] + intro F hF hF0 + obtain ⟨grep, hg⟩ := OrdinalGraded.IsMinimalSystem.exists_derivativeRep hx hΔ hgz + have hδ0 : δ ≠ 0 := by + rintro rfl + rw [NatOrdinal.constantCoeff_zero] at hδ + exact lt_irrefl _ hδ + obtain ⟨T, hT⟩ : ∃ T : Finset ι, T = varsOfFinitePart wt F δ := ⟨_, rfl⟩ + obtain ⟨c, hc⟩ : ∃ c : ι → MvPolynomial ι K, ∀ t, c t = pderiv t F := ⟨_, fun _ ↦ rfl⟩ + have hcfun : (fun t ↦ pderiv t F) = c := funext fun t ↦ (hc t).symm + have hFI : F ∈ Ideal.span (c '' (T : Set ι)) := by + rw [hT, ← hcfun] + exact DerivativeRep.mem_span_varsOfFinitePart hx hg hΔ hgz hint hinj hδ hF hF0 + -- a minimal generating subset `B ⊆ T` + obtain ⟨B, hBmem, hBmin⟩ := Finset.exists_min_image + (T.powerset.filter fun S : Finset ι ↦ + Ideal.span (c '' (S : Set ι)) = Ideal.span (c '' (T : Set ι))) + Finset.card ⟨T, Finset.mem_filter.mpr ⟨Finset.mem_powerset_self T, rfl⟩⟩ + rw [Finset.mem_filter, Finset.mem_powerset] at hBmem + obtain ⟨hBT, hBspan⟩ := hBmem + rcases B.eq_empty_or_nonempty with hBe | hBne + · -- no generators: `F ∈ (0)` + rw [hBe, Finset.coe_empty, Set.image_empty, Ideal.span_empty] at hBspan + rw [← hBspan] at hFI + exact (Ideal.mem_bot).mp hFI + exfalso + -- the variables of finite part `n` and the partial derivatives at them + have hmemT : ∀ t ∈ T, t ∈ F.vars ∧ (wt t).constantCoeff = δ.constantCoeff := fun t ht ↦ + mem_varsOfFinitePart_iff.mp (hT ▸ ht) + have hlam : ∀ t ∈ T, ∃ β, β + wt t = δ := fun t ht ↦ + exists_add_wt_eq_of_mem_vars hF (hmemT t ht).1 + choose! lam hlam using hlam + have hlamc : ∀ t ∈ T, (lam t).constantCoeff = 0 := fun t ht ↦ + NatOrdinal.constantCoeff_eq_zero_of_add_eq (hmemT t ht).2 (hlam t ht) + have hchom : ∀ t ∈ T, IsWeightedHomogeneous wt (c t) (lam t) := fun t ht ↦ by + rw [hc] + exact isWeightedHomogeneous_pderiv_of_add_wt_eq hF (hlam t ht) + have hcvars : ∀ t ∈ T, ∀ i ∈ (c t).vars, (wt i).constantCoeff = 0 := fun t ht i hi ↦ + constantCoeff_wt_eq_zero_of_mem_vars (hchom t ht) (hlamc t ht) hi + have hlamlt : ∀ t ∈ T, lam t < δ := fun t ht ↦ by + rw [← hlam t ht] + exact lt_add_of_pos_right _ (pos_iff_ne_zero.mpr (hx.ne_zero t)) + -- minimality: no `c_b` lies in the ideal of the others + have hBmin' : ∀ b ∈ B, c b ∉ Ideal.span (c '' ((B.erase b : Finset ι) : Set ι)) := by + intro b hb hmem + have hspan' : Ideal.span (c '' ((B.erase b : Finset ι) : Set ι)) = + Ideal.span (c '' (T : Set ι)) := by + refine le_antisymm ?_ ?_ + · rw [← hBspan] + exact Ideal.span_mono (Set.image_mono (Finset.coe_subset.mpr (Finset.erase_subset b B))) + · rw [← hBspan, Ideal.span_le] + rintro _ ⟨t, ht, rfl⟩ + by_cases htb : t = b + · subst htb + exact hmem + · exact Ideal.subset_span ⟨t, Finset.mem_erase.mpr ⟨htb, ht⟩, rfl⟩ + have := hBmin (B.erase b) (Finset.mem_filter.mpr + ⟨Finset.mem_powerset.mpr ((Finset.erase_subset b B).trans hBT), hspan'⟩) + rw [Finset.card_erase_of_mem hb] at this + have hpos : 0 < B.card := Finset.card_pos.mpr hBne + omega + -- `F = ∑_t c_t (X_t + V_t)` + obtain ⟨V, hV, hFV⟩ := exists_eq_sum_pderiv_mul_X_add_of_mem_span hδ hF + (DerivativeRep.mem_span_varsOfFinitePart hx hg hΔ hgz hint hinj hδ hF hF0) + rw [← hT] at hV hFV + simp only [← hc] at hFV + -- homogeneous coefficients `c_t = ∑_b c_b a_{tb}` + have hct : ∀ t ∈ T, c t ∈ Ideal.span (Set.range fun b : ↥B ↦ c b) := fun t ht ↦ by + have h1 : c t ∈ Ideal.span (c '' (B : Set ι)) := by + rw [hBspan] + exact Ideal.subset_span ⟨t, ht, rfl⟩ + refine Ideal.span_mono ?_ h1 + rintro _ ⟨t', ht', rfl⟩ + exact ⟨⟨t', ht'⟩, rfl⟩ + have hdec : ∀ t ∈ T, ∃ a : ↥B → MvPolynomial ι K, + (∀ b : ↥B, ∀ β, β + lam b = lam t → IsWeightedHomogeneous wt (a b) β) ∧ + (∀ b : ↥B, (¬ ∃ β, β + lam b = lam t) → a b = 0) ∧ c t = ∑ b : ↥B, c b * a b := by + intro t ht + let := weightedGradedAlgebra K wt + obtain ⟨a, ha, ha0, hsum⟩ := exists_eq_sum_mul_of_mem_span + (𝒜 := weightedHomogeneousSubmodule K wt) (q := fun b : ↥B ↦ c b) (c := fun b : ↥B ↦ lam b) + (fun b ↦ (mem_weightedHomogeneousSubmodule _ _ _ _).mpr (hchom b (hBT b.2))) + ((mem_weightedHomogeneousSubmodule _ _ _ _).mpr (hchom t ht)) (hct t ht) + exact ⟨a, fun b β hβ ↦ (mem_weightedHomogeneousSubmodule _ _ _ _).mp (ha b β hβ), ha0, hsum⟩ + choose! a ha ha0 hsum using hdec + -- Kronecker coefficients for `t ∈ B` + obtain ⟨a', ha'⟩ : ∃ a' : ι → ↥B → MvPolynomial ι K, + ∀ t b, a' t b = if t ∈ B then (if (b : ι) = t then 1 else 0) else a t b := + ⟨_, fun _ _ ↦ rfl⟩ + have ha'hom : ∀ t ∈ T, ∀ b : ↥B, ∀ β, β + lam b = lam t → + IsWeightedHomogeneous wt (a' t b) β := by + intro t ht b β hβ + rw [ha'] + split_ifs with htB hbt + · have h0 : β = 0 := by + rw [hbt] at hβ + exact add_right_cancel (hβ.trans (zero_add _).symm) + rw [h0] + exact isWeightedHomogeneous_one K wt + · exact isWeightedHomogeneous_zero K wt β + · exact ha t ht b β hβ + have ha'0 : ∀ t ∈ T, ∀ b : ↥B, (¬ ∃ β, β + lam b = lam t) → a' t b = 0 := by + intro t ht b hn + rw [ha'] + split_ifs with htB hbt + · exact absurd ⟨0, by rw [hbt, zero_add]⟩ hn + · rfl + · exact ha0 t ht b hn + have hsum' : ∀ t ∈ T, c t = ∑ b : ↥B, c b * a' t b := by + intro t ht + by_cases htB : t ∈ B + · rw [Finset.sum_eq_single ⟨t, htB⟩] + · rw [ha', ite_eq_left htB, ite_eq_left rfl, mul_one] + · intro b _ hb + rw [ha', ite_eq_left htB, ite_eq_right fun h ↦ hb (Subtype.ext h), mul_zero] + · intro h + exact absurd (Finset.mem_univ _) h + · rw [hsum t ht] + exact Finset.sum_congr rfl fun b _ ↦ by rw [ha', ite_eq_right htB] + -- `F = ∑_b c_b W_b` + obtain ⟨W, hW⟩ : ∃ W : ↥B → MvPolynomial ι K, ∀ b, W b = ∑ t ∈ T, a' t b * (X t + V t) := + ⟨_, fun _ ↦ rfl⟩ + have hFW : F = ∑ b : ↥B, c b * W b := by + conv_lhs => rw [hFV] + simp only [hW, Finset.mul_sum] + rw [Finset.sum_comm] + refine Finset.sum_congr rfl fun t ht ↦ ?_ + rw [hsum' t ht, Finset.sum_mul] + exact Finset.sum_congr rfl fun b _ ↦ by ring + -- the evaluated syzygy, homogeneous of degree `δ` + obtain ⟨u, hu'⟩ : ∃ u : ↥B → R, ∀ b, u b = aeval x (W b) := ⟨_, fun _ ↦ rfl⟩ + have hsyz : ∑ b : ↥B, aeval x (c b) * u b = 0 := by + simp only [hu'] + rw [← hF0] + conv_rhs => rw [hFW] + rw [map_sum] + exact Finset.sum_congr rfl fun b _ ↦ (map_mul _ _ _).symm + have hWhom : ∀ b : ↥B, IsWeightedHomogeneous wt (W b) (wt b) := by + intro b + rw [hW] + refine IsWeightedHomogeneous.sum _ _ _ fun t ht ↦ ?_ + by_cases h : ∃ β, β + lam b = lam t + · obtain ⟨β, hβ⟩ := h + have hXV : IsWeightedHomogeneous wt (X t + V t) (wt t) := + (isWeightedHomogeneous_X K wt t).add (hV t ht).1 + have hdeg : β + wt t = wt b := by + apply add_right_cancel (b := lam b) + rw [add_right_comm, hβ, hlam t ht, add_comm, hlam b (hBT b.2)] + rw [← hdeg] + exact (ha'hom t ht b β hβ).mul hXV + · rw [ha'0 t ht b h, zero_mul] + exact isWeightedHomogeneous_zero K wt _ + have hu : IsHomogeneousTuple A (fun b : ↥B ↦ lam b) u δ := by + rw [isHomogeneousTuple_iff] + intro b + have hwl : wt b + lam b = δ := by rw [add_comm]; exact hlam b (hBT b.2) + refine ⟨fun β hβ ↦ ?_, fun h ↦ absurd ⟨wt b, hwl⟩ h⟩ + have hβ' : β = wt b := add_right_cancel (hβ.trans hwl.symm) + rw [hβ', hu'] + exact aeval_mem_of_forall_mem hx.mem (hWhom b) + -- the variables of the `c_t`, all with degree `0` or a limit ordinal, and the polynomial syzygies + -- of `(c_b)` + set Λ : Set ι := ↑(T.biUnion fun t ↦ (c t).vars) with hΛdef + have hΛ : ∀ i ∈ Λ, (wt i).constantCoeff = 0 := by + intro i hi + obtain ⟨t, ht, hit⟩ := Finset.mem_biUnion.mp (Finset.mem_coe.mp hi) + exact hcvars t ht i hit + have hcΛ : ∀ b : ↥B, c b ∈ supported K Λ := fun b ↦ mem_supported.mpr fun i hi ↦ + Finset.mem_coe.mpr (Finset.mem_biUnion.mpr ⟨b, hBT b.2, hi⟩) + obtain ⟨L, hL, hLspan⟩ := exists_finset_syzygy_span_supported Λ (fun b : ↥B ↦ c b) hcΛ + -- evaluations of the generators and their homogeneous components + obtain ⟨ev, hev⟩ : ∃ ev : (↥B → MvPolynomial ι K) → (↥B → R), + ∀ σ b, ev σ b = aeval x (σ b) := ⟨fun σ b ↦ aeval x (σ b), fun _ _ ↦ rfl⟩ + obtain ⟨TP, eT, hTPhom, hTPlim, hTPd, hTPsyz, hev_mem⟩ := + exists_homogeneous_evaluated_syzygies hx hΔ (fun b : ↥B ↦ lam b) (fun b : ↥B ↦ c b) + (fun b ↦ hchom b (hBT b.2)) Λ hΛ L hL ev hev + -- the hypothesis in the degrees below `δ`: evaluation injective below `δ` + have hbase : ∀ d < δ, d.constantCoeff = 0 → ∀ u' : ↥B → R, + IsHomogeneousTuple A (fun b : ↥B ↦ lam b) u' d → ∑ b : ↥B, aeval x (c b) * u' b = 0 → + u' ∈ Submodule.span R (TP : Set (↥B → R)) := by + intro d hd _ u' hu' hsyz' + exact evaluated_syzygy_mem_span_of_injective hx hgz (fun b : ↥B ↦ lam b) + (fun b : ↥B ↦ c b) (fun b ↦ hchom b (hBT b.2)) L hLspan TP ev hev hev_mem + d (hinj d hd) u' hu' hsyz' + -- the induction on syzygies + have huN := mem_span_of_isHomogeneousTuple_of_sum_eq_zero (c := fun b : ↥B ↦ aeval x (c b)) + (lam := fun b : ↥B ↦ lam b) hΔ (fun b ↦ aeval_mem_of_forall_mem hx.mem (hchom b (hBT b.2))) + (fun b ↦ hlamc b (hBT b.2)) (hsyzint (fun b : ↥B ↦ lam b)) TP eT hTPhom hTPd hδ hbase + δ le_rfl u hu hsyz + obtain ⟨a₂, ha₂, hu_eq⟩ := exists_eq_sum_smul_of_mem_span hTPhom hu huN + -- every `u_b` lies in `(P̂_+)² ∩ P_{deg b}` + have hudec := syzygy_entries_mem_decomposable hx hgz hδ hinj B c lam + (fun b ↦ hlam b (hBT b.2)) (fun b ↦ hlamc b (hBT b.2)) + (fun b ↦ hlamlt b (hBT b.2)) (fun b ↦ hchom b (hBT b.2)) hBmin' + TP eT hTPhom hTPlim hTPsyz u a₂ ha₂ hu_eq + exact not_forall_aeval_cofactors_mem_decomposable hx hδ T B hBT hBne lam hlam + (fun t ht ↦ (hmemT t ht).2) V hV a' + (fun b ↦ by rw [ha', ite_eq_left b.2, ite_eq_left rfl]) ha'hom ha'0 W hW + (fun b ↦ by simpa only [hu'] using hudec b) + +end OrdinalGraded + +end diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/DirectSum/GermSyzygy.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/DirectSum/GermSyzygy.lean new file mode 100644 index 0000000000..104a4265cd --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/DirectSum/GermSyzygy.lean @@ -0,0 +1,388 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.GradedRing.OrdinalGenerators +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.GradedRing.HomogeneousSpan +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.DirectSum.GermPolynomial + +/-! +# Homogeneous tuples over an ordinal-graded algebra + +A tuple `u` indexed by `B` is homogeneous of degree `d` relative to degrees `λ_b` when `u_b` +sits in degree `β` for the `β` with `β ⊕ λ_b = d`, and vanishes when +`λ_b \not\preccurlyeq d` in the +algebraic order. + +The one substantial statement here is that a homogeneous tuple lying in the span of finitely many +homogeneous tuples has homogeneous coefficients: take the graded component of each coefficient at +the degree forced by the equation. That is bookkeeping about the grading, with nothing about +derivations or about where the entries live, and both the real-exponent development and the +Cantor–Bendixson germ argument uses it. + +The ordinal degrees may lie in any universe. +-/ + +universe u v w z + +open DirectSum + +public noncomputable section + +namespace OrdinalGraded + +variable {K : Type u} {R : Type v} [Field K] [CommRing R] [Algebra K R] +variable {A : NatOrdinal.{z} → Submodule K R} [GradedAlgebra A] +variable {B : Type w} + +variable (A) in +/-- A tuple `u` is homogeneous of degree `d` relative to the degrees `λ_b`: `u_b` sits in degree +`β` for the `β` with `β + λ_b = d`, and is zero when `λ_b` does not precede `d` in the +algebraic order. -/ +def IsHomogeneousTuple (lam : B → NatOrdinal.{z}) (u : B → R) (d : NatOrdinal.{z}) : Prop := + ∀ b, (∀ β, β + lam b = d → u b ∈ A β) ∧ ((¬ ∃ β, β + lam b = d) → u b = 0) + +omit [GradedAlgebra A] in +theorem isHomogeneousTuple_iff {lam : B → NatOrdinal.{z}} {u : B → R} {d : NatOrdinal.{z}} : + IsHomogeneousTuple A lam u d ↔ + ∀ b, (∀ β, β + lam b = d → u b ∈ A β) ∧ + ((¬ ∃ β, β + lam b = d) → u b = 0) := + Iff.rfl + +omit [GradedAlgebra A] in +theorem isHomogeneousTuple_zero (lam : B → NatOrdinal.{z}) (d : NatOrdinal.{z}) : + IsHomogeneousTuple A lam (0 : B → R) d := + fun _ ↦ ⟨fun _ _ ↦ zero_mem _, fun _ ↦ rfl⟩ + +omit [GradedAlgebra A] in +theorem IsHomogeneousTuple.mem {lam : B → NatOrdinal.{z}} {u : B → R} {d : NatOrdinal.{z}} + (hu : IsHomogeneousTuple A lam u d) {b : B} {β : NatOrdinal.{z}} (hβ : β + lam b = d) : + u b ∈ A β := + (hu b).1 β hβ + +omit [GradedAlgebra A] in +theorem IsHomogeneousTuple.eq_zero {lam : B → NatOrdinal.{z}} {u : B → R} {d : NatOrdinal.{z}} + (hu : IsHomogeneousTuple A lam u d) {b : B} (h : ¬ ∃ β, β + lam b = d) : u b = 0 := + (hu b).2 h + +/-- **Homogeneous coefficients along homogeneous generators.** A homogeneous tuple `w` of degree +`d` in the span of a finite set `T` of homogeneous tuples is `∑ a_τ • τ` with each `a_τ` +homogeneous of the degree forced by the equation, and zero when there is none. -/ +theorem exists_eq_sum_smul_of_mem_span {lam : B → NatOrdinal.{z}} {T : Finset (B → R)} + {eT : (B → R) → NatOrdinal.{z}} (hT : ∀ τ ∈ T, IsHomogeneousTuple A lam τ (eT τ)) + {w : B → R} {d : NatOrdinal.{z}} (hw : IsHomogeneousTuple A lam w d) + (hwN : w ∈ Submodule.span R (T : Set (B → R))) : + ∃ a : (B → R) → R, + (∀ τ ∈ T, (∀ ρ, ρ + eT τ = d → a τ ∈ A ρ) ∧ + ((¬ ∃ ρ, ρ + eT τ = d) → a τ = 0)) ∧ + w = ∑ τ ∈ T, a τ • τ := by + classical + obtain ⟨r, _, hr⟩ := Submodule.mem_span_finset.mp hwN + refine ⟨fun τ ↦ if h : ∃ ρ, ρ + eT τ = d then + (decompose A (r τ) (Classical.choose h) : R) else 0, + fun τ _ ↦ ⟨fun ρ hρ ↦ ?_, fun h ↦ dite_eq_right h⟩, ?_⟩ + · have h : ∃ ρ, ρ + eT τ = d := ⟨ρ, hρ⟩ + have hρ' : ∀ h' : ∃ ρ, ρ + eT τ = d, Classical.choose h' = ρ := fun h' ↦ + add_right_cancel ((Classical.choose_spec h').trans hρ.symm) + beta_reduce + rw [dite_eq_left h, hρ'] + exact (decompose A (r τ) ρ).2 + · funext b + rw [Finset.sum_apply] + simp only [Pi.smul_apply, smul_eq_mul] + by_cases hb : ∃ β, β + lam b = d + · obtain ⟨β, hβ⟩ := hb + -- take the degree-`β` component of `w b = ∑ r τ * τ b` + have hwb : w b = (decompose A (w b) β : R) := (decompose_of_mem_same _ (hw.mem hβ)).symm + rw [hwb, ← hr, Finset.sum_apply] + simp only [Pi.smul_apply, smul_eq_mul] + rw [← GradedRing.proj_apply, map_sum] + refine Finset.sum_congr rfl fun τ hτ ↦ ?_ + rw [GradedRing.proj_apply] + by_cases hτb : ∃ β', β' + lam b = eT τ + · obtain ⟨β', hβ'⟩ := hτb + have hmem : τ b ∈ A β' := (hT τ hτ).mem hβ' + rw [mul_comm, OrdinalGraded.coe_decompose_mul_of_left_mem hmem (r τ) β] + -- `ρ + β' = β` exactly when `ρ + e_τ = d` + have hiff : (∃ ρ, ρ + β' = β) ↔ ∃ ρ, ρ + eT τ = d := by + constructor + · rintro ⟨ρ, hρ⟩ + exact ⟨ρ, by rw [← hβ', ← add_assoc, hρ, hβ]⟩ + · rintro ⟨ρ, hρ⟩ + refine ⟨ρ, add_right_cancel (b := lam b) ?_⟩ + rw [add_assoc, hβ', hρ, hβ] + by_cases h1 : ∃ ρ, ρ + β' = β + · have h2 : ∃ ρ, ρ + eT τ = d := hiff.mp h1 + have hch : Classical.choose h1 = Classical.choose h2 := by + refine add_right_cancel (b := β') ?_ + rw [Classical.choose_spec h1] + refine add_right_cancel (b := lam b) ?_ + rw [add_assoc, hβ', Classical.choose_spec h2, hβ] + rw [dite_eq_left h1, dite_eq_left h2, hch, mul_comm] + · have h2 : ¬ ∃ ρ, ρ + eT τ = d := fun h ↦ h1 (hiff.mpr h) + rw [dite_eq_right h1, dite_eq_right h2, zero_mul] + · rw [(hT τ hτ).eq_zero hτb, mul_zero, ← GradedRing.proj_apply, map_zero, mul_zero] + · -- no degree is forced: both sides vanish + rw [hw.eq_zero hb] + symm + refine Finset.sum_eq_zero fun τ hτ ↦ ?_ + by_cases hτb : ∃ β', β' + lam b = eT τ + · obtain ⟨β', hβ'⟩ := hτb + have h2 : ¬ ∃ ρ, ρ + eT τ = d := fun ⟨ρ, hρ⟩ ↦ + hb ⟨ρ + β', by rw [add_assoc, hβ', hρ]⟩ + beta_reduce + rw [dite_eq_right h2, zero_mul] + · rw [(hT τ hτ).eq_zero hτb, mul_zero] + +section Induction + +variable {T : Type*} {l : Filter T} {Δ : Derivation K R (Filter.Germ l R)} +variable {B : Type w} [Fintype B] {c : B → R} {lam : B → NatOrdinal.{z}} + +open Filter + +/-- The germ of a pointwise finite sum is the sum of the germs. -/ +theorem germ_coe_sum {ι' : Type*} (s : Finset ι') (f : ι' → T → R) : + ((fun t ↦ ∑ i ∈ s, f i t : T → R) : Germ l R) = + ∑ i ∈ s, ((f i : T → R) : Germ l R) := by + have hfun : (fun t ↦ ∑ i ∈ s, f i t : T → R) = ∑ i ∈ s, f i := by + ext t + simp only [Finset.sum_apply] + rw [hfun] + exact map_sum (Filter.Germ.coeRingHom l) f s + +variable (A Δ lam) in +/-- What the successor induction needs from the setting. A homogeneous tuple of successor degree +has a derivative representative supported on some set, homogeneous one degree lower; and values +prescribed homogeneously on that set are themselves derivatives, vanishing off it. + +Over the real line this is the `ω`-sequence of cutoffs together with the image theorem for +derivatives; for the Cantor–Bendixson construction it is an exact-rank set together with the +theorem integrating prescribed homogeneous classes on that set. Both are proved by their own +construction, so this remains a hypothesis of the abstract theorem. + +What the Cantor–Bendixson instance supplies. The set here is shared by every entry of the tuple, +while a derivative representative is supported on the exact-rank level of its own series, so the +candidate is the union of those levels. The integration theorem requires a discrete set, and a +union of discrete sets is not discrete in general—but it is near zero, which is the only place the +germs detect. Past its own cutoff a level stays away from the points it misses, finitely many +cutoffs have a largest, and above that the union is discrete +(`exists_isDiscrete_iUnion_rankLevelSet`). The integration construction then runs over it +(`exists_prescribed_components_on_set_of_isDiscrete`), and the representatives may be cut off +below the common bound without changing their germs. -/ +def HasSyzygyIntegration : Prop := + ∀ {d : NatOrdinal.{z}}, 0 < d.constantCoeff → ∀ {u : B → R}, + IsHomogeneousTuple A lam u d → + ∃ (S : Set T) (D : B → T → R), + (∀ b, Δ (u b) = ((D b : T → R) : Germ l R)) ∧ + (∀ t, IsHomogeneousTuple A lam (fun b ↦ D b t) (d.removeNat 1)) ∧ + (∀ b, ∀ t ∉ S, D b t = 0) ∧ + ∀ {ρ : NatOrdinal.{z}} (a : T → R), (∀ t, a t ∈ A ρ) → + ∃ s : R, s ∈ A (ρ + 1) ∧ ∃ G : T → R, Δ s = (G : Germ l R) ∧ + (∀ t ∈ S, G t = a t) ∧ (∀ t ∉ S, G t = 0) + +omit [GradedAlgebra A] [Fintype B] in +/-- Characterization of the successor syzygy-integration interface. -/ +theorem hasSyzygyIntegration_iff : HasSyzygyIntegration A Δ lam (T := T) ↔ + ∀ {d : NatOrdinal.{z}}, 0 < d.constantCoeff → ∀ {u : B → R}, + IsHomogeneousTuple A lam u d → + ∃ (S : Set T) (D : B → T → R), + (∀ b, Δ (u b) = ((D b : T → R) : Germ l R)) ∧ + (∀ t, IsHomogeneousTuple A lam (fun b ↦ D b t) (d.removeNat 1)) ∧ + (∀ b, ∀ t ∉ S, D b t = 0) ∧ + ∀ {ρ : NatOrdinal.{z}} (a : T → R), (∀ t, a t ∈ A ρ) → + ∃ s : R, s ∈ A (ρ + 1) ∧ ∃ G : T → R, Δ s = (G : Germ l R) ∧ + (∀ t ∈ S, G t = a t) ∧ (∀ t ∉ S, G t = 0) := + Iff.rfl + +/-- **The induction on syzygies.** Let the `c_b` be homogeneous of degrees that are zero or limits, +let `T` be a finite set of homogeneous syzygies of `(c_b)` annihilated by the derivation, and `N` +the submodule it spans. If every homogeneous syzygy of degree below `δ` with finite part zero lies +in `N`, then every homogeneous syzygy of degree at most `δ` lies in `N`. + +The induction is on the finite part of the degree. A syzygy of successor degree has a derivative +representative that is again a syzygy one degree lower, hence in `N`; decomposing it along the +generators and integrating the coefficients produces a candidate whose difference from the original +has zero derivative, so injectivity in successor degree finishes. -/ +theorem mem_span_of_isHomogeneousTuple_of_sum_eq_zero + (hΔ : GermPolynomial.IsLoweringDerivation A Δ) + (hc : ∀ b, c b ∈ A (lam b)) (hlam : ∀ b, (lam b).constantCoeff = 0) + (hint : HasSyzygyIntegration A Δ lam (T := T)) + (T' : Finset (B → R)) (eT : (B → R) → NatOrdinal.{z}) + (hT : ∀ τ ∈ T', IsHomogeneousTuple A lam τ (eT τ)) + (hTd : ∀ τ ∈ T', ∀ b, Δ (τ b) = 0) + {δ : NatOrdinal.{z}} (hδ : 0 < δ.constantCoeff) + (hbase : ∀ d < δ, d.constantCoeff = 0 → ∀ u : B → R, IsHomogeneousTuple A lam u d → + ∑ b, c b * u b = 0 → u ∈ Submodule.span R (T' : Set (B → R))) : + ∀ d ≤ δ, ∀ u : B → R, IsHomogeneousTuple A lam u d → ∑ b, c b * u b = 0 → + u ∈ Submodule.span R (T' : Set (B → R)) := by + classical + suffices h : ∀ n : ℕ, ∀ d, d.constantCoeff = n → d ≤ δ → ∀ u : B → R, + IsHomogeneousTuple A lam u d → ∑ b, c b * u b = 0 → + u ∈ Submodule.span R (T' : Set (B → R)) from + fun d hd u hu hsyz ↦ h _ d rfl hd u hu hsyz + intro n + induction n with + | zero => + intro d hd hdδ u hu hsyz + refine hbase d (lt_of_le_of_ne hdδ fun h ↦ ?_) hd u hu hsyz + rw [h] at hd + omega + | succ n ih => + intro d hd hdδ u hu hsyz + have hdpos : 0 < d.constantCoeff := by rw [hd]; omega + obtain ⟨d', hd'def⟩ : ∃ d', d' = d.removeNat 1 := ⟨_, rfl⟩ + have hd'1 : d' + 1 = d := by + have hstep := NatOrdinal.removeNat_add_natCast (a := d) (n := 1) hdpos + rw [Nat.cast_one] at hstep + rw [hd'def] + exact hstep + have hd'c : d'.constantCoeff = n := by + rw [hd'def, NatOrdinal.constantCoeff_removeNat, hd] + omega + have hd'lt : d' < δ := lt_of_lt_of_le (lt_of_lt_of_eq (lt_add_one d') hd'1) hdδ + -- the derivative representative and its prescription set + obtain ⟨S, D, hD, hDhom, hDoff, hintS⟩ := hint hdpos hu + -- the derivative tuple is a syzygy on a set of the filter + have hDsyz : ∀ᶠ t in l, ∑ b, c b * D b t = 0 := by + have hzero := congrArg Δ hsyz + rw [map_zero, map_sum] at hzero + have hterm : ∀ b, Δ (c b * u b) = ((fun t ↦ c b * D b t : T → R) : Germ l R) := by + intro b + rw [GermPolynomial.derivation_leibniz, hΔ.eq_zero (hlam b) (hc b), + zero_mul, zero_add, hD] + rfl + simp only [hterm] at hzero + have hsum : ((fun t ↦ ∑ b, c b * D b t : T → R) : Germ l R) = + ((fun _ ↦ (0 : R) : T → R) : Germ l R) := by + rw [germ_coe_sum] + exact hzero + exact Germ.coe_eq.mp hsum + obtain ⟨V, hV, hVsub⟩ := eventually_iff_exists_mem.mp hDsyz + -- cut the representative down to that set, so its values lie in the span everywhere + obtain ⟨W, hWon, hWoff⟩ : ∃ W : T → B → R, (∀ t ∈ V, W t = fun b ↦ D b t) ∧ + ∀ t ∉ V, W t = 0 := + ⟨fun t ↦ if t ∈ V then (fun b ↦ D b t) else 0, + fun t ht ↦ ite_eq_left ht, fun t ht ↦ ite_eq_right ht⟩ + have hWhom : ∀ t, IsHomogeneousTuple A lam (W t) d' := fun t ↦ by + by_cases ht : t ∈ V + · rw [hWon t ht, hd'def] + exact hDhom t + · rw [hWoff t ht] + exact isHomogeneousTuple_zero lam d' + have hWN : ∀ t, W t ∈ Submodule.span R (T' : Set (B → R)) := fun t ↦ by + by_cases ht : t ∈ V + · rw [hWon t ht] + refine ih d' hd'c hd'lt.le _ ?_ (hVsub t ht) + rw [hd'def] + exact hDhom t + · rw [hWoff t ht] + exact zero_mem _ + obtain ⟨a, ha, hasum⟩ : ∃ a : T → (B → R) → R, + (∀ t, ∀ τ ∈ T', (∀ ρ, ρ + eT τ = d' → a t τ ∈ A ρ) ∧ + ((¬ ∃ ρ, ρ + eT τ = d') → a t τ = 0)) ∧ + ∀ t, W t = ∑ τ ∈ T', a t τ • τ := by + choose a ha hasum using fun t ↦ exists_eq_sum_smul_of_mem_span hT (hWhom t) (hWN t) + exact ⟨a, ha, hasum⟩ + -- integrate each coefficient family + obtain ⟨s, hs, hs0, G, hG, hGon, hGoff⟩ : ∃ s : (B → R) → R, + (∀ τ ∈ T', ∀ ρ, ρ + eT τ = d' → s τ ∈ A (ρ + 1)) ∧ + (∀ τ ∈ T', (¬ ∃ ρ, ρ + eT τ = d') → s τ = 0) ∧ + ∃ G : (B → R) → T → R, + (∀ τ ∈ T', Δ (s τ) = ((G τ : T → R) : Germ l R)) ∧ + (∀ τ ∈ T', ∀ t ∈ S, G τ t = a t τ) ∧ + (∀ τ ∈ T', ∀ t ∉ S, G τ t = 0) := by + have hone : ∀ τ ∈ T', ∃ sτ : R, (∀ ρ, ρ + eT τ = d' → sτ ∈ A (ρ + 1)) ∧ + ((¬ ∃ ρ, ρ + eT τ = d') → sτ = 0) ∧ + ∃ Gτ : T → R, Δ sτ = ((Gτ : T → R) : Germ l R) ∧ + (∀ t ∈ S, Gτ t = a t τ) ∧ (∀ t ∉ S, Gτ t = 0) := by + intro τ hτ + by_cases hρ : ∃ ρ, ρ + eT τ = d' + · obtain ⟨ρ, hρ⟩ := hρ + obtain ⟨sτ, hsτ, Gτ, hGτ, hGon', hGoff'⟩ := + hintS (ρ := ρ) (fun t ↦ a t τ) (fun t ↦ (ha t τ hτ).1 ρ hρ) + refine ⟨sτ, fun ρ' hρ' ↦ ?_, fun hn ↦ absurd ⟨ρ, hρ⟩ hn, Gτ, hGτ, + hGon', hGoff'⟩ + rwa [add_right_cancel (hρ'.trans hρ.symm)] + · exact ⟨0, fun ρ hρ' ↦ absurd ⟨ρ, hρ'⟩ hρ, fun _ ↦ rfl, fun _ ↦ 0, + by rw [map_zero]; rfl, fun t _ ↦ ((ha t τ hτ).2 hρ).symm, fun _ _ ↦ rfl⟩ + choose! sf hsf hsf0 Gf hGf hGon' hGoff' using hone + exact ⟨sf, hsf, hsf0, Gf, hGf, hGon', hGoff'⟩ + -- the difference has zero derivative in every entry, hence vanishes + have hy : ∀ b, u b - ∑ τ ∈ T', s τ * τ b = 0 := by + intro b + by_cases hb : ∃ β, β + lam b = d + · obtain ⟨β, hβ⟩ := hb + have hβpos : 0 < β.constantCoeff := by + have hc1 := congrArg NatOrdinal.constantCoeff hβ + rw [NatOrdinal.constantCoeff_add, hlam b, add_zero, hd] at hc1 + omega + have hβ' : β.removeNat 1 + lam b = d' := by + have hstep := NatOrdinal.removeNat_add_right β (lam b) hβpos + rw [hβ, ← hd'def] at hstep + exact hstep.symm + have hβ1 : β.removeNat 1 + 1 = β := by + have hstep := NatOrdinal.removeNat_add_natCast (a := β) (n := 1) hβpos + rwa [Nat.cast_one] at hstep + have hmem : u b - ∑ τ ∈ T', s τ * τ b ∈ A β := by + refine sub_mem (hu.mem hβ) (sum_mem fun τ hτ ↦ ?_) + by_cases hτb : ∃ β', β' + lam b = eT τ + · obtain ⟨β', hβ'b⟩ := hτb + by_cases hρ : ∃ ρ, ρ + eT τ = d' + · obtain ⟨ρ, hρ⟩ := hρ + have h1 : ρ + β' = β.removeNat 1 := + add_right_cancel (b := lam b) (by rw [add_assoc, hβ'b, hρ, hβ']) + have h2 : (ρ + 1) + β' = β := by rw [add_right_comm, h1, hβ1] + rw [← h2] + exact SetLike.mul_mem_graded (hs τ hτ ρ hρ) ((hT τ hτ).mem hβ'b) + · rw [hs0 τ hτ hρ, zero_mul] + exact zero_mem _ + · rw [(hT τ hτ).eq_zero hτb, mul_zero] + exact zero_mem _ + refine hΔ.injective hβpos hmem ?_ + have hΔs : Δ (∑ τ ∈ T', s τ * τ b) = + ((fun t ↦ ∑ τ ∈ T', G τ t * τ b : T → R) : Germ l R) := by + rw [map_sum] + have hterm : ∀ τ ∈ T', Δ (s τ * τ b) = + ((fun t ↦ G τ t * τ b : T → R) : Germ l R) := by + intro τ hτ + rw [GermPolynomial.derivation_leibniz, hTd τ hτ b, mul_zero, add_zero, hG τ hτ] + rfl + rw [Finset.sum_congr rfl hterm, germ_coe_sum] + rw [map_sub, hD, hΔs, ← Germ.coe_sub] + refine Germ.coe_eq.mpr ?_ + filter_upwards [hV] with t ht + simp only [Pi.sub_apply] + by_cases hSt : t ∈ S + · have hdec := congrFun (hasum t) b + rw [hWon t ht, Finset.sum_apply] at hdec + simp only [Pi.smul_apply, smul_eq_mul] at hdec + rw [hdec, sub_eq_zero] + exact Finset.sum_congr rfl fun τ hτ ↦ by rw [hGon τ hτ t hSt] + · rw [hDoff b t hSt, Finset.sum_eq_zero fun τ hτ ↦ by + rw [hGoff τ hτ t hSt, zero_mul], sub_zero] + · rw [hu.eq_zero hb, Finset.sum_eq_zero, sub_zero] + intro τ hτ + by_cases hτb : ∃ β', β' + lam b = eT τ + · obtain ⟨β', hβ'b⟩ := hτb + have hρ : ¬ ∃ ρ, ρ + eT τ = d' := fun ⟨ρ, hρ⟩ ↦ hb ⟨ρ + β' + 1, by + calc ρ + β' + 1 + lam b = ρ + (β' + lam b) + 1 := by abel + _ = d := by rw [hβ'b, hρ, hd'1]⟩ + rw [hs0 τ hτ hρ, zero_mul] + · rw [(hT τ hτ).eq_zero hτb, mul_zero] + have hueq : u = ∑ τ ∈ T', s τ • τ := by + funext b + rw [Finset.sum_apply] + simp only [Pi.smul_apply, smul_eq_mul] + exact sub_eq_zero.mp (hy b) + rw [hueq] + exact Submodule.sum_mem _ fun τ hτ ↦ Submodule.smul_mem _ _ (Submodule.subset_span hτ) + +end Induction + +end OrdinalGraded + +end diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/DirectSum/HomogeneousDivisibility.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/DirectSum/HomogeneousDivisibility.lean new file mode 100644 index 0000000000..00dace4d95 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/DirectSum/HomogeneousDivisibility.lean @@ -0,0 +1,84 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import Mathlib.Algebra.DirectSum.Ring + +import Mathlib.Algebra.BigOperators.Ring.Finset +import Mathlib.Algebra.GroupWithZero.Divisibility + +/-! +# Divisibility by homogeneous elements in graded direct sums + +Multiplication by an element supported in grade `i` shifts every component by `i`. When addition +of grades is left-cancellative, this identifies the component at `i + j` with the product of the +homogeneous element and the component at `j`. Consequently, a homogeneous element divides a +graded sum if and only if it divides every homogeneous component. +-/ + +universe u v + +public noncomputable section + +open scoped DirectSum + +namespace DirectSum + +variable {ι : Type u} (A : ι → Type v) + [DecidableEq ι] [AddCommMonoid ι] [IsLeftCancelAdd ι] + [∀ i, AddCommMonoid (A i)] [DirectSum.GSemiring A] + +theorem of_mul_apply_add {i : ι} (a : A i) (x : DirectSum ι A) (j : ι) : + (DirectSum.of A i a * x) (i + j) = + GradedMonoid.GMul.mul a (x j) := by + induction x using DirectSum.induction_on with + | zero => + rw [mul_zero] + exact (DirectSum.GNonUnitalNonAssocSemiring.mul_zero (A := A) a).symm + | of k b => + by_cases hkj : k = j + · subst k + rw [DirectSum.of_mul_of, DirectSum.of_eq_same, DirectSum.of_eq_same] + · rw [DirectSum.of_mul_of] + rw [DirectSum.of_eq_of_ne k j b (Ne.symm hkj)] + rw [DirectSum.GNonUnitalNonAssocSemiring.mul_zero] + rw [DirectSum.of_eq_of_ne] + exact fun h ↦ hkj (add_left_cancel h).symm + | add x y hx hy => + rw [mul_add, add_apply, add_apply, hx, hy] + exact (DirectSum.GNonUnitalNonAssocSemiring.mul_add (A := A) a (x j) (y j)).symm + +omit [IsLeftCancelAdd ι] in +theorem of_mul_apply_eq_zero_of_not_exists {i k : ι} (a : A i) + (x : DirectSum ι A) (h : ¬∃ j, i + j = k) : + (DirectSum.of A i a * x) k = 0 := by + induction x using DirectSum.induction_on with + | zero => simp + | of j b => + rw [DirectSum.of_mul_of] + rw [DirectSum.of_eq_of_ne] + exact fun hij ↦ h ⟨j, hij.symm⟩ + | add x y hx hy => + rw [mul_add, add_apply, hx, hy, add_zero] + +/-- A homogeneous element divides a graded sum if and only if it divides every component. -/ +theorem of_dvd_iff_dvd_components {i : ι} (a : A i) (x : DirectSum ι A) : + DirectSum.of A i a ∣ x ↔ + ∀ k, DirectSum.of A i a ∣ DirectSum.of A k (x k) := by + classical + constructor + · rintro ⟨y, rfl⟩ k + by_cases h : ∃ j, i + j = k + · obtain ⟨j, rfl⟩ := h + refine ⟨DirectSum.of A j (y j), ?_⟩ + rw [DirectSum.of_mul_of, of_mul_apply_add] + · rw [of_mul_apply_eq_zero_of_not_exists A a y h, map_zero] + exact dvd_zero _ + · intro h + rw [← DirectSum.sum_support_of x] + exact Finset.dvd_sum fun k _ ↦ h k + +end DirectSum diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/DirectSum/HomogeneousPrime.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/DirectSum/HomogeneousPrime.lean new file mode 100644 index 0000000000..8e6b6befc9 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/DirectSum/HomogeneousPrime.lean @@ -0,0 +1,171 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.DirectSum.HomogeneousDivisibility +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.DirectSum.LeadingGrade + +import Mathlib.Tactic.Abel +import Mathlib.Algebra.Ring.Divisibility.Basic +public import Mathlib.Algebra.Prime.Defs + +/-! +# Primality of a homogeneous element from its homogeneous divisibility property + +In a graded direct sum whose homogeneous components multiply without cancellation, a +homogeneous element dividing one of the two factors of every homogeneous product it divides +does so for every product it divides. The induction is on the total number of nonzero +components, so it is uniform in the grading monoid and in the grade of the divisor. +-/ + +open scoped DirectSum + +universe u v + +public noncomputable section + +namespace DirectSum + +variable {ι : Type u} (A : ι → Type v) + [LinearOrder ι] [AddCommMonoid ι] [IsOrderedCancelAddMonoid ι] + [∀ i, AddCommGroup (A i)] [DirectSum.GCommRing A] + +open scoped Classical in +omit [IsOrderedCancelAddMonoid ι] in +private theorem card_support_sub_lt {x : DirectSum ι A} {m : ι} (hm : x m ≠ 0) : + (DFinsupp.support (x - DirectSum.of A m (x m))).card < + (DFinsupp.support x).card := by + classical + refine Finset.card_lt_card ⟨fun j hj ↦ ?_, fun hsub ↦ ?_⟩ + · rw [DFinsupp.mem_support_iff] at hj ⊢ + intro hzero + apply hj + by_cases hjm : j = m + · subst j + simp [DirectSum.sub_apply] + · simp [DirectSum.sub_apply, DirectSum.of_apply, Ne.symm hjm, hzero] + · have hmem := hsub (DFinsupp.mem_support_iff.mpr hm) + rw [DFinsupp.mem_support_iff] at hmem + exact hmem (by simp [DirectSum.sub_apply]) + +theorem dvd_or_dvd_of_homogeneous_dvd_or_dvd + {i : ι} (a : A i) + (hhom : ∀ (j k : ι) (b : A j) (c : A k), + DirectSum.of A i a ∣ DirectSum.of A j b * DirectSum.of A k c → + DirectSum.of A i a ∣ DirectSum.of A j b ∨ + DirectSum.of A i a ∣ DirectSum.of A k c) + (x y : DirectSum ι A) (hdvd : DirectSum.of A i a ∣ x * y) : + DirectSum.of A i a ∣ x ∨ DirectSum.of A i a ∣ y := by + classical + generalize hcard : (DFinsupp.support x).card + (DFinsupp.support y).card = n + induction n using Nat.strong_induction_on generalizing x y with + | _ n ih => + by_cases hx : x = 0 + · exact Or.inl (hx ▸ ⟨0, (mul_zero _).symm⟩) + by_cases hy : y = 0 + · exact Or.inr (hy ▸ ⟨0, (mul_zero _).symm⟩) + obtain ⟨m, hmlead, hmne⟩ := exists_grade_eq_leadingGrade A hx + obtain ⟨p, hplead, hpne⟩ := exists_grade_eq_leadingGrade A hy + have htop : (x * y) (m + p) = GradedMonoid.GMul.mul (x m) (y p) := + mul_apply_add_eq_of_leadingGrade_eq A hmlead hplead + have hsplit : DirectSum.of A i a ∣ + DirectSum.of A m (x m) * DirectSum.of A p (y p) := by + have hcomp := (of_dvd_iff_dvd_components A a (x * y)).mp hdvd (m + p) + rwa [htop, ← DirectSum.of_mul_of] at hcomp + rcases hhom m p (x m) (y p) hsplit with hxm | hyp + · have hrest : DirectSum.of A i a ∣ (x - DirectSum.of A m (x m)) * y := by + rw [sub_mul] + exact dvd_sub hdvd (dvd_mul_of_dvd_left hxm y) + have hlt : (DFinsupp.support (x - DirectSum.of A m (x m))).card + + (DFinsupp.support y).card < n := by + rw [← hcard] + exact Nat.add_lt_add_right (card_support_sub_lt A hmne) _ + rcases ih _ hlt _ _ hrest rfl with hrec | hrec + · refine Or.inl ?_ + have hx' : x = (x - DirectSum.of A m (x m)) + DirectSum.of A m (x m) := by abel + rw [hx'] + exact dvd_add hrec hxm + · exact Or.inr hrec + · have hrest : DirectSum.of A i a ∣ x * (y - DirectSum.of A p (y p)) := by + rw [mul_sub] + exact dvd_sub hdvd (dvd_mul_of_dvd_right hyp x) + have hlt : (DFinsupp.support x).card + + (DFinsupp.support (y - DirectSum.of A p (y p))).card < n := by + rw [← hcard] + exact Nat.add_lt_add_left (card_support_sub_lt A hpne) _ + rcases ih _ hlt _ _ hrest rfl with hrec | hrec + · exact Or.inl hrec + · refine Or.inr ?_ + have hy' : y = (y - DirectSum.of A p (y p)) + DirectSum.of A p (y p) := by abel + rw [hy'] + exact dvd_add hrec hyp + +theorem prime_of_homogeneous_dvd_or_dvd + {i : ι} (a : A i) + (hne : DirectSum.of A i a ≠ 0) + (hunit : ¬ IsUnit (DirectSum.of A i a)) + (hhom : ∀ (j k : ι) (b : A j) (c : A k), + DirectSum.of A i a ∣ DirectSum.of A j b * DirectSum.of A k c → + DirectSum.of A i a ∣ DirectSum.of A j b ∨ + DirectSum.of A i a ∣ DirectSum.of A k c) : + Prime (DirectSum.of A i a) := + ⟨hne, hunit, fun x y hdvd ↦ + dvd_or_dvd_of_homogeneous_dvd_or_dvd A a hhom x y hdvd⟩ + +theorem irreducible_of_homogeneous_of_grade_not_split {i : ι} (a : A i) + (hmulne : ∀ {j k : ι} (u : A j) (v : A k), u ≠ 0 → v ≠ 0 → + GradedMonoid.GMul.mul u v ≠ 0) + (hbot : ∀ j : ι, 0 ≤ j) + (hunitZero : ∀ u : A 0, u ≠ 0 → IsUnit (DirectSum.of A 0 u)) + (hsplit : ∀ j k : ι, j + k = i → j = 0 ∨ k = 0) + (hne : DirectSum.of A i a ≠ 0) + (hunit : ¬ IsUnit (DirectSum.of A i a)) : + Irreducible (DirectSum.of A i a) := by + classical + have ha : a ≠ 0 := by + intro h + exact hne (by rw [h, map_zero]) + refine ⟨hunit, fun x y hxy ↦ ?_⟩ + have hx0 : x ≠ 0 := by + intro h + rw [h, zero_mul] at hxy + exact hne hxy + have hy0 : y ≠ 0 := by + intro h + rw [h, mul_zero] at hxy + exact hne hxy + obtain ⟨m, hm, hxm⟩ := exists_grade_eq_leadingGrade A hx0 + obtain ⟨n, hn, hyn⟩ := exists_grade_eq_leadingGrade A hy0 + have hlead : leadingGrade A x + leadingGrade A y = ((i : ι) : WithBot ι) := by + rw [← leadingGrade_mul A hmulne x y, ← hxy, leadingGrade_of A ha] + rw [hm, hn, ← WithBot.coe_add, WithBot.coe_eq_coe] at hlead + have key : ∀ z : DirectSum ι A, z ≠ 0 → leadingGrade A z = ((0 : ι) : WithBot ι) → + IsUnit z := by + intro z hz hlz + have hconc : z = DirectSum.of A 0 (z 0) := by + refine DFinsupp.ext fun j ↦ ?_ + by_cases hj : j = 0 + · subst hj + simp + · have hzj : z j = 0 := by + by_contra hjne + have hle := grade_le_leadingGrade A hjne + rw [hlz, WithBot.coe_le_coe] at hle + exact hj (le_antisymm hle (hbot j)) + rw [hzj, DirectSum.of_apply, dite_eq_right (Ne.symm hj)] + have hz0 : z 0 ≠ 0 := by + intro h + apply hz + rw [hconc, h, map_zero] + rw [hconc] + exact hunitZero _ hz0 + rcases hsplit m n hlead with hm0 | hn0 + · exact Or.inl (key x hx0 (by rw [hm, hm0])) + · exact Or.inr (key y hy0 (by rw [hn, hn0])) + +end DirectSum + +end diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/DirectSum/InternalGrading.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/DirectSum/InternalGrading.lean new file mode 100644 index 0000000000..37dcc9d6ef --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/DirectSum/InternalGrading.lean @@ -0,0 +1,119 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import Mathlib.Algebra.DirectSum.Algebra +public import Mathlib.RingTheory.GradedAlgebra.Basic + +/-! +# The internal grading of an external graded algebra + +An external graded algebra `⨁ i, A i` is internally graded by the ranges of the canonical +inclusions `lof i : A i → ⨁ i, A i`. This file records the submodules `rangeLof R A i` and the +resulting `GradedAlgebra` instance, so that results stated for internally graded algebras apply +to direct sums. +-/ + +universe u v w + +open scoped DirectSum + +public noncomputable section + +namespace DirectSum + +variable (R : Type u) {ι : Type v} (A : ι → Type w) +variable [CommSemiring R] [DecidableEq ι] [AddMonoid ι] +variable [∀ i, AddCommMonoid (A i)] [∀ i, Module R (A i)] [GSemiring A] [GAlgebra R A] + +/-- The grade-`i` part of an external direct sum: the range of the inclusion of `A i`. -/ +def rangeLof (i : ι) : Submodule R (⨁ i, A i) := + LinearMap.range (lof R ι A i) + +omit [AddMonoid ι] [GSemiring A] [GAlgebra R A] in +theorem rangeLof_eq_range (i : ι) : rangeLof R A i = LinearMap.range (lof R ι A i) := (rfl) + +omit [AddMonoid ι] [GSemiring A] [GAlgebra R A] in +theorem lof_mem_rangeLof (i : ι) (a : A i) : lof R ι A i a ∈ rangeLof R A i := + ⟨a, rfl⟩ + +omit [AddMonoid ι] [GSemiring A] [GAlgebra R A] in +theorem of_mem_rangeLof (i : ι) (a : A i) : of A i a ∈ rangeLof R A i := + ⟨a, rfl⟩ + +omit [AddMonoid ι] [GSemiring A] [GAlgebra R A] in +theorem mem_rangeLof_iff (i : ι) (x : ⨁ i, A i) : + x ∈ rangeLof R A i ↔ ∃ a : A i, lof R ι A i a = x := + Iff.rfl + +instance instRangeLofGradedMonoid : SetLike.GradedMonoid (rangeLof R A) where + one_mem := ⟨GradedMonoid.GOne.one, (one_def A).symm⟩ + mul_mem i j x y hx hy := by + obtain ⟨a, rfl⟩ := hx + obtain ⟨b, rfl⟩ := hy + exact ⟨GradedMonoid.GMul.mul a b, by + rw [lof_eq_of, lof_eq_of, lof_eq_of, of_mul_of]⟩ + +/-- The componentwise equivalence `A i ≃ rangeLof R A i`. -/ +def rangeLofEquiv (i : ι) : A i ≃ₗ[R] rangeLof R A i := + LinearEquiv.ofInjective (lof R ι A i) (of_injective i) + +/-- The decomposition of an external direct sum along its internal grading. -/ +def rangeLofDecompose : (⨁ i, A i) →ₗ[R] ⨁ i, rangeLof R A i := + toModule R ι _ fun i ↦ (lof R ι (fun i ↦ rangeLof R A i) i).comp (rangeLofEquiv R A i).toLinearMap + +omit [AddMonoid ι] [GSemiring A] [GAlgebra R A] in +theorem rangeLofDecompose_lof (i : ι) (a : A i) : + rangeLofDecompose R A (lof R ι A i a) = + lof R ι (fun i ↦ rangeLof R A i) i (rangeLofEquiv R A i a) := by + rw [rangeLofDecompose, toModule_lof, LinearMap.comp_apply, LinearEquiv.coe_coe] + +omit [GAlgebra R A] in +theorem coeLinearMap_rangeLofDecompose (x : ⨁ i, A i) : + coeLinearMap (rangeLof R A) (rangeLofDecompose R A x) = x := by + induction x using DirectSum.induction_on with + | zero => rw [map_zero, map_zero] + | of i a => + rw [← lof_eq_of R, rangeLofDecompose_lof, coeLinearMap_lof] + rfl + | add x y hx hy => rw [map_add, map_add, hx, hy] + +omit [GAlgebra R A] in +theorem rangeLofDecompose_coeLinearMap (x : ⨁ i, rangeLof R A i) : + rangeLofDecompose R A (coeLinearMap (rangeLof R A) x) = x := by + induction x using DirectSum.induction_on with + | zero => rw [map_zero, map_zero] + | of i a => + obtain ⟨b, rfl⟩ := (rangeLofEquiv R A i).surjective a + rw [← lof_eq_of R, coeLinearMap_lof] + change rangeLofDecompose R A (lof R ι A i b) = _ + rw [rangeLofDecompose_lof] + | add x y hx hy => rw [map_add, map_add, hx, hy] + +omit [GAlgebra R A] in +theorem rangeLof_isInternal : IsInternal (rangeLof R A) := + Function.bijective_iff_has_inverse.mpr ⟨rangeLofDecompose R A, + rangeLofDecompose_coeLinearMap R A, coeLinearMap_rangeLofDecompose R A⟩ + +/-- The internal graded-algebra structure on an external direct sum. -/ +instance instRangeLofGradedAlgebra : GradedAlgebra (rangeLof R A) := + (rangeLof_isInternal R A).gradedAlgebra + +/-- The decomposition of the internal grading recovers the components. -/ +theorem coe_decompose_rangeLof (x : ⨁ i, A i) (i : ι) : + ((DirectSum.decompose (rangeLof R A) x i : rangeLof R A i) : ⨁ i, A i) = + lof R ι A i (x i) := by + classical + conv_lhs => rw [← DirectSum.sum_support_of x] + rw [DirectSum.decompose_sum, DirectSum.sum_apply, Submodule.coe_sum, Finset.sum_eq_single i] + · rw [DirectSum.decompose_of_mem_same _ (of_mem_rangeLof R A i (x i)), lof_eq_of] + · intro j _ hji + rw [DirectSum.decompose_of_mem_ne _ (of_mem_rangeLof R A j (x j)) hji] + · intro hi + rw [DFinsupp.notMem_support_iff.mp hi, map_zero, DirectSum.decompose_zero] + rfl + +end DirectSum diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/DirectSum/LeadingGrade.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/DirectSum/LeadingGrade.lean new file mode 100644 index 0000000000..9136e24de1 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/DirectSum/LeadingGrade.lean @@ -0,0 +1,228 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import Mathlib.Algebra.DirectSum.Ring +public import Mathlib.Algebra.Order.Monoid.Unbundled.WithTop +public import Mathlib.Data.Finset.Max + +/-! +# Leading grades in graded direct sums + +The leading grade of a finitely supported graded sum is the largest grade at which its component +is nonzero, with value bottom at zero. It satisfies the max-form addition inequality. + +For a graded ring whose nonzero homogeneous elements have nonzero product, leading grade is +multiplicative. The proof isolates the unique contribution at the sum of the two leading grades; +all other pairs of support indices have strictly smaller sum. +-/ + +universe u v + +public noncomputable section + +open scoped DirectSum + +namespace DirectSum + +section Additive + +variable {ι : Type u} (A : ι → Type v) + [LinearOrder ι] [∀ i, AddCommMonoid (A i)] + +/-- The largest grade at which a graded direct-sum element has nonzero component. -/ +def leadingGrade (x : DirectSum ι A) : WithBot ι := by + classical + exact x.support.max + +@[simp] +theorem leadingGrade_zero : leadingGrade A 0 = ⊥ := by + classical + simp [leadingGrade] + +theorem leadingGrade_of {i : ι} {a : A i} (ha : a ≠ 0) : + leadingGrade A (DirectSum.of A i a) = i := by + classical + rw [leadingGrade, DirectSum.support_of i a ha, Finset.max_singleton] + +@[simp] +theorem leadingGrade_eq_bot_iff (x : DirectSum ι A) : + leadingGrade A x = ⊥ ↔ x = 0 := by + classical + simp only [leadingGrade, Finset.max_eq_bot, DFinsupp.support_eq_empty] + +theorem grade_le_leadingGrade {x : DirectSum ι A} {i : ι} (hi : x i ≠ 0) : + (i : WithBot ι) ≤ leadingGrade A x := by + classical + exact Finset.le_max (DFinsupp.mem_support_iff.mpr hi) + +theorem leadingGrade_eq_coe_iff (x : DirectSum ι A) (m : ι) : + leadingGrade A x = (m : WithBot ι) ↔ + x m ≠ 0 ∧ ∀ i, x i ≠ 0 → i ≤ m := by + classical + constructor + · intro h + have hm : m ∈ x.support := Finset.mem_of_max h + refine ⟨DFinsupp.mem_support_iff.mp hm, ?_⟩ + intro i hi + exact Finset.le_max_of_eq (DFinsupp.mem_support_iff.mpr hi) h + · rintro ⟨hm, hmax⟩ + apply le_antisymm + · rw [leadingGrade] + apply Finset.max_le + intro i hi + exact WithBot.coe_le_coe.mpr (hmax i (DFinsupp.mem_support_iff.mp hi)) + · exact Finset.le_max (DFinsupp.mem_support_iff.mpr hm) + +theorem leadingGrade_add_le_max (x y : DirectSum ι A) : + leadingGrade A (x + y) ≤ max (leadingGrade A x) (leadingGrade A y) := by + classical + rw [leadingGrade, leadingGrade, leadingGrade, ← Finset.max_union] + exact Finset.max_mono DFinsupp.support_add + +theorem exists_grade_eq_leadingGrade {x : DirectSum ι A} (hx : x ≠ 0) : + ∃ m : ι, leadingGrade A x = m ∧ x m ≠ 0 := by + classical + have hs : x.support.Nonempty := by + rw [Finset.nonempty_iff_ne_empty] + intro hs + apply hx + apply DirectSum.ext + intro i + apply DFinsupp.notMem_support_iff.mp + rw [hs] + simp + obtain ⟨m, hm⟩ := Finset.max_of_nonempty hs + exact ⟨m, hm, DFinsupp.mem_support_iff.mp (Finset.mem_of_max hm)⟩ + +end Additive + +section Group + +variable {ι : Type u} (A : ι → Type v) + [LinearOrder ι] [∀ i, AddCommGroup (A i)] + +@[simp] +theorem leadingGrade_neg (x : DirectSum ι A) : leadingGrade A (-x) = leadingGrade A x := by + have hsupp : ∀ i, (-x) i ≠ 0 ↔ x i ≠ 0 := fun i ↦ by + rw [← zero_sub, DirectSum.sub_apply, DirectSum.zero_apply, zero_sub] + exact neg_ne_zero + apply le_antisymm + · by_cases h : -x = 0 + · rw [h, leadingGrade_zero] + exact bot_le + obtain ⟨m, hm, hxm⟩ := exists_grade_eq_leadingGrade A h + rw [hm] + exact grade_le_leadingGrade A ((hsupp m).mp hxm) + · by_cases h : x = 0 + · rw [h, leadingGrade_zero] + exact bot_le + obtain ⟨m, hm, hxm⟩ := exists_grade_eq_leadingGrade A h + rw [hm] + exact grade_le_leadingGrade A ((hsupp m).mpr hxm) + +end Group + +section Multiplicative + +variable {ι : Type u} (A : ι → Type v) + [LinearOrder ι] [AddCommMonoid ι] [IsOrderedCancelAddMonoid ι] + [∀ i, AddCommMonoid (A i)] [DirectSum.GSemiring A] + +omit [IsOrderedCancelAddMonoid ι] in +theorem exists_grades_of_mul_apply_ne_zero {x y : DirectSum ι A} {k : ι} + (hk : (x * y) k ≠ 0) : + ∃ i j, x i ≠ 0 ∧ y j ≠ 0 ∧ i + j = k := by + classical + rw [DirectSum.mul_eq_sum_support_ghas_mul, DirectSum.sum_apply] at hk + obtain ⟨ij, hij, hterm⟩ := Finset.exists_ne_zero_of_sum_ne_zero hk + refine ⟨ij.1, ij.2, ?_, ?_, ?_⟩ + · exact DFinsupp.mem_support_iff.mp (Finset.mem_product.mp hij).1 + · exact DFinsupp.mem_support_iff.mp (Finset.mem_product.mp hij).2 + · by_contra hgrade + rw [DirectSum.of_eq_of_ne _ _ _ (Ne.symm hgrade)] at hterm + exact hterm rfl + +theorem leadingGrade_mul_le (x y : DirectSum ι A) : + leadingGrade A (x * y) ≤ leadingGrade A x + leadingGrade A y := by + classical + rw [leadingGrade] + apply Finset.max_le + intro k hk + obtain ⟨i, j, hi, hj, rfl⟩ := + exists_grades_of_mul_apply_ne_zero A (DFinsupp.mem_support_iff.mp hk) + rw [WithBot.coe_add] + exact add_le_add (grade_le_leadingGrade A hi) (grade_le_leadingGrade A hj) + +theorem mul_apply_add_eq_of_leadingGrade_eq {x y : DirectSum ι A} {m n : ι} + (hm : leadingGrade A x = m) (hn : leadingGrade A y = n) : + (x * y) (m + n) = GradedMonoid.GMul.mul (x m) (y n) := by + classical + rw [DirectSum.mul_eq_sum_support_ghas_mul, DirectSum.sum_apply] + let term : ι × ι → A (m + n) := fun ij ↦ + (DirectSum.of A (ij.1 + ij.2) + (GradedMonoid.GMul.mul (x ij.1) (y ij.2))) (m + n) + change (∑ ij ∈ x.support ×ˢ y.support, term ij) = _ + rw [Finset.sum_eq_single (f := term) (m, n)] + · simp [term] + · intro ij hij hne + by_cases hgrade : ij.1 + ij.2 = m + n + · exfalso + apply hne + apply Prod.ext + · change ij.1 = m + apply le_antisymm + · exact Finset.le_max_of_eq (Finset.mem_product.mp hij).1 hm + · apply le_of_not_gt + intro hmi + have hjn : ij.2 ≤ n := + Finset.le_max_of_eq (Finset.mem_product.mp hij).2 hn + exact (add_lt_add_of_lt_of_le hmi hjn).ne hgrade + · change ij.2 = n + apply le_antisymm + · exact Finset.le_max_of_eq (Finset.mem_product.mp hij).2 hn + · apply le_of_not_gt + intro hnj + have him : ij.1 ≤ m := + Finset.le_max_of_eq (Finset.mem_product.mp hij).1 hm + exact (add_lt_add_of_le_of_lt him hnj).ne hgrade + · simp [term, DirectSum.of_eq_of_ne _ _ _ (Ne.symm hgrade)] + · intro hnotmem + simp only [Finset.mem_product, not_and_or] at hnotmem + rcases hnotmem with hmnot | hnnot + · dsimp [term] + rw [DFinsupp.notMem_support_iff.mp hmnot] + rw [DirectSum.GNonUnitalNonAssocSemiring.zero_mul (A := A)] + simp + · dsimp [term] + rw [DFinsupp.notMem_support_iff.mp hnnot] + rw [DirectSum.GNonUnitalNonAssocSemiring.mul_zero (A := A)] + simp + +/-- Leading grade is multiplicative when nonzero homogeneous products remain nonzero. -/ +theorem leadingGrade_mul + (hmul : ∀ {i j} (a : A i) (b : A j), a ≠ 0 → b ≠ 0 → + GradedMonoid.GMul.mul a b ≠ 0) + (x y : DirectSum ι A) : + leadingGrade A (x * y) = leadingGrade A x + leadingGrade A y := by + by_cases hx : x = 0 + · subst x + simp [leadingGrade_zero] + by_cases hy : y = 0 + · subst y + simp [leadingGrade_zero] + obtain ⟨m, hm, hxm⟩ := exists_grade_eq_leadingGrade A hx + obtain ⟨n, hn, hyn⟩ := exists_grade_eq_leadingGrade A hy + apply le_antisymm + · exact leadingGrade_mul_le A x y + · rw [hm, hn, ← WithBot.coe_add] + apply grade_le_leadingGrade A + rw [mul_apply_add_eq_of_leadingGrade_eq A hm hn] + exact hmul (x m) (y n) hxm hyn + +end Multiplicative + +end DirectSum diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/DirectSum/TrailingGrade.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/DirectSum/TrailingGrade.lean new file mode 100644 index 0000000000..4f32ab4b79 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/DirectSum/TrailingGrade.lean @@ -0,0 +1,190 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import Mathlib.Algebra.DirectSum.Ring +public import Mathlib.Algebra.Order.Monoid.Unbundled.WithTop +public import Mathlib.Data.Finset.Max + +import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.DirectSum.LeadingGrade + +/-! +# Trailing grades in graded direct sums + +The trailing grade of a finitely supported graded sum is the smallest grade at which its component +is nonzero, with value top at zero. It satisfies the min-form addition inequality. + +For a graded ring whose nonzero homogeneous elements have nonzero product, trailing grade is +multiplicative. The proof isolates the unique contribution at the sum of the two trailing grades. +This is the minimum-grade counterpart of `DirectSum.leadingGrade`. +-/ + +universe u v + +public noncomputable section + +open scoped DirectSum + +namespace DirectSum + +section Additive + +variable {ι : Type u} (A : ι → Type v) + [LinearOrder ι] [∀ i, AddCommMonoid (A i)] + +/-- The smallest grade at which a graded direct-sum element has nonzero component. -/ +def trailingGrade (x : DirectSum ι A) : WithTop ι := by + classical + exact x.support.min + +@[simp] +theorem trailingGrade_zero : trailingGrade A 0 = ⊤ := by + classical + simp [trailingGrade] + +theorem trailingGrade_of {i : ι} {a : A i} (ha : a ≠ 0) : + trailingGrade A (DirectSum.of A i a) = i := by + classical + rw [trailingGrade, DirectSum.support_of i a ha, Finset.min_singleton] + +@[simp] +theorem trailingGrade_eq_top_iff (x : DirectSum ι A) : + trailingGrade A x = ⊤ ↔ x = 0 := by + classical + simp only [trailingGrade, Finset.min_eq_top, DFinsupp.support_eq_empty] + +theorem trailingGrade_le_grade {x : DirectSum ι A} {i : ι} (hi : x i ≠ 0) : + trailingGrade A x ≤ (i : WithTop ι) := by + classical + exact Finset.min_le (DFinsupp.mem_support_iff.mpr hi) + +theorem trailingGrade_eq_coe_iff (x : DirectSum ι A) (m : ι) : + trailingGrade A x = (m : WithTop ι) ↔ + x m ≠ 0 ∧ ∀ i, x i ≠ 0 → m ≤ i := by + classical + constructor + · intro h + have hm : m ∈ x.support := Finset.mem_of_min h + refine ⟨DFinsupp.mem_support_iff.mp hm, ?_⟩ + intro i hi + exact Finset.min_le_of_eq (DFinsupp.mem_support_iff.mpr hi) h + · rintro ⟨hm, hmin⟩ + apply le_antisymm + · exact Finset.min_le (DFinsupp.mem_support_iff.mpr hm) + · rw [trailingGrade] + apply Finset.le_min + intro i hi + exact WithTop.coe_le_coe.mpr (hmin i (DFinsupp.mem_support_iff.mp hi)) + +theorem min_le_trailingGrade_add (x y : DirectSum ι A) : + min (trailingGrade A x) (trailingGrade A y) ≤ trailingGrade A (x + y) := by + classical + rw [trailingGrade, trailingGrade, trailingGrade, ← Finset.min_union] + exact Finset.min_mono DFinsupp.support_add + +theorem exists_grade_eq_trailingGrade {x : DirectSum ι A} (hx : x ≠ 0) : + ∃ m : ι, trailingGrade A x = m ∧ x m ≠ 0 := by + classical + have hs : x.support.Nonempty := by + rw [Finset.nonempty_iff_ne_empty] + intro hs + apply hx + apply DirectSum.ext + intro i + apply DFinsupp.notMem_support_iff.mp + rw [hs] + simp + obtain ⟨m, hm⟩ := Finset.min_of_nonempty hs + exact ⟨m, hm, DFinsupp.mem_support_iff.mp (Finset.mem_of_min hm)⟩ + +end Additive + +section Multiplicative + +variable {ι : Type u} (A : ι → Type v) + [LinearOrder ι] [AddCommMonoid ι] [IsOrderedCancelAddMonoid ι] + [∀ i, AddCommMonoid (A i)] [DirectSum.GSemiring A] + +theorem le_trailingGrade_mul (x y : DirectSum ι A) : + trailingGrade A x + trailingGrade A y ≤ trailingGrade A (x * y) := by + classical + rw [trailingGrade] + apply Finset.le_min + intro k hk + obtain ⟨i, j, hi, hj, rfl⟩ := + exists_grades_of_mul_apply_ne_zero A (DFinsupp.mem_support_iff.mp hk) + rw [WithTop.coe_add] + exact add_le_add (trailingGrade_le_grade A hi) (trailingGrade_le_grade A hj) + +theorem mul_apply_add_eq_of_trailingGrade_eq {x y : DirectSum ι A} {m n : ι} + (hm : trailingGrade A x = m) (hn : trailingGrade A y = n) : + (x * y) (m + n) = GradedMonoid.GMul.mul (x m) (y n) := by + classical + rw [DirectSum.mul_eq_sum_support_ghas_mul, DirectSum.sum_apply] + let term : ι × ι → A (m + n) := fun ij ↦ + (DirectSum.of A (ij.1 + ij.2) + (GradedMonoid.GMul.mul (x ij.1) (y ij.2))) (m + n) + change (∑ ij ∈ x.support ×ˢ y.support, term ij) = _ + rw [Finset.sum_eq_single (f := term) (m, n)] + · simp [term] + · intro ij hij hne + by_cases hgrade : ij.1 + ij.2 = m + n + · exfalso + apply hne + apply Prod.ext + · change ij.1 = m + apply le_antisymm + · apply le_of_not_gt + intro hmi + have hnj : n ≤ ij.2 := + Finset.min_le_of_eq (Finset.mem_product.mp hij).2 hn + exact (add_lt_add_of_lt_of_le hmi hnj).ne hgrade.symm + · exact Finset.min_le_of_eq (Finset.mem_product.mp hij).1 hm + · change ij.2 = n + apply le_antisymm + · apply le_of_not_gt + intro hni + have hmi : m ≤ ij.1 := + Finset.min_le_of_eq (Finset.mem_product.mp hij).1 hm + exact (add_lt_add_of_le_of_lt hmi hni).ne hgrade.symm + · exact Finset.min_le_of_eq (Finset.mem_product.mp hij).2 hn + · simp [term, DirectSum.of_eq_of_ne _ _ _ (Ne.symm hgrade)] + · intro hnotmem + simp only [Finset.mem_product, not_and_or] at hnotmem + rcases hnotmem with hmnot | hnnot + · dsimp [term] + rw [DFinsupp.notMem_support_iff.mp hmnot] + rw [DirectSum.GNonUnitalNonAssocSemiring.zero_mul (A := A)] + simp + · dsimp [term] + rw [DFinsupp.notMem_support_iff.mp hnnot] + rw [DirectSum.GNonUnitalNonAssocSemiring.mul_zero (A := A)] + simp + +/-- Trailing grade is multiplicative when nonzero homogeneous products remain nonzero. -/ +theorem trailingGrade_mul + (hmul : ∀ {i j} (a : A i) (b : A j), a ≠ 0 → b ≠ 0 → + GradedMonoid.GMul.mul a b ≠ 0) + (x y : DirectSum ι A) : + trailingGrade A (x * y) = trailingGrade A x + trailingGrade A y := by + by_cases hx : x = 0 + · subst x + simp [trailingGrade_zero] + by_cases hy : y = 0 + · subst y + simp [trailingGrade_zero] + obtain ⟨m, hm, hxm⟩ := exists_grade_eq_trailingGrade A hx + obtain ⟨n, hn, hyn⟩ := exists_grade_eq_trailingGrade A hy + apply le_antisymm + · rw [hm, hn, ← WithTop.coe_add] + apply trailingGrade_le_grade A + rw [mul_apply_add_eq_of_trailingGrade_eq A hm hn] + exact hmul (x m) (y n) hxm hyn + · exact le_trailingGrade_mul A x y + +end Multiplicative + +end DirectSum diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Divisibility.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Divisibility.lean new file mode 100644 index 0000000000..fc6d7c097b --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Divisibility.lean @@ -0,0 +1,16 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Divisibility.DenominatorIdeal +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Divisibility.MaximalDivisor +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Divisibility.PrimalPreimage +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Divisibility.PrimalProduct +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Divisibility.Refinement +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Divisibility.Tests + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Divisibility/DenominatorIdeal.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Divisibility/DenominatorIdeal.lean new file mode 100644 index 0000000000..6879eab0e2 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Divisibility/DenominatorIdeal.lean @@ -0,0 +1,171 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Divisibility.Refinement +public import Mathlib.Algebra.Ring.Subring.Basic +public import Mathlib.RingTheory.Ideal.Defs + +import Mathlib.Tactic.FieldSimp +import Mathlib.Tactic.Ring + +/-! +# Denominator ideals and four-factor refinement + +For a subring `R` of a field and a field element `ξ`, the denominator ideal + +`I_ξ(R) = {x ∈ R | ξ * x ∈ R}` + +packages the possible denominators for `ξ`. Given two nonzero elements `x, y ∈ I_ξ(R)`, their +tautological rank-one equality + +`x * (ξ * y) = y * (ξ * x)` + +has a four-factor refinement in `R` exactly when `x` and `y` have a common divisor which still +belongs to `I_ξ(R)`. Consequently, a subring of a field has four-factor refinement exactly when +every pair in every denominator ideal has such a common divisor. This is the binary form of the +denominator-ideal criterion used by Zafrullah to characterize pre-Schreier domains. +-/ + +universe u + +public section + +namespace Subring + +variable {K : Type u} [Field K] + +/-- The elements of a subring whose product with `ξ` still lies in the subring. -/ +def denominatorIdeal (R : Subring K) (ξ : K) : Ideal R where + carrier := {x | ξ * (x : K) ∈ R} + zero_mem' := by simp + add_mem' {x y} hx hy := by + simpa [mul_add] using R.add_mem hx hy + smul_mem' c x hx := by + simpa [mul_assoc, mul_left_comm, mul_comm] using R.mul_mem c.2 hx + +@[simp] +theorem mem_denominatorIdeal_iff (R : Subring K) (ξ : K) (x : R) : + x ∈ denominatorIdeal R ξ ↔ ξ * (x : K) ∈ R := + Iff.rfl + +/-- Multiplication by the fraction defining a denominator ideal, with codomain restricted back to +the subring. -/ +def denominatorNumerator (R : Subring K) (ξ : K) (x : denominatorIdeal R ξ) : R := + ⟨ξ * (x : R), x.2⟩ + +@[simp] +theorem coe_denominatorNumerator (R : Subring K) (ξ : K) + (x : denominatorIdeal R ξ) : + (denominatorNumerator R ξ x : K) = ξ * (x : R) := + (rfl) + +/-- Two nonzero elements of a denominator ideal have a nonzero common divisor in that ideal +exactly when their associated rank-one equality has a four-factor refinement in the subring. -/ +theorem exists_common_divisor_denominatorIdeal_iff_exists_fourFactorRefinement + (R : Subring K) (ξ : K) (x y : denominatorIdeal R ξ) (hx : (x : R) ≠ 0) : + (∃ s : denominatorIdeal R ξ, + (s : R) ∣ (x : R) ∧ (s : R) ∣ (y : R)) ↔ + ∃ e f g h : R, + (x : R) = e * f ∧ denominatorNumerator R ξ y = g * h ∧ + (y : R) = e * g ∧ denominatorNumerator R ξ x = f * h := by + constructor + · rintro ⟨s, ⟨f, hxf⟩, ⟨g, hyg⟩⟩ + let h : R := denominatorNumerator R ξ s + refine ⟨s, f, g, h, hxf, ?_, hyg, ?_⟩ + · apply Subtype.ext + change ξ * (y : R) = (g : K) * (h : K) + rw [hyg] + change ξ * ((s : K) * g) = (g : K) * (ξ * s) + ring + · apply Subtype.ext + change ξ * (x : R) = (f : K) * (h : K) + rw [hxf] + change ξ * ((s : K) * f) = (f : K) * (ξ * s) + ring + · rintro ⟨e, f, g, h, hxf, _, hyg, hxh⟩ + have hf0 : (f : K) ≠ 0 := by + intro hf + apply hx + rw [hxf] + apply Subtype.ext + simp [hf] + have hxfK : (x : K) = (e : K) * f := congrArg Subtype.val hxf + have hxhK : ξ * (x : K) = (f : K) * h := congrArg Subtype.val hxh + have hξe : ξ * (e : K) = (h : K) := by + apply mul_right_cancel₀ hf0 + calc + (ξ * (e : K)) * f = ξ * ((e : K) * f) := by ring + _ = ξ * (x : K) := by rw [hxfK] + _ = (f : K) * h := hxhK + _ = (h : K) * f := by ring + let s : denominatorIdeal R ξ := + ⟨e, (mem_denominatorIdeal_iff R ξ e).2 (by rw [hξe]; exact h.2)⟩ + exact ⟨s, ⟨f, hxf⟩, ⟨g, hyg⟩⟩ + +/-- A subring of a field has four-factor refinement exactly when every pair in every denominator +ideal has a common divisor belonging to that denominator ideal. -/ +theorem hasFourFactorRefinement_iff_forall_denominatorIdeal_exists_common_divisor + (R : Subring K) : + HasFourFactorRefinement R ↔ + ∀ (ξ : K) (x y : denominatorIdeal R ξ), + ∃ s : denominatorIdeal R ξ, (s : R) ∣ (x : R) ∧ (s : R) ∣ (y : R) := by + constructor + · intro hR ξ x y + by_cases hx : (x : R) = 0 + · refine ⟨y, ⟨0, by simp [hx]⟩, ⟨1, by simp⟩⟩ + · apply + (exists_common_divisor_denominatorIdeal_iff_exists_fourFactorRefinement R ξ x y hx).2 + apply hR.refine + apply Subtype.ext + change (x : K) * (ξ * (y : R)) = (y : K) * (ξ * (x : R)) + ring + · intro h + apply hasFourFactorRefinement_def.mpr + intro a b c d habcd + by_cases hb : b = 0 + · subst b + have hcd : c * d = 0 := by simpa using habcd.symm + rcases eq_zero_or_eq_zero_of_mul_eq_zero hcd with hc | hd + · subst c + exact ⟨a, 1, 0, d, by simp⟩ + · subst d + exact ⟨1, a, c, 0, by simp⟩ + · have hbK : (b : K) ≠ 0 := fun h0 ↦ hb (Subtype.ext h0) + let ξ : K := (d : K) / b + have hξb : ξ * (b : K) = d := by + dsimp [ξ] + field_simp + have habcdK : (a : K) * b = (c : K) * d := congrArg Subtype.val habcd + have hξc : ξ * (c : K) = a := by + dsimp [ξ] + field_simp + simpa [mul_comm] using habcdK.symm + let x : denominatorIdeal R ξ := + ⟨b, (mem_denominatorIdeal_iff R ξ b).2 (by rw [hξb]; exact d.2)⟩ + let y : denominatorIdeal R ξ := + ⟨c, (mem_denominatorIdeal_iff R ξ c).2 (by rw [hξc]; exact a.2)⟩ + obtain ⟨s, hsx, hsy⟩ := h ξ x y + obtain ⟨e, f, g, k, hxef, hykg, hyeg, hxhk⟩ := + (exists_common_divisor_denominatorIdeal_iff_exists_fourFactorRefinement + R ξ x y (by exact hb)).1 ⟨s, hsx, hsy⟩ + have hnumx : denominatorNumerator R ξ x = d := by + apply Subtype.ext + exact hξb + have hnumy : denominatorNumerator R ξ y = a := by + apply Subtype.ext + exact hξc + refine ⟨g, k, e, f, ?_, hxef, ?_, ?_⟩ + · calc + a = denominatorNumerator R ξ y := hnumy.symm + _ = g * k := hykg + · simpa [mul_comm] using hyeg + · calc + d = denominatorNumerator R ξ x := hnumx.symm + _ = f * k := hxhk + _ = k * f := mul_comm _ _ + +end Subring diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Divisibility/MaximalDivisor.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Divisibility/MaximalDivisor.lean new file mode 100644 index 0000000000..35818e7771 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Divisibility/MaximalDivisor.lean @@ -0,0 +1,98 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import Mathlib.Algebra.GroupWithZero.Associated + +/-! +# Maximal divisors along a multiplicative map + +For a multiplicative map `f : D →* R`, an associate class `a : Associates D` is the maximal +divisor of `x : R` coming from `D` when `f q ∣ x` holds exactly for the elements `q : D` whose +associate classes divide `a`. + +The definition is invariant under multiplication by units in `D`. It supplies the common +divisibility interface later used for both the associated graded ring and the Hahn-series ring in +LM24. +-/ + +universe u v + +public section + +/-- `a` records exactly the divisors of `x` that arise through `f`. -/ +def IsMaximalDivisorAlong + {D : Type u} {R : Type v} + [CommMonoidWithZero D] + [CommMonoidWithZero R] + (f : D →* R) (x : R) (a : Associates D) : Prop := + ∀ q : D, Associates.mk q ≤ a ↔ f q ∣ x + +/-- The defining divisibility characterization of a maximal divisor along a map. -/ +theorem isMaximalDivisorAlong_iff + {D : Type u} {R : Type v} + [CommMonoidWithZero D] + [CommMonoidWithZero R] + (f : D →* R) (x : R) (a : Associates D) : + IsMaximalDivisorAlong f x a ↔ + ∀ q : D, Associates.mk q ≤ a ↔ f q ∣ x := + Iff.rfl + +namespace IsMaximalDivisorAlong + +variable {D : Type u} {R : Type v} +variable [CommMonoidWithZero D] [IsCancelMulZero D] +variable [CommMonoidWithZero R] +variable {f : D →* R} {x y : R} {a b c : Associates D} + +omit [IsCancelMulZero D] in +/-- Zero has zero as its maximal divisor class along every multiplicative map. -/ +theorem zero (f : D →* R) : IsMaximalDivisorAlong f 0 0 := by + rw [isMaximalDivisorAlong_iff] + intro q + constructor + · intro _ + exact dvd_zero _ + · intro _ + change Associates.mk q ≤ Associates.mk 0 + exact Associates.mk_le_mk_of_dvd (dvd_zero q) + +/-- The maximal-divisor property determines at most one associate class. -/ +theorem eq (ha : IsMaximalDivisorAlong f x a) + (hb : IsMaximalDivisorAlong f x b) : a = b := by + induction a using Quotient.inductionOn with + | _ p => + induction b using Quotient.inductionOn with + | _ q => + apply le_antisymm + · exact (hb p).2 ((ha p).1 le_rfl) + · exact (ha q).2 ((hb q).1 le_rfl) + +omit [IsCancelMulZero D] in +/-- Every representative of the maximal associate class divides the target after applying `f`. +-/ +theorem map_dvd_of_mk_eq (ha : IsMaximalDivisorAlong f x a) + {p : D} (hp : Associates.mk p = a) : f p ∣ x := by + exact (ha p).1 hp.le + +omit [IsCancelMulZero D] in +/-- Maximal divisor classes are supermultiplicative: the product of maximal divisors of two +elements divides every maximal divisor of their product. -/ +theorem mul_le (ha : IsMaximalDivisorAlong f x a) + (hb : IsMaximalDivisorAlong f y b) + (hc : IsMaximalDivisorAlong f (x * y) c) : a * b ≤ c := by + induction a using Quotient.inductionOn with + | _ p => + induction b using Quotient.inductionOn with + | _ q => + apply (hc (p * q)).2 + obtain ⟨x', hx⟩ := (ha p).1 le_rfl + obtain ⟨y', hy⟩ := (hb q).1 le_rfl + refine ⟨x' * y', ?_⟩ + rw [map_mul, hx, hy] + ac_rfl + +end IsMaximalDivisorAlong diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Divisibility/PrimalPreimage.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Divisibility/PrimalPreimage.lean new file mode 100644 index 0000000000..07a0ccf19e --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Divisibility/PrimalPreimage.lean @@ -0,0 +1,802 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Divisibility.Refinement +public import Mathlib.Algebra.Algebra.Subalgebra.Basic +public import Mathlib.Algebra.Ring.Subring.Basic +public import Mathlib.Algebra.Field.Subfield.Basic +public import Mathlib.Algebra.GroupWithZero.Divisibility +import Mathlib.Tactic.Ring +import Mathlib.Tactic.FieldSimp +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint + +/-! +# Primality in a ring cut out by a residue condition + +Let `L` be a field, `A` a commutative `L`-algebra that is a domain, and `π : A →ₐ[L] L` a +retraction of the structure map. For a subring `S ⊆ L`, the elements of `A` whose residue under +`π` lies in `S` form a subring `π ⁻¹ S`. This file decides when an element of that subring is +primal in it, in terms of primality of its residue in `S` and primality of the element in `A`. + +The application is `𝐙 + 𝐊((𝐆^{<0}))`, which is exactly the preimage of `𝐙` under the +coefficient-at-zero map on `𝐊((𝐆^{≤0}))`; that map is a ring hom because `x + y = 0` with +`x, y ≤ 0` forces `x = y = 0`. + +The statement is LM24, Lemma 9.2.1, and the proof follows theirs with two repairs the printed +argument needs. It concludes `e = f * g` from `b * e = b * (f * g)`, which requires cancellation, +so `A` is assumed to be a domain and `b = 0` is treated separately. And both left-to-right +directions invoke primality in `π ⁻¹ S` at a product whose quotient need not have residue in `S`: +at `π b ≠ 0` the residue can be `1 / π b`, and at `π b = 0` it can be any element of `Frac S`. In +each case a scalar is cleared before primality is invoked and undone afterwards. The rescaling +parameter `η` must also be chosen nonzero, in `L` for the first case and in `Frac S` for the +second. +-/ + +universe u v + +public section + +variable {L A : Type*} [Field L] [CommRing A] [Algebra L A] + +/-- Primality is invariant under a ring equivalence. -/ +theorem RingEquiv.isPrimal_iff {B : Type*} [CommRing B] + (e : A ≃+* B) (a : A) : IsPrimal (e a) ↔ IsPrimal a := by + constructor + · intro h b c hdvd + have hdvd' : e a ∣ e b * e c := by simpa using e.map_dvd hdvd + obtain ⟨a₁, a₂, h₁, h₂, ha⟩ := h hdvd' + refine ⟨e.symm a₁, e.symm a₂, ?_, ?_, ?_⟩ + · simpa using e.symm.map_dvd h₁ + · simpa using e.symm.map_dvd h₂ + · apply e.injective + simp [ha] + · intro h b c hdvd + have hdvd' : a ∣ e.symm b * e.symm c := by simpa using e.symm.map_dvd hdvd + obtain ⟨a₁, a₂, h₁, h₂, ha⟩ := h hdvd' + refine ⟨e a₁, e a₂, ?_, ?_, ?_⟩ + · simpa using e.map_dvd h₁ + · simpa using e.map_dvd h₂ + · simp [ha] + +namespace Subring + +/-- `π ⁻¹ S`, as a subring of `A`. -/ +abbrev residueSubring (π : A →ₐ[L] L) (S : Subring L) : Subring A := S.comap (π : A →+* L) + +/-- `Frac S`, realised as a subring of the ambient field `L`. -/ +abbrev fracSubring (S : Subring L) : Subring L := (Subfield.closure (S : Set L)).toSubring + +variable {π : A →ₐ[L] L} {S : Subring L} + +theorem mem_residueSubring {b : A} : b ∈ residueSubring π S ↔ π b ∈ S := (Iff.rfl) + +theorem le_fracSubring : S ≤ fracSubring S := fun _ hx ↦ Subfield.subset_closure hx + +theorem residueSubring_le_fracSubring : residueSubring π S ≤ residueSubring π (fracSubring S) := + fun _ hx ↦ le_fracSubring hx + +/-- Every element of `Frac S` has a denominator in `S`. -/ +theorem exists_den {x : L} (hx : x ∈ fracSubring S) : + ∃ s ∈ S, s ≠ 0 ∧ s * x ∈ S := by + obtain ⟨y, hy, z, hz, rfl⟩ := Subfield.mem_closure_iff.mp hx + rw [Subring.closure_eq] at hy hz + rcases eq_or_ne z 0 with rfl | hz0 + · exact ⟨1, S.one_mem, one_ne_zero, by simp⟩ + · exact ⟨z, hz, hz0, by rw [mul_div_cancel₀ _ hz0]; exact hy⟩ + +theorem inv_mem_fracSubring {x : L} (hx : x ∈ fracSubring S) : x⁻¹ ∈ fracSubring S := + Subfield.inv_mem _ hx + +/-- Divisibility inside `π ⁻¹ S`, unfolded to the ambient algebra. -/ +theorem dvd_residueSubring_iff {x y : residueSubring π S} : + x ∣ y ↔ ∃ z : A, π z ∈ S ∧ (y : A) = x * z := by + constructor + · rintro ⟨z, rfl⟩; exact ⟨z, z.2, rfl⟩ + · rintro ⟨z, hz, h⟩; exact ⟨⟨z, hz⟩, Subtype.ext h⟩ + +/-! ### Normalising a factor so that its residue is `0` or `1` -/ + +open scoped Classical in +/-- The scalar used to normalise `c`; always nonzero. -/ +noncomputable def scale (π : A →ₐ[L] L) (c : A) : L := if π c = 0 then 1 else π c + +theorem scale_ne_zero (π : A →ₐ[L] L) (c : A) : scale π c ≠ 0 := by + unfold scale; split <;> simp_all + +open scoped Classical in +theorem mem_scale_frac (π : A →ₐ[L] L) {c : A} (hc : π c ∈ fracSubring S) : + scale π c ∈ fracSubring S := by + unfold scale; split + · exact (fracSubring S).one_mem + · exact hc + +/-- `c` with its residue normalised to `0` or `1`. -/ +noncomputable def nrm (π : A →ₐ[L] L) (c : A) : A := c * algebraMap L A (scale π c)⁻¹ + +open scoped Classical in +theorem pi_nrm (π : A →ₐ[L] L) (c : A) : π (nrm π c) = if π c = 0 then 0 else 1 := by + unfold nrm scale + rw [map_mul, π.commutes] + split <;> simp_all + +open scoped Classical in +theorem pi_nrm_mem (π : A →ₐ[L] L) (c : A) : π (nrm π c) ∈ S := by + rw [pi_nrm]; split + · exact S.zero_mem + · exact S.one_mem + +theorem nrm_mul_scale (π : A →ₐ[L] L) (c : A) : + nrm π c * algebraMap L A (scale π c) = c := by + unfold nrm + rw [mul_assoc, ← map_mul, inv_mul_cancel₀ (scale_ne_zero π c), map_one, mul_one] + + + +/-! ### The residue map on `π ⁻¹ S` -/ + +/-- `π` restricted to `π ⁻¹ S`, as a ring map onto `S`. -/ +def residueHom (π : A →ₐ[L] L) (S : Subring L) : residueSubring π S →+* S where + toFun x := ⟨π x, x.2⟩ + map_one' := Subtype.ext (map_one π) + map_mul' _ _ := Subtype.ext (map_mul π _ _) + map_zero' := Subtype.ext (map_zero π) + map_add' _ _ := Subtype.ext (map_add π _ _) + +@[simp] theorem coe_residueHom (x : residueSubring π S) : ((residueHom π S x : S) : L) = π x := + (rfl) + +/-! ### Lemma 9.2.1, case `π b ≠ 0` -/ + +variable [IsDomain A] + +/-- Suppose `p` is nonzero, has image zero under `π`, and cannot be factored into two elements +whose images are both zero. If `p` is primal in `π ⁻¹ S`, then `L` is the fraction field of +`S`. -/ +@[blueprint "lem:primal-zero-residue-fraction-field" + (phase := "Algebraic and ordinal preliminaries") + (title := "A primal zero-residue element forces the fraction-field condition") + (statement := /-- + Let $L$ be a field, let $A$ be a domain and an $L$-algebra, and let + $\pi:A\to L$ be an $L$-algebra retraction. Let $S\subseteq L$ be a + subring. Suppose that $p\in A$ is nonzero, $\pi(p)=0$, and every + factorisation $p=ab$ has $\pi(a)\ne0$ or $\pi(b)\ne0$. If $p$ is + primal in $\pi^{-1}(S)$, then $L$ is the fraction field of $S$. + -/) + (proof := /-- + Fix $x\in L^\times$. In $\pi^{-1}(S)$, primality of $p$ applied to + \[ + (xp)(x^{-1}p)=p^2 + \] + gives a factorisation $p=p_1p_2$ with $p_1\mid xp$ and + $p_2\mid x^{-1}p$. At least one of $\pi(p_1)$ and $\pi(p_2)$ is + nonzero. Cancelling $p$ from the corresponding divisibility equation + expresses $x$ as a quotient of two nonzero residues of elements of + $\pi^{-1}(S)$. Both residues lie in $S$, so $x\in\operatorname{Frac}(S)$. + The case $x=0$ is immediate. + -/)] +theorem fracSubring_eq_top_of_isPrimal_of_residue_eq_zero + {p : A} (hpπ : π p = 0) (hp0 : p ≠ 0) + (hfactor : ∀ a b : A, p = a * b → π a ≠ 0 ∨ π b ≠ 0) + (hp : IsPrimal (⟨p, by simp [hpπ]⟩ : residueSubring π S)) : + fracSubring S = ⊤ := by + apply top_unique + intro x _ + rcases eq_or_ne x 0 with rfl | hx + · exact (fracSubring S).zero_mem + let P : residueSubring π S := ⟨p, by simp [hpπ]⟩ + let C : residueSubring π S := + ⟨algebraMap L A x * p, by + rw [mem_residueSubring, map_mul, AlgHom.commutes, hpπ, mul_zero] + exact S.zero_mem⟩ + let D : residueSubring π S := + ⟨algebraMap L A x⁻¹ * p, by + rw [mem_residueSubring, map_mul, AlgHom.commutes, hpπ, mul_zero] + exact S.zero_mem⟩ + have hdiv : P ∣ C * D := by + refine ⟨P, Subtype.ext ?_⟩ + change algebraMap L A x * p * (algebraMap L A x⁻¹ * p) = p * p + rw [show algebraMap L A x * p * (algebraMap L A x⁻¹ * p) = + algebraMap L A (x * x⁻¹) * (p * p) by rw [map_mul]; ring, + mul_inv_cancel₀ hx, map_one, one_mul] + obtain ⟨p₁, p₂, hp₁, hp₂, hprod⟩ := hp hdiv + have hprodA : p = (p₁ : A) * p₂ := congrArg Subtype.val hprod + rcases hfactor p₁ p₂ hprodA with hp₁res | hp₂res + · obtain ⟨q, hq⟩ := hp₂ + have hDA : algebraMap L A x⁻¹ * p = (p₂ : A) * q := congrArg Subtype.val hq + have hcancel : p * (algebraMap L A x⁻¹ * (p₁ : A)) = p * (q : A) := by + calc + p * (algebraMap L A x⁻¹ * (p₁ : A)) = + (p₁ : A) * (algebraMap L A x⁻¹ * p) := by ring + _ = (p₁ : A) * ((p₂ : A) * q) := by rw [hDA] + _ = p * q := by rw [hprodA]; ring + have hscalar : algebraMap L A x⁻¹ * (p₁ : A) = q := + mul_left_cancel₀ hp0 hcancel + have hres : x⁻¹ * π (p₁ : A) = π (q : A) := by + simpa using congrArg π hscalar + have hqres : π (q : A) ≠ 0 := by + rw [← hres] + exact mul_ne_zero (inv_ne_zero hx) hp₁res + have hratio : x = π (p₁ : A) * (π (q : A))⁻¹ := by rw [← hres]; field_simp + rw [hratio] + exact (fracSubring S).mul_mem (le_fracSubring p₁.2) + (inv_mem_fracSubring (le_fracSubring q.2)) + · obtain ⟨q, hq⟩ := hp₁ + have hCA : algebraMap L A x * p = (p₁ : A) * q := congrArg Subtype.val hq + have hcancel : p * (algebraMap L A x * (p₂ : A)) = p * (q : A) := by + calc + p * (algebraMap L A x * (p₂ : A)) = + (p₂ : A) * (algebraMap L A x * p) := by ring + _ = (p₂ : A) * ((p₁ : A) * q) := by rw [hCA] + _ = p * q := by rw [hprodA]; ring + have hscalar : algebraMap L A x * (p₂ : A) = q := + mul_left_cancel₀ hp0 hcancel + have hres : x * π (p₂ : A) = π (q : A) := by + simpa using congrArg π hscalar + have hratio : x = π (q : A) * (π (p₂ : A))⁻¹ := by rw [← hres]; field_simp + rw [hratio] + exact (fracSubring S).mul_mem (le_fracSubring q.2) + (inv_mem_fracSubring (le_fracSubring p₂.2)) + +/-- Suppose `p` maps to an irreducible element under `φ`, and every element whose image under +`φ` is a unit has nonzero image under `π`. If `p` has image zero under `π` and is primal in +`π ⁻¹ S`, then `L` is the fraction field of `S`. -/ +theorem fracSubring_eq_top_of_isPrimal_of_irreducible_map + {B : Type*} [CommRing B] (phi : A →+* B) {p : A} + (hpπ : π p = 0) (hpIrr : Irreducible (phi p)) + (hunit : ∀ a : A, IsUnit (phi a) → π a ≠ 0) + (hp : IsPrimal (⟨p, by simp [hpπ]⟩ : residueSubring π S)) : + fracSubring S = ⊤ := by + apply fracSubring_eq_top_of_isPrimal_of_residue_eq_zero hpπ + (fun hp0 ↦ hpIrr.ne_zero (by simp [hp0])) + · intro a b hab + have hmap : phi p = phi a * phi b := by simpa only [map_mul] using congrArg phi hab + rcases hpIrr.isUnit_or_isUnit hmap with ha | hb + · exact Or.inl (hunit a ha) + · exact Or.inr (hunit b hb) + · exact hp + +omit [IsDomain A] in +/-- Forward, first half: the residue of a primal element is primal in `S`. -/ +theorem isPrimal_residue_of_isPrimal {b : A} (hb : π b ∈ S) + (h : IsPrimal (⟨b, hb⟩ : residueSubring π S)) (hb0 : π b ≠ 0) : + IsPrimal (⟨π b, hb⟩ : S) := by + rintro ⟨c, hc⟩ ⟨d, hd⟩ ⟨⟨e, he⟩, hcd⟩ + have hcd' : c * d = π b * e := congrArg Subtype.val hcd + have hce : c * d * (π b)⁻¹ = e := by rw [hcd']; field_simp + set b' : A := b * algebraMap L A (π b)⁻¹ with hb' + have hpb' : π b' = 1 := by simp [hb', mul_inv_cancel₀ hb0] + have hmem1 : π (algebraMap L A c) ∈ S := by simpa using hc + have hmem2 : π (algebraMap L A d * b') ∈ S := by simpa [hpb'] using hd + have hmem3 : π (algebraMap L A e) ∈ S := by simpa using he + have key : (⟨b, hb⟩ : residueSubring π S) + ∣ ⟨algebraMap L A c, hmem1⟩ * ⟨algebraMap L A d * b', hmem2⟩ := by + refine ⟨⟨algebraMap L A e, hmem3⟩, Subtype.ext ?_⟩ + change algebraMap L A c * (algebraMap L A d * b') = b * algebraMap L A e + calc algebraMap L A c * (algebraMap L A d * b') + = algebraMap L A (c * d * (π b)⁻¹) * b := by rw [hb', map_mul, map_mul]; ring + _ = b * algebraMap L A e := by rw [hce]; ring + obtain ⟨b₁, b₂, h₁, h₂, hprod⟩ := h key + refine ⟨residueHom π S b₁, residueHom π S b₂, ?_, ?_, ?_⟩ + · simpa [residueHom, Subtype.ext_iff] using map_dvd (residueHom π S) h₁ + · simpa [residueHom, Subtype.ext_iff, hpb'] using map_dvd (residueHom π S) h₂ + · simpa [residueHom, Subtype.ext_iff] using congrArg (residueHom π S) hprod + +omit [IsDomain A] in +/-- Forward, second half: a primal element of `π ⁻¹ S` is primal in the ambient algebra. + +This is where the printed proof invokes primality in `π ⁻¹ S` at a product whose quotient can +have residue `1 / π b ∉ S`. Scaling one normalised factor by `π b` first repairs it. -/ +theorem isPrimal_of_isPrimal_residueSubring {b : A} (hb : π b ∈ S) + (h : IsPrimal (⟨b, hb⟩ : residueSubring π S)) (hb0 : π b ≠ 0) : + IsPrimal b := by + intro c d ⟨e, hcd⟩ + set σ : L := scale π c * scale π d with hσ + have hσ0 : σ ≠ 0 := mul_ne_zero (scale_ne_zero π c) (scale_ne_zero π d) + -- normalise both factors, then scale the first by `π b` + have hc : nrm π c * algebraMap L A (scale π c) = c := nrm_mul_scale π c + have hd : nrm π d * algebraMap L A (scale π d) = d := nrm_mul_scale π d + have hsplit : nrm π c * nrm π d = b * (e * algebraMap L A σ⁻¹) := by + have : (nrm π c * nrm π d) * algebraMap L A σ = c * d := by + rw [hσ, map_mul] + calc (nrm π c * nrm π d) + * (algebraMap L A (scale π c) * algebraMap L A (scale π d)) + = (nrm π c * algebraMap L A (scale π c)) + * (nrm π d * algebraMap L A (scale π d)) := by ring + _ = c * d := by rw [hc, hd] + calc nrm π c * nrm π d = (nrm π c * nrm π d) * algebraMap L A σ * algebraMap L A σ⁻¹ := by + rw [mul_assoc, ← map_mul, mul_inv_cancel₀ hσ0, map_one, mul_one] + _ = b * (e * algebraMap L A σ⁻¹) := by rw [this, hcd]; ring + set w : A := e * algebraMap L A (σ⁻¹ * π b) with hw + have hres : π w = π (nrm π c) * π (nrm π d) := by + have h2 := congrArg π hsplit + simp only [map_mul, AlgHom.commutes, Algebra.algebraMap_self, RingHom.id_apply] at h2 + rw [hw] + simp only [map_mul, AlgHom.commutes, Algebra.algebraMap_self, RingHom.id_apply] + rw [h2]; ring + have hmemc : π (nrm π c * algebraMap L A (π b)) ∈ S := by + rw [map_mul] + exact S.mul_mem (pi_nrm_mem π c) (by simpa using hb) + have hmemd : π (nrm π d) ∈ S := pi_nrm_mem π d + have hmemw : π w ∈ S := by rw [hres]; exact S.mul_mem (pi_nrm_mem π c) (pi_nrm_mem π d) + have key : (⟨b, hb⟩ : residueSubring π S) + ∣ ⟨nrm π c * algebraMap L A (π b), hmemc⟩ * ⟨nrm π d, hmemd⟩ := by + refine ⟨⟨w, hmemw⟩, Subtype.ext ?_⟩ + change nrm π c * algebraMap L A (π b) * nrm π d = b * w + calc nrm π c * algebraMap L A (π b) * nrm π d + = (nrm π c * nrm π d) * algebraMap L A (π b) := by ring + _ = (b * (e * algebraMap L A σ⁻¹)) * algebraMap L A (π b) := by rw [hsplit] + _ = b * (e * algebraMap L A (σ⁻¹ * π b)) := by rw [map_mul]; ring + _ = b * w := by rw [hw] + obtain ⟨b₁, b₂, h₁, h₂, hprod⟩ := h key + refine ⟨(b₁ : A), (b₂ : A), ?_, ?_, ?_⟩ + · obtain ⟨u, hu⟩ := h₁ + refine ⟨(u : A) * algebraMap L A (scale π c * (π b)⁻¹), ?_⟩ + have hu' : nrm π c * algebraMap L A (π b) = (b₁ : A) * u := congrArg Subtype.val hu + calc c = nrm π c * algebraMap L A (scale π c) := hc.symm + _ = (nrm π c * algebraMap L A (π b)) * algebraMap L A (scale π c * (π b)⁻¹) := by + rw [map_mul] + calc nrm π c * algebraMap L A (scale π c) + = nrm π c * algebraMap L A (scale π c) * algebraMap L A (π b * (π b)⁻¹) := by + rw [mul_inv_cancel₀ hb0, map_one, mul_one] + _ = nrm π c * algebraMap L A (π b) + * (algebraMap L A (scale π c) * algebraMap L A (π b)⁻¹) := by + rw [map_mul]; ring + _ = (b₁ : A) * ((u : A) * algebraMap L A (scale π c * (π b)⁻¹)) := by rw [hu']; ring + · obtain ⟨u, hu⟩ := h₂ + refine ⟨(u : A) * algebraMap L A (scale π d), ?_⟩ + have hu' : nrm π d = (b₂ : A) * u := congrArg Subtype.val hu + calc d = nrm π d * algebraMap L A (scale π d) := hd.symm + _ = (b₂ : A) * ((u : A) * algebraMap L A (scale π d)) := by rw [hu']; ring + · exact congrArg Subtype.val hprod + +/-- Converse, case `π b ≠ 0`: primal residue plus primal in the ambient algebra gives primal +in `π ⁻¹ S`. The rescaling parameter `η` must be a nonzero element of `L`; it need not lie in +`S`. -/ +theorem isPrimal_residueSubring_of_isPrimal {b : A} (hb : π b ∈ S) (hb0 : π b ≠ 0) + (hS : IsPrimal (⟨π b, hb⟩ : S)) (hA : IsPrimal b) : + IsPrimal (⟨b, hb⟩ : residueSubring π S) := by + have hbne : b ≠ 0 := fun h ↦ hb0 (by rw [h, map_zero]) + rintro c d ⟨e, hcde⟩ + have hcd : (c : A) * d = b * e := congrArg Subtype.val hcde + obtain ⟨b₁, b₂, ⟨f, hf⟩, ⟨g, hg⟩, hprod⟩ := hA (Dvd.intro _ hcd.symm) + -- cancellation, available because `A` is a domain and `b ≠ 0` + have hefg : (e : A) = f * g := by + have : b * (e : A) = b * (f * g) := by rw [← hcd, hf, hg, hprod]; ring + exact mul_left_cancel₀ hbne this + have hpb : π b = π b₁ * π b₂ := by rw [hprod, map_mul] + have hb₁0 : π b₁ ≠ 0 := fun h ↦ hb0 (by rw [hpb, h, zero_mul]) + have hb₂0 : π b₂ ≠ 0 := fun h ↦ hb0 (by rw [hpb, h, mul_zero]) + -- factor the residue in `S` + have hdvdS : (⟨π b, hb⟩ : S) ∣ (⟨π c, c.2⟩ : S) * ⟨π d, d.2⟩ := by + refine ⟨⟨π e, e.2⟩, Subtype.ext ?_⟩ + change π c * π d = π b * π e + rw [← map_mul, ← map_mul, hcd] + obtain ⟨⟨b₁', hb₁'⟩, ⟨b₂', hb₂'⟩, ⟨⟨s, hs⟩, hsc⟩, ⟨⟨u, hu⟩, huc⟩, hprod'⟩ := hS hdvdS + have hbb : π b = b₁' * b₂' := congrArg Subtype.val hprod' + have hcs : π c = b₁' * s := congrArg Subtype.val hsc + have hdu : π d = b₂' * u := congrArg Subtype.val huc + have hb₁'0 : b₁' ≠ 0 := fun h ↦ hb0 (by rw [hbb, h, zero_mul]) + have hb₂'0 : b₂' ≠ 0 := fun h ↦ hb0 (by rw [hbb, h, mul_zero]) + set η : L := π b₁ * b₁'⁻¹ with hη + have hη0 : η ≠ 0 := mul_ne_zero hb₁0 (inv_ne_zero hb₁'0) + -- the four rescaled factors and their residues + have e₁ : π (b₁ * algebraMap L A η⁻¹) = b₁' := by + simp only [map_mul, AlgHom.commutes, Algebra.algebraMap_self, RingHom.id_apply, hη] + field_simp + have e₂ : π (b₂ * algebraMap L A η) = b₂' := by + simp only [map_mul, AlgHom.commutes, Algebra.algebraMap_self, RingHom.id_apply, hη] + have : π b₂ * (π b₁ * b₁'⁻¹) = (π b₁ * π b₂) * b₁'⁻¹ := by ring + rw [this, ← hpb, hbb]; field_simp + have e₃ : π (f * algebraMap L A η) = s := by + have hpc : π c = π b₁ * π f := by rw [hf, map_mul] + simp only [map_mul, AlgHom.commutes, Algebra.algebraMap_self, RingHom.id_apply, hη] + have : π f * (π b₁ * b₁'⁻¹) = (π b₁ * π f) * b₁'⁻¹ := by ring + rw [this, ← hpc, hcs]; field_simp + have hηinv : η⁻¹ = b₁' * (π b₁)⁻¹ := by rw [hη]; field_simp + have e₄ : π (g * algebraMap L A η⁻¹) = u := by + have hpd : π b₂ * π g = π d := by rw [hg, map_mul] + simp only [map_mul, AlgHom.commutes, Algebra.algebraMap_self, RingHom.id_apply, hηinv] + apply mul_right_cancel₀ (mul_ne_zero hb₁0 hb₂0) + have h5 : π g * (b₁' * (π b₁)⁻¹) * (π b₁ * π b₂) = (π b₂ * π g) * b₁' := by + field_simp + rw [h5, hpd, hdu, show u * (π b₁ * π b₂) = u * π b by rw [hpb], hbb] + ring + refine ⟨⟨b₁ * algebraMap L A η⁻¹, mem_residueSubring.mpr (by rw [e₁]; exact hb₁')⟩, + ⟨b₂ * algebraMap L A η, mem_residueSubring.mpr (by rw [e₂]; exact hb₂')⟩, ?_, ?_, ?_⟩ + · exact ⟨⟨f * algebraMap L A η, mem_residueSubring.mpr (by rw [e₃]; exact hs)⟩, Subtype.ext (by + change (c : A) = b₁ * algebraMap L A η⁻¹ * (f * algebraMap L A η) + rw [hf, show b₁ * algebraMap L A η⁻¹ * (f * algebraMap L A η) + = b₁ * f * (algebraMap L A η⁻¹ * algebraMap L A η) by ring, ← map_mul, + inv_mul_cancel₀ hη0, map_one, mul_one])⟩ + · exact ⟨⟨g * algebraMap L A η⁻¹, mem_residueSubring.mpr (by rw [e₄]; exact hu)⟩, Subtype.ext (by + change (d : A) = b₂ * algebraMap L A η * (g * algebraMap L A η⁻¹) + rw [hg, show b₂ * algebraMap L A η * (g * algebraMap L A η⁻¹) + = b₂ * g * (algebraMap L A η * algebraMap L A η⁻¹) by ring, ← map_mul, + mul_inv_cancel₀ hη0, map_one, mul_one])⟩ + · refine Subtype.ext ?_ + change b = b₁ * algebraMap L A η⁻¹ * (b₂ * algebraMap L A η) + rw [hprod, show b₁ * algebraMap L A η⁻¹ * (b₂ * algebraMap L A η) + = b₁ * b₂ * (algebraMap L A η⁻¹ * algebraMap L A η) by ring, ← map_mul, + inv_mul_cancel₀ hη0, map_one, mul_one] + +/-! ### Lemma 9.2.1, case `π b = 0` -/ + +omit [IsDomain A] in +/-- Forward, case `π b = 0`. The printed proof invokes primality in `π ⁻¹ S` at a product whose +quotient can have residue anywhere in `Frac S`; clearing a denominator first repairs it. Since a +normalised residue is `0` or `1`, the denominator may be attached to either factor. -/ +theorem isPrimal_fracSubring_of_isPrimal_residueSubring {b : A} (hb : π b ∈ S) + (h : IsPrimal (⟨b, hb⟩ : residueSubring π S)) : + IsPrimal (⟨b, le_fracSubring hb⟩ : residueSubring π (fracSubring S)) := by + rintro c d ⟨e, hcde⟩ + have hcd : (c : A) * d = b * e := congrArg Subtype.val hcde + set σ : L := scale π c * scale π d with hσ + have hσ0 : σ ≠ 0 := mul_ne_zero (scale_ne_zero π (c : A)) (scale_ne_zero π (d : A)) + have hc : nrm π (c : A) * algebraMap L A (scale π (c : A)) = (c : A) := nrm_mul_scale π _ + have hd : nrm π (d : A) * algebraMap L A (scale π (d : A)) = (d : A) := nrm_mul_scale π _ + have hsplit : nrm π (c : A) * nrm π (d : A) = b * ((e : A) * algebraMap L A σ⁻¹) := by + have h1 : (nrm π (c : A) * nrm π (d : A)) * algebraMap L A σ = (c : A) * d := by + rw [hσ, map_mul] + calc (nrm π (c : A) * nrm π (d : A)) + * (algebraMap L A (scale π (c : A)) * algebraMap L A (scale π (d : A))) + = (nrm π (c : A) * algebraMap L A (scale π (c : A))) + * (nrm π (d : A) * algebraMap L A (scale π (d : A))) := by ring + _ = (c : A) * d := by rw [hc, hd] + calc nrm π (c : A) * nrm π (d : A) + = (nrm π (c : A) * nrm π (d : A)) * algebraMap L A σ * algebraMap L A σ⁻¹ := by + rw [mul_assoc, ← map_mul, mul_inv_cancel₀ hσ0, map_one, mul_one] + _ = b * ((e : A) * algebraMap L A σ⁻¹) := by rw [h1, hcd]; ring + -- the quotient's residue lies in `Frac S`; clear its denominator + set w : A := (e : A) * algebraMap L A σ⁻¹ with hw + have hwF : π w ∈ fracSubring S := by + rw [hw, map_mul, AlgHom.commutes] + exact (fracSubring S).mul_mem e.2 + (inv_mem_fracSubring (mul_mem (mem_scale_frac π c.2) (mem_scale_frac π d.2))) + obtain ⟨s, hs, hs0, hsw⟩ := exists_den hwF + have hmemc : π (nrm π (c : A) * algebraMap L A s) ∈ S := by + rw [map_mul, AlgHom.commutes] + exact S.mul_mem (pi_nrm_mem π _) hs + have hmemd : π (nrm π (d : A)) ∈ S := pi_nrm_mem π _ + have hmemw : π (w * algebraMap L A s) ∈ S := by + rw [map_mul, AlgHom.commutes, mul_comm]; exact hsw + have key : (⟨b, hb⟩ : residueSubring π S) + ∣ ⟨nrm π (c : A) * algebraMap L A s, hmemc⟩ * ⟨nrm π (d : A), hmemd⟩ := by + refine ⟨⟨w * algebraMap L A s, hmemw⟩, Subtype.ext ?_⟩ + change nrm π (c : A) * algebraMap L A s * nrm π (d : A) = b * (w * algebraMap L A s) + calc nrm π (c : A) * algebraMap L A s * nrm π (d : A) + = (nrm π (c : A) * nrm π (d : A)) * algebraMap L A s := by ring + _ = (b * w) * algebraMap L A s := by rw [hsplit, hw] + _ = b * (w * algebraMap L A s) := by ring + obtain ⟨b₁, b₂, ⟨v, hv⟩, ⟨u, hu⟩, hprod⟩ := h key + have hv' : nrm π (c : A) * algebraMap L A s = (b₁ : A) * v := congrArg Subtype.val hv + have hu' : nrm π (d : A) = (b₂ : A) * u := congrArg Subtype.val hu + refine ⟨⟨(b₁ : A), le_fracSubring b₁.2⟩, ⟨(b₂ : A), le_fracSubring b₂.2⟩, ?_, ?_, ?_⟩ + · refine ⟨⟨(v : A) * algebraMap L A (s⁻¹ * scale π (c : A)), ?_⟩, Subtype.ext ?_⟩ + · rw [mem_residueSubring, map_mul, AlgHom.commutes] + exact (fracSubring S).mul_mem (le_fracSubring v.2) + ((fracSubring S).mul_mem + (inv_mem_fracSubring (le_fracSubring hs)) (mem_scale_frac π c.2)) + · change (c : A) = (b₁ : A) * ((v : A) * algebraMap L A (s⁻¹ * scale π (c : A))) + have hs' : algebraMap L A s * algebraMap L A s⁻¹ = 1 := by + rw [← map_mul, mul_inv_cancel₀ hs0, map_one] + calc (c : A) = nrm π (c : A) * algebraMap L A (scale π (c : A)) := hc.symm + _ = (nrm π (c : A) * algebraMap L A s) + * (algebraMap L A s⁻¹ * algebraMap L A (scale π (c : A))) := by + rw [show nrm π (c : A) * algebraMap L A s + * (algebraMap L A s⁻¹ * algebraMap L A (scale π (c : A))) + = nrm π (c : A) * algebraMap L A (scale π (c : A)) + * (algebraMap L A s * algebraMap L A s⁻¹) by ring, hs', mul_one] + _ = (b₁ : A) * ((v : A) * algebraMap L A (s⁻¹ * scale π (c : A))) := by + rw [hv', map_mul]; ring + · refine ⟨⟨(u : A) * algebraMap L A (scale π (d : A)), ?_⟩, Subtype.ext ?_⟩ + · rw [mem_residueSubring, map_mul, AlgHom.commutes] + exact (fracSubring S).mul_mem (le_fracSubring u.2) (mem_scale_frac π d.2) + · change (d : A) = (b₂ : A) * ((u : A) * algebraMap L A (scale π (d : A))) + calc (d : A) = nrm π (d : A) * algebraMap L A (scale π (d : A)) := hd.symm + _ = (b₂ : A) * ((u : A) * algebraMap L A (scale π (d : A))) := by rw [hu']; ring + · refine Subtype.ext ?_ + change b = (b₁ : A) * (b₂ : A) + simpa using congrArg Subtype.val hprod + +omit [IsDomain A] in +/-- The rescaling step of the converse at `π b = 0`, in the orientation where the first factor +has zero residue. The paper takes this orientation "without loss of generality"; isolating it +lets both orientations be discharged by the same argument. Here `η` must be a nonzero element +of `Frac S`. -/ +private theorem eta_rescale {b c d e : A} (hb : π b ∈ S) (hc : π c ∈ S) (hd : π d ∈ S) + (he : π e ∈ S) {b₁ b₂ f g : A} + (hb₂F : π b₂ ∈ fracSubring S) (hfF : π f ∈ fracSubring S) + (hprod : b = b₁ * b₂) (hcf : c = b₁ * f) (hdg : d = b₂ * g) (hefg : e = f * g) + (h₁0 : π b₁ = 0) : + ∃ B₁ B₂ : residueSubring π S, B₁ ∣ (⟨c, hc⟩ : residueSubring π S) ∧ + B₂ ∣ (⟨d, hd⟩ : residueSubring π S) ∧ (⟨b, hb⟩ : residueSubring π S) = B₁ * B₂ := by + obtain ⟨η, hη0, hηb₂, hηf, hηg⟩ : + ∃ η : L, η ≠ 0 ∧ η * π b₂ ∈ S ∧ η * π f ∈ S ∧ π g * η⁻¹ ∈ S := by + rcases eq_or_ne (π g) 0 with hg0 | hg0 + · obtain ⟨s₁, hs₁, hs₁0, hs₁b⟩ := exists_den hb₂F + obtain ⟨s₂, hs₂, hs₂0, hs₂f⟩ := exists_den hfF + refine ⟨s₁ * s₂, mul_ne_zero hs₁0 hs₂0, ?_, ?_, ?_⟩ + · rw [show s₁ * s₂ * π b₂ = s₂ * (s₁ * π b₂) by ring]; exact S.mul_mem hs₂ hs₁b + · rw [show s₁ * s₂ * π f = s₁ * (s₂ * π f) by ring]; exact S.mul_mem hs₁ hs₂f + · rw [hg0, zero_mul]; exact S.zero_mem + · refine ⟨π g, hg0, ?_, ?_, ?_⟩ + · rw [mul_comm, ← map_mul, ← hdg]; exact hd + · rw [mul_comm, ← map_mul, ← hefg]; exact he + · rw [mul_inv_cancel₀ hg0]; exact S.one_mem + have hinv : algebraMap L A η⁻¹ * algebraMap L A η = 1 := by + rw [← map_mul, inv_mul_cancel₀ hη0, map_one] + have hinv' : algebraMap L A η * algebraMap L A η⁻¹ = 1 := by rw [mul_comm]; exact hinv + refine ⟨⟨b₁ * algebraMap L A η⁻¹, ?_⟩, ⟨b₂ * algebraMap L A η, ?_⟩, ?_, ?_, ?_⟩ + · rw [mem_residueSubring, map_mul, AlgHom.commutes, h₁0, zero_mul]; exact S.zero_mem + · rw [mem_residueSubring, map_mul, AlgHom.commutes, mul_comm]; exact hηb₂ + · refine ⟨⟨f * algebraMap L A η, ?_⟩, Subtype.ext ?_⟩ + · rw [mem_residueSubring, map_mul, AlgHom.commutes, mul_comm]; exact hηf + · change c = b₁ * algebraMap L A η⁻¹ * (f * algebraMap L A η) + rw [hcf, show b₁ * algebraMap L A η⁻¹ * (f * algebraMap L A η) + = b₁ * f * (algebraMap L A η⁻¹ * algebraMap L A η) by ring, hinv, mul_one] + · refine ⟨⟨g * algebraMap L A η⁻¹, ?_⟩, Subtype.ext ?_⟩ + · rw [mem_residueSubring, map_mul, AlgHom.commutes]; exact hηg + · change d = b₂ * algebraMap L A η * (g * algebraMap L A η⁻¹) + rw [hdg, show b₂ * algebraMap L A η * (g * algebraMap L A η⁻¹) + = b₂ * g * (algebraMap L A η * algebraMap L A η⁻¹) by ring, hinv', mul_one] + · refine Subtype.ext ?_ + change b = b₁ * algebraMap L A η⁻¹ * (b₂ * algebraMap L A η) + rw [hprod, show b₁ * algebraMap L A η⁻¹ * (b₂ * algebraMap L A η) + = b₁ * b₂ * (algebraMap L A η⁻¹ * algebraMap L A η) by ring, hinv, mul_one] + +/-- Converse, case `π b = 0`. -/ +theorem isPrimal_residueSubring_of_isPrimal_pre_fracSubring {b : A} (hb : π b ∈ S) (hb0 : π b = 0) + (h : IsPrimal (⟨b, le_fracSubring hb⟩ : residueSubring π (fracSubring S))) : + IsPrimal (⟨b, hb⟩ : residueSubring π S) := by + rcases eq_or_ne b 0 with rfl | hbne + · have hz : (⟨(0 : A), hb⟩ : residueSubring π S) = 0 := rfl + rw [hz]; exact isPrimal_zero + rintro c d ⟨e, hcde⟩ + have hcd : (c : A) * d = b * e := congrArg Subtype.val hcde + have hdvdF : (⟨b, le_fracSubring hb⟩ : residueSubring π (fracSubring S)) + ∣ ⟨(c : A), le_fracSubring c.2⟩ * ⟨(d : A), le_fracSubring d.2⟩ := + ⟨⟨(e : A), le_fracSubring e.2⟩, Subtype.ext hcd⟩ + obtain ⟨b₁, b₂, ⟨f, hf⟩, ⟨g, hg⟩, hprod⟩ := h hdvdF + have hprod' : b = (b₁ : A) * b₂ := congrArg Subtype.val hprod + have hcf : (c : A) = (b₁ : A) * f := congrArg Subtype.val hf + have hdg : (d : A) = (b₂ : A) * g := congrArg Subtype.val hg + have hefg : (e : A) = (f : A) * g := by + have h6 : b * (e : A) = b * ((f : A) * g) := by rw [← hcd, hcf, hdg, hprod']; ring + exact mul_left_cancel₀ hbne h6 + have hzero : π (b₁ : A) = 0 ∨ π (b₂ : A) = 0 := + mul_eq_zero.mp (by rw [← map_mul, ← hprod']; exact hb0) + rcases hzero with h1 | h2 + · exact eta_rescale hb c.2 d.2 e.2 b₂.2 f.2 hprod' hcf hdg hefg h1 + · obtain ⟨B₁, B₂, hd1, hd2, hp⟩ := + eta_rescale hb d.2 c.2 e.2 b₁.2 g.2 (by rw [hprod']; ring) hdg hcf + (by rw [hefg]; ring) h2 + exact ⟨B₂, B₁, hd2, hd1, by rw [hp]; ring⟩ + +/-! ### Lemma 9.2.1 -/ + +/-- LM24, Lemma 9.2.1, with the repairs its errata require: `A` must be a domain, and the two +left-to-right steps must clear a denominator before primality in `π ⁻¹ S` is invoked. -/ +theorem isPrimal_residueSubring_iff {b : A} (hb : π b ∈ S) : + IsPrimal (⟨b, hb⟩ : residueSubring π S) ↔ + (π b ≠ 0 ∧ IsPrimal (⟨π b, hb⟩ : S) ∧ IsPrimal b) ∨ + (π b = 0 ∧ IsPrimal (⟨b, le_fracSubring hb⟩ : residueSubring π (fracSubring S))) := by + rcases eq_or_ne (π b) 0 with h0 | h0 + · simp only [h0, ne_eq, not_true_eq_false, false_and, false_or, true_and] + exact ⟨isPrimal_fracSubring_of_isPrimal_residueSubring hb, + isPrimal_residueSubring_of_isPrimal_pre_fracSubring hb h0⟩ + · constructor + · exact fun h ↦ Or.inl + ⟨h0, isPrimal_residue_of_isPrimal hb h h0, isPrimal_of_isPrimal_residueSubring hb h h0⟩ + · rintro (⟨-, hS, hA⟩ | ⟨h, -⟩) + · exact isPrimal_residueSubring_of_isPrimal hb h0 hS hA + · exact absurd h h0 + +omit [IsDomain A] in +/-- An exact ambient four-factor refinement whose first input has nonzero residue can be +rescaled into the residue subring, provided that residue is primal. Only this one ambient +refinement and this one primal residue are required. -/ +theorem exists_refinement_residueSubring_of_ambient_of_residue_ne_zero + {a b c d : residueSubring π S} + (haS : IsPrimal (⟨π (a : A), a.2⟩ : S)) (haπ : π (a : A) ≠ 0) + (habcd : a * b = c * d) + {e f g h : A} + (ha : (a : A) = e * f) (hb : (b : A) = g * h) + (hc : (c : A) = e * g) (hd : (d : A) = f * h) : + ∃ E F G H : residueSubring π S, + a = E * F ∧ b = G * H ∧ c = E * G ∧ d = F * H := by + have habcdS : + (⟨π (a : A), a.2⟩ : S) * ⟨π (b : A), b.2⟩ = + ⟨π (c : A), c.2⟩ * ⟨π (d : A), d.2⟩ := by + apply Subtype.ext + change π (a : A) * π (b : A) = π (c : A) * π (d : A) + rw [← map_mul, ← map_mul] + exact congrArg π (congrArg Subtype.val habcd) + have haS0 : (⟨π (a : A), a.2⟩ : S) ≠ 0 := by + intro hzero + apply haπ + exact congrArg Subtype.val hzero + obtain ⟨e₀, f₀, g₀, h₀, ha₀, hb₀, hc₀, hd₀⟩ := + exists_fourFactorRefinement_of_isPrimal haS0 haS habcdS + have ha₀' : π (a : A) = (e₀ : L) * f₀ := congrArg Subtype.val ha₀ + have hc₀' : π (c : A) = (e₀ : L) * g₀ := congrArg Subtype.val hc₀ + have hd₀' : π (d : A) = (f₀ : L) * h₀ := congrArg Subtype.val hd₀ + have he0 : π e ≠ 0 := by + intro he + apply haπ + rw [ha, map_mul, he, zero_mul] + have hf0 : π f ≠ 0 := by + intro hf + apply haπ + rw [ha, map_mul, hf, mul_zero] + have he₀0 : (e₀ : L) ≠ 0 := by + intro he₀ + apply haπ + rw [ha₀', he₀, zero_mul] + have hf₀0 : (f₀ : L) ≠ 0 := by + intro hf₀ + apply haπ + rw [ha₀', hf₀, mul_zero] + let η : L := π e * (e₀ : L)⁻¹ + have hη0 : η ≠ 0 := mul_ne_zero he0 (inv_ne_zero he₀0) + have hE : π (e * algebraMap L A η⁻¹) = e₀ := by + simp only [map_mul, AlgHom.commutes, Algebra.algebraMap_self, RingHom.id_apply] + dsimp only [η] + field_simp + have hF : π (f * algebraMap L A η) = f₀ := by + simp only [map_mul, AlgHom.commutes, Algebra.algebraMap_self, RingHom.id_apply] + dsimp only [η] + have hae : π (a : A) = π e * π f := by rw [ha, map_mul] + calc + π f * (π e * (e₀ : L)⁻¹) = (π e * π f) * (e₀ : L)⁻¹ := by ring + _ = π (a : A) * (e₀ : L)⁻¹ := by rw [hae] + _ = (e₀ : L) * f₀ * (e₀ : L)⁻¹ := by rw [ha₀'] + _ = f₀ := by field_simp + have hG : π (g * algebraMap L A η) = g₀ := by + simp only [map_mul, AlgHom.commutes, Algebra.algebraMap_self, RingHom.id_apply] + dsimp only [η] + have hce : π (c : A) = π e * π g := by rw [hc, map_mul] + rw [show π g * (π e * (e₀ : L)⁻¹) = (π e * π g) * (e₀ : L)⁻¹ by ring, + ← hce, hc₀'] + field_simp + have hH : π (h * algebraMap L A η⁻¹) = h₀ := by + simp only [map_mul, AlgHom.commutes, Algebra.algebraMap_self, RingHom.id_apply] + have hFscalar : π f * η = (f₀ : L) := by simpa using hF + have hdh : π (d : A) = π f * π h := by rw [hd, map_mul] + apply mul_left_cancel₀ hf₀0 + calc + (f₀ : L) * (π h * η⁻¹) = (π f * η) * (π h * η⁻¹) := by rw [hFscalar] + _ = π f * π h := by field_simp + _ = π (d : A) := hdh.symm + _ = (f₀ : L) * h₀ := hd₀' + refine ⟨⟨e * algebraMap L A η⁻¹, mem_residueSubring.mpr (by rw [hE]; exact e₀.2)⟩, + ⟨f * algebraMap L A η, mem_residueSubring.mpr (by rw [hF]; exact f₀.2)⟩, + ⟨g * algebraMap L A η, mem_residueSubring.mpr (by rw [hG]; exact g₀.2)⟩, + ⟨h * algebraMap L A η⁻¹, mem_residueSubring.mpr (by rw [hH]; exact h₀.2)⟩, + ?_, ?_, ?_, ?_⟩ + all_goals + apply Subtype.ext + simp only [Subring.coe_mul] + · rw [ha] + rw [show (e * algebraMap L A η⁻¹) * (f * algebraMap L A η) = + e * f * (algebraMap L A η⁻¹ * algebraMap L A η) by ring, + ← map_mul, inv_mul_cancel₀ hη0, map_one, mul_one] + · rw [hb] + rw [show (g * algebraMap L A η) * (h * algebraMap L A η⁻¹) = + g * h * (algebraMap L A η * algebraMap L A η⁻¹) by ring, + ← map_mul, mul_inv_cancel₀ hη0, map_one, mul_one] + · rw [hc] + rw [show (e * algebraMap L A η⁻¹) * (g * algebraMap L A η) = + e * g * (algebraMap L A η⁻¹ * algebraMap L A η) by ring, + ← map_mul, inv_mul_cancel₀ hη0, map_one, mul_one] + · rw [hd] + rw [show (f * algebraMap L A η) * (h * algebraMap L A η⁻¹) = + f * h * (algebraMap L A η * algebraMap L A η⁻¹) by ring, + ← map_mul, mul_inv_cancel₀ hη0, map_one, mul_one] + +/-- A nonzero exact ambient four-factor refinement can be rescaled into the residue subring when +the first residue is primal and that subring generates the coefficient field. This is the +equation-local form needed after an exact germ refinement; no global refinement property of the +residue ring is assumed. -/ +theorem exists_refinement_residueSubring_of_ambient + {a b c d : residueSubring π S} + (haS : IsPrimal (⟨π (a : A), a.2⟩ : S)) (hfrac : fracSubring S = ⊤) + (ha0 : a ≠ 0) (habcd : a * b = c * d) + {e f g h : A} + (ha : (a : A) = e * f) (hb : (b : A) = g * h) + (hc : (c : A) = e * g) (hd : (d : A) = f * h) : + ∃ E F G H : residueSubring π S, + a = E * F ∧ b = G * H ∧ c = E * G ∧ d = F * H := by + by_cases haπ : π (a : A) = 0 + · have haA0 : (a : A) ≠ 0 := fun h ↦ ha0 (Subtype.ext h) + have hef0 : π e = 0 ∨ π f = 0 := by + apply mul_eq_zero.mp + rw [← map_mul, ← ha] + exact haπ + rcases hef0 with he0 | hf0 + · obtain ⟨E, F, hEc, hFd, haEF⟩ := eta_rescale a.2 c.2 d.2 b.2 + (by rw [hfrac]; exact Subring.mem_top _) + (by rw [hfrac]; exact Subring.mem_top _) + ha hc hd hb he0 + obtain ⟨G, hcEG⟩ := hEc + obtain ⟨H, hdFH⟩ := hFd + refine ⟨E, F, G, H, haEF, ?_, hcEG, hdFH⟩ + apply Subtype.ext + apply mul_left_cancel₀ haA0 + change (a : A) * (b : A) = (a : A) * ((G : A) * H) + have habcd' := congrArg Subtype.val habcd + have hcEG' := congrArg Subtype.val hcEG + have hdFH' := congrArg Subtype.val hdFH + have haEF' := congrArg Subtype.val haEF + simp only [Subring.coe_mul] at habcd' hcEG' hdFH' haEF' + rw [habcd', hcEG', hdFH', haEF'] + ring + · obtain ⟨F, E, hFd, hEc, haFE⟩ := eta_rescale a.2 d.2 c.2 b.2 + (by rw [hfrac]; exact Subring.mem_top _) + (by rw [hfrac]; exact Subring.mem_top _) + (by rw [ha]; ring) hd hc (by rw [hb]; ring) hf0 + obtain ⟨H, hdFH⟩ := hFd + obtain ⟨G, hcEG⟩ := hEc + refine ⟨E, F, G, H, ?_, ?_, hcEG, hdFH⟩ + · exact haFE.trans (mul_comm F E) + · apply Subtype.ext + apply mul_left_cancel₀ haA0 + change (a : A) * (b : A) = (a : A) * ((G : A) * H) + have habcd' := congrArg Subtype.val habcd + have hcEG' := congrArg Subtype.val hcEG + have hdFH' := congrArg Subtype.val hdFH + have haFE' := congrArg Subtype.val haFE + simp only [Subring.coe_mul] at habcd' hcEG' hdFH' haFE' + rw [habcd', hcEG', hdFH', haFE'] + ring + · exact exists_refinement_residueSubring_of_ambient_of_residue_ne_zero + haS haπ habcd ha hb hc hd + +/-- A nonzero element of a residue subring is primal when its residue is primal, the coefficient +subring generates the whole coefficient field, and the element is primal in the ambient algebra. +This equation-local form avoids assuming refinement for every ambient element. -/ +theorem isPrimal_residueSubring_of_isPrimal_ambient + {b : residueSubring π S} (hb0 : b ≠ 0) + (hbS : IsPrimal (⟨π (b : A), b.2⟩ : S)) (hfrac : fracSubring S = ⊤) + (hbA : IsPrimal (b : A)) : IsPrimal b := by + intro c d hdvd + obtain ⟨q, hq⟩ := hdvd + have hprod : b * q = c * d := hq.symm + obtain ⟨e, f, g, h, hb, hq, hc, hd⟩ := + exists_fourFactorRefinement_of_isPrimal + (fun hzero ↦ hb0 (Subtype.ext hzero)) hbA (congrArg Subtype.val hprod) + obtain ⟨E, F, G, H, hb', -, hc', hd'⟩ := + exists_refinement_residueSubring_of_ambient hbS hfrac hb0 hprod hb hq hc hd + exact ⟨E, F, ⟨G, hc'⟩, ⟨H, hd'⟩, hb'⟩ + +/-- Four-factor refinement ascends from the ambient algebra and the residue subring when the +residue subring generates the whole coefficient field. The zero-residue branch uses ambient +refinement after identifying the enlarged residue pullback with the ambient algebra. -/ +theorem hasFourFactorRefinement_residueSubring + (hA : HasFourFactorRefinement A) (hS : HasFourFactorRefinement S) + (hfrac : fracSubring S = ⊤) : + HasFourFactorRefinement (residueSubring π S) := by + rw [hasFourFactorRefinement_iff_forall_isPrimal] + intro b + rw [isPrimal_residueSubring_iff b.2] + by_cases hb : π b = 0 + · right + refine ⟨hb, ?_⟩ + let b' : residueSubring π (fracSubring S) := ⟨b, le_fracSubring b.2⟩ + let e : residueSubring π (fracSubring S) ≃+* A := { + toFun x := x + invFun x := ⟨x, by rw [mem_residueSubring, hfrac]; exact Subring.mem_top _⟩ + left_inv _ := rfl + right_inv _ := rfl + map_mul' _ _ := rfl + map_add' _ _ := rfl } + apply (e.isPrimal_iff b').mp + change IsPrimal (b : A) + exact hA.isPrimal (b : A) + · left + exact ⟨hb, hS.isPrimal _, hA.isPrimal b⟩ + +end Subring diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Divisibility/PrimalProduct.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Divisibility/PrimalProduct.lean new file mode 100644 index 0000000000..8de122ed78 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Divisibility/PrimalProduct.lean @@ -0,0 +1,32 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import Mathlib.Algebra.GroupWithZero.Divisibility +public import Mathlib.Algebra.BigOperators.Group.List.Basic + +/-! +# Finite products of primal elements + +Mathlib records that a unit is primal and that the product of two primal elements of a +cancellative commutative monoid with zero is primal. This file iterates the binary statement to +finite products indexed by a list. +-/ + +universe u + +public section + +/-- A product of primal elements over a list is primal. -/ +theorem isPrimal_list_prod {M : Type u} [CommMonoidWithZero M] [IsCancelMulZero M] + {l : List M} (hl : ∀ c ∈ l, IsPrimal c) : IsPrimal l.prod := by + induction l with + | nil => simpa using isUnit_one.isPrimal + | cons c cs ih => + rw [List.prod_cons] + exact (hl c List.mem_cons_self).mul (ih fun d hd ↦ hl d (List.mem_cons_of_mem c hd)) + +end diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Divisibility/Refinement.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Divisibility/Refinement.lean new file mode 100644 index 0000000000..d70f691146 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Divisibility/Refinement.lean @@ -0,0 +1,221 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import Mathlib.Algebra.Divisibility.Basic +public import Mathlib.Algebra.GroupWithZero.Defs +public import Mathlib.Algebra.Ring.Divisibility.Basic +public import Mathlib.Algebra.Ring.Subring.Basic + +/-! +# Four-factor refinement + +This file defines the binary four-factor refinement property for a commutative monoid and relates +it to Mathlib's predicates `IsPrimal` and `DecompositionMonoid`. This is the algebraic form of +Conway's refinement conjecture in *On Numbers and Games*, page 46, and in LM24, +Conjecture 1.1.1(2). + +The equivalence itself is Cohn, Theorem 2.2, in its four-factor case. Cohn shows that an +integrally closed domain is Schreier — every element primal — exactly when any two factorisations +of an element admit a common refinement, and the forward direction of his proof is the four-factor +argument reproduced below. The name "primal" is his; "pre-Schreier", for the same condition +without integral closure, is Zafrullah's. What follows drops the domain and integral-closure +hypotheses and keeps the binary case, which is what the refinement conjecture needs. + +For commutative monoids with zero, cancellation away from zero is needed only in the reverse +implication from primality to four-factor refinement. The zero case uses the absence of zero +divisors supplied by `IsCancelMulZero`. These generic equivalences do not assert that the omnific +integers satisfy either equivalent property; that specialization remains Conway's refinement +conjecture. +-/ + +universe u + +public section + +/-- A commutative monoid has four-factor refinement if every equality `a * b = c * d` admits +elements `e`, `f`, `g`, and `h` such that +`a = e * f`, `b = g * h`, `c = e * g`, and `d = f * h`. -/ +def HasFourFactorRefinement (R : Type u) [CommMonoid R] : Prop := + ∀ a b c d : R, a * b = c * d → + ∃ e f g h : R, a = e * f ∧ b = g * h ∧ c = e * g ∧ d = f * h + +/-- The defining condition for four-factor refinement. -/ +theorem hasFourFactorRefinement_def {R : Type u} [CommMonoid R] : + HasFourFactorRefinement R ↔ + ∀ a b c d : R, a * b = c * d → + ∃ e f g h : R, a = e * f ∧ b = g * h ∧ c = e * g ∧ d = f * h := + (Iff.rfl) + +namespace HasFourFactorRefinement + +variable {R : Type u} [CommMonoid R] + +/-- Four-factor refinement is preserved by a multiplicative equivalence. -/ +theorem map_mulEquiv {S : Type*} [CommMonoid S] + (hR : HasFourFactorRefinement R) (e : R ≃* S) : HasFourFactorRefinement S := by + rw [hasFourFactorRefinement_def] + intro a b c d habcd + have hsource : e.symm a * e.symm b = e.symm c * e.symm d := by + simpa only [map_mul] using congrArg e.symm habcd + obtain ⟨f, g, h, i, haf, hbg, hch, hdi⟩ := hR _ _ _ _ hsource + exact ⟨e f, e g, e h, e i, + by simpa only [map_mul, e.apply_symm_apply] using congrArg e haf, + by simpa only [map_mul, e.apply_symm_apply] using congrArg e hbg, + by simpa only [map_mul, e.apply_symm_apply] using congrArg e hch, + by simpa only [map_mul, e.apply_symm_apply] using congrArg e hdi⟩ + +/-- Obtain four refinement factors from an equality of two products. -/ +theorem refine (hR : HasFourFactorRefinement R) {a b c d : R} (h : a * b = c * d) : + ∃ e f g h : R, a = e * f ∧ b = g * h ∧ c = e * g ∧ d = f * h := + hasFourFactorRefinement_def.mp hR a b c d h + +/-- Every element of a commutative monoid with four-factor refinement is primal. -/ +theorem isPrimal (hR : HasFourFactorRefinement R) (a : R) : IsPrimal a := by + intro b c hadvd + obtain ⟨q, hq⟩ := hadvd + obtain ⟨e, f, g, h, ha, _, hb, hc⟩ := hR.refine hq.symm + exact ⟨e, f, ⟨g, hb⟩, ⟨h, hc⟩, ha⟩ + +/-- A commutative monoid with four-factor refinement is a decomposition monoid. -/ +theorem decompositionMonoid (hR : HasFourFactorRefinement R) : DecompositionMonoid R := + ⟨hR.isPrimal⟩ + +end HasFourFactorRefinement + +/-- Multiplicatively equivalent commutative monoids have four-factor refinement simultaneously. -/ +theorem MulEquiv.hasFourFactorRefinement_iff + {R : Type u} {S : Type*} [CommMonoid R] [CommMonoid S] (e : R ≃* S) : + HasFourFactorRefinement R ↔ HasFourFactorRefinement S := + ⟨fun h ↦ h.map_mulEquiv e, fun h ↦ h.map_mulEquiv e.symm⟩ + +section CancelMulZero + +variable {R : Type u} [CommMonoidWithZero R] [IsCancelMulZero R] + +/-- A product equality with one nonzero primal factor has a four-factor refinement. -/ +theorem exists_fourFactorRefinement_of_isPrimal + {a b c d : R} (ha0 : a ≠ 0) (ha : IsPrimal a) (habcd : a * b = c * d) : + ∃ e f g h : R, a = e * f ∧ b = g * h ∧ c = e * g ∧ d = f * h := by + have hadvd : a ∣ c * d := ⟨b, habcd.symm⟩ + obtain ⟨e, f, hec, hfd, haef⟩ := ha hadvd + obtain ⟨g, hcg⟩ := hec + obtain ⟨h, hdh⟩ := hfd + refine ⟨e, f, g, h, haef, ?_, hcg, hdh⟩ + apply mul_left_cancel₀ ha0 + calc + a * b = c * d := habcd + _ = (e * g) * (f * h) := by rw [hcg, hdh] + _ = (e * f) * (g * h) := by ac_rfl + _ = a * (g * h) := by rw [← haef] + +/-- Splice an equation-local refinement of one factor with primality of the complementary factor. +If `a = t * w`, the retained factor `t` has been split as `e * f` with `e ∣ c` and `f ∣ d`, +and `w` is primal, then the original divisibility `a ∣ c * d` has a primal refinement. -/ +theorem exists_primalRefinement_of_factor_refinement + {a b c d t w e f : R} (ha0 : a ≠ 0) (hab : a * b = c * d) + (hatw : a = t * w) (htef : t = e * f) (hec : e ∣ c) (hfd : f ∣ d) + (hw : IsPrimal w) : + ∃ a₁ a₂, a₁ ∣ c ∧ a₂ ∣ d ∧ a = a₁ * a₂ := by + obtain ⟨g, hcg⟩ := hec + obtain ⟨h, hdh⟩ := hfd + have ht0 : t ≠ 0 := fun ht ↦ ha0 (by rw [hatw, ht, zero_mul]) + have hwdiv : w ∣ g * h := by + refine ⟨b, ?_⟩ + apply mul_left_cancel₀ ht0 + calc + t * (g * h) = (e * f) * (g * h) := by rw [htef] + _ = (e * g) * (f * h) := by ac_rfl + _ = c * d := by rw [← hcg, ← hdh] + _ = a * b := hab.symm + _ = t * (w * b) := by rw [hatw]; ac_rfl + obtain ⟨w₁, w₂, ⟨u, hgu⟩, ⟨v, hhv⟩, hww⟩ := hw hwdiv + refine ⟨e * w₁, f * w₂, ⟨u, ?_⟩, ⟨v, ?_⟩, ?_⟩ + · rw [hcg, hgu] + ac_rfl + · rw [hdh, hhv] + ac_rfl + · rw [hatw, htef, hww] + ac_rfl + +/-- A commutative decomposition monoid with cancellation away from zero has four-factor +refinement. -/ +theorem hasFourFactorRefinement_of_decompositionMonoid [DecompositionMonoid R] : + HasFourFactorRefinement R := by + intro a b c d hab + by_cases ha : a = 0 + · subst a + have hcd : c * d = 0 := by simpa using hab.symm + rcases eq_zero_or_eq_zero_of_mul_eq_zero hcd with rfl | rfl + · exact ⟨0, d, b, 1, by simp⟩ + · exact ⟨c, 0, 1, b, by simp⟩ + · have hadvd : a ∣ c * d := ⟨b, hab.symm⟩ + obtain ⟨e, f, hec, hfd, haef⟩ := DecompositionMonoid.primal a hadvd + obtain ⟨g, hcg⟩ := hec + obtain ⟨h, hdh⟩ := hfd + refine ⟨e, f, g, h, haef, ?_, hcg, hdh⟩ + apply mul_left_cancel₀ ha + calc + a * b = c * d := hab + _ = (e * g) * (f * h) := by rw [hcg, hdh] + _ = (e * f) * (g * h) := by ac_rfl + _ = a * (g * h) := by rw [← haef] + +/-- Four-factor refinement is equivalent to primality of every element. -/ +theorem hasFourFactorRefinement_iff_forall_isPrimal : + HasFourFactorRefinement R ↔ ∀ a : R, IsPrimal a := by + constructor + · exact fun hR a ↦ hR.isPrimal a + · intro h + let : DecompositionMonoid R := ⟨h⟩ + exact hasFourFactorRefinement_of_decompositionMonoid + +/-- Four-factor refinement is equivalent to the decomposition-monoid property. -/ +theorem hasFourFactorRefinement_iff_decompositionMonoid : + HasFourFactorRefinement R ↔ DecompositionMonoid R := by + rw [hasFourFactorRefinement_iff_forall_isPrimal, decompositionMonoid_iff] + +end CancelMulZero + +namespace Subring + +variable {R : Type u} [CommRing R] + +/-- Four-factor refinement in a subring is equivalent to ambient refinement with all four +factors retained in the subring. -/ +theorem hasFourFactorRefinement_iff (S : Subring R) : + HasFourFactorRefinement S ↔ + ∀ a b c d : R, a ∈ S → b ∈ S → c ∈ S → d ∈ S → a * b = c * d → + ∃ e f g h : R, + e ∈ S ∧ f ∈ S ∧ g ∈ S ∧ h ∈ S ∧ + a = e * f ∧ b = g * h ∧ c = e * g ∧ d = f * h := by + constructor + · intro hS a b c d ha hb hc hd habcd + obtain ⟨e, f, g, h, hA, hB, hC, hD⟩ := + hS.refine (a := ⟨a, ha⟩) (b := ⟨b, hb⟩) (c := ⟨c, hc⟩) (d := ⟨d, hd⟩) + (Subtype.ext habcd) + exact ⟨e, f, g, h, e.2, f.2, g.2, h.2, + congrArg Subtype.val hA, congrArg Subtype.val hB, + congrArg Subtype.val hC, congrArg Subtype.val hD⟩ + · intro hS a b c d habcd + obtain ⟨e, f, g, h, he, hf, hg, hh, hA, hB, hC, hD⟩ := + hS a b c d a.2 b.2 c.2 d.2 (congrArg Subtype.val habcd) + exact ⟨⟨e, he⟩, ⟨f, hf⟩, ⟨g, hg⟩, ⟨h, hh⟩, + Subtype.ext hA, Subtype.ext hB, Subtype.ext hC, Subtype.ext hD⟩ + +/-- A decomposition subring refines every ambient product equality whose four entries lie in +the subring. -/ +theorem exists_fourFactorRefinement_of_decompositionMonoid + (S : Subring R) [IsDomain S] [DecompositionMonoid S] + {a b c d : R} (ha : a ∈ S) (hb : b ∈ S) (hc : c ∈ S) (hd : d ∈ S) + (habcd : a * b = c * d) : + ∃ e f g h : R, + e ∈ S ∧ f ∈ S ∧ g ∈ S ∧ h ∈ S ∧ + a = e * f ∧ b = g * h ∧ c = e * g ∧ d = f * h := by + exact (hasFourFactorRefinement_iff S).mp + hasFourFactorRefinement_of_decompositionMonoid a b c d ha hb hc hd habcd + +end Subring diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Divisibility/Tests.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Divisibility/Tests.lean new file mode 100644 index 0000000000..89e6459f81 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Divisibility/Tests.lean @@ -0,0 +1,11 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Divisibility.Tests.Refinement + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Divisibility/Tests/Refinement.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Divisibility/Tests/Refinement.lean new file mode 100644 index 0000000000..0288326e7d --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Divisibility/Tests/Refinement.lean @@ -0,0 +1,44 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Divisibility.Refinement + +import Mathlib.Algebra.GCDMonoid.Nat +import Mathlib.Tactic.NormNum + +/-! +# Tests for four-factor refinement + +The natural numbers provide nonzero and zero examples of the public refinement interface. +-/ + +public section + +namespace Tests + +/-- The natural numbers give a four-factor refinement model with `0 ≠ 1` and nonunit elements. -/ +theorem nat_hasFourFactorRefinement : HasFourFactorRefinement ℕ := + hasFourFactorRefinement_of_decompositionMonoid + +theorem nat_hasFourFactorRefinement_iff_decompositionMonoid : + HasFourFactorRefinement ℕ ↔ DecompositionMonoid ℕ := + hasFourFactorRefinement_iff_decompositionMonoid + +/-- The equality `6 * 35 = 10 * 21` has the refinement `(2, 3, 5, 7)`. -/ +theorem nat_six_thirty_five_ten_twenty_one_refinement : + ∃ e f g h : ℕ, 6 = e * f ∧ 35 = g * h ∧ 10 = e * g ∧ 21 = f * h := + ⟨2, 3, 5, 7, by norm_num⟩ + +theorem nat_zero_left_refinement (b d : ℕ) : + ∃ e f g h : ℕ, 0 = e * f ∧ b = g * h ∧ 0 = e * g ∧ d = f * h := + nat_hasFourFactorRefinement.refine (by simp) + +theorem nat_zero_right_refinement (b c : ℕ) : + ∃ e f g h : ℕ, 0 = e * f ∧ b = g * h ∧ c = e * g ∧ 0 = f * h := + nat_hasFourFactorRefinement.refine (by simp) + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Finset/FilterCard.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Finset/FilterCard.lean new file mode 100644 index 0000000000..f1d29bd5c6 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Finset/FilterCard.lean @@ -0,0 +1,34 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import Mathlib.Data.Finset.Card + +/-! +# Cardinalities of strict upper filters + +Raising a weight threshold past a member of a finite set strictly decreases the number of +members above the threshold. This supplies the induction measure for partial-derivative identities. +-/ + +public section + +namespace ConwayRefinement + +/-- Raising the weight threshold to a larger member strictly decreases the upper filter's size. -/ +theorem card_filter_above_lt {ι η : Type*} [LinearOrder η] + (wt : ι → η) (s : Finset ι) {i j : ι} (hj : j ∈ s) (hij : wt i < wt j) : + (s.filter fun v ↦ wt j < wt v).card < (s.filter fun v ↦ wt i < wt v).card := by + classical + refine Finset.card_lt_card + (Finset.ssubset_iff_subset_ne.mpr ⟨fun v hv ↦ ?_, fun heq ↦ ?_⟩) + · obtain ⟨hv, hlt⟩ := Finset.mem_filter.mp hv + exact Finset.mem_filter.mpr ⟨hv, hij.trans hlt⟩ + · have hjmem : j ∈ s.filter fun v ↦ wt i < wt v := Finset.mem_filter.mpr ⟨hj, hij⟩ + rw [← heq, Finset.mem_filter] at hjmem + exact lt_irrefl _ hjmem.2 + +end ConwayRefinement diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/GeometricIntegrality.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/GeometricIntegrality.lean new file mode 100644 index 0000000000..b60e7395b6 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/GeometricIntegrality.lean @@ -0,0 +1,213 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import Mathlib.Algebra.MvPolynomial.Eval +public import Mathlib.RingTheory.Ideal.Quotient.Defs +public import Mathlib.RingTheory.Ideal.Span +public import Mathlib.RingTheory.TensorProduct.Basic + +import Mathlib.LinearAlgebra.Basis.VectorSpace +import Mathlib.Algebra.Field.ULift +import Mathlib.Algebra.Ring.Hom.InjSurj +import Mathlib.RingTheory.Flat.Basic +import Mathlib.RingTheory.Ideal.Quotient.Basic +import Mathlib.RingTheory.Ideal.Quotient.Operations +import Mathlib.RingTheory.Localization.FractionRing +import Mathlib.RingTheory.Polynomial.UniqueFactorization +import Mathlib.RingTheory.TensorProduct.MvPolynomial +import Mathlib.RingTheory.TensorProduct.Quotient + +/-! +# Geometrically integral algebras + +A commutative algebra over a field is geometrically integral when its scalar extension to every +field in the ambient universe is a domain. This algebraic formulation is the one used by the +filtered-substitution argument: an irreducible polynomial over the base field remains prime after +extending its coefficients to a geometrically integral algebra. + +The proof embeds the scalar extension by the irreducible polynomial's quotient domain into the +scalar extension by its fraction field. Polynomial and quotient tensor equivalences then identify +that tensor product with the required polynomial quotient. + +The definition quantifies over the fields of the universe `max u v` of `B ⊗[k] L`. A `Prop` +cannot quantify over universes, and the universe-free characterization, that `B ⊗[k] k_alg` is a +domain for an algebraic closure `k_alg`, is a theorem of descent that is not in Mathlib; the +scheme-theoretic `AlgebraicGeometry.GeometricallyIntegral` is likewise fixed to one universe. For +the paper's quotient `P̂/I`, the statement in every universe is proved separately, by putting a +lowering derivation on `E ⊗_K P̂` rather than from this definition. +-/ + +open scoped TensorProduct + +universe u v w + +namespace Algebra + +public noncomputable section + +attribute [local instance 1100] Module.Free.of_divisionRing Module.Flat.of_free + +/-- A commutative algebra is geometrically integral when every scalar extension to a field in the +ambient universe is a domain. -/ +def IsGeometricallyIntegral (k : Type u) (B : Type v) + [Field k] [CommRing B] [Algebra k B] : Prop := + ∀ (K : Type (max u v)) [Field K] [Algebra k K], IsDomain (B ⊗[k] K) + +/-- A geometrically integral algebra is a domain. -/ +theorem IsGeometricallyIntegral.isDomain + {k : Type u} [Field k] {B : Type v} [CommRing B] [Algebra k B] + (hB : IsGeometricallyIntegral k B) : IsDomain B := by + have : IsDomain (B ⊗[k] ULift.{max u v} k) := + hB (ULift.{max u v} k) + let e : (B ⊗[k] ULift.{max u v} k) ≃ₐ[k] (B ⊗[k] k) := + Algebra.TensorProduct.congr AlgEquiv.refl ULift.algEquiv + have : IsDomain (B ⊗[k] k) := e.symm.toMulEquiv.isDomain _ + exact (Algebra.TensorProduct.rid k k B).symm.toMulEquiv.isDomain _ + +section BaseChange + +/-- Geometric integrality transports along an algebra equivalence. -/ +theorem IsGeometricallyIntegral.of_algEquiv {k : Type u} [Field k] {A B : Type v} + [CommRing A] [Algebra k A] [CommRing B] [Algebra k B] + (hA : IsGeometricallyIntegral k A) (e : A ≃ₐ[k] B) : + IsGeometricallyIntegral k B := fun M _ _ ↦ by + have : IsDomain (A ⊗[k] M) := hA M + exact (Algebra.TensorProduct.congr e + (AlgEquiv.refl (R := k) (A₁ := M))).symm.toMulEquiv.isDomain _ + +end BaseChange + +variable {k : Type u} {σ : Type (max u v)} {B : Type v} + [Field k] [CommRing B] [Algebra k B] + +/-- The defining field-extension criterion for geometric integrality. -/ +theorem isGeometricallyIntegral_iff : + IsGeometricallyIntegral k B ↔ + ∀ (K : Type (max u v)) [Field K] [Algebra k K], IsDomain (B ⊗[k] K) := + Iff.rfl + +/-- An algebra over a field whose tensor products with the fields of some universe are domains +remains a domain after tensoring with any domain of that universe: the tensor product embeds, by +flatness, into the tensor product with the fraction field. -/ +theorem isDomain_tensor_of_isDomain_of_forall_field {k : Type u} [Field k] {B : Type v} + [CommRing B] [Algebra k B] + (hB : ∀ (L : Type w) [Field L] [Algebra k L], IsDomain (B ⊗[k] L)) + (D : Type w) [CommRing D] [IsDomain D] [Algebra k D] : IsDomain (B ⊗[k] D) := by + let L := FractionRing D + let : Algebra k L := Algebra.ofModule + (fun r x y ↦ smul_mul_assoc r x y) + (fun r x y ↦ mul_smul_comm r x y) + let : IsScalarTower k D L := inferInstance + let : IsDomain (B ⊗[k] L) := hB L + let ι : D →ₐ[k] L := (IsScalarTower.toAlgHom k D L).restrictScalars k + let Φ : B ⊗[k] D →ₐ[k] B ⊗[k] L := + Algebra.TensorProduct.map (AlgHom.id k B) ι + have hι : Function.Injective ι := IsFractionRing.injective D L + have hΦ : Function.Injective Φ := by + have h := TensorProduct.map_injective_of_flat_flat + (LinearMap.id (R := k) (M := B)) + ((IsScalarTower.toAlgHom k D L).restrictScalars k).toLinearMap + Function.injective_id hι + change Function.Injective Φ.toLinearMap + dsimp only [Φ] + rw [Algebra.TensorProduct.toLinearMap_map, + TensorProduct.AlgebraTensorModule.map_eq] + exact h + exact hΦ.isDomain Φ.toRingHom + +/-- A geometrically integral algebra remains a domain after tensoring with any domain of the +ambient universe over the base field. -/ +theorem IsGeometricallyIntegral.isDomain_tensor_of_isDomain + (hB : IsGeometricallyIntegral k B) (D : Type (max u v)) [CommRing D] [IsDomain D] + [Algebra k D] : IsDomain (B ⊗[k] D) := + isDomain_tensor_of_isDomain_of_forall_field (fun L _ _ ↦ hB L) D + +/-- An irreducible polynomial over the base field generates a prime ideal after extending +coefficients to a geometrically integral algebra. -/ +theorem IsGeometricallyIntegral.isDomain_mvPolynomial_quotient_span_map + (hB : IsGeometricallyIntegral k B) {F : MvPolynomial σ k} + (hF : Irreducible F) : + IsDomain + (MvPolynomial σ B ⧸ + Ideal.span {MvPolynomial.map (algebraMap k B) F}) := by + let I : Ideal (MvPolynomial σ k) := Ideal.span {F} + have hFPrime : Prime F := + UniqueFactorizationMonoid.irreducible_iff_prime.mp hF + have hIPrime : I.IsPrime := by + exact (Ideal.span_singleton_prime hFPrime.ne_zero).mpr hFPrime + let : I.IsPrime := hIPrime + let D := MvPolynomial σ k ⧸ I + let : IsDomain (B ⊗[k] D) := hB.isDomain_tensor_of_isDomain D + let ePoly : B ⊗[k] MvPolynomial σ k ≃ₐ[B] MvPolynomial σ B := + MvPolynomial.algebraTensorAlgEquiv k B + let rightInclusion : MvPolynomial σ k →ₐ[k] B ⊗[k] MvPolynomial σ k := + Algebra.TensorProduct.includeRight + let J : Ideal (B ⊗[k] MvPolynomial σ k) := I.map rightInclusion + let eQuot := + Algebra.TensorProduct.tensorQuotientEquiv + (R := k) B (MvPolynomial σ k) B I + have hIdeal : + Ideal.map ePoly.toRingEquiv J = + Ideal.span {MvPolynomial.map (algebraMap k B) F} := by + dsimp only [J, I] + change Ideal.map ePoly.toRingEquiv.toRingHom + (Ideal.map rightInclusion.toRingHom (Ideal.span {F})) = _ + rw [Ideal.map_map rightInclusion.toRingHom ePoly.toRingEquiv.toRingHom] + rw [Ideal.map_span, Set.image_singleton] + congr 2 + change ePoly (rightInclusion F) = MvPolynomial.map (algebraMap k B) F + simp [rightInclusion, ePoly] + let : IsDomain + ((B ⊗[k] MvPolynomial σ k) ⧸ J) := + eQuot.symm.toMulEquiv.isDomain + let eMap : + (B ⊗[k] MvPolynomial σ k) ⧸ J ≃+* + MvPolynomial σ B ⧸ Ideal.span {MvPolynomial.map (algebraMap k B) F} := + Ideal.quotientEquiv _ _ ePoly.toRingEquiv hIdeal.symm + exact eMap.symm.toMulEquiv.isDomain + +private def quotientSpanEquivOfEq {A C : Type*} [CommRing A] [CommRing C] + (e : A ≃+* C) {x : A} {y : C} (hxy : e x = y) : + A ⧸ Ideal.span {x} ≃+* C ⧸ Ideal.span {y} := + Ideal.quotientEquiv (Ideal.span {x}) (Ideal.span {y}) e <| by + rw [Ideal.map_span, Set.image_singleton] + change Ideal.span {y} = Ideal.span {e x} + rw [hxy] + +/-- The irreducible base-change quotient is a domain for a finite variable type, independently +of the universes of the base field and coefficient algebra. -/ +theorem IsGeometricallyIntegral.isDomain_fin_mvPolynomial_quotient_span_map + (hB : IsGeometricallyIntegral k B) {n : ℕ} {F : MvPolynomial (Fin n) k} + (hF : Irreducible F) : + IsDomain + (MvPolynomial (Fin n) B ⧸ + Ideal.span {MvPolynomial.map (algebraMap k B) F}) := by + let τ := ULift.{max u v, 0} (Fin n) + let liftEquiv : Fin n ≃ τ := Equiv.ulift.symm + let F' : MvPolynomial τ k := MvPolynomial.renameEquiv k liftEquiv F + have hF' : Irreducible F' := by + exact hF.map (MvPolynomial.renameEquiv k liftEquiv).toMulEquiv + let : IsDomain + (MvPolynomial τ B ⧸ + Ideal.span {MvPolynomial.map (algebraMap k B) F'}) := + hB.isDomain_mvPolynomial_quotient_span_map hF' + let e : MvPolynomial (Fin n) B ≃+* MvPolynomial τ B := + (MvPolynomial.renameEquiv B liftEquiv).toRingEquiv + have hmap : + e (MvPolynomial.map (algebraMap k B) F) = + MvPolynomial.map (algebraMap k B) F' := by + change MvPolynomial.rename liftEquiv + (MvPolynomial.map (algebraMap k B) F) = + MvPolynomial.map (algebraMap k B) + (MvPolynomial.rename liftEquiv F) + exact MvPolynomial.map_rename (algebraMap k B) liftEquiv F |>.symm + let eQuot := quotientSpanEquivOfEq e hmap + exact eQuot.isDomain _ + +end + +end Algebra diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/GradedRing.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/GradedRing.lean new file mode 100644 index 0000000000..06a25f6d55 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/GradedRing.lean @@ -0,0 +1,15 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.GradedRing.Extension +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.GradedRing.FinitePartSubstitution +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.GradedRing.HomogeneousSpan +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.GradedRing.HomogeneousZeroDivisors +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.GradedRing.OrdinalGenerators + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/GradedRing/Extension.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/GradedRing/Extension.lean new file mode 100644 index 0000000000..8f5ab9c52d --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/GradedRing/Extension.lean @@ -0,0 +1,279 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.GradedRing.OrdinalGenerators +public import Mathlib.LinearAlgebra.Basis.VectorSpace + +/-! +# Extending a degreewise independent family to a minimal system + +Let `(A_β)` be a family of subspaces of a commutative algebra over a field `E`, and put +`D_β = ∑_{i ⊕ j = β, i, j ≠ 0} A_i A_j` (Lean `decomposableAt 𝒜 β`). A family +`x i ∈ A_{wt i}` of positive weights whose members of each weight `β` are linearly independent +modulo `D_β` extends to a minimal system relative to `(A_β)`: in each nonzero weight, extend the +given classes to a basis of `A_β / (A_β ∩ D_β)` and lift the new basis vectors to `A_β`. +-/ + +universe u v w o + +open MvPolynomial Module + +public noncomputable section + +namespace OrdinalGraded + +variable {E : Type u} {R : Type v} [Field E] [CommRing R] [Algebra E R] +variable (𝒜 : NatOrdinal.{o} → Submodule E R) [GradedAlgebra 𝒜] +variable {ι : Type w} {wt : ι → NatOrdinal.{o}} {x : ι → R} + +omit [GradedAlgebra 𝒜] in +/-- **Extension to a minimal system.** Elements `x i ∈ A_{wt i}` of positive weight, linearly +independent in each weight `β` modulo `decomposableAt 𝒜 β`, are part of a minimal system +relative to `𝒜`: there are `wt'`, `x'` with `IsMinimalSystem 𝒜 wt' x'` and an injection `e` +satisfying `wt' (e i) = wt i` and `x' (e i) = x i`. -/ +@[blueprint "lem:extend-to-minimal-system" + (phase := "Algebraic and ordinal preliminaries") + (title := "Extension of a degreewise independent family") + (statement := /-- + Let $E$ be a field, let $R$ be a commutative $E$-algebra, and let + $(A_\alpha)_{\alpha\in\mathbf{On}}$ be a family of $E$-subspaces of $R$. + Put + \[ + D_\beta=\sum_{\substack{i\oplus j=\beta\\i,j\ne0}}A_iA_j. + \] + Suppose $w_i\ne0$, $x_i\in A_{w_i}$, and every finitely supported + combination $\sum_i c_ix_i$ with all $w_i=\beta$ belongs to $D_\beta$ + only when every $c_i$ is zero. Then there are a family $(x'_j)_{j\in I'}$, + weights $w'_j$, and an injection $e:I\to I'$ such that + $w'_j\ne0$, $x'_j\in A_{w'_j}$, $w'_{e(i)}=w_i$, and + $x'_{e(i)}=x_i$. Moreover, the $x'_j$ of weight $\beta$ are independent + modulo $D_\beta$ for every $\beta$ and span $A_\beta$ modulo $D_\beta$ + whenever $\beta\ne0$. + -/) + (proof := /-- + For every $\beta$, pass to $A_\beta/(A_\beta\cap D_\beta)$. Extend the + prescribed independent classes to a basis and choose lifts in $A_\beta$ for + the added basis vectors. The union over all nonzero + weights contains the original family and its classes give the required + independence and spanning properties weight by weight. + -/)] +theorem exists_isMinimalSystem_extension (hwt : ∀ i, wt i ≠ 0) (hmem : ∀ i, x i ∈ 𝒜 (wt i)) + (hind : ∀ (β : NatOrdinal) (c : ι →₀ E), (∀ i ∈ c.support, wt i = β) → + Finsupp.linearCombination E x c ∈ decomposableAt 𝒜 β → c = 0) : + ∃ (ι' : Type (max v w (o + 1))) (wt' : ι' → NatOrdinal.{o}) (x' : ι' → R) (e : ι → ι'), + Function.Injective e ∧ (∀ i, wt' (e i) = wt i) ∧ (∀ i, x' (e i) = x i) ∧ + IsMinimalSystem 𝒜 wt' x' := by + classical + -- the quotients `A_β / ((A_+)² ∩ A_β)` + let D : ∀ β : NatOrdinal, Submodule E (𝒜 β) := fun β ↦ (decomposableAt 𝒜 β).comap (𝒜 β).subtype + let mkV : ∀ β : NatOrdinal, (𝒜 β) →ₗ[E] ((𝒜 β) ⧸ D β) := fun β ↦ (D β).mkQ + have hmk : ∀ β (z : 𝒜 β), mkV β z = 0 ↔ (z : R) ∈ decomposableAt 𝒜 β := fun β z ↦ by + change Submodule.Quotient.mk z = 0 ↔ _ + rw [Submodule.Quotient.mk_eq_zero] + exact Iff.rfl + -- the classes of the given generators of degree `β` + have hmemβ : ∀ β (i : {i // wt i = β}), x i.1 ∈ 𝒜 β := fun β i ↦ by + have h := hmem i.1 + rwa [i.2] at h + let xs : ∀ β : NatOrdinal, {i // wt i = β} → (𝒜 β) ⧸ D β := fun β i ↦ mkV β ⟨x i.1, hmemβ β i⟩ + -- they are linearly independent + have hli : ∀ β, LinearIndependent E (xs β) := by + intro β + rw [linearIndependent_iff'] + intro s g hsum i hi + set c : ι →₀ E := ∑ j ∈ s, Finsupp.single j.1 (g j) with hcdef + have hcval : ∀ j ∈ s, c j.1 = g j := by + intro j hj + rw [hcdef, Finsupp.finsetSum_apply, Finset.sum_eq_single j] + · rw [Finsupp.single_eq_same] + · intro j' _ hj' + rw [Finsupp.single_apply, ite_eq_right] + exact fun h ↦ hj' (Subtype.ext h) + · intro h; exact absurd hj h + have hcsupp : ∀ j ∈ c.support, wt j = β := by + intro j hj + obtain ⟨j', -, hjj'⟩ := Finset.mem_biUnion.mp (Finsupp.support_finsetSum hj) + have := Finsupp.support_single_subset hjj' + rw [Finset.mem_singleton] at this + rw [this]; exact j'.2 + have hlc : Finsupp.linearCombination E x c = ∑ j ∈ s, g j • x j.1 := by + rw [hcdef, map_sum] + exact Finset.sum_congr rfl fun j _ ↦ Finsupp.linearCombination_single _ _ _ + have hmem' : Finsupp.linearCombination E x c ∈ decomposableAt 𝒜 β := by + rw [hlc] + have h0 : mkV β (∑ j ∈ s, g j • (⟨x j.1, hmemβ β j⟩ : 𝒜 β)) = 0 := by + rw [map_sum] + simpa only [map_smul] using hsum + rw [hmk] at h0 + simpa only [Submodule.coe_sum, Submodule.coe_smul] using h0 + have hc0 := hind β c hcsupp hmem' + rw [← hcval i hi, hc0, Finsupp.zero_apply] + have hinjxs : ∀ β, Function.Injective (xs β) := fun β ↦ (hli β).injective + -- the basis extending the classes + let S : ∀ β : NatOrdinal, Set ((𝒜 β) ⧸ D β) := fun β ↦ Set.range (xs β) + have hS : ∀ β, LinearIndepOn E id (S β) := + fun β ↦ (linearIndepOn_id_range_iff (hinjxs β)).mpr (hli β) + let bas : ∀ β : NatOrdinal, Basis ((hS β).extend (Set.subset_univ _)) E ((𝒜 β) ⧸ D β) := + fun β ↦ Basis.extend (hS β) + -- the new generators: lifts of the basis vectors outside `S β` + let J : NatOrdinal → Type v := fun β ↦ + {q : (hS β).extend (Set.subset_univ _) // (q : (𝒜 β) ⧸ D β) ∉ S β} + have hlift : ∀ β (q : J β), ∃ r : 𝒜 β, mkV β r = q.1.1 := + fun β q ↦ Submodule.Quotient.mk_surjective (D β) q.1.1 + choose lift hlift using hlift + -- the extended system + let wt' : ι ⊕ (Σ β : {β : NatOrdinal // β ≠ 0}, J β.1) → NatOrdinal := + Sum.elim wt fun p ↦ p.1.1 + let x' : ι ⊕ (Σ β : {β : NatOrdinal // β ≠ 0}, J β.1) → R := + Sum.elim x fun p ↦ (lift p.1.1 p.2 : R) + have hmem' : ∀ j, x' j ∈ 𝒜 (wt' j) := by + rintro (i | ⟨β, q⟩) + · exact hmem i + · exact (lift β.1 q).2 + refine ⟨_, wt', x', Sum.inl, Sum.inl_injective, fun i ↦ rfl, fun i ↦ rfl, ?_⟩ + refine { ne_zero := ?_, mem := hmem', independent := ?_, spans := ?_ } + · rintro (i | ⟨β, q⟩) + · exact hwt i + · exact β.2 + · -- independence + intro β c hc hdec + -- the classes of the generators of degree `β` + have hmemβ' : ∀ j : {j // wt' j = β}, x' j.1 ∈ 𝒜 β := fun j ↦ by + have h := hmem' j.1 + rwa [j.2] at h + let ψ : {j // wt' j = β} → (𝒜 β) ⧸ D β := fun j ↦ mkV β ⟨x' j.1, hmemβ' j⟩ + have hψinl : ∀ (i : ι) (h : wt' (Sum.inl i) = β), ψ ⟨Sum.inl i, h⟩ = xs β ⟨i, h⟩ := + fun i h ↦ rfl + have hψinr : ∀ (β' : {β : NatOrdinal // β ≠ 0}) (q : J β'.1) (h : wt' (Sum.inr ⟨β', q⟩) = β), + ψ ⟨Sum.inr ⟨β', q⟩, h⟩ = h ▸ q.1.1 := by + rintro β' q h + change β'.1 = β at h + subst h + exact hlift β'.1 q + have hψS : ∀ j, ψ j ∈ (hS β).extend (Set.subset_univ _) := by + rintro ⟨(i | ⟨β', q⟩), hj⟩ + · rw [hψinl] + exact (hS β).subset_extend (Set.subset_univ _) ⟨⟨i, hj⟩, rfl⟩ + · rw [hψinr] + change β'.1 = β at hj + subst hj + exact q.1.2 + have hψinj : Function.Injective ψ := by + rintro ⟨(i | ⟨β', q⟩), hj⟩ ⟨(i' | ⟨β'', q'⟩), hj'⟩ heq + · rw [hψinl, hψinl] at heq + have := hinjxs β heq + exact Subtype.ext (congrArg Sum.inl (congrArg Subtype.val this)) + · rw [hψinl, hψinr] at heq + change β''.1 = β at hj' + subst hj' + exact absurd ⟨⟨i, hj⟩, heq⟩ q'.2 + · rw [hψinr, hψinl] at heq + change β'.1 = β at hj + subst hj + exact absurd ⟨⟨i', hj'⟩, heq.symm⟩ q.2 + · rw [hψinr, hψinr] at heq + change β'.1 = β at hj + change β''.1 = β at hj' + obtain ⟨β', hβ'⟩ := β' + obtain ⟨β'', hβ''⟩ := β'' + change β' = β at hj + change β'' = β at hj' + subst hj hj' + have hq : q = q' := Subtype.ext (Subtype.ext heq) + subst hq + rfl + have hψli : LinearIndependent E ψ := by + have : ψ = fun j ↦ bas β ⟨ψ j, hψS j⟩ := by + funext j + exact (Basis.extend_apply_self (hS β) ⟨ψ j, hψS j⟩).symm + rw [this] + exact (bas β).linearIndependent.comp _ fun j j' h ↦ hψinj (congrArg Subtype.val h) + -- the combination is zero in the quotient + have hZ : Finsupp.linearCombination E x' c ∈ 𝒜 β := by + rw [Finsupp.linearCombination_apply, Finsupp.sum] + refine Submodule.sum_mem _ fun j hj ↦ Submodule.smul_mem _ _ ?_ + rw [← hc j hj]; exact hmem' j + have hsum : ∑ j ∈ c.support.attach, c j.1 • ψ ⟨j.1, hc j.1 j.2⟩ = 0 := by + have h1 : (⟨Finsupp.linearCombination E x' c, hZ⟩ : 𝒜 β) = + ∑ j ∈ c.support.attach, c j.1 • ⟨x' j.1, hmemβ' ⟨j.1, hc j.1 j.2⟩⟩ := by + apply Subtype.ext + rw [Submodule.coe_sum] + change Finsupp.linearCombination E x' c = ∑ j ∈ c.support.attach, c j.1 • x' j.1 + rw [Finset.sum_attach c.support fun j ↦ c j • x' j, Finsupp.linearCombination_apply, + Finsupp.sum] + have h2 := (hmk β ⟨_, hZ⟩).mpr hdec + rw [h1, map_sum] at h2 + simpa only [map_smul] using h2 + have hall := linearIndependent_iff'.mp hψli + (c.support.attach.map ⟨fun j ↦ (⟨j.1, hc j.1 j.2⟩ : {j // wt' j = β}), + fun a b h ↦ Subtype.ext (by simpa using h)⟩) (fun t ↦ c t.1) (by + rw [Finset.sum_map] + exact hsum) + ext j + by_cases hj : j ∈ c.support + · exact hall ⟨j, hc j hj⟩ (Finset.mem_map.mpr ⟨⟨j, hj⟩, Finset.mem_attach _ _, rfl⟩) + · exact Finsupp.notMem_support_iff.mp hj + · -- spans + intro β hβ y hy + obtain ⟨l, hl⟩ : ∃ l, l = (bas β).repr (mkV β ⟨y, hy⟩) := ⟨_, rfl⟩ + let g : (hS β).extend (Set.subset_univ _) → ι ⊕ (Σ β : {β : NatOrdinal // β ≠ 0}, J β.1) := + fun q ↦ if h : (q : (𝒜 β) ⧸ D β) ∈ S β then Sum.inl (Classical.choose (Set.mem_range.mp h)).1 + else Sum.inr ⟨⟨β, hβ⟩, ⟨q, h⟩⟩ + have hg : ∀ q, wt' (g q) = β ∧ ∀ hq, mkV β ⟨x' (g q), hq⟩ = (q : (𝒜 β) ⧸ D β) := by + intro q + by_cases h : (q : (𝒜 β) ⧸ D β) ∈ S β + · have hspec := Classical.choose_spec (Set.mem_range.mp h) + have hq : g q = Sum.inl (Classical.choose (Set.mem_range.mp h)).1 := dite_eq_left h + refine ⟨by rw [hq]; exact (Classical.choose (Set.mem_range.mp h)).2, fun hq' ↦ ?_⟩ + rw [← hspec] + exact congrArg (mkV β) (Subtype.ext (by change x' (g q) = _; rw [hq]; rfl)) + · have hq : g q = Sum.inr ⟨⟨β, hβ⟩, ⟨q, h⟩⟩ := dite_eq_right h + refine ⟨by rw [hq]; rfl, fun hq' ↦ ?_⟩ + rw [← hlift β ⟨q, h⟩] + exact congrArg (mkV β) (Subtype.ext (by change x' (g q) = _; rw [hq]; rfl)) + have hmemg : ∀ q, x' (g q) ∈ 𝒜 β := fun q ↦ by + have h := hmem' (g q) + rwa [(hg q).1] at h + refine ⟨Finsupp.mapDomain g l, fun j hj ↦ ?_, ?_⟩ + · obtain ⟨q, -, hq⟩ := Finset.mem_image.mp (Finsupp.mapDomain_support hj) + rw [← hq] + exact (hg q).1 + · have hlc : Finsupp.linearCombination E x' (Finsupp.mapDomain g l) ∈ 𝒜 β := by + rw [Finsupp.linearCombination_mapDomain, Finsupp.linearCombination_apply, Finsupp.sum] + exact Submodule.sum_mem _ fun q _ ↦ Submodule.smul_mem _ _ (hmemg q) + rw [← hmk β ⟨y - Finsupp.linearCombination E x' (Finsupp.mapDomain g l), sub_mem hy hlc⟩] + have h1 : (⟨y - Finsupp.linearCombination E x' (Finsupp.mapDomain g l), + sub_mem hy hlc⟩ : 𝒜 β) = ⟨y, hy⟩ - ⟨_, hlc⟩ := rfl + rw [h1, map_sub, sub_eq_zero] + have h2 : (⟨Finsupp.linearCombination E x' (Finsupp.mapDomain g l), hlc⟩ : 𝒜 β) = + ∑ q ∈ l.support, l q • ⟨x' (g q), hmemg q⟩ := by + apply Subtype.ext + rw [Submodule.coe_sum] + change Finsupp.linearCombination E x' (Finsupp.mapDomain g l) = + ∑ q ∈ l.support, l q • x' (g q) + rw [Finsupp.linearCombination_mapDomain, Finsupp.linearCombination_apply, Finsupp.sum] + rfl + rw [h2, map_sum] + simp only [map_smul] + conv_lhs => rw [← (bas β).linearCombination_repr (mkV β ⟨y, hy⟩), ← hl, + Finsupp.linearCombination_apply, Finsupp.sum] + exact Finset.sum_congr rfl fun q _ ↦ by rw [Basis.extend_apply_self, (hg q).2] + +omit [GradedAlgebra 𝒜] in +/-- Every ordinal-graded algebra has a minimal system of homogeneous generators: extend the empty +family. -/ +theorem exists_isMinimalSystem : + ∃ (ι' : Type (max v (o + 1))) (wt' : ι' → NatOrdinal.{o}) (x' : ι' → R), + IsMinimalSystem 𝒜 wt' x' := by + obtain ⟨ι', wt', x', -, -, -, -, hmin⟩ := exists_isMinimalSystem_extension 𝒜 + (wt := (Empty.elim : Empty → NatOrdinal.{o})) (x := (Empty.elim : Empty → R)) + (fun i ↦ i.elim) (fun i ↦ i.elim) (fun _ c _ _ ↦ Finsupp.ext fun i ↦ i.elim) + exact ⟨ι', wt', x', hmin⟩ + +end OrdinalGraded diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/GradedRing/FinitePartSubstitution.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/GradedRing/FinitePartSubstitution.lean new file mode 100644 index 0000000000..4629d030d0 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/GradedRing/FinitePartSubstitution.lean @@ -0,0 +1,105 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.GradedRing.OrdinalGenerators +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MvPolynomial.FinitePartDecomposition + + +/-! +# Values of the cofactors in the successor step + +The successor step writes a relation as `F = ∑_t (∂F/∂X_t)(X_t + V_t)` with each `V_t` homogeneous +of degree `wt t` and free of the variables carrying the finite part. What it then needs is that +each `V_t` evaluates into the square of the ideal of positive degree. + +The reason is that a monomial of degree `wt t` free of those variables cannot be a single variable: +if it were, that variable would carry the whole finite part, which the freeness forbids. So every +monomial splits into two factors of nonzero degree, and their product is decomposable. + +Only two properties of the generators are used, that each sits in its own degree and that no degree +is zero, so they are taken directly rather than through a minimal-system structure. +-/ + +universe u v w z + +open scoped NatOrdinal + +open MvPolynomial + +public noncomputable section + +namespace OrdinalGraded + +variable {K : Type u} {R : Type v} [Field K] [CommRing R] [Algebra K R] +variable {A : NatOrdinal.{z} → Submodule K R} [GradedAlgebra A] +variable {ι : Type w} {wt : ι → NatOrdinal.{z}} {x : ι → R} + +/-- Multiplying a decomposable element by a homogeneous one keeps it decomposable, at the sum of +the degrees. -/ +theorem mul_mem_decomposableAt_of_mem_decomposableAt {g β : NatOrdinal.{z}} {z y : R} + (hz : z ∈ decomposableAt A g) (hy : y ∈ A β) : z * y ∈ decomposableAt A (g + β) := by + have hle : decomposableAt A g ≤ + (decomposableAt A (g + β)).comap (LinearMap.mulRight K y) := by + refine decomposableAt_le A fun i j hi hj hij ↦ ?_ + rw [Submodule.mul_le] + intro a ha b hb + rw [Submodule.mem_comap, LinearMap.mulRight_apply, mul_assoc] + have hjβ : j + β ≠ 0 := fun h ↦ hj (le_antisymm (h ▸ NatOrdinal.le_add_right) zero_le) + rw [← hij, add_assoc] + exact mul_mem_decomposableAt A hi hjβ ha (SetLike.mul_mem_graded hb hy) + exact hle hz + +/-- **A cofactor evaluates into the square of the ideal of positive degree.** A homogeneous +polynomial of degree `g` with finite part `n ≥ 1`, free of the variables carrying that finite part, +has no monomial equal to a single variable, so each of its monomials splits into two factors of +nonzero degree. -/ +theorem aeval_mem_decomposableAt_of_mem_supported + (hmem : ∀ i, x i ∈ A (wt i)) (hne : ∀ i, wt i ≠ 0) + {V : MvPolynomial ι K} {g : NatOrdinal.{z}} + (hg : 0 < g.constantCoeff) (hV : IsWeightedHomogeneous wt V g) + (hsupp : V ∈ supported K {i | (wt i).constantCoeff ≠ g.constantCoeff}) : + aeval x V ∈ decomposableAt A g := by + classical + rw [V.as_sum, map_sum] + refine sum_mem fun d hd ↦ ?_ + have hwd : Finsupp.weight wt d = g := hV (mem_support_iff.mp hd) + -- the monomial has a variable `i` not carrying the finite part, and is not `X_i` alone + have hdne : d ≠ 0 := by + rintro rfl + rw [map_zero] at hwd + rw [← hwd, NatOrdinal.constantCoeff_zero] at hg + exact lt_irrefl _ hg + obtain ⟨i, hi⟩ := Finsupp.support_nonempty_iff.mpr hdne + have hik : (wt i).constantCoeff ≠ g.constantCoeff := + (mem_supported.mp hsupp) ((mem_vars_iff_mem_support i).mpr ⟨d, hd, hi⟩) + obtain ⟨d', hd'def⟩ : ∃ d', d' = d - Finsupp.single i 1 := ⟨_, rfl⟩ + have hsplit : Finsupp.weight wt d' + wt i = g := by + rw [hd'def, Finsupp.weight_sub_single_add (w := wt) (Finsupp.mem_support_iff.mp hi), hwd] + have hd'ne : d' ≠ 0 := by + intro h0 + rw [h0, map_zero, zero_add] at hsplit + exact hik (by rw [hsplit]) + obtain ⟨j, hj⟩ := Finsupp.support_nonempty_iff.mpr hd'ne + have hwd' : Finsupp.weight wt d' ≠ 0 := fun h ↦ by + have hle := Finsupp.le_weight_of_mem_support wt d' hj + rw [h] at hle + exact hne j (le_antisymm hle zero_le) + -- `X^d = X^{d'} * X_i` + have hmono : monomial d (V.coeff d) = C (V.coeff d) * (monomial d' 1 * X i) := by + rw [X, MvPolynomial.monomial_mul_monomial, mul_one, C_mul_monomial, mul_one, hd'def, + Finsupp.sub_add_single_one_cancel (Finsupp.mem_support_iff.mp hi)] + rw [hmono, map_mul, map_mul, ← algebraMap_eq, AlgHom.commutes, Algebra.algebraMap_eq_smul_one, + smul_mul_assoc, one_mul] + refine Submodule.smul_mem _ _ ?_ + have h1 : aeval x (monomial d' (1 : K)) ∈ A (Finsupp.weight wt d') := + aeval_mem_of_forall_mem hmem (isWeightedHomogeneous_monomial wt d' 1 rfl) + rw [aeval_X, ← hsplit] + exact mul_mem_decomposableAt A hwd' (hne i) h1 (hmem i) + +end OrdinalGraded + +end diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/GradedRing/HomogeneousSpan.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/GradedRing/HomogeneousSpan.lean new file mode 100644 index 0000000000..db51b235d1 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/GradedRing/HomogeneousSpan.lean @@ -0,0 +1,123 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.LoweringDerivation.Mu +public import Mathlib.LinearAlgebra.Finsupp.LinearCombination + +/-! +# Homogeneous components of the ideal generated by homogeneous elements + +Let `A` (Lean `R`) be an algebra graded by `NatOrdinal` and `q j ∈ A_{c j}` finitely many +homogeneous elements of degrees `c j`. The degree-`α` component of `(q j) r` is `(q j) r_β` for +the unique `β` with `β ⊕ c j = α`, that is `β = α ⊖ c j` when `c j ≼ α` in the algebraic order, +and `0` otherwise (the natural sum is cancellative, so `β` is unique when it exists, but unlike the +case of `ℕ` it need not exist: `β ⊕ 1 = ω` has no solution). Consequently a homogeneous element of +degree `α` of the ideal `(q j)` is `∑_j (q j) (u j)` with `u j ∈ A_{α ⊖ c j}` when `c j ≼ α`, +and `u j = 0` otherwise. +-/ + +universe u v w + +open DirectSum + +public noncomputable section + +namespace OrdinalGraded + +variable {E : Type u} {R : Type v} [Field E] [CommRing R] [Algebra E R] +variable {𝒜 : NatOrdinal → Submodule E R} [GradedAlgebra 𝒜] + +open Classical in +/-- The degree-`α` component of `q * r` for `q ∈ 𝒜 c`: `q * r_β` if `β ⊕ c = α`, and `0` if +`c` does not precede `α` in the algebraic order. -/ +theorem coe_decompose_mul_of_left_mem {q : R} {c : NatOrdinal} (hq : q ∈ 𝒜 c) (r : R) + (α : NatOrdinal) : + (decompose 𝒜 (q * r) α : R) = + if h : ∃ β, β + c = α then q * (decompose 𝒜 r (Classical.choose h) : R) else 0 := by + split_ifs with h + · obtain ⟨β₀, hβ₀⟩ : ∃ β₀, Classical.choose h = β₀ := ⟨_, rfl⟩ + have hβ : β₀ + c = α := hβ₀ ▸ Classical.choose_spec h + rw [hβ₀] + subst hβ + -- expand `r` into its components: only `q * r_β₀` has degree `β₀ + c` + rw [← GradedRing.proj_apply] + conv_lhs => rw [← sum_support_decompose 𝒜 r, Finset.mul_sum, map_sum] + have hmem : ∀ β, q * (decompose 𝒜 r β : R) ∈ 𝒜 (c + β) := fun β ↦ + SetLike.mul_mem_graded hq (decompose 𝒜 r β).2 + rw [Finset.sum_eq_single β₀] + · rw [GradedRing.proj_apply, add_comm] + exact decompose_of_mem_same 𝒜 (hmem β₀) + · intro β _ hβ + rw [GradedRing.proj_apply] + exact decompose_of_mem_ne 𝒜 (hmem β) fun heq ↦ + hβ (add_left_cancel (heq.trans (add_comm _ _))) + · intro hnot + rw [DFinsupp.notMem_support_iff.mp hnot, Submodule.coe_zero, mul_zero, map_zero] + · -- expand `r` into its components: every `q * r_β` has degree `c + β ≠ α` + rw [← GradedRing.proj_apply] + conv_lhs => rw [← sum_support_decompose 𝒜 r, Finset.mul_sum, map_sum] + refine Finset.sum_eq_zero fun β _ ↦ ?_ + have hmem : q * (decompose 𝒜 r β : R) ∈ 𝒜 (c + β) := + SetLike.mul_mem_graded hq (decompose 𝒜 r β).2 + rw [GradedRing.proj_apply] + exact decompose_of_mem_ne 𝒜 hmem fun heq ↦ h ⟨β, by rw [add_comm]; exact heq⟩ + +/-- **The homogeneous components of an element of the ideal generated by homogeneous elements.** +If `q j ∈ 𝒜 (c j)` and `x` lies in the ideal `(q j)`, then the degree-`α` component of `x` is +`∑_j (q j) (u j)` with `u j ∈ 𝒜 β` for the `β` with `β ⊕ c j = α`, and `u j = 0` if `c j` is not a +below `α` in the algebraic order. -/ +theorem exists_decompose_eq_sum_mul_of_mem_span {ι : Type w} [Fintype ι] {q : ι → R} + {c : ι → NatOrdinal} (hq : ∀ j, q j ∈ 𝒜 (c j)) {x : R} (hxI : x ∈ Ideal.span (Set.range q)) + (α : NatOrdinal) : + ∃ u : ι → R, (∀ j, ∀ β, β + c j = α → u j ∈ 𝒜 β) ∧ (∀ j, (¬ ∃ β, β + c j = α) → u j = 0) ∧ + (decompose 𝒜 x α : R) = ∑ j, q j * u j := by + classical + obtain ⟨r, hr⟩ := (Submodule.mem_span_range_iff_exists_fun R).mp hxI + have hr' : ∑ j, q j * r j = x := by + rw [← hr] + exact Finset.sum_congr rfl fun j _ ↦ by rw [smul_eq_mul, mul_comm] + refine ⟨fun j ↦ if h : ∃ β, β + c j = α then (decompose 𝒜 (r j) (Classical.choose h) : R) else 0, + fun j β hβ ↦ ?_, fun j h ↦ dite_eq_right h, ?_⟩ + · have h : ∃ β, β + c j = α := ⟨β, hβ⟩ + have hβ' : ∀ h' : ∃ β, β + c j = α, Classical.choose h' = β := fun h' ↦ + add_right_cancel ((Classical.choose_spec h').trans hβ.symm) + beta_reduce + rw [dite_eq_left h, hβ'] + exact (decompose 𝒜 (r j) β).2 + · calc (decompose 𝒜 x α : R) = GradedRing.proj 𝒜 α (∑ j, q j * r j) := by + rw [GradedRing.proj_apply, hr'] + _ = ∑ j, GradedRing.proj 𝒜 α (q j * r j) := map_sum _ _ _ + _ = _ := Finset.sum_congr rfl fun j _ ↦ by + rw [GradedRing.proj_apply, coe_decompose_mul_of_left_mem (hq j) (r j) α, mul_dite, + mul_zero] + +/-- **Homogeneous elements of the ideal generated by homogeneous elements.** If `q j ∈ 𝒜 (c j)` +and `x ∈ 𝒜 α` lies in the ideal `(q j)`, then `x = ∑_j (q j) (u j)`, where `u j ∈ 𝒜 β` +whenever `β ⊕ c j = α`, and `u j = 0` if no such `β` exists. -/ +@[blueprint "lem:homogeneous-element-of-generated-ideal" + (phase := "Algebraic and ordinal preliminaries") + (title := "Homogeneous decomposition in a finitely generated graded ideal") + (statement := /-- + For a finite family of homogeneous elements $Q_j\in A_{c_j}$, if + $x\in A_\alpha$ lies in the ideal generated by the $Q_j$, then there are + $u_j$ such that $x=\sum_jQ_ju_j$, where $u_j\in A_\beta$ whenever + $\beta\oplus c_j=\alpha$, and $u_j=0$ if no such $\beta$ exists. + -/) + (proof := /-- + Apply the componentwise ideal representation and use $x_\alpha=x$. + -/)] +theorem exists_eq_sum_mul_of_mem_span {ι : Type w} [Fintype ι] {q : ι → R} {c : ι → NatOrdinal} + (hq : ∀ j, q j ∈ 𝒜 (c j)) {x : R} {α : NatOrdinal} (hx : x ∈ 𝒜 α) + (hxI : x ∈ Ideal.span (Set.range q)) : + ∃ u : ι → R, (∀ j, ∀ β, β + c j = α → u j ∈ 𝒜 β) ∧ (∀ j, (¬ ∃ β, β + c j = α) → u j = 0) ∧ + x = ∑ j, q j * u j := by + obtain ⟨u, hu, hu0, hsum⟩ := exists_decompose_eq_sum_mul_of_mem_span hq hxI α + exact ⟨u, hu, hu0, by rw [← hsum, decompose_of_mem_same 𝒜 hx]⟩ + +end OrdinalGraded diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/GradedRing/HomogeneousZeroDivisors.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/GradedRing/HomogeneousZeroDivisors.lean new file mode 100644 index 0000000000..620f31da59 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/GradedRing/HomogeneousZeroDivisors.lean @@ -0,0 +1,35 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import Mathlib.RingTheory.GradedAlgebra.Radical + +/-! +# Graded rings without homogeneous zero divisors + +A commutative ring graded by a linearly ordered cancellative monoid in which the product of two +nonzero homogeneous elements is nonzero is a domain: the zero ideal is homogeneous, and a +homogeneous ideal which is prime on homogeneous elements is prime +(`Ideal.IsHomogeneous.isPrime_of_homogeneous_mem_or_mem`). +-/ + +public section + +variable {ι σ A : Type*} [CommRing A] [AddCommMonoid ι] [LinearOrder ι] + [IsOrderedCancelAddMonoid ι] [SetLike σ A] [AddSubmonoidClass σ A] + +/-- A graded ring in which a product of homogeneous elements vanishes only if one factor does is +a domain. -/ +theorem GradedRing.isDomain_of_homogeneous_eq_zero_or_eq_zero (𝒜 : ι → σ) [GradedRing 𝒜] + [Nontrivial A] + (h : ∀ {x y : A}, SetLike.IsHomogeneousElem 𝒜 x → SetLike.IsHomogeneousElem 𝒜 y → + x * y = 0 → x = 0 ∨ y = 0) : IsDomain A := + have : (⊥ : Ideal A).IsPrime := + (Ideal.IsHomogeneous.bot 𝒜).isPrime_of_homogeneous_mem_or_mem bot_ne_top fun hx hy hxy ↦ by + simpa only [Ideal.mem_bot] using h hx hy (Ideal.mem_bot.mp hxy) + IsDomain.of_bot_isPrime A + +end diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/GradedRing/OrdinalGenerators.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/GradedRing/OrdinalGenerators.lean new file mode 100644 index 0000000000..b30a12e082 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/GradedRing/OrdinalGenerators.lean @@ -0,0 +1,616 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.LoweringDerivation.Mu +public import Mathlib.Algebra.MvPolynomial.Eval +public import Mathlib.RingTheory.MvPolynomial.WeightedHomogeneous +public import Mathlib.Algebra.MvPolynomial.Variables + +/-! +# Homogeneous generators of an ordinal-graded algebra + +Let `A` (Lean `R`) be a commutative algebra over a field `E` graded by `NatOrdinal` (the ordinals +under the natural sum `⊕`), so that `A_i A_j ⊆ A_{i ⊕ j}`. Let `A_+ := ⨁_{β ≠ 0} A_β` be the ideal +of elements of positive degree; its square meets `A_β` in +`(A_+)² ∩ A_β = ∑_{i ⊕ j = β, i, j ≠ 0} A_i A_j` (the decomposable elements of degree `β`; Lean +`decomposableAt 𝒜 β`). A *minimal system of homogeneous generators* is a family of homogeneous +elements `x i ∈ A_{wt i}` of positive degree whose members of each degree `β` are linearly +independent modulo `(A_+)² ∩ A_β` and span `A_β` modulo it — a basis of a complement of +`(A_+)² ∩ A_β` in `A_β` for every `β ≠ 0`. Evaluation `E[X_i] → A`, `X_i ↦ x i`, is then graded +for the degrees `deg X_i = wt i` (Mathlib's `IsWeightedHomogeneous wt`) and surjective, by +well-founded induction on the degree. Whether it is injective is the question whether `A` is a +polynomial algebra on the generators; this file only names the homogeneous pieces of that question, +`InjectiveAt β` (evaluation is injective in degree `β`), and shows that they assemble into the +injectivity of evaluation. The finite-degree theory of +`ConwayRefinement.Algebra.LoweringDerivation` is the case of degrees in `ℕ`. +-/ + +universe u v w o + +open LoweringDerivation MvPolynomial + +public noncomputable section + +namespace OrdinalGraded + +variable {E : Type u} {R : Type v} [Field E] [CommRing R] [Algebra E R] +variable (𝒜 : NatOrdinal.{o} → Submodule E R) [GradedAlgebra 𝒜] + +/-! ### The square of the ideal of positive degree -/ + +/-- `(A_+)² ∩ A_β = ∑_{i ⊕ j = β, i, j ≠ 0} A_i A_j`, the square of the ideal of positive degree +in degree `β`. -/ +def decomposableAt (β : NatOrdinal.{o}) : Submodule E R := + ⨆ (i : NatOrdinal.{o}) (j : NatOrdinal.{o}) (_ : i ≠ 0) (_ : j ≠ 0) (_ : i + j = β), 𝒜 i * 𝒜 j + +omit [GradedAlgebra 𝒜] in +theorem decomposableAt_le {β : NatOrdinal.{o}} {N : Submodule E R} + (h : ∀ i j : NatOrdinal.{o}, i ≠ 0 → j ≠ 0 → i + j = β → 𝒜 i * 𝒜 j ≤ N) : + decomposableAt 𝒜 β ≤ N := + iSup_le fun i ↦ iSup_le fun j ↦ iSup_le fun hi ↦ iSup_le fun hj ↦ iSup_le fun hij ↦ + h i j hi hj hij + +omit [GradedAlgebra 𝒜] in +theorem mul_mem_decomposableAt {i j : NatOrdinal.{o}} (hi : i ≠ 0) (hj : j ≠ 0) {a b : R} + (ha : a ∈ 𝒜 i) (hb : b ∈ 𝒜 j) : a * b ∈ decomposableAt 𝒜 (i + j) := + Submodule.mem_iSup_of_mem i (Submodule.mem_iSup_of_mem j (Submodule.mem_iSup_of_mem hi + (Submodule.mem_iSup_of_mem hj (Submodule.mem_iSup_of_mem rfl (Submodule.mul_mem_mul ha hb))))) + +/-- `(A_+)² ∩ A_β` lies in `A_β`. -/ +theorem decomposableAt_le_degree (β : NatOrdinal.{o}) : decomposableAt 𝒜 β ≤ 𝒜 β := + decomposableAt_le 𝒜 fun i j _ _ hij ↦ by + rw [← hij] + exact Submodule.mul_le.mpr fun a ha b hb ↦ SetLike.mul_mem_graded ha hb + +/-! ### Minimal systems of homogeneous generators -/ + +variable {ι : Type w} (wt : ι → NatOrdinal.{o}) (x : ι → R) + +/-- A minimal system of homogeneous generators of an ordinal-graded algebra: homogeneous elements +`x i ∈ A_{wt i}` of positive degree whose members of degree `β` are linearly independent modulo +`(A_+)² ∩ A_β = ∑_{i ⊕ j = β, i, j ≠ 0} A_i A_j` and span `A_β` modulo it, for every `β ≠ 0`. -/ +structure IsMinimalSystem : Prop where + /-- Every generator has positive degree. -/ + ne_zero : ∀ i, wt i ≠ 0 + /-- `x i` is homogeneous of degree `wt i`. -/ + mem : ∀ i, x i ∈ 𝒜 (wt i) + /-- The generators of degree `β` are linearly independent modulo `(A_+)² ∩ A_β`. -/ + independent : ∀ (β : NatOrdinal.{o}) (c : ι →₀ E), (∀ i ∈ c.support, wt i = β) → + Finsupp.linearCombination E x c ∈ decomposableAt 𝒜 β → c = 0 + /-- The generators of degree `β` span `A_β` modulo `(A_+)² ∩ A_β`, for `β ≠ 0`. -/ + spans : ∀ β : NatOrdinal.{o}, β ≠ 0 → ∀ y ∈ 𝒜 β, ∃ c : ι →₀ E, + (∀ i ∈ c.support, wt i = β) ∧ y - Finsupp.linearCombination E x c ∈ decomposableAt 𝒜 β + +variable {𝒜 wt x} + +/-! ### Graded evaluation -/ + +/-- Evaluation of a polynomial homogeneous of degree `β` (for `deg X_i = wt i`) at homogeneous +elements `x i ∈ A_{wt i}` lands in `A_β`. -/ +theorem aeval_mem_of_forall_mem (hmem : ∀ i, x i ∈ 𝒜 (wt i)) {F : MvPolynomial ι E} + {β : NatOrdinal.{o}} (hF : IsWeightedHomogeneous wt F β) : aeval x F ∈ 𝒜 β := by + induction hF using IsWeightedHomogeneous.induction_on with + | zero => rw [map_zero]; exact zero_mem _ + | add p q hp hq ihp ihq => rw [map_add]; exact add_mem ihp ihq + | monomial d r hr => + rw [aeval_monomial, ← hr, Finsupp.weight_apply, Finsupp.sum, Finsupp.prod] + have h1 : ∏ i ∈ d.support, x i ^ d i ∈ 𝒜 (∑ i ∈ d.support, d i • wt i) := + SetLike.prod_mem_graded 𝒜 (fun i ↦ d i • wt i) (fun i ↦ x i ^ d i) + fun i _ ↦ SetLike.pow_mem_graded _ (hmem i) + have h2 := SetLike.mul_mem_graded (SetLike.algebraMap_mem_graded 𝒜 r) h1 + rwa [zero_add] at h2 + +/-- Evaluation at homogeneous `x i ∈ A_{wt i}` is graded: the degree-`β` component of `F(x)` is +the evaluation of the degree-`β` component of `F`. -/ +theorem decompose_aeval (hmem : ∀ i, x i ∈ 𝒜 (wt i)) (F : MvPolynomial ι E) (β : NatOrdinal.{o}) : + (DirectSum.decompose 𝒜 (aeval x F) β : R) = + aeval x (weightedHomogeneousComponent wt β F) := by + classical + have hmem' : ∀ m : NatOrdinal.{o}, aeval x (weightedHomogeneousComponent wt m F) ∈ 𝒜 m := + fun m ↦ aeval_mem_of_forall_mem hmem + (weightedHomogeneousComponent_isWeightedHomogeneous (w := wt) (n := m) (φ := F)) + conv_lhs => rw [← sum_weightedHomogeneousComponent wt F, + finsum_eq_sum _ (weightedHomogeneousComponent_finsupp F), map_sum, DirectSum.decompose_sum, + DirectSum.sum_apply, Submodule.coe_sum] + rw [Finset.sum_eq_single β (fun m _ hne ↦ DirectSum.decompose_of_mem_ne 𝒜 (hmem' m) hne) + fun hn ↦ ?_, DirectSum.decompose_of_mem_same 𝒜 (hmem' β)] + have hz : weightedHomogeneousComponent wt β F = 0 := by + apply not_not.mp + intro hz + exact hn ((weightedHomogeneousComponent_finsupp F).mem_toFinset.mpr hz) + rw [hz, map_zero, DirectSum.decompose_zero, DirectSum.zero_apply, Submodule.coe_zero] + +/-- A linear combination of the generators is the evaluation of the same combination of the +variables. -/ +theorem aeval_linearCombination_X (c : ι →₀ E) : + aeval x (Finsupp.linearCombination E (X : ι → MvPolynomial ι E) c) = + Finsupp.linearCombination E x c := by + rw [← AlgHom.toLinearMap_apply, Finsupp.apply_linearCombination] + congr 2 + funext i + exact aeval_X x i + +/-- A linear combination of variables of degree `β` is homogeneous of degree `β`. -/ +theorem isWeightedHomogeneous_linearCombination_X {β : NatOrdinal.{o}} (c : ι →₀ E) + (hc : ∀ i ∈ c.support, wt i = β) : + IsWeightedHomogeneous wt (Finsupp.linearCombination E (X : ι → MvPolynomial ι E) c) β := by + rw [Finsupp.linearCombination_apply, Finsupp.sum] + refine IsWeightedHomogeneous.sum _ _ _ fun i hi ↦ ?_ + rw [smul_eq_C_mul] + have := (isWeightedHomogeneous_C wt (c i)).mul (isWeightedHomogeneous_X E wt i) + rwa [zero_add, hc i hi] at this + +/-! ### Generation -/ + +namespace IsMinimalSystem + +variable (hx : IsMinimalSystem 𝒜 wt x) +include hx + +omit hx [GradedAlgebra 𝒜] in +private theorem map_decomposableAt + {S : Type*} [CommRing S] [Algebra E S] + {ℬ : NatOrdinal.{o} → Submodule E S} + (e : R ≃ₐ[E] S) (hgrade : ∀ (n : NatOrdinal.{o}) (r : R), r ∈ 𝒜 n ↔ e r ∈ ℬ n) + {n : NatOrdinal.{o}} {r : R} (hr : r ∈ decomposableAt 𝒜 n) : + e r ∈ decomposableAt ℬ n := by + apply (decomposableAt_le 𝒜 fun i j hi hj hij ↦ ?_ : + decomposableAt 𝒜 n ≤ (decomposableAt ℬ n).comap e.toLinearMap) hr + apply Submodule.mul_le.mpr + intro a ha b hb + change e (a * b) ∈ decomposableAt ℬ n + rw [show e (a * b) = e a * e b from map_mul e a b, ← hij] + exact mul_mem_decomposableAt ℬ hi hj (hgrade i a |>.mp ha) (hgrade j b |>.mp hb) + +omit hx [GradedAlgebra 𝒜] in +private theorem symm_mem_decomposableAt + {S : Type*} [CommRing S] [Algebra E S] + {ℬ : NatOrdinal.{o} → Submodule E S} + (e : R ≃ₐ[E] S) (hgrade : ∀ (n : NatOrdinal.{o}) (r : R), r ∈ 𝒜 n ↔ e r ∈ ℬ n) + {n : NatOrdinal.{o}} {s : S} (hs : s ∈ decomposableAt ℬ n) : + e.symm s ∈ decomposableAt 𝒜 n := by + apply (decomposableAt_le ℬ fun i j hi hj hij ↦ ?_ : + decomposableAt ℬ n ≤ (decomposableAt 𝒜 n).comap e.symm.toLinearMap) hs + apply Submodule.mul_le.mpr + intro a ha b hb + change e.symm (a * b) ∈ decomposableAt 𝒜 n + rw [show e.symm (a * b) = e.symm a * e.symm b from map_mul e.symm a b, ← hij] + exact mul_mem_decomposableAt 𝒜 hi hj + ((hgrade i (e.symm a)).mpr (by simpa)) ((hgrade j (e.symm b)).mpr (by simpa)) + +omit [GradedAlgebra 𝒜] in +/-- An algebra equivalence preserving every homogeneous component carries minimal systems to +minimal systems. -/ +theorem map_algEquiv + {S : Type*} [CommRing S] [Algebra E S] + {ℬ : NatOrdinal.{o} → Submodule E S} + (e : R ≃ₐ[E] S) (hgrade : ∀ (n : NatOrdinal.{o}) (r : R), r ∈ 𝒜 n ↔ e r ∈ ℬ n) : + IsMinimalSystem ℬ wt (fun i ↦ e (x i)) where + ne_zero := hx.ne_zero + mem i := (hgrade (wt i) (x i)).mp (hx.mem i) + independent β c hc hmem := by + apply hx.independent β c hc + have hlc : e (Finsupp.linearCombination E x c) = + Finsupp.linearCombination E (fun i ↦ e (x i)) c := by + rw [Finsupp.linearCombination_apply, Finsupp.linearCombination_apply, + Finsupp.sum, Finsupp.sum, map_sum] + apply Finset.sum_congr rfl + intro i _ + exact map_smul e (c i) (x i) + have hmem' : e (Finsupp.linearCombination E x c) ∈ decomposableAt ℬ β := by + rw [hlc] + exact hmem + simpa only [AlgEquiv.symm_apply_apply] using + symm_mem_decomposableAt e hgrade hmem' + spans β hβ y hy := by + obtain ⟨c, hc, hmem⟩ := hx.spans β hβ (e.symm y) + ((hgrade β (e.symm y)).mpr (by simpa)) + refine ⟨c, hc, ?_⟩ + have hlc : e (Finsupp.linearCombination E x c) = + Finsupp.linearCombination E (fun i ↦ e (x i)) c := by + rw [Finsupp.linearCombination_apply, Finsupp.linearCombination_apply, + Finsupp.sum, Finsupp.sum, map_sum] + apply Finset.sum_congr rfl + intro i _ + exact map_smul e (c i) (x i) + have hmem' := map_decomposableAt e hgrade hmem + simpa only [map_sub, AlgEquiv.apply_symm_apply, hlc] using hmem' + +omit [GradedAlgebra 𝒜] in +/-- No generator of a minimal system is zero: zero lies in `(A_+)² ∩ A_β`. -/ +theorem apply_ne_zero (i : ι) : x i ≠ 0 := by + intro h0 + have h := hx.independent (wt i) (Finsupp.single i 1) (fun j hj ↦ by + rw [((Finsupp.mem_support_single j i 1).mp hj).1]) (by + rw [Finsupp.linearCombination_single, one_smul, h0] + exact zero_mem _) + exact one_ne_zero (Finsupp.single_eq_zero.mp h) + +/-- Evaluation of a polynomial homogeneous of degree `β` lands in `A_β`. -/ +theorem aeval_mem {F : MvPolynomial ι E} {β : NatOrdinal.{o}} (hF : IsWeightedHomogeneous wt F β) : + aeval x F ∈ 𝒜 β := + aeval_mem_of_forall_mem hx.mem hF + +omit [GradedAlgebra 𝒜] in +/-- Every element of `A_β` is the evaluation of a weighted-homogeneous polynomial of weight `β` +at a minimal system relative to the family `𝒜`. -/ +@[blueprint "lem:generate" + (phase := "Algebraic and ordinal preliminaries") + (title := "Weighted-homogeneous polynomial representatives") + (statement := /-- + Let $E$ be a field, let $R$ be a commutative $E$-algebra, and let + $(A_\alpha)_{\alpha\in\mathbf{On}}$ be a family of $E$-subspaces of $R$. + Put + \[ + D_\beta=\sum_{\substack{i\oplus j=\beta\\i,j\ne0}}A_iA_j. + \] + Let $(x_i,w_i)$ have positive weights, with $x_i\in A_{w_i}$. Suppose the + $x_i$ of weight $\beta$ are independent modulo $D_\beta$ for every + $\beta$ and span $A_\beta$ modulo $D_\beta$ whenever $\beta\ne0$. + If every element of $A_0$ is a scalar from $E$, then every $y\in A_\beta$ + equals $F(x)$ for some $F\in E[X_i:i\in I]$ weighted-homogeneous of + weight $\beta$. + -/) + (proof := /-- + Proceed by well-founded induction on $\beta$. At weight zero the hypothesis + makes $y$ a constant polynomial value. At positive weight, write $y$ modulo + $D_\beta$ as a linear combination of the weight-$\beta$ generators. Every + product defining $D_\beta$ has two positive weights strictly below $\beta$, + so induction represents both factors by weighted-homogeneous polynomials. + Adding their products to the linear combination gives the required polynomial. + -/)] +theorem exists_aeval_eq (h0 : GradeZeroScalars 𝒜) (β : NatOrdinal.{o}) : + ∀ y ∈ 𝒜 β, ∃ F : MvPolynomial ι E, IsWeightedHomogeneous wt F β ∧ aeval x F = y := by + induction β using WellFoundedLT.induction with + | _ β ih => + intro y hy + rcases eq_or_ne β 0 with rfl | hβ + · obtain ⟨e, rfl⟩ := (gradeZeroScalars_iff 𝒜).mp h0 y hy + exact ⟨C e, isWeightedHomogeneous_C wt e, aeval_C x e⟩ + · obtain ⟨c, hcw, hc⟩ := hx.spans β hβ y hy + -- the elements of degree `β` that are values of homogeneous polynomials form a submodule + -- containing `(A_+)² ∩ A_β` + let N : Submodule E R := + { carrier := {z | ∃ F : MvPolynomial ι E, IsWeightedHomogeneous wt F β ∧ aeval x F = z} + zero_mem' := ⟨0, isWeightedHomogeneous_zero E wt β, map_zero _⟩ + add_mem' := fun ⟨F, hF, hFz⟩ ⟨G, hG, hGz⟩ ↦ + ⟨F + G, hF.add hG, by rw [map_add, hFz, hGz]⟩ + smul_mem' := fun e _ ⟨F, hF, hFz⟩ ↦ + ⟨C e * F, by simpa using (isWeightedHomogeneous_C wt e).mul hF, + by rw [map_mul, aeval_C, hFz, Algebra.smul_def]⟩ } + have hD : decomposableAt 𝒜 β ≤ N := by + refine decomposableAt_le 𝒜 fun i j hi hj hij ↦ Submodule.mul_le.mpr fun a ha b hb ↦ ?_ + have hi' : i < β := hij ▸ lt_add_of_pos_right i (pos_iff_ne_zero.mpr hj) + have hj' : j < β := hij ▸ lt_add_of_pos_left j (pos_iff_ne_zero.mpr hi) + obtain ⟨F, hF, hFa⟩ := ih i hi' a ha + obtain ⟨G, hG, hGb⟩ := ih j hj' b hb + exact ⟨F * G, hij ▸ hF.mul hG, by rw [map_mul, hFa, hGb]⟩ + obtain ⟨G, hG, hGz⟩ := hD hc + refine ⟨G + Finsupp.linearCombination E (X : ι → MvPolynomial ι E) c, + hG.add (isWeightedHomogeneous_linearCombination_X c hcw), ?_⟩ + rw [map_add, hGz, aeval_linearCombination_X, sub_add_cancel] + +/-- Evaluation is surjective. -/ +theorem aeval_surjective (h0 : GradeZeroScalars 𝒜) : + Function.Surjective (aeval x : MvPolynomial ι E →ₐ[E] R) := by + intro y + induction y using DirectSum.Decomposition.inductionOn 𝒜 with + | zero => exact ⟨0, map_zero _⟩ + | homogeneous z => + obtain ⟨F, -, hF⟩ := hx.exists_aeval_eq h0 _ z.1 z.2 + exact ⟨F, hF⟩ + | add y z hy hz => + obtain ⟨F, rfl⟩ := hy + obtain ⟨G, rfl⟩ := hz + exact ⟨F + G, map_add _ _ _⟩ + +end IsMinimalSystem + +/-! ### Homogeneous polynomials of degree zero -/ + +omit [GradedAlgebra 𝒜] in +/-- For degrees `wt i ≠ 0`, a polynomial homogeneous of degree zero is a constant. -/ +theorem eq_C_of_isWeightedHomogeneous_zero (hwt : ∀ i, wt i ≠ 0) {p : MvPolynomial ι E} + (hp : IsWeightedHomogeneous wt p 0) : p = C (p.coeff 0) := by + classical + ext m + rw [coeff_C] + split_ifs with hm + · rw [hm] + · by_contra h + have hw := hp h + obtain ⟨i, hi⟩ := Finsupp.support_nonempty_iff.mpr (fun h ↦ hm h.symm) + have hi' : m i ≠ 0 := Finsupp.mem_support_iff.mp hi + rw [Finsupp.weight_apply, Finsupp.sum, + Finset.sum_eq_zero_iff_of_nonneg fun _ _ ↦ bot_le] at hw + have h1 : wt i ≤ m i • wt i := by + simpa using nsmul_le_nsmul_left (bot_le : (0 : NatOrdinal.{o}) ≤ wt i) + (Nat.one_le_iff_ne_zero.mpr hi') + exact hwt i (le_antisymm (h1.trans_eq (hw i hi)) bot_le) + +/-! ### Injectivity degree by degree -/ + +variable (E wt x) in +/-- Evaluation is injective in degree `β`: `F = 0` is the only polynomial homogeneous of degree `β` +with `F(x) = 0`. -/ +def InjectiveAt (β : NatOrdinal.{o}) : Prop := + ∀ F : MvPolynomial ι E, IsWeightedHomogeneous wt F β → + (aeval x : MvPolynomial ι E →ₐ[E] R) F = 0 → F = 0 + +omit [GradedAlgebra 𝒜] in +theorem injectiveAt_iff (β : NatOrdinal.{o}) : + InjectiveAt E wt x β ↔ + ∀ F : MvPolynomial ι E, IsWeightedHomogeneous wt F β → + (aeval x : MvPolynomial ι E →ₐ[E] R) F = 0 → F = 0 := + Iff.rfl + +omit [GradedAlgebra 𝒜] in +/-- In degree zero evaluation is injective: a homogeneous polynomial of degree zero is a scalar. -/ +theorem injectiveAt_zero [Nontrivial R] (hwt : ∀ i, wt i ≠ 0) : InjectiveAt E wt x 0 := by + intro F hF hF0 + rw [eq_C_of_isWeightedHomogeneous_zero hwt hF] at hF0 ⊢ + rw [aeval_C] at hF0 + rw [(algebraMap E R).injective (hF0.trans (map_zero _).symm), map_zero] + +omit [GradedAlgebra 𝒜] in +/-- Injectivity in every ordinal degree follows from the zero, successor, and limit cases. -/ +theorem injectiveAt_of_zero_successor_limit + (hzero : InjectiveAt E wt x 0) + (hsuccessor : ∀ α : NatOrdinal.{o}, α.constantCoeff ≠ 0 → + (∀ β < α, InjectiveAt E wt x β) → InjectiveAt E wt x α) + (hlimit : ∀ α : NatOrdinal.{o}, α ≠ 0 → α.constantCoeff = 0 → + (∀ β < α, InjectiveAt E wt x β) → InjectiveAt E wt x α) : + ∀ α, InjectiveAt E wt x α := by + intro α + induction α using WellFoundedLT.induction with + | _ α ih => + rcases eq_or_ne α 0 with rfl | hα + · exact hzero + · by_cases hcc : α.constantCoeff = 0 + · exact hlimit α hα hcc ih + · exact hsuccessor α hcc ih + +/-- Injectivity in every degree gives injectivity of evaluation. -/ +theorem aeval_injective_of_forall_injectiveAt (hmem : ∀ i, x i ∈ 𝒜 (wt i)) + (h : ∀ β, InjectiveAt E wt x β) : + Function.Injective (aeval x : MvPolynomial ι E →ₐ[E] R) := by + classical + rw [injective_iff_map_eq_zero] + intro F hF + have hcomp : ∀ m : NatOrdinal.{o}, aeval x (weightedHomogeneousComponent wt m F) = 0 := fun m ↦ by + rw [← decompose_aeval hmem, hF, DirectSum.decompose_zero, DirectSum.zero_apply, + Submodule.coe_zero] + conv_lhs => rw [← sum_weightedHomogeneousComponent wt F, + finsum_eq_sum _ (weightedHomogeneousComponent_finsupp F)] + exact Finset.sum_eq_zero fun m _ ↦ h m _ + (weightedHomogeneousComponent_isWeightedHomogeneous (w := wt) (n := m) (φ := F)) (hcomp m) + +/-! ### The linear part of a homogeneous polynomial -/ + +/-- A polynomial homogeneous of degree `β ≠ 0` evaluates at homogeneous generators of positive +degree to its linear part in the degree-`β` variables plus an element of `(A_+)² ∩ A_β`; the +linear coefficients are read off the polynomial. -/ +@[blueprint "lem:homogeneous-polynomial-linear-term" + (phase := "Algebraic and ordinal preliminaries") + (title := "Linear part of a weighted-homogeneous polynomial") + (statement := /-- + Let $E$ be a field and let $A=\bigoplus_{\alpha\in\mathbf{On}}A_\alpha$ + be a commutative $E$-algebra graded by the ordinals in a fixed universe, + with multiplication graded by Hessenberg sum. Let $(x_i)_{i\in I}$ satisfy + $x_i\in A_{w(i)}$ with $w(i)\neq0$. If + $F\in E[X_i:i\in I]$ is weighted-homogeneous of degree $\beta\neq0$, then + \[ + F(x)\equiv\sum_{w(i)=\beta}c_i x_i \bmod (A_+)^2\cap A_\beta, + \] + where $c_i$ is the coefficient of $X_i$ in $F$. + -/) + (proof := /-- + It suffices to inspect one monomial. A monomial $cX_i$ of degree $\beta$ + contributes its linear term, while every other nonconstant monomial factors + into two positive-degree monomials and therefore evaluates into + $(A_+)^2\cap A_\beta$. + -/)] +theorem exists_linear_part (hwt : ∀ i, wt i ≠ 0) (hmem : ∀ i, x i ∈ 𝒜 (wt i)) + {F : MvPolynomial ι E} {β : NatOrdinal.{o}} (hβ : β ≠ 0) (hF : IsWeightedHomogeneous wt F β) : + ∃ c : ι →₀ E, (∀ i ∈ c.support, wt i = β) ∧ + aeval x F - Finsupp.linearCombination E x c ∈ decomposableAt 𝒜 β ∧ + ∀ i, c i = F.coeff (Finsupp.single i 1) := by + classical + induction hF using IsWeightedHomogeneous.induction_on with + | zero => exact ⟨0, by simp, by simp, fun i ↦ by simp⟩ + | add p q hp hq ihp ihq => + obtain ⟨c, hcw, hc, hcoeff⟩ := ihp + obtain ⟨c', hcw', hc', hcoeff'⟩ := ihq + refine ⟨c + c', fun i hi ↦ ?_, ?_, fun i ↦ by + rw [Finsupp.add_apply, hcoeff, hcoeff', AddMonoidAlgebra.coeff_add, Finsupp.add_apply]⟩ + · rcases Finset.mem_union.mp (Finsupp.support_add hi) with h | h + · exact hcw i h + · exact hcw' i h + · rw [map_add, map_add] + have := add_mem hc hc' + convert this using 1 + abel + | monomial d r hr => + by_cases hd : ∃ i, d = Finsupp.single i 1 + · obtain ⟨i, rfl⟩ := hd + refine ⟨Finsupp.single i r, fun j hj ↦ ?_, ?_, fun j ↦ ?_⟩ + · rw [Finsupp.mem_support_iff, Finsupp.single_apply] at hj + split_ifs at hj with h + · subst h + rw [Finsupp.weight_single, one_smul] at hr + exact hr + · exact absurd rfl hj + · have hprod : (Finsupp.single i 1).prod (fun j k ↦ x j ^ k) = x i := by + simp + rw [Finsupp.linearCombination_single, aeval_monomial, hprod, Algebra.smul_def, sub_self] + exact zero_mem _ + · rw [Finsupp.single_apply, coeff_monomial] + by_cases h : i = j + · subst h; simp + · rw [ite_eq_right h, ite_eq_right] + intro h' + exact h (Finsupp.single_left_injective one_ne_zero h') + · push Not at hd + refine ⟨0, by simp, ?_, fun j ↦ by rw [Finsupp.coe_zero, Pi.zero_apply, coeff_monomial, + ite_eq_right (hd j)]⟩ + rw [map_zero, sub_zero] + -- `d` has at least two factors: split off one variable + have hd0 : d ≠ 0 := by + rintro rfl + rw [map_zero] at hr + exact hβ hr.symm + obtain ⟨i, hi⟩ := Finsupp.support_nonempty_iff.mpr hd0 + have hi' : d i ≠ 0 := Finsupp.mem_support_iff.mp hi + set d' := d - Finsupp.single i 1 with hd' + have hdd' : d = Finsupp.single i 1 + d' := by + rw [hd', add_comm, tsub_add_cancel_of_le] + intro y + rw [Finsupp.single_apply] + split_ifs with hy + · subst hy; exact Nat.pos_of_ne_zero hi' + · exact Nat.zero_le _ + have hd'0 : d' ≠ 0 := by + intro h + rw [h, add_zero] at hdd' + exact hd i hdd' + have hw' : Finsupp.weight wt d' + wt i = β := by + rw [← hr, hdd', map_add, Finsupp.weight_single, one_smul, add_comm] + have hw'1 : Finsupp.weight wt d' ≠ 0 := by + obtain ⟨j, hj⟩ := Finsupp.support_nonempty_iff.mpr hd'0 + have hj' := Finsupp.mem_support_iff.mp hj + intro h0 + rw [Finsupp.weight_apply, Finsupp.sum, + Finset.sum_eq_zero_iff_of_nonneg fun _ _ ↦ bot_le] at h0 + have h1 : wt j ≤ d' j • wt j := by + simpa using nsmul_le_nsmul_left (bot_le : (0 : NatOrdinal.{o}) ≤ wt j) + (Nat.one_le_iff_ne_zero.mpr hj') + exact hwt j (le_antisymm (h1.trans_eq (h0 j hj)) bot_le) + have hmono : monomial d r = X i * monomial d' r := by + rw [hdd', add_comm, monomial_add_single, pow_one, mul_comm] + rw [hmono, map_mul, aeval_X, ← hw', add_comm] + exact mul_mem_decomposableAt 𝒜 (hwt i) hw'1 (hmem i) + (aeval_mem_of_forall_mem hmem (isWeightedHomogeneous_monomial wt d' r rfl)) + +/-! ### Monomials of degree zero -/ + +omit [GradedAlgebra 𝒜] in +/-- For degrees `wt i ≠ 0`, only the constant monomial has degree zero. -/ +theorem eq_zero_of_weight_eq_zero (hwt : ∀ i, wt i ≠ 0) {d : ι →₀ ℕ} + (hd : Finsupp.weight wt d = 0) : d = 0 := by + by_contra hne + obtain ⟨i, hi⟩ := Finsupp.support_nonempty_iff.mpr hne + have hi' : d i ≠ 0 := Finsupp.mem_support_iff.mp hi + rw [Finsupp.weight_apply, Finsupp.sum, Finset.sum_eq_zero_iff_of_nonneg fun _ _ ↦ bot_le] at hd + have h1 : wt i ≤ d i • wt i := by + simpa using nsmul_le_nsmul_left (bot_le : (0 : NatOrdinal.{o}) ≤ wt i) + (Nat.one_le_iff_ne_zero.mpr hi') + exact hwt i (le_antisymm (h1.trans_eq (hd i hi)) bot_le) + +/-! ### Relations have no linear part and only variables of smaller degree -/ + +namespace IsMinimalSystem + +variable (hx : IsMinimalSystem 𝒜 wt x) +include hx + +/-- A homogeneous relation `F(x) = 0` of degree `β ≠ 0` has no linear monomial: its linear part is +a combination of the generators of degree `β` lying in `(A_+)² ∩ A_β`. -/ +@[blueprint "lem:minimal-generators-relation-has-no-linear-term" + (phase := "Algebraic and ordinal preliminaries") + (title := "Vanishing of the linear part of a homogeneous relation") + (statement := /-- + If $(x_i)_{i\in I}$ is a minimal system of homogeneous generators and the + weighted-homogeneous polynomial $F$ of nonzero degree $\beta$ satisfies + $F(x)=0$, then the coefficient of every linear monomial $X_i$ in $F$ is + zero. + -/) + (proof := /-- + \ref{lem:homogeneous-polynomial-linear-term} places the linear + combination of the degree-$\beta$ generators in + $(A_+)^2\cap A_\beta$. Their defining independence modulo this subspace + kills every coefficient. + -/)] +theorem coeff_single_eq_zero_of_aeval_eq_zero + {F : MvPolynomial ι E} {β : NatOrdinal.{o}} (hβ : β ≠ 0) + (hF : IsWeightedHomogeneous wt F β) (h0 : aeval x F = 0) (i : ι) : + F.coeff (Finsupp.single i 1) = 0 := by + obtain ⟨c, hcw, hc, hcoeff⟩ := exists_linear_part hx.ne_zero hx.mem hβ hF + rw [h0, zero_sub, neg_mem_iff] at hc + have := hx.independent β c hcw hc + rw [← hcoeff, this, Finsupp.coe_zero, Pi.zero_apply] + +/-- Every variable of a homogeneous relation `F(x) = 0` of degree `β ≠ 0` has degree below `β`. -/ +@[blueprint "lem:variables-of-homogeneous-relation-have-smaller-degree" + (phase := "Algebraic and ordinal preliminaries") + (title := "Weights of variables in a homogeneous relation") + (statement := /-- + Every variable occurring in a nonzero-degree weighted-homogeneous relation + among a minimal system $(x_i)_{i\in I}$ of homogeneous generators has + weight strictly below the degree of the relation. + -/) + (proof := /-- + Weighted homogeneity gives $w(i)\le\beta$. Equality would make the monomial + containing $X_i$ linear, contradicting + \ref{lem:minimal-generators-relation-has-no-linear-term}. + -/)] +theorem wt_lt_of_mem_vars_of_aeval_eq_zero {F : MvPolynomial ι E} {β : NatOrdinal.{o}} (hβ : β ≠ 0) + (hF : IsWeightedHomogeneous wt F β) (h0 : aeval x F = 0) {i : ι} (hi : i ∈ F.vars) : + wt i < β := by + classical + obtain ⟨d, hd, hdi⟩ := (mem_vars_iff_mem_support i).mp hi + have hdi' : d i ≠ 0 := Finsupp.mem_support_iff.mp hdi + have hdw : Finsupp.weight wt d = β := hF (mem_support_iff.mp hd) + -- split off the variable `i` + set d' := d - Finsupp.single i (d i) with hd' + have hdd' : d = Finsupp.single i (d i) + d' := by + rw [hd', add_comm, tsub_add_cancel_of_le] + intro y + rw [Finsupp.single_apply] + split_ifs with hy + · subst hy; exact le_rfl + · exact Nat.zero_le _ + have hd'i : d' i = 0 := by rw [hd', Finsupp.tsub_apply, Finsupp.single_eq_same, Nat.sub_self] + have hsplit : d i • wt i + Finsupp.weight wt d' = β := by + rw [← hdw] + conv_rhs => rw [hdd'] + rw [map_add, Finsupp.weight_single] + have hle : wt i ≤ β := by + rw [← hsplit] + calc wt i ≤ d i • wt i := by + simpa using nsmul_le_nsmul_left (bot_le : (0 : NatOrdinal.{o}) ≤ wt i) + (Nat.one_le_iff_ne_zero.mpr hdi') + _ ≤ _ := NatOrdinal.le_add_right + refine lt_of_le_of_ne hle fun heq ↦ ?_ + -- `wt i = β` forces `d = single i 1`, a linear monomial + rw [heq] at hsplit + have hd'0 : Finsupp.weight wt d' = 0 := by + by_contra hne + have : β < d i • β + Finsupp.weight wt d' := by + calc β ≤ d i • β := by + simpa using nsmul_le_nsmul_left (bot_le : (0 : NatOrdinal.{o}) ≤ β) + (Nat.one_le_iff_ne_zero.mpr hdi') + _ < d i • β + Finsupp.weight wt d' := lt_add_of_pos_right _ (pos_iff_ne_zero.mpr hne) + exact this.ne hsplit.symm + have hd'zero : d' = 0 := eq_zero_of_weight_eq_zero hx.ne_zero hd'0 + rw [hd'0, add_zero] at hsplit + have hdi1 : d i = 1 := by + by_contra hne + have h2 : 2 ≤ d i := by omega + have : β < d i • β := by + calc β < β + β := lt_add_of_pos_right _ (pos_iff_ne_zero.mpr hβ) + _ = 2 • β := (two_nsmul β).symm + _ ≤ d i • β := nsmul_le_nsmul_left bot_le h2 + exact this.ne hsplit.symm + have hdsingle : d = Finsupp.single i 1 := by rw [hdd', hd'zero, add_zero, hdi1] + have := hx.coeff_single_eq_zero_of_aeval_eq_zero hβ hF h0 i + rw [← hdsingle] at this + exact mem_support_iff.mp hd this + +end IsMinimalSystem + +end OrdinalGraded diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/LoweringDerivation.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/LoweringDerivation.lean new file mode 100644 index 0000000000..31d25ef9c4 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/LoweringDerivation.lean @@ -0,0 +1,17 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.LoweringDerivation.BaseChange +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.LoweringDerivation.Correction +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.LoweringDerivation.FilteredModule +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.LoweringDerivation.Grading +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.LoweringDerivation.IdealGEGraded +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.LoweringDerivation.Mu +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.LoweringDerivation.Polynomial + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/LoweringDerivation/BaseChange.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/LoweringDerivation/BaseChange.lean new file mode 100644 index 0000000000..d92f5d1c25 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/LoweringDerivation/BaseChange.lean @@ -0,0 +1,344 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.LoweringDerivation.Correction +public import Mathlib.RingTheory.GradedAlgebra.TensorProduct +public import Mathlib.RingTheory.TensorProduct.Quotient + +import Mathlib.RingTheory.Flat.Basic +import Mathlib.Algebra.Module.Torsion.Field +import Mathlib.LinearAlgebra.Basis.VectorSpace +import Mathlib.Algebra.CharP.Algebra + +/-! +# Extension of the coefficient field + +Let `A` (Lean `R`) be a `NatOrdinal`-graded algebra over a field `K` with grading `𝒜` and a +lowering derivation `∂` (Lean `Δ`), and let `E / K` be a field extension. The `E`-algebra +`E ⊗_K A` is graded by the base-changed submodules `E ⊗_K A_α`, and the composite + +`∂_E = θ ∘ (1 ⊗ ∂) : E ⊗ A → E ⊗ Fun_{0⁻}(A) → Fun_{0⁻}(E ⊗ A)`, + +where `θ` is the pointwise tensor map, is again a lowering derivation: the Leibniz rule extends +bilinearly, and injectivity on `E ⊗_K A_{α+1}` follows from the injectivity of `θ`, `E` being +flat over `K`. Degree zero is still the scalars, and `(E ⊗_K A)/I = E ⊗_K (A/I)`. Consequently, +whenever `E ⊗_K A` is a domain, so is `E ⊗_K (A/I)`. +-/ + +universe u u' v + +open scoped DirectSum TensorProduct +open Filter Topology + +public noncomputable section + +namespace LoweringDerivation + +variable {K : Type u} {E : Type u'} {R : Type v} [Field K] [Field E] [Algebra K E] +variable [CommRing R] [Algebra K R] + +/-! ### Functions at `0⁻` with values in a tensor product -/ + +section TensorFunAtZeroMinus + +variable (K E R) + +/-- The pointwise tensor map `e ⊗ g ↦ (γ ↦ e ⊗ g(γ))`. -/ +def tensorFunAtZeroMinusLeft (e : E) : FunAtZeroMinus R →ₗ[K] FunAtZeroMinus (E ⊗[K] R) := + Filter.Germ.mapLinear (TensorProduct.mk K E R e) + +theorem tensorFunAtZeroMinusLeft_coe (e : E) (f : ℝ → R) : + tensorFunAtZeroMinusLeft K E R e (f : FunAtZeroMinus R) = + ((fun γ ↦ e ⊗ₜ[K] f γ : ℝ → E ⊗[K] R) : FunAtZeroMinus (E ⊗[K] R)) := by + rw [tensorFunAtZeroMinusLeft, Filter.Germ.mapLinear_coe] + rfl + +/-- The canonical map `θ : E ⊗ Fun_{0⁻}(A) → Fun_{0⁻}(E ⊗ A)`. -/ +def tensorFunAtZeroMinus : E ⊗[K] FunAtZeroMinus R →ₗ[E] FunAtZeroMinus (E ⊗[K] R) := + TensorProduct.AlgebraTensorModule.lift + { toFun := tensorFunAtZeroMinusLeft K E R + map_add' := fun e e' ↦ LinearMap.ext fun g ↦ by + induction g using Filter.Germ.inductionOn with + | _ f => + rw [LinearMap.add_apply, tensorFunAtZeroMinusLeft_coe, tensorFunAtZeroMinusLeft_coe, + tensorFunAtZeroMinusLeft_coe] + change _ = ((fun γ ↦ e ⊗ₜ[K] f γ + e' ⊗ₜ[K] f γ : ℝ → E ⊗[K] R) : + FunAtZeroMinus (E ⊗[K] R)) + congr 1 + funext γ + rw [TensorProduct.add_tmul] + map_smul' := fun c e ↦ LinearMap.ext fun g ↦ by + induction g using Filter.Germ.inductionOn with + | _ f => + rw [RingHom.id_apply, LinearMap.smul_apply, tensorFunAtZeroMinusLeft_coe, + tensorFunAtZeroMinusLeft_coe] + change _ = ((fun γ ↦ c • (e ⊗ₜ[K] f γ) : ℝ → E ⊗[K] R) : FunAtZeroMinus (E ⊗[K] R)) + congr 1 } + +theorem tensorFunAtZeroMinus_tmul (e : E) (g : FunAtZeroMinus R) : + tensorFunAtZeroMinus K E R (e ⊗ₜ[K] g) = tensorFunAtZeroMinusLeft K E R e g := by + rw [tensorFunAtZeroMinus, TensorProduct.AlgebraTensorModule.lift_tmul] + rfl + +theorem tensorFunAtZeroMinus_tmul_coe (e : E) (f : ℝ → R) : + tensorFunAtZeroMinus K E R (e ⊗ₜ[K] (f : FunAtZeroMinus R)) = + ((fun γ ↦ e ⊗ₜ[K] f γ : ℝ → E ⊗[K] R) : FunAtZeroMinus (E ⊗[K] R)) := by + rw [tensorFunAtZeroMinus_tmul, tensorFunAtZeroMinusLeft_coe] + +theorem tensorFunAtZeroMinusLeft_mul_const (e e' : E) (g : FunAtZeroMinus R) (b : R) : + tensorFunAtZeroMinusLeft K E R e g * ((e' ⊗ₜ[K] b : E ⊗[K] R) : FunAtZeroMinus (E ⊗[K] R)) = + tensorFunAtZeroMinusLeft K E R (e * e') (g * (b : FunAtZeroMinus R)) := by + induction g using Filter.Germ.inductionOn with + | _ f => + rw [tensorFunAtZeroMinusLeft_coe] + change _ = + tensorFunAtZeroMinusLeft K E R (e * e') ((fun γ ↦ f γ * b : ℝ → R) : FunAtZeroMinus R) + rw [tensorFunAtZeroMinusLeft_coe] + change ((fun γ ↦ e ⊗ₜ[K] f γ * e' ⊗ₜ[K] b : ℝ → E ⊗[K] R) : FunAtZeroMinus (E ⊗[K] R)) = _ + congr 1 + funext γ + rw [Algebra.TensorProduct.tmul_mul_tmul] + +theorem const_mul_tensorFunAtZeroMinusLeft (e e' : E) (a : R) (g : FunAtZeroMinus R) : + ((e ⊗ₜ[K] a : E ⊗[K] R) : FunAtZeroMinus (E ⊗[K] R)) * tensorFunAtZeroMinusLeft K E R e' g = + tensorFunAtZeroMinusLeft K E R (e * e') ((a : FunAtZeroMinus R) * g) := by + induction g using Filter.Germ.inductionOn with + | _ f => + rw [tensorFunAtZeroMinusLeft_coe] + change _ = + tensorFunAtZeroMinusLeft K E R (e * e') ((fun γ ↦ a * f γ : ℝ → R) : FunAtZeroMinus R) + rw [tensorFunAtZeroMinusLeft_coe] + change ((fun γ ↦ e ⊗ₜ[K] a * e' ⊗ₜ[K] f γ : ℝ → E ⊗[K] R) : FunAtZeroMinus (E ⊗[K] R)) = _ + congr 1 + funext γ + rw [Algebra.TensorProduct.tmul_mul_tmul] + +end TensorFunAtZeroMinus + +/-! ### The base-changed derivation -/ + +variable (E) in +/-- The base change `∂_E = θ ∘ (1 ⊗ ∂)` of a derivation with values in functions at `0⁻`. -/ +def baseChangeDerivation (Δ : R →ₗ[K] FunAtZeroMinus R) : + E ⊗[K] R →ₗ[E] FunAtZeroMinus (E ⊗[K] R) := + (tensorFunAtZeroMinus K E R).comp (Δ.baseChange E) + +theorem baseChangeDerivation_tmul (Δ : R →ₗ[K] FunAtZeroMinus R) (e : E) (x : R) : + baseChangeDerivation E Δ (e ⊗ₜ[K] x) = tensorFunAtZeroMinusLeft K E R e (Δ x) := by + rw [baseChangeDerivation, LinearMap.comp_apply, LinearMap.baseChange_tmul, + tensorFunAtZeroMinus_tmul] + +variable {𝒜 : NatOrdinal → Submodule K R} [GradedAlgebra 𝒜] + +/-- The base change of the grading: `E ⊗_K A_α`. -/ +abbrev baseChangeGrading (E : Type u') [Field E] [Algebra K E] (𝒜 : NatOrdinal → Submodule K R) : + NatOrdinal → Submodule E (E ⊗[K] R) := + fun α ↦ (𝒜 α).baseChange E + +omit [GradedAlgebra 𝒜] in +theorem gradeZeroScalars_baseChange (h0 : GradeZeroScalars 𝒜) : + GradeZeroScalars (baseChangeGrading E 𝒜) := by + rw [gradeZeroScalars_iff] at h0 ⊢ + intro x hx + obtain ⟨x', rfl⟩ := hx + induction x' using TensorProduct.inductionOn with + | tmul e a => + obtain ⟨k, hk⟩ := h0 a a.2 + refine ⟨k • e, ?_⟩ + rw [LinearMap.baseChange_tmul, Submodule.subtype_apply, hk, + Algebra.TensorProduct.algebraMap_apply, Algebra.algebraMap_eq_smul_one, + TensorProduct.tmul_smul, TensorProduct.smul_tmul', Algebra.algebraMap_self_apply] + | add x y hx hy => + obtain ⟨k, hk⟩ := hx + obtain ⟨k', hk'⟩ := hy + exact ⟨k + k', by rw [map_add, hk, hk', map_add]⟩ + +namespace IsLoweringDerivation + +variable {Δ : R →ₗ[K] FunAtZeroMinus R} (hΔ : IsLoweringDerivation 𝒜 Δ) +include hΔ + +omit [GradedAlgebra 𝒜] in +theorem baseChangeDerivation_mul (x y : E ⊗[K] R) : + baseChangeDerivation E Δ (x * y) = + baseChangeDerivation E Δ x * (y : FunAtZeroMinus _) + + (x : FunAtZeroMinus _) * baseChangeDerivation E Δ y := by + have hconst_add : ∀ u v : E ⊗[K] R, ((u + v : E ⊗[K] R) : FunAtZeroMinus (E ⊗[K] R)) = + (u : FunAtZeroMinus (E ⊗[K] R)) + (v : FunAtZeroMinus (E ⊗[K] R)) := fun _ _ ↦ rfl + induction x using TensorProduct.inductionOn with + | tmul e a => + induction y using TensorProduct.inductionOn with + | tmul e' b => + rw [Algebra.TensorProduct.tmul_mul_tmul, baseChangeDerivation_tmul, baseChangeDerivation_tmul, + baseChangeDerivation_tmul, hΔ.map_mul, map_add, tensorFunAtZeroMinusLeft_mul_const, + const_mul_tensorFunAtZeroMinusLeft] + | add y z hy hz => + rw [mul_add, map_add, hy, hz, map_add, hconst_add, mul_add, mul_add] + abel + | add x z hx hz => + rw [add_mul, map_add, hx, hz, map_add, hconst_add, add_mul, add_mul] + abel + +omit hΔ [GradedAlgebra 𝒜] in +/-- Membership statements for `∂_E` reduce to pure tensors `e ⊗ a` with `a ∈ A_α`. -/ +theorem baseChange_induction {α : NatOrdinal} (P : Submodule E (FunAtZeroMinus (E ⊗[K] R))) + (h : ∀ (e : E) (a : R), a ∈ 𝒜 α → baseChangeDerivation E Δ (e ⊗ₜ[K] a) ∈ P) + {x : E ⊗[K] R} (hx : x ∈ (𝒜 α).baseChange E) : baseChangeDerivation E Δ x ∈ P := by + obtain ⟨x', rfl⟩ := hx + induction x' using TensorProduct.inductionOn with + | tmul e a => + rw [LinearMap.baseChange_tmul, Submodule.subtype_apply] + exact h e a a.2 + | add x y hx hy => + rw [map_add, map_add] + exact P.add_mem hx hy + +omit [GradedAlgebra 𝒜] in +theorem baseChangeDerivation_mem_lower {α : NatOrdinal} (hα : 0 < α.constantCoeff) {x : E ⊗[K] R} + (hx : x ∈ (𝒜 α).baseChange E) : + baseChangeDerivation E Δ x ∈ funAtZeroMinusSubmodule ((𝒜 (α.removeNat 1)).baseChange E) := by + refine baseChange_induction _ (fun e a ha ↦ ?_) hx + obtain ⟨f, hf, hfeq⟩ := exists_coe_eq_of_mem_funAtZeroMinusSubmodule _ (hΔ.mem_lower hα ha) + rw [baseChangeDerivation_tmul, hfeq, tensorFunAtZeroMinusLeft_coe, + coe_mem_funAtZeroMinusSubmodule_iff] + exact Eventually.of_forall fun γ ↦ Submodule.tmul_mem_baseChange_of_mem e (hf γ) + +omit [GradedAlgebra 𝒜] in +theorem baseChangeDerivation_eq_zero {α : NatOrdinal} (hα : α.constantCoeff = 0) {x : E ⊗[K] R} + (hx : x ∈ (𝒜 α).baseChange E) : baseChangeDerivation E Δ x = 0 := by + have := baseChange_induction (Δ := Δ) (⊥ : Submodule E (FunAtZeroMinus (E ⊗[K] R))) + (fun e a ha ↦ by rw [baseChangeDerivation_tmul, hΔ.eq_zero hα ha, map_zero]; exact rfl) hx + exact (Submodule.mem_bot E).mp this + +/-- `∂` on `A_α`, `α` a successor, as a map into functions at `0⁻` with values in the degree one +below (Lean `𝒜 (α.removeNat 1)`). -/ +def derivLinearAt {α : NatOrdinal} (hα : 0 < α.constantCoeff) : + 𝒜 α →ₗ[K] FunAtZeroMinus (𝒜 (α.removeNat 1)) := + (funAtZeroMinusSubmoduleEquiv (𝒜 (α.removeNat 1))).symm.toLinearMap.comp + ((Δ.comp (𝒜 α).subtype).codRestrict _ fun a ↦ hΔ.mem_lower hα a.2) + +omit [GradedAlgebra 𝒜] in +theorem funAtZeroMinusSubmoduleMap_derivLinearAt {α : NatOrdinal} (hα : 0 < α.constantCoeff) + (a : 𝒜 α) : + funAtZeroMinusSubmoduleMap _ (hΔ.derivLinearAt hα a) = Δ a := by + rw [derivLinearAt, LinearMap.comp_apply, LinearEquiv.coe_coe, + ← coe_funAtZeroMinusSubmoduleEquiv_apply, LinearEquiv.apply_symm_apply] + rfl + +omit [GradedAlgebra 𝒜] in +theorem derivLinearAt_injective {α : NatOrdinal} (hα : 0 < α.constantCoeff) : + Function.Injective (hΔ.derivLinearAt hα) := by + intro a a' h + apply Subtype.ext + refine sub_eq_zero.mp (hΔ.injective hα ((𝒜 α).sub_mem a.2 a'.2) ?_) + rw [map_sub, ← hΔ.funAtZeroMinusSubmoduleMap_derivLinearAt hα, + ← hΔ.funAtZeroMinusSubmoduleMap_derivLinearAt hα, + h, sub_self] + +/-- The embedding `A_{α'} ⊗ E → E ⊗ A`, `α'` the degree one below `α`. -/ +def lowerGradeTensorEmbedding (α : NatOrdinal) : 𝒜 (α.removeNat 1) ⊗[K] E →ₗ[K] E ⊗[K] R := + ((𝒜 (α.removeNat 1)).subtype.baseChange E).restrictScalars K ∘ₗ + (TensorProduct.comm K (𝒜 (α.removeNat 1)) E).toLinearMap + +omit hΔ [GradedAlgebra 𝒜] in +theorem lowerGradeTensorEmbedding_injective (α : NatOrdinal) : + Function.Injective (lowerGradeTensorEmbedding (𝒜 := 𝒜) (E := E) α) := by + have h1 : Function.Injective ((𝒜 (α.removeNat 1)).subtype.baseChange E) := by + rw [LinearMap.baseChange_eq_ltensor] + exact Module.Flat.lTensor_preserves_injective_linearMap _ (Submodule.injective_subtype _) + intro x y h + exact (TensorProduct.comm K _ E).injective (h1 h) + +omit [GradedAlgebra 𝒜] in +theorem baseChangeDerivation_baseChange {α : NatOrdinal} (hα : 0 < α.constantCoeff) + (x : 𝒜 α ⊗[K] E) : + baseChangeDerivation E Δ ((𝒜 α).subtype.baseChange E (TensorProduct.comm K _ _ x)) = + Filter.Germ.mapLinear (lowerGradeTensorEmbedding α) + (funAtZeroMinusTensorId (hΔ.derivLinearAt hα) x) := by + induction x using TensorProduct.inductionOn with + | tmul a e => + obtain ⟨f, hf⟩ : ∃ f : ℝ → 𝒜 (α.removeNat 1), hΔ.derivLinearAt hα a = (f : FunAtZeroMinus _) := + ⟨Quotient.out _, (Quotient.out_eq _).symm⟩ + rw [TensorProduct.comm_tmul, LinearMap.baseChange_tmul, baseChangeDerivation_tmul, + funAtZeroMinusTensorId_tmul_of_eq_coe _ _ _ _ hf, Filter.Germ.mapLinear_coe] + have hΔa : Δ a = ((fun γ ↦ (f γ : R)) : FunAtZeroMinus R) := by + rw [← hΔ.funAtZeroMinusSubmoduleMap_derivLinearAt hα, hf, funAtZeroMinusSubmoduleMap_coe] + rw [Submodule.subtype_apply, hΔa, tensorFunAtZeroMinusLeft_coe] + rfl + | add x y hx hy => rw [map_add, map_add, map_add, hx, hy, map_add, map_add] + +omit [GradedAlgebra 𝒜] in +theorem baseChangeDerivation_injective {α : NatOrdinal} (hα : 0 < α.constantCoeff) {x : E ⊗[K] R} + (hx : x ∈ (𝒜 α).baseChange E) (h : baseChangeDerivation E Δ x = 0) : x = 0 := by + obtain ⟨x', rfl⟩ := hx + obtain ⟨x'', rfl⟩ := (TensorProduct.comm K (𝒜 α) E).surjective x' + rw [hΔ.baseChangeDerivation_baseChange hα] at h + have h1 := Filter.Germ.mapLinear_injective _ + (lowerGradeTensorEmbedding_injective (𝒜 := 𝒜) (E := E) α) + (by rw [h, map_zero] : Filter.Germ.mapLinear (lowerGradeTensorEmbedding α) + (funAtZeroMinusTensorId (hΔ.derivLinearAt hα) x'') = Filter.Germ.mapLinear _ 0) + have h2 : x'' = 0 := funAtZeroMinusTensorId_injective_of_injective _ + (hΔ.derivLinearAt_injective hα) (by rw [h1, map_zero]) + rw [h2, map_zero, map_zero] + +omit [GradedAlgebra 𝒜] in +/-- The base change of a lowering derivation is a lowering derivation for the base-changed +grading. -/ +theorem baseChange : + IsLoweringDerivation (baseChangeGrading E 𝒜) (baseChangeDerivation E Δ) where + map_mul := hΔ.baseChangeDerivation_mul + mem_lower hα _ hx := hΔ.baseChangeDerivation_mem_lower hα hx + eq_zero hα _ hx := hΔ.baseChangeDerivation_eq_zero hα hx + injective hα _ hx h := hΔ.baseChangeDerivation_injective hα hx h + +end IsLoweringDerivation + +/-! ### The quotient of the base change -/ + +variable (E 𝒜) + +omit [GradedAlgebra 𝒜] in +theorem fibreIdeal_baseChange : + fibreIdeal (baseChangeGrading E 𝒜) = + (fibreIdeal 𝒜).map (Algebra.TensorProduct.includeRight : R →ₐ[K] E ⊗[K] R) := by + rw [fibreIdeal, fibreIdeal, idealGE_eq_span, idealGE_eq_span] + refine le_antisymm (Ideal.span_le.mpr ?_) (Ideal.map_le_iff_le_comap.mpr (Ideal.span_le.mpr ?_)) + · intro x hx + obtain ⟨e, hje, x', rfl⟩ := (mem_idealGEGenerators_iff _ 1 x).mp hx + clear hx + induction x' using TensorProduct.inductionOn with + | tmul c a => + rw [LinearMap.baseChange_tmul, Submodule.subtype_apply, + show c ⊗ₜ[K] (a : R) = (c ⊗ₜ[K] (1 : R)) * + (Algebra.TensorProduct.includeRight (R := K) (A := E) (a : R)) by + rw [Algebra.TensorProduct.includeRight_apply, Algebra.TensorProduct.tmul_mul_tmul, + mul_one, one_mul]] + exact Ideal.mul_mem_left _ _ (Ideal.mem_map_of_mem _ + (Ideal.subset_span ((mem_idealGEGenerators_iff 𝒜 1 _).mpr ⟨e, hje, a.2⟩))) + | add x y hx hy => rw [map_add]; exact add_mem hx hy + · intro a ha + obtain ⟨e, hje, hae⟩ := (mem_idealGEGenerators_iff 𝒜 1 a).mp ha + refine Ideal.subset_span ((mem_idealGEGenerators_iff _ 1 _).mpr ⟨e, hje, ?_⟩) + rw [Algebra.TensorProduct.includeRight_apply] + exact Submodule.tmul_mem_baseChange_of_mem 1 hae + +/-- `(E ⊗_K A)/I = E ⊗_K (A/I)`: the quotient of the base change is the base change of the +quotient. -/ +def fibreBaseChangeEquiv : E ⊗[K] Fibre 𝒜 ≃ₐ[E] Fibre (baseChangeGrading E 𝒜) := + (Algebra.TensorProduct.tensorQuotientEquiv (R := K) E R E (fibreIdeal 𝒜)).trans + (Ideal.quotientEquivAlgOfEq E (fibreIdeal_baseChange E 𝒜).symm) + +/-- If `E ⊗_K A` is a domain, so is `E ⊗_K (A/I)`: the base change is again a graded domain over +`E` with a lowering derivation, and its quotient is `E ⊗_K (A/I)`. -/ +theorem isDomain_tensor_fibre [CharZero K] [IsDomain (E ⊗[K] R)] (h0 : GradeZeroScalars 𝒜) + {Δ : R →ₗ[K] FunAtZeroMinus R} (hΔ : IsLoweringDerivation 𝒜 Δ) : + IsDomain (E ⊗[K] Fibre 𝒜) := + haveI : CharZero E := charZero_of_injective_algebraMap (algebraMap K E).injective + haveI := hΔ.baseChange.fibre_isDomain (gradeZeroScalars_baseChange (E := E) h0) + (fibreBaseChangeEquiv E 𝒜).toMulEquiv.isDomain _ + +end LoweringDerivation diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/LoweringDerivation/Correction.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/LoweringDerivation/Correction.lean new file mode 100644 index 0000000000..e1a0471508 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/LoweringDerivation/Correction.lean @@ -0,0 +1,584 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.LoweringDerivation.Mu + +import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.GradedRing.HomogeneousZeroDivisors +import Mathlib.Algebra.Module.Torsion.Field +import Mathlib.LinearAlgebra.Basis.VectorSpace +import Mathlib.RingTheory.Flat.Basic +import Mathlib.Tactic.LinearCombination + +/-! +# The correction argument: `A/I` is a domain + +Let `A` (Lean `R`) be a `NatOrdinal`-graded domain over a field `E` of characteristic zero with +`A_0 = E` and a lowering derivation `∂` (Lean `Δ`). This file proves that non-zero homogeneous +`ρ, τ ∈ A/I` (the paper's `B, C`) satisfy `ρ^s τ ≠ 0`, hence that `A/I` is a domain. + +The proof is a lexicographic induction on `(n, n', s)`, `n, n'` the finite parts of the degrees +`α, β` of `ρ, τ`. Supposing `ρ^(r+1) τ = 0`, one builds homogeneous lifts `x, y` of `ρ, τ` with +`x^(r+1) y ∈ I_{≥j+1}` and `∂x, ∂y ∈ Fun_{0⁻}(I_{≥j})` for `j = 0, …, N`, where `N` is the +smaller of the positive finite parts among `n, n'`. The *correction step* passes from stage `j` +to stage `j + 1`: the Leibniz rule, read through `μ_j` as an identity between tensors, + +`(∂ ⊗ 1) ν_{j+1}(x^(r+1) y) = (1 ⊗ m)(ν_j(∂x), ν_j(∂y))`, `m(a, b) = (r+1) ρ^r τ a + ρ^(r+1) b` + +(`ν_j(H)` the tensor with `μ_j(ν_j(H)) = H + I_{≥j+1}`), together with the injectivity of +`θ : V ⊗ Fun_{0⁻}(W) → Fun_{0⁻}(V ⊗ W)` and the injectivity of `m` (which is where the induction +hypothesis enters), produces homogeneous corrections `G ∈ I_{≥j+1} ∩ A_α`, `G' ∈ I_{≥j+1} ∩ A_β` +with `(x - G)^(r+1) (y - G') ∈ I_{≥j+2}` and `∂(x - G), ∂(y - G') ∈ Fun_{0⁻}(I_{≥j+1})`. At +stage `N` the derivative of one lift is a function with values in `I_{≥N} ∩ A_{α'}`, `α'` the +degree one below `α`, which vanishes, against the injectivity of `∂` on `A_α`. +-/ + +universe u v + +open scoped DirectSum TensorProduct +open Filter Topology + +public noncomputable section + +namespace LoweringDerivation + +variable {E : Type u} {R : Type v} [Field E] [CommRing R] [Algebra E R] +variable {𝒜 : NatOrdinal → Submodule E R} [GradedAlgebra 𝒜] +variable {Δ : R →ₗ[E] FunAtZeroMinus R} (hΔ : IsLoweringDerivation 𝒜 Δ) + +/-! ### Endpoint spaces -/ + +omit [GradedAlgebra 𝒜] in +theorem lTensor_subtype_lTensor_inclusion {M : Type*} [AddCommGroup M] [Module E M] + {W W' : Submodule E M} (h : W ≤ W') {U : Type*} [AddCommGroup U] [Module E U] + (T : U ⊗[E] W) : + W'.subtype.lTensor U ((Submodule.inclusion h).lTensor U T) = W.subtype.lTensor U T := by + rw [← LinearMap.comp_apply, ← LinearMap.lTensor_comp, Submodule.subtype_comp_inclusion] + +section Endpoint + +variable (𝒜) + +/-- The paper's `V_α`: for `α = λ + n` with `n > 0`, the degree-`(λ + (n-j-1))` part of `A/I` +(Lean `fibreGrade 𝒜 (α.removeNat (j + 1))`), and `0` when `n = 0`. -/ +def endpointSpace (j : ℕ) (α : NatOrdinal) : Submodule E (Fibre 𝒜) := + if 0 < α.constantCoeff then fibreGrade 𝒜 (α.removeNat (j + 1)) else ⊥ + +omit [GradedAlgebra 𝒜] in +theorem endpointSpace_of_pos {j : ℕ} {α : NatOrdinal} (hα : 0 < α.constantCoeff) : + endpointSpace 𝒜 j α = fibreGrade 𝒜 (α.removeNat (j + 1)) := ite_eq_left hα + +omit [GradedAlgebra 𝒜] in +theorem endpointSpace_of_eq_zero {j : ℕ} {α : NatOrdinal} (hα : α.constantCoeff = 0) : + endpointSpace 𝒜 j α = ⊥ := ite_eq_right (by omega) + +omit [GradedAlgebra 𝒜] in +theorem endpointSpace_le (j : ℕ) (α : NatOrdinal) : + endpointSpace 𝒜 j α ≤ fibreGrade 𝒜 (α.removeNat (j + 1)) := by + by_cases hα : 0 < α.constantCoeff + · rw [endpointSpace_of_pos 𝒜 hα] + · rw [endpointSpace_of_eq_zero 𝒜 (by omega)] + exact bot_le + +omit [GradedAlgebra 𝒜] in +theorem subtype_endpointSpace_of_eq_zero {j : ℕ} {α : NatOrdinal} (hα : α.constantCoeff = 0) : + (endpointSpace 𝒜 j α).subtype = 0 := by + ext ⟨x, hx⟩ + rw [endpointSpace_of_eq_zero 𝒜 hα] at hx + simpa using hx + +/-- Homogeneous lifting into `V_α`: a tensor in `A_{j+1} ⊗ V_α` is the class modulo `I_{≥j+2}` of a +homogeneous element of `I_{≥j+1} ∩ A_α`. -/ +theorem exists_homogeneous_mu_eq_endpoint {j : ℕ} {α : NatOrdinal} + (hj : 0 < α.constantCoeff → j + 1 ≤ α.constantCoeff) + (T : 𝒜 ((j + 1 : ℕ) : NatOrdinal) ⊗[E] endpointSpace 𝒜 j α) : + ∃ G ∈ 𝒜 α, G ∈ idealGE 𝒜 (j + 1) ∧ + mu 𝒜 (j + 1) ((endpointSpace 𝒜 j α).subtype.lTensor _ T) = + (Submodule.Quotient.mk G : R ⧸ idealGE 𝒜 (j + 1 + 1)) := by + by_cases hα : 0 < α.constantCoeff + · obtain ⟨G, hGα, hGW, hG⟩ := exists_homogeneous_mu_eq 𝒜 (hj hα) + ((Submodule.inclusion (endpointSpace_le 𝒜 j α)).lTensor _ T) + refine ⟨G, hGα, hGW, ?_⟩ + rw [← hG, lTensor_subtype_lTensor_inclusion] + · refine ⟨0, zero_mem _, zero_mem _, ?_⟩ + rw [subtype_endpointSpace_of_eq_zero 𝒜 (by omega), LinearMap.lTensor_zero, LinearMap.zero_apply, + map_zero, Submodule.Quotient.mk_zero] + +end Endpoint + +namespace IsLoweringDerivation +include hΔ + +/-- For `x ∈ A_α` with `∂x ∈ Fun_{0⁻}(I_{≥j})`, the classes of `∂x` modulo `I_{≥j+1}` have +pointwise representatives in `A_j ⊗ V_α`: the paper's tensor `ν_j(∂x)`. -/ +theorem exists_rep_endpoint {j : ℕ} {α : NatOrdinal} + (hj : 0 < α.constantCoeff → j + 1 ≤ α.constantCoeff) {x : R} (hx : x ∈ 𝒜 α) + (hΔx : Δ x ∈ funAtZeroMinusIdeal E (idealGE 𝒜 j)) : + ∃ f : ℝ → R, Δ x = (f : FunAtZeroMinus R) ∧ ∀ γ, + ∃ T : 𝒜 (j : NatOrdinal) ⊗[E] endpointSpace 𝒜 j α, + mu 𝒜 j ((endpointSpace 𝒜 j α).subtype.lTensor _ T) = + (Submodule.Quotient.mk (f γ) : R ⧸ idealGE 𝒜 (j + 1)) := by + by_cases hα : 0 < α.constantCoeff + · have hpred := hΔ.mem_lower hα hx + obtain ⟨f, hf, hfeq⟩ := exists_coe_eq_of_mem_funAtZeroMinusSubmodule _ + (mem_funAtZeroMinusSubmodule_inf _ _ hpred hΔx) + refine ⟨f, hfeq, fun γ ↦ ?_⟩ + obtain ⟨hf1, hf2⟩ := Submodule.mem_inf.mp (hf γ) + have hη : (α.removeNat 1).removeNat j = α.removeNat (j + 1) := by + have := NatOrdinal.removeNat_one_removeNat_pred (delta := α) (j := j + 1) + (Nat.le_add_left 1 j) (hj hα) + rwa [Nat.add_sub_cancel] at this + obtain ⟨T, hT⟩ := exists_mu_lTensor_eq 𝒜 hf1 hf2 + have hle : fibreGrade 𝒜 ((α.removeNat 1).removeNat j) ≤ endpointSpace 𝒜 j α := by + rw [hη, endpointSpace_of_pos 𝒜 hα] + refine ⟨(Submodule.inclusion hle).lTensor _ T, ?_⟩ + rw [lTensor_subtype_lTensor_inclusion, hT] + · refine ⟨fun _ ↦ 0, ?_, fun γ ↦ ⟨0, by simp⟩⟩ + rw [hΔ.eq_zero (by omega) hx] + rfl + +end IsLoweringDerivation + +/-! ### The correction map -/ + +section CorrectionMap + +variable (𝒜) + +/-- The paper's map `m : V_α ⊕ V_β → A/I`, `(a, b) ↦ z a + w b`. -/ +def correctionMap (j : ℕ) (α β : NatOrdinal) (z w : Fibre 𝒜) : + endpointSpace 𝒜 j α × endpointSpace 𝒜 j β →ₗ[E] Fibre 𝒜 := + (LinearMap.mulLeft E z).comp ((endpointSpace 𝒜 j α).subtype.comp (LinearMap.fst E _ _)) + + (LinearMap.mulLeft E w).comp ((endpointSpace 𝒜 j β).subtype.comp (LinearMap.snd E _ _)) + +omit [GradedAlgebra 𝒜] in +theorem correctionMap_apply (j : ℕ) (α β : NatOrdinal) (z w : Fibre 𝒜) + (p : endpointSpace 𝒜 j α × endpointSpace 𝒜 j β) : + correctionMap 𝒜 j α β z w p = z * p.1 + w * p.2 := (rfl) + +omit [GradedAlgebra 𝒜] in +theorem correctionMap_comp_inl (j : ℕ) (α β : NatOrdinal) (z w : Fibre 𝒜) : + (correctionMap 𝒜 j α β z w).comp (LinearMap.inl E _ _) = + (LinearMap.mulLeft E z).comp (endpointSpace 𝒜 j α).subtype := by + ext a + simp [correctionMap_apply] + +omit [GradedAlgebra 𝒜] in +theorem correctionMap_comp_inr (j : ℕ) (α β : NatOrdinal) (z w : Fibre 𝒜) : + (correctionMap 𝒜 j α β z w).comp (LinearMap.inr E _ _) = + (LinearMap.mulLeft E w).comp (endpointSpace 𝒜 j β).subtype := by + ext b + simp [correctionMap_apply] + +omit [GradedAlgebra 𝒜] in +theorem lTensor_fst_lTensor_inl_add_lTensor_inr {U A B : Type*} [AddCommGroup U] [Module E U] + [AddCommGroup A] [Module E A] [AddCommGroup B] [Module E B] (a : U ⊗[E] A) (b : U ⊗[E] B) : + (LinearMap.fst E A B).lTensor U + ((LinearMap.inl E A B).lTensor U a + (LinearMap.inr E A B).lTensor U b) = a := by + rw [map_add, ← LinearMap.comp_apply (LinearMap.lTensor _ _), ← LinearMap.lTensor_comp, + LinearMap.fst_comp_inl, LinearMap.lTensor_id, LinearMap.id_apply, + ← LinearMap.comp_apply (LinearMap.lTensor _ _) (LinearMap.lTensor _ _), + ← LinearMap.lTensor_comp, LinearMap.fst_comp_inr, LinearMap.lTensor_zero, + LinearMap.zero_apply, add_zero] + +omit [GradedAlgebra 𝒜] in +theorem lTensor_snd_lTensor_inl_add_lTensor_inr {U A B : Type*} [AddCommGroup U] [Module E U] + [AddCommGroup A] [Module E A] [AddCommGroup B] [Module E B] (a : U ⊗[E] A) (b : U ⊗[E] B) : + (LinearMap.snd E A B).lTensor U + ((LinearMap.inl E A B).lTensor U a + (LinearMap.inr E A B).lTensor U b) = b := by + rw [map_add, ← LinearMap.comp_apply (LinearMap.lTensor _ _), ← LinearMap.lTensor_comp, + LinearMap.snd_comp_inl, LinearMap.lTensor_zero, LinearMap.zero_apply, zero_add, + ← LinearMap.comp_apply (LinearMap.lTensor _ _) (LinearMap.lTensor _ _), + ← LinearMap.lTensor_comp, LinearMap.snd_comp_inr, LinearMap.lTensor_id, LinearMap.id_apply] + +end CorrectionMap + +namespace IsLoweringDerivation +include hΔ + +/-- The Leibniz rule as an identity between tensors, +`(∂ ⊗ 1) ν_{j+1}(x^(r+1) y) = (1 ⊗ m)(ν_j(∂x), ν_j(∂y))` with `m(a, b) = (r+1) ρ^r τ a + ρ^(r+1) b`, +together with representatives: `∂ ⊗ 1` applied to a tensor `T` with +`μ_{j+1}(T) = x^(r+1) y + I_{≥j+2}` is represented by the pointwise images under `1 ⊗ m` of +tensors `t γ` whose two components are classes of representatives `f`, `g` of `∂x` and `∂y`. -/ +theorem exists_rep_coordinate_identity (h0 : GradeZeroScalars 𝒜) {j : ℕ} {α β : NatOrdinal} + (hjα : 0 < α.constantCoeff → j + 1 ≤ α.constantCoeff) + (hjβ : 0 < β.constantCoeff → j + 1 ≤ β.constantCoeff) + {x y : R} (hx : x ∈ 𝒜 α) (hy : y ∈ 𝒜 β) (r : ℕ) + (hΔx : Δ x ∈ funAtZeroMinusIdeal E (idealGE 𝒜 j)) + (hΔy : Δ y ∈ funAtZeroMinusIdeal E (idealGE 𝒜 j)) + {T : 𝒜 ((j + 1 : ℕ) : NatOrdinal) ⊗[E] Fibre 𝒜} + (hT : mu 𝒜 (j + 1) T = Submodule.Quotient.mk (x ^ (r + 1) * y)) : + ∃ (f g : ℝ → R) + (t : ℝ → 𝒜 (j : NatOrdinal) ⊗[E] (endpointSpace 𝒜 j α × endpointSpace 𝒜 j β)), + Δ x = (f : FunAtZeroMinus R) ∧ Δ y = (g : FunAtZeroMinus R) ∧ + (∀ γ, mu 𝒜 j ((endpointSpace 𝒜 j α).subtype.lTensor _ + ((LinearMap.fst E _ _).lTensor _ (t γ))) = Submodule.Quotient.mk (f γ)) ∧ + (∀ γ, mu 𝒜 j ((endpointSpace 𝒜 j β).subtype.lTensor _ + ((LinearMap.snd E _ _).lTensor _ (t γ))) = Submodule.Quotient.mk (g γ)) ∧ + funAtZeroMinusTensorId (hΔ.derivLinear j) T = + Filter.Germ.mapLinear ((correctionMap 𝒜 j α β + (fibreMap 𝒜 ((r + 1) • (x ^ r * y))) (fibreMap 𝒜 (x ^ (r + 1)))).lTensor _) + (t : FunAtZeroMinus _) := by + obtain ⟨f, hf, hfT⟩ := hΔ.exists_rep_endpoint hjα hx hΔx + obtain ⟨g, hg, hgT⟩ := hΔ.exists_rep_endpoint hjβ hy hΔy + choose tf htf using hfT + choose tg htg using hgT + set m := correctionMap 𝒜 j α β (fibreMap 𝒜 ((r + 1) • (x ^ r * y))) (fibreMap 𝒜 (x ^ (r + 1))) + with hm + refine ⟨f, g, fun γ ↦ (LinearMap.inl E _ _).lTensor _ (tf γ) + + (LinearMap.inr E _ _).lTensor _ (tg γ), hf, hg, fun γ ↦ ?_, fun γ ↦ ?_, ?_⟩ + · rw [lTensor_fst_lTensor_inl_add_lTensor_inr, htf] + · rw [lTensor_snd_lTensor_inl_add_lTensor_inr, htg] + · apply Filter.Germ.mapLinear_injective (mu 𝒜 j) (mu_injective hΔ h0 j) + rw [hΔ.mapLinear_mu_funAtZeroMinusTensorId j hT, Filter.Germ.mapLinear_comp, + Filter.Germ.mapLinear_coe] + have hΔH : Δ (x ^ (r + 1) * y) = + ((fun γ ↦ ((r + 1) • (x ^ r * f γ)) * y + x ^ (r + 1) * g γ : ℝ → R) : + FunAtZeroMinus R) := by + rw [hΔ.map_mul, hΔ.map_pow_succ, hf, hg] + rfl + rw [hΔH, mapLinear_idealGEQuot_coe] + congr 1 + funext γ + simp only [Function.comp_apply, LinearMap.comp_apply, map_add] + rw [← LinearMap.comp_apply (LinearMap.lTensor _ m), ← LinearMap.lTensor_comp, hm, + correctionMap_comp_inl, + ← LinearMap.comp_apply (LinearMap.lTensor _ (correctionMap _ _ _ _ _ _)), + ← LinearMap.lTensor_comp, correctionMap_comp_inr, LinearMap.lTensor_comp, + LinearMap.lTensor_comp, LinearMap.comp_apply, LinearMap.comp_apply, mu_lTensor_mulLeft, + mu_lTensor_mulLeft, htf, htg] + change Ideal.Quotient.mk _ _ = Ideal.Quotient.mk _ (f γ) * Ideal.Quotient.mk _ _ + + Ideal.Quotient.mk _ (g γ) * Ideal.Quotient.mk _ _ + rw [← RingHom.map_mul, ← RingHom.map_mul, ← RingHom.map_add] + congr 1 + simp only [nsmul_eq_mul] + ring + +/-- The Leibniz rule as an identity between tensors, +`(∂ ⊗ 1) ν_{j+1}(x^(r+1) y) = (1 ⊗ m)(ν_j(∂x), ν_j(∂y))`: `∂ ⊗ 1` applied to a tensor `T` with +`μ_{j+1}(T) = x^(r+1) y + I_{≥j+2}` is the image under `1 ⊗ m` of a function at `0⁻` with values +in `A_j ⊗ (V_α ⊕ V_β)`. -/ +theorem exists_coordinate_identity (h0 : GradeZeroScalars 𝒜) {j : ℕ} {α β : NatOrdinal} + (hjα : 0 < α.constantCoeff → j + 1 ≤ α.constantCoeff) + (hjβ : 0 < β.constantCoeff → j + 1 ≤ β.constantCoeff) + {x y : R} (hx : x ∈ 𝒜 α) (hy : y ∈ 𝒜 β) (r : ℕ) + (hΔx : Δ x ∈ funAtZeroMinusIdeal E (idealGE 𝒜 j)) + (hΔy : Δ y ∈ funAtZeroMinusIdeal E (idealGE 𝒜 j)) + {T : 𝒜 ((j + 1 : ℕ) : NatOrdinal) ⊗[E] Fibre 𝒜} + (hT : mu 𝒜 (j + 1) T = Submodule.Quotient.mk (x ^ (r + 1) * y)) : + ∃ t : ℝ → 𝒜 (j : NatOrdinal) ⊗[E] (endpointSpace 𝒜 j α × endpointSpace 𝒜 j β), + funAtZeroMinusTensorId (hΔ.derivLinear j) T = + Filter.Germ.mapLinear ((correctionMap 𝒜 j α β + (fibreMap 𝒜 ((r + 1) • (x ^ r * y))) (fibreMap 𝒜 (x ^ (r + 1)))).lTensor _) + (t : FunAtZeroMinus _) := + let ⟨_, _, t, _, _, _, _, hid⟩ := + hΔ.exists_rep_coordinate_identity h0 hjα hjβ hx hy r hΔx hΔy hT + ⟨t, hid⟩ + +end IsLoweringDerivation + +/-! ### The correction step -/ + +omit [Field E] [CommRing R] [Algebra E R] [GradedAlgebra 𝒜] in +/-- The algebra behind the correction: if `x^(r+1) y ≡ (r+1) g x^r y + h x^(r+1)` and the +corrections `g, h` multiply to zero, then `(x - g)^(r+1) (y - h) = 0`. -/ +theorem pow_sub_mul_sub_eq_zero {Q : Type*} [CommRing Q] (x y g h : Q) (r : ℕ) + (hgg : g * g = 0) (hgh : g * h = 0) + (hcong : x ^ (r + 1) * y = g * ((r + 1) * (x ^ r * y)) + h * x ^ (r + 1)) : + (x - g) ^ (r + 1) * (y - h) = 0 := by + have hpow : ∀ n : ℕ, (x - g) ^ (n + 1) = x ^ (n + 1) - (n + 1) * (x ^ n * g) := by + intro n + induction n with + | zero => ring + | succ n ih => + rw [pow_succ, ih] + push_cast + linear_combination ((n : Q) + 1) * x ^ n * hgg + linear_combination (y - h) * hpow r + hcong + (r + 1) * x ^ r * hgh + +omit [GradedAlgebra 𝒜] in +theorem lTensor_inl_fst_add_lTensor_inr_snd {U A B : Type*} [AddCommGroup U] [Module E U] + [AddCommGroup A] [Module E A] [AddCommGroup B] [Module E B] (t : U ⊗[E] (A × B)) : + (LinearMap.inl E A B).lTensor U ((LinearMap.fst E A B).lTensor U t) + + (LinearMap.inr E A B).lTensor U ((LinearMap.snd E A B).lTensor U t) = t := by + rw [← LinearMap.comp_apply, ← LinearMap.lTensor_comp, ← LinearMap.comp_apply, + ← LinearMap.lTensor_comp, ← LinearMap.add_apply, ← LinearMap.lTensor_add] + have : (LinearMap.inl E A B).comp (LinearMap.fst E A B) + + (LinearMap.inr E A B).comp (LinearMap.snd E A B) = LinearMap.id := by + ext <;> simp + rw [this, LinearMap.lTensor_id, LinearMap.id_apply] + +namespace IsLoweringDerivation + +variable (Δ) in +/-- Stage `j` of the correction argument: homogeneous lifts `x, y` of `ρ, τ` with +`x^(r+1) y ∈ I_{≥j+1}` and `∂x, ∂y ∈ Fun_{0⁻}(I_{≥j})`. -/ +structure Stage (ρ τ : Fibre 𝒜) (α β : NatOrdinal) (r j : ℕ) (x y : R) : Prop where + mem_left : x ∈ 𝒜 α + mem_right : y ∈ 𝒜 β + map_left : fibreMap 𝒜 x = ρ + map_right : fibreMap 𝒜 y = τ + prod_mem : x ^ (r + 1) * y ∈ idealGE 𝒜 (j + 1) + deriv_left : Δ x ∈ funAtZeroMinusIdeal E (idealGE 𝒜 j) + deriv_right : Δ y ∈ funAtZeroMinusIdeal E (idealGE 𝒜 j) + +include hΔ + +omit hΔ [GradedAlgebra 𝒜] in +theorem Stage.correctionMap_eq {ρ τ : Fibre 𝒜} {α β : NatOrdinal} {r j : ℕ} {x y : R} + (hs : Stage Δ ρ τ α β r j x y) : + correctionMap 𝒜 j α β (fibreMap 𝒜 ((r + 1) • (x ^ r * y))) (fibreMap 𝒜 (x ^ (r + 1))) = + correctionMap 𝒜 j α β ((r + 1) • (ρ ^ r * τ)) (ρ ^ (r + 1)) := by + rw [map_nsmul, _root_.map_mul, map_pow, map_pow, hs.map_left, hs.map_right] + +/-- The correction step: stage `j` data can be corrected to stage `j + 1` data, provided the +map `m : V_α ⊕ V_β → A/I` is injective. -/ +theorem Stage.exists_succ (h0 : GradeZeroScalars 𝒜) {ρ τ : Fibre 𝒜} {α β : NatOrdinal} + {r j : ℕ} (hjα : 0 < α.constantCoeff → j + 1 ≤ α.constantCoeff) + (hjβ : 0 < β.constantCoeff → j + 1 ≤ β.constantCoeff) + (hinj : Function.Injective (correctionMap 𝒜 j α β ((r + 1) • (ρ ^ r * τ)) (ρ ^ (r + 1)))) + {x y : R} (hs : Stage Δ ρ τ α β r j x y) : + ∃ x' y', Stage Δ ρ τ α β r (j + 1) x' y' := by + classical + -- the class of `x^(r+1) y` and the tensor form of the Leibniz rule + obtain ⟨T, hT⟩ := exists_mu_eq 𝒜 hs.prod_mem + obtain ⟨t, hid⟩ := hΔ.exists_coordinate_identity h0 hjα hjβ hs.mem_left hs.mem_right r + hs.deriv_left hs.deriv_right hT + set m := correctionMap 𝒜 j α β (fibreMap 𝒜 ((r + 1) • (x ^ r * y))) (fibreMap 𝒜 (x ^ (r + 1))) + with hm + have hminj : Function.Injective m := by rw [hm, hs.correctionMap_eq]; exact hinj + obtain ⟨T', hT'⟩ := exists_eq_lTensor_of_funAtZeroMinusTensorId_eq _ + (hΔ.derivLinear_injective j) m T _ hid + -- homogeneous lifts of the two components + obtain ⟨G, hGα, hGW, hG⟩ := exists_homogeneous_mu_eq_endpoint 𝒜 hjα + ((LinearMap.fst E _ _).lTensor _ T') + obtain ⟨G', hG'β, hG'W, hG'⟩ := exists_homogeneous_mu_eq_endpoint 𝒜 hjβ + ((LinearMap.snd E _ _).lTensor _ T') + -- the congruence `x^(r+1) y ≡ G (r+1) x^r y + G' x^(r+1)` modulo `I_{≥j+2}` + have hcong : (Submodule.Quotient.mk (x ^ (r + 1) * y) : R ⧸ idealGE 𝒜 (j + 1 + 1)) = + Submodule.Quotient.mk (G * ((r + 1) • (x ^ r * y)) + G' * x ^ (r + 1)) := by + rw [← hT, hT', ← lTensor_inl_fst_add_lTensor_inr_snd T', map_add, map_add, + ← LinearMap.comp_apply (LinearMap.lTensor _ m), ← LinearMap.lTensor_comp, hm, + correctionMap_comp_inl, + ← LinearMap.comp_apply (LinearMap.lTensor _ (correctionMap _ _ _ _ _ _)), + ← LinearMap.lTensor_comp, correctionMap_comp_inr, LinearMap.lTensor_comp, + LinearMap.lTensor_comp, LinearMap.comp_apply, LinearMap.comp_apply, mu_lTensor_mulLeft, + mu_lTensor_mulLeft, hG, hG'] + change Ideal.Quotient.mk _ G * Ideal.Quotient.mk _ _ + Ideal.Quotient.mk _ G' * + Ideal.Quotient.mk _ _ = Ideal.Quotient.mk _ _ + rw [← RingHom.map_mul, ← RingHom.map_mul, ← RingHom.map_add] + -- the corrected lifts + have hGG : G * G ∈ idealGE 𝒜 (j + 1 + 1) := + idealGE_antitone 𝒜 (by omega) (mul_mem_idealGE 𝒜 hGW hGW) + have hGG' : G * G' ∈ idealGE 𝒜 (j + 1 + 1) := + idealGE_antitone 𝒜 (by omega) (mul_mem_idealGE 𝒜 hGW hG'W) + have hprod : (x - G) ^ (r + 1) * (y - G') ∈ idealGE 𝒜 (j + 1 + 1) := by + rw [← Ideal.Quotient.eq_zero_iff_mem, RingHom.map_mul, RingHom.map_pow, RingHom.map_sub, + RingHom.map_sub] + refine pow_sub_mul_sub_eq_zero _ _ _ _ r ?_ ?_ ?_ + · rw [← RingHom.map_mul, Ideal.Quotient.eq_zero_iff_mem]; exact hGG + · rw [← RingHom.map_mul, Ideal.Quotient.eq_zero_iff_mem]; exact hGG' + · have h := hcong + simp only [nsmul_eq_mul] at h + change Ideal.Quotient.mk _ _ = Ideal.Quotient.mk _ _ at h + simp only [RingHom.map_add, RingHom.map_mul, RingHom.map_pow, map_natCast] at h + push_cast at h ⊢ + exact h + have hW1 : idealGE 𝒜 (j + 1) ≤ fibreIdeal 𝒜 := idealGE_antitone 𝒜 (by omega) + have hs' : Stage Δ ρ τ α β r j (x - G) (y - G') := + { mem_left := sub_mem hs.mem_left hGα + mem_right := sub_mem hs.mem_right hG'β + map_left := by rw [map_sub, hs.map_left, (fibreMap_eq_zero_iff 𝒜 G).mpr (hW1 hGW), sub_zero] + map_right := by + rw [map_sub, hs.map_right, (fibreMap_eq_zero_iff 𝒜 G').mpr (hW1 hG'W), sub_zero] + prod_mem := idealGE_antitone 𝒜 (by omega) hprod + deriv_left := by + rw [map_sub] + refine sub_mem hs.deriv_left ?_ + have := hΔ.map_mem_funAtZeroMinusIdeal_idealGE (j := j + 1) (by omega) hGW + rwa [Nat.add_sub_cancel] at this + deriv_right := by + rw [map_sub] + refine sub_mem hs.deriv_right ?_ + have := hΔ.map_mem_funAtZeroMinusIdeal_idealGE (j := j + 1) (by omega) hG'W + rwa [Nat.add_sub_cancel] at this } + -- the tensor identity for the corrected lifts has zero left side + have hT0 : mu 𝒜 (j + 1) (0 : 𝒜 ((j + 1 : ℕ) : NatOrdinal) ⊗[E] Fibre 𝒜) = + Submodule.Quotient.mk ((x - G) ^ (r + 1) * (y - G')) := by + rw [map_zero, eq_comm, Submodule.Quotient.mk_eq_zero] + exact hprod + obtain ⟨f', g', t', hf', hg', htf', htg', hid'⟩ := hΔ.exists_rep_coordinate_identity h0 hjα + hjβ hs'.mem_left hs'.mem_right r hs'.deriv_left hs'.deriv_right hT0 + rw [map_zero, hs'.correctionMap_eq] at hid' + have ht' : ∀ᶠ γ in 𝓝[<] (0 : ℝ), t' γ = 0 := by + have hinj' := Module.Flat.lTensor_preserves_injective_linearMap + (M := 𝒜 (j : NatOrdinal)) _ hinj + have h := Filter.Germ.mapLinear_injective _ hinj' (by rw [← hid', map_zero] : + Filter.Germ.mapLinear _ (t' : FunAtZeroMinus _) = Filter.Germ.mapLinear _ 0) + exact Filter.Germ.coe_eq.mp h + refine ⟨x - G, y - G', { hs' with prod_mem := hprod, deriv_left := ?_, deriv_right := ?_ }⟩ + · rw [hf', coe_mem_funAtZeroMinusIdeal_iff] + refine ht'.mono fun γ hγ ↦ ?_ + rw [← Submodule.Quotient.mk_eq_zero, ← htf' γ, hγ, map_zero, map_zero, map_zero] + · rw [hg', coe_mem_funAtZeroMinusIdeal_iff] + refine ht'.mono fun γ hγ ↦ ?_ + rw [← Submodule.Quotient.mk_eq_zero, ← htg' γ, hγ, map_zero, map_zero, map_zero] + +/-! ### Homogeneous nonvanishing -/ + +omit hΔ in +theorem mem_funAtZeroMinusIdeal_idealGE_zero (g : FunAtZeroMinus R) : + g ∈ funAtZeroMinusIdeal E (idealGE 𝒜 0) := by + induction g using Filter.Germ.inductionOn with + | _ f => + rw [coe_mem_funAtZeroMinusIdeal_iff, idealGE_zero] + exact Eventually.of_forall fun _ ↦ Submodule.mem_top + +omit hΔ in +/-- A function at `0⁻` with values in `I_{≥N} ∩ A_η` vanishes when `N` exceeds the finite part of +`η`. -/ +theorem eq_zero_of_mem_funAtZeroMinusIdeal_of_mem_funAtZeroMinusSubmodule {N : ℕ} {η : NatOrdinal} + {g : FunAtZeroMinus R} + (hg : g ∈ funAtZeroMinusIdeal E (idealGE 𝒜 N)) (hgη : g ∈ funAtZeroMinusSubmodule (𝒜 η)) + (hη : η.constantCoeff < N) : g = 0 := by + obtain ⟨f, hf, rfl⟩ := exists_coe_eq_of_mem_funAtZeroMinusSubmodule _ + (mem_funAtZeroMinusSubmodule_inf _ _ hgη hg) + have : f = fun _ ↦ 0 := funext fun γ ↦ by + obtain ⟨h1, h2⟩ := Submodule.mem_inf.mp (hf γ) + exact eq_zero_of_mem_idealGE_of_constantCoeff_lt 𝒜 h1 h2 hη + rw [this] + rfl + +omit hΔ in +theorem nsmul_eq_zero_iff_of_charZero [CharZero E] {V : Type*} [AddCommGroup V] [Module E V] + (n : ℕ) (v : V) : (n + 1) • v = 0 ↔ v = 0 := by + rw [← Nat.cast_smul_eq_nsmul E, smul_eq_zero] + simp [Nat.cast_add_one_ne_zero] + +/-- Homogeneous non-vanishing in `A/I`: `ρ^s τ ≠ 0` for non-zero homogeneous `ρ, τ ∈ A/I`. The +proof is a lexicographic induction on `(n, n', s)`, `n, n'` the finite parts of the degrees of +`ρ, τ` (Lean `α.constantCoeff`, `β.constantCoeff`). -/ +theorem pow_mul_ne_zero [IsDomain R] [CharZero E] (h0 : GradeZeroScalars 𝒜) (A B s : ℕ) : + ∀ {α β : NatOrdinal}, α.constantCoeff = A → β.constantCoeff = B → + ∀ {ρ τ : Fibre 𝒜}, ρ ∈ fibreGrade 𝒜 α → τ ∈ fibreGrade 𝒜 β → ρ ≠ 0 → τ ≠ 0 → + ρ ^ s * τ ≠ 0 := by + induction A using Nat.strong_induction_on generalizing B s with + | _ A ihA => + induction B using Nat.strong_induction_on generalizing s with + | _ B ihB => + induction s with + | zero => + intro α β hA hB ρ τ hρ hτ hρ0 hτ0 + simpa using hτ0 + | succ r ihs => + intro α β hA hB ρ τ hρ hτ hρ0 hτ0 hcontra + have hz : ρ ^ r * τ ≠ 0 := ihs hA hB hρ hτ hρ0 hτ0 + have hzmem : ρ ^ r * τ ∈ fibreGrade 𝒜 (r • α + β) := + mul_mem_fibreGrade 𝒜 (pow_mem_fibreGrade 𝒜 hρ r) hτ + -- (i): multiplication by `ρ^r τ` is injective on `(A/I)_{α'}` for `α'` of smaller finite part + have hi : ∀ j : ℕ, 0 < A → ∀ a ∈ fibreGrade 𝒜 (α.removeNat (j + 1)), + ρ ^ r * τ * a = 0 → a = 0 := by + intro j hA0 a ha h + by_contra ha0 + refine ihA (A - (j + 1)) (by omega) (r • α + β).constantCoeff 1 + (by rw [NatOrdinal.constantCoeff_removeNat, hA]) rfl ha hzmem ha0 hz ?_ + rw [pow_one, mul_comm] + exact h + -- (ii): multiplication by `ρ^(r+2)` is injective on `(A/I)_{β'}` for `β'` of smaller finite part + have hii : ∀ j : ℕ, 0 < B → ∀ b ∈ fibreGrade 𝒜 (β.removeNat (j + 1)), + ρ ^ (r + 2) * b = 0 → b = 0 := by + intro j hB0 b hb h + by_contra hb0 + exact ihB (B - (j + 1)) (by omega) (r + 2) hA + (by rw [NatOrdinal.constantCoeff_removeNat, hB]) hρ hb hρ0 hb0 h + -- injectivity of the correction map at every stage + have hinj : ∀ j : ℕ, + Function.Injective (correctionMap 𝒜 j α β ((r + 1) • (ρ ^ r * τ)) (ρ ^ (r + 1))) := by + intro j + rw [injective_iff_map_eq_zero] + rintro ⟨a, b⟩ hab + rw [correctionMap_apply] at hab + have hb : (b : Fibre 𝒜) = 0 := by + have h1 := congrArg (ρ * ·) hab + simp only [mul_add, mul_zero, smul_mul_assoc, mul_smul_comm] at h1 + have h2 : ρ * (ρ ^ r * τ * a) = 0 := by + rw [← mul_assoc, ← mul_assoc, ← pow_succ', hcontra, zero_mul] + rw [h2, nsmul_zero, zero_add, ← mul_assoc, ← pow_succ'] at h1 + by_cases hB0 : 0 < B + · exact hii j hB0 b ((endpointSpace_le 𝒜 j β) b.2) h1 + · exact (Submodule.mem_bot E).mp ((endpointSpace_of_eq_zero 𝒜 (by omega)).le b.2) + rw [hb, mul_zero, add_zero, smul_mul_assoc, nsmul_eq_zero_iff_of_charZero (E := E)] at hab + have ha : (a : Fibre 𝒜) = 0 := by + by_cases hA0 : 0 < A + · exact hi j hA0 a ((endpointSpace_le 𝒜 j α) a.2) hab + · exact (Submodule.mem_bot E).mp ((endpointSpace_of_eq_zero 𝒜 (by omega)).le a.2) + exact Prod.ext (Subtype.ext ha) (Subtype.ext hb) + -- lifts + obtain ⟨x, hx, hxρ⟩ := exists_mem_of_mem_fibreGrade 𝒜 hρ + obtain ⟨y, hy, hyτ⟩ := exists_mem_of_mem_fibreGrade 𝒜 hτ + have hx0 : x ≠ 0 := fun h ↦ hρ0 (by rw [← hxρ, h, map_zero]) + have hy0 : y ≠ 0 := fun h ↦ hτ0 (by rw [← hyτ, h, map_zero]) + have hprod : x ^ (r + 1) * y ∈ idealGE 𝒜 1 := by + rw [← fibreMap_eq_zero_iff, _root_.map_mul, map_pow, hxρ, hyτ] + exact hcontra + have hprodmem : x ^ (r + 1) * y ∈ 𝒜 ((r + 1) • α + β) := + SetLike.mul_mem_graded (SetLike.pow_mem_graded _ hx) hy + by_cases hAB : A = 0 ∧ B = 0 + · -- both finite parts are zero + refine mul_ne_zero (pow_ne_zero _ hx0) hy0 + (eq_zero_of_mem_idealGE_of_constantCoeff_lt 𝒜 hprodmem hprod ?_) + rw [NatOrdinal.constantCoeff_add, NatOrdinal.constantCoeff_nsmul, hA, hB, hAB.1, hAB.2] + simp + -- the positive minimum `N` of the non-zero finite parts among `n, n'` + obtain ⟨N, hNpos, hNA, hNB, hN⟩ : ∃ N : ℕ, 0 < N ∧ (0 < A → N ≤ A) ∧ (0 < B → N ≤ B) ∧ + ((N = A ∧ 0 < A) ∨ (N = B ∧ 0 < B)) := by + by_cases hA0 : 0 < A + · by_cases hB0 : 0 < B + · by_cases hle : A ≤ B + · exact ⟨A, hA0, fun _ ↦ le_rfl, fun _ ↦ hle, Or.inl ⟨rfl, hA0⟩⟩ + · exact ⟨B, hB0, fun _ ↦ by omega, fun _ ↦ le_rfl, Or.inr ⟨rfl, hB0⟩⟩ + · exact ⟨A, hA0, fun _ ↦ le_rfl, fun h ↦ absurd h hB0, Or.inl ⟨rfl, hA0⟩⟩ + · have hB0 : 0 < B := by omega + exact ⟨B, hB0, fun h ↦ absurd h hA0, fun _ ↦ le_rfl, Or.inr ⟨rfl, hB0⟩⟩ + -- the stages + have hstage : ∀ j ≤ N, ∃ x' y', Stage Δ ρ τ α β r j x' y' := by + intro j + induction j with + | zero => + intro _ + exact ⟨x, y, ⟨hx, hy, hxρ, hyτ, hprod, mem_funAtZeroMinusIdeal_idealGE_zero _, + mem_funAtZeroMinusIdeal_idealGE_zero _⟩⟩ + | succ j ih => + intro hj + obtain ⟨x', y', hs⟩ := ih (by omega) + exact hs.exists_succ hΔ h0 (fun hA0 ↦ by have := hNA (hA ▸ hA0); omega) + (fun hB0 ↦ by have := hNB (hB ▸ hB0); omega) (hinj j) + -- termination + obtain ⟨x', y', hs⟩ := hstage N le_rfl + rcases hN with ⟨rfl, hA0⟩ | ⟨rfl, hB0⟩ + · have hpred := hΔ.mem_lower (by omega) hs.mem_left + have hΔ0 : Δ x' = 0 := eq_zero_of_mem_funAtZeroMinusIdeal_of_mem_funAtZeroMinusSubmodule + hs.deriv_left hpred (by rw [NatOrdinal.constantCoeff_removeNat]; omega) + have := hΔ.injective (by omega) hs.mem_left hΔ0 + exact hρ0 (by rw [← hs.map_left, this, map_zero]) + · have hpred := hΔ.mem_lower (by omega) hs.mem_right + have hΔ0 : Δ y' = 0 := eq_zero_of_mem_funAtZeroMinusIdeal_of_mem_funAtZeroMinusSubmodule + hs.deriv_right hpred (by rw [NatOrdinal.constantCoeff_removeNat]; omega) + have := hΔ.injective (by omega) hs.mem_right hΔ0 + exact hτ0 (by rw [← hs.map_right, this, map_zero]) + +/-- `A/I` is a domain: it is graded by the `(A/I)_β`, and by homogeneous non-vanishing it has no +homogeneous zero divisors. -/ +theorem fibre_isDomain [IsDomain R] [CharZero E] (h0 : GradeZeroScalars 𝒜) : + IsDomain (Fibre 𝒜) := + GradedRing.isDomain_of_homogeneous_eq_zero_or_eq_zero (fibreGrade 𝒜) fun ⟨_, hρ⟩ ⟨_, hτ⟩ h ↦ + or_iff_not_imp_left.mpr fun hρ0 ↦ by_contra fun hτ0 ↦ + hΔ.pow_mul_ne_zero h0 _ _ 1 rfl rfl hρ hτ hρ0 hτ0 (by rwa [pow_one]) + +end IsLoweringDerivation + +end LoweringDerivation diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/LoweringDerivation/FilteredModule.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/LoweringDerivation/FilteredModule.lean new file mode 100644 index 0000000000..43ca54becd --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/LoweringDerivation/FilteredModule.lean @@ -0,0 +1,517 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.LoweringDerivation.Mu +public import Mathlib.LinearAlgebra.Basis.VectorSpace +public import Mathlib.LinearAlgebra.TensorProduct.Tower + +import Mathlib.LinearAlgebra.TensorProduct.Finiteness +import Mathlib.RingTheory.TensorProduct.Free +import Mathlib.Algebra.BigOperators.Group.Finset.Preimage + +/-! +# Freeness over the finite-degree part + +Let `A` (Lean `R`) be a `NatOrdinal`-graded algebra over a field `E` with a lowering derivation +`∂` (Lean `Δ`), and let `A_{<ω} = ⨁_{n < ω} A_n` be its finite-degree part. For a graded +`E`-linear section `s : A/I → A` of the quotient map `π`, the `A_{<ω}`-linear map + +`μ_s : A_{<ω} ⊗_E A/I → A`, `B ⊗ C ↦ B s(C)`, + +is bijective and carries `(A_{<ω})_{≥j} ⊗_E A/I` onto `I_{≥j}` for every `j`: + +* injectivity: writing a kernel element as a sum of pieces in the `A_n ⊗ A/I`, the piece of least + degree `d` gives a relation in the kernel of `μ_d`, which is injective; +* surjectivity onto `I_{≥j}`: a homogeneous element of `I_{≥j}` is, modulo `I_{≥j+1}`, the image + of a tensor in `A_j ⊗ A/I`, and `I_{≥j} ∩ A_δ = 0` once `j` exceeds the finite part of `δ`. + +In particular `A` is a free `A_{<ω}`-module. A homogeneous `E`-basis `𝓒` of `A/I` (through the +grading of `A/I`) with homogeneous lifts `s(C)` of its vectors determines such a graded section, +and the lifts `s(C)`, `C ∈ 𝓒`, form the basis of `A` over `A_{<ω}` corresponding under `μ_s` to +the basis `1 ⊗ C` of `A_{<ω} ⊗_E A/I`. +-/ + +universe u v + +open scoped DirectSum TensorProduct + +public noncomputable section + +namespace LoweringDerivation + +variable {E : Type u} {R : Type v} [Field E] [CommRing R] [Algebra E R] +variable (𝒜 : NatOrdinal → Submodule E R) [GradedAlgebra 𝒜] + +/-! ### The finite-degree part `A_{<ω}` -/ + +/-- The submodule `⨁_{n < ω} A_n` spanned by the finite degrees. -/ +def finiteDegreeSubmodule : Submodule E R := ⨆ n : ℕ, 𝒜 (n : NatOrdinal) + +omit [GradedAlgebra 𝒜] in +theorem mem_finiteDegreeSubmodule_of_mem {n : ℕ} {x : R} (hx : x ∈ 𝒜 (n : NatOrdinal)) : + x ∈ finiteDegreeSubmodule 𝒜 := + Submodule.mem_iSup_of_mem n hx + +omit [GradedAlgebra 𝒜] in +theorem finiteDegreeSubmodule_induction {p : (x : R) → x ∈ finiteDegreeSubmodule 𝒜 → Prop} + (mem : ∀ (n : ℕ) (x) (hx : x ∈ 𝒜 (n : NatOrdinal)), p x (mem_finiteDegreeSubmodule_of_mem 𝒜 hx)) + (zero : p 0 (zero_mem _)) + (add : ∀ x y hx hy, p x hx → p y hy → p (x + y) (add_mem hx hy)) + {x : R} (hx : x ∈ finiteDegreeSubmodule 𝒜) : p x hx := + Submodule.iSup_induction' (motive := p) _ mem zero add hx + +/-- Membership in `⨁_{n < ω} A_n`: every non-zero homogeneous component has finite degree. -/ +theorem mem_finiteDegreeSubmodule_iff (x : R) : + x ∈ finiteDegreeSubmodule 𝒜 ↔ + ∀ α, (DirectSum.decompose 𝒜 x α : R) ≠ 0 → ∃ n : ℕ, α = n := by + constructor + · intro hx + refine finiteDegreeSubmodule_induction 𝒜 (p := fun x _ ↦ ∀ α, + (DirectSum.decompose 𝒜 x α : R) ≠ 0 → ∃ n : ℕ, α = n) ?_ ?_ ?_ hx + · intro n y hy α hα + by_contra hne + exact hα (DirectSum.decompose_of_mem_ne 𝒜 hy fun h ↦ hne ⟨n, h.symm⟩) + · intro α hα + exact absurd (by rw [DirectSum.decompose_zero]; rfl) hα + · intro y z _ _ hy hz α hα + by_contra hne + apply hα + rw [DirectSum.decompose_add, DirectSum.add_apply, Submodule.coe_add] + have h1 : (DirectSum.decompose 𝒜 y α : R) = 0 := by + by_contra h; exact hne (hy α h) + have h2 : (DirectSum.decompose 𝒜 z α : R) = 0 := by + by_contra h; exact hne (hz α h) + rw [h1, h2, add_zero] + · intro hx + classical + rw [← DirectSum.sum_support_decompose 𝒜 x] + refine Submodule.sum_mem _ fun α hα ↦ ?_ + obtain ⟨n, rfl⟩ := hx α (by + intro h + exact (DFinsupp.mem_support_iff.mp hα) (Subtype.ext h)) + exact mem_finiteDegreeSubmodule_of_mem 𝒜 (DirectSum.decompose 𝒜 x (n : NatOrdinal)).2 + +/-- The finite-degree part `A_{<ω} = ⨁_{n < ω} A_n`, a subalgebra of `A` since `m ⊕ n = m + n` for +finite `m, n`. -/ +def finiteDegreePart : Subalgebra E R where + carrier := finiteDegreeSubmodule 𝒜 + add_mem' := add_mem + zero_mem' := zero_mem _ + algebraMap_mem' r := mem_finiteDegreeSubmodule_of_mem 𝒜 (n := 0) (by + rw [Nat.cast_zero] + exact SetLike.algebraMap_mem_graded 𝒜 r) + mul_mem' {x y} hx hy := by + refine finiteDegreeSubmodule_induction 𝒜 (p := fun x _ ↦ x * y ∈ finiteDegreeSubmodule 𝒜) + ?_ ?_ ?_ hx + · intro m a ha + refine finiteDegreeSubmodule_induction 𝒜 (p := fun y _ ↦ a * y ∈ finiteDegreeSubmodule 𝒜) + ?_ ?_ ?_ hy + · intro n b hb + exact mem_finiteDegreeSubmodule_of_mem 𝒜 (n := m + n) + (by rw [Nat.cast_add]; exact SetLike.mul_mem_graded ha hb) + · rw [mul_zero]; exact zero_mem _ + · intro b c _ _ hb hc + rw [mul_add]; exact add_mem hb hc + · rw [zero_mul]; exact zero_mem _ + · intro a b _ _ ha hb + rw [add_mul]; exact add_mem ha hb + +theorem mem_finiteDegreePart_iff (x : R) : + x ∈ finiteDegreePart 𝒜 ↔ x ∈ finiteDegreeSubmodule 𝒜 := Iff.rfl + +theorem mem_finiteDegreePart_of_mem {n : ℕ} {x : R} (hx : x ∈ 𝒜 (n : NatOrdinal)) : + x ∈ finiteDegreePart 𝒜 := + mem_finiteDegreeSubmodule_of_mem 𝒜 hx + +/-- The degree-`n` component of an element of `A_{<ω}`. -/ +def finiteDegreeComponent (n : ℕ) (a : finiteDegreePart 𝒜) : 𝒜 (n : NatOrdinal) := + DirectSum.decompose 𝒜 (a : R) (n : NatOrdinal) + +theorem coe_finiteDegreeComponent (n : ℕ) (a : finiteDegreePart 𝒜) : + (finiteDegreeComponent 𝒜 n a : R) = DirectSum.decompose 𝒜 (a : R) (n : NatOrdinal) := (rfl) + +theorem finiteDegreeComponent_add (n : ℕ) (a b : finiteDegreePart 𝒜) : + finiteDegreeComponent 𝒜 n (a + b) = + finiteDegreeComponent 𝒜 n a + finiteDegreeComponent 𝒜 n b := by + simp only [finiteDegreeComponent, Subalgebra.coe_add, DirectSum.decompose_add, + DirectSum.add_apply] + +theorem finiteDegreeComponent_mem_idealGE (n : ℕ) (a : finiteDegreePart 𝒜) : + (finiteDegreeComponent 𝒜 n a : R) ∈ idealGE 𝒜 n := + mem_idealGE_of_mem 𝒜 le_rfl (finiteDegreeComponent 𝒜 n a).2 + +/-- The finite degrees at which an element of `A_{<ω}` has a non-zero component. -/ +def finiteDegreeSupport (a : finiteDegreePart 𝒜) : Finset ℕ := by + classical + exact (DirectSum.decompose 𝒜 (a : R)).support.preimage Nat.cast + (Nat.cast_injective.injOn) + +theorem mem_finiteDegreeSupport_iff (a : finiteDegreePart 𝒜) (n : ℕ) : + n ∈ finiteDegreeSupport 𝒜 a ↔ finiteDegreeComponent 𝒜 n a ≠ 0 := by + classical + rw [finiteDegreeSupport, Finset.mem_preimage, DFinsupp.mem_support_iff] + rfl + +/-- An element of `A_{<ω}` is the sum of its homogeneous components. -/ +theorem sum_finiteDegreeComponent (a : finiteDegreePart 𝒜) : + ∑ n ∈ finiteDegreeSupport 𝒜 a, (finiteDegreeComponent 𝒜 n a : R) = a := by + classical + conv_rhs => rw [← DirectSum.sum_support_decompose 𝒜 (a : R)] + rw [finiteDegreeSupport] + refine Finset.sum_preimage (Nat.cast : ℕ → NatOrdinal) _ _ + (fun α ↦ (DirectSum.decompose 𝒜 (a : R) α : R)) ?_ + intro α hα hnot + exfalso + obtain ⟨n, rfl⟩ := (mem_finiteDegreeSubmodule_iff 𝒜 a).mp a.2 α + (fun h ↦ (DFinsupp.mem_support_iff.mp hα) (Subtype.ext h)) + exact hnot ⟨n, rfl⟩ + +theorem sum_finiteDegreeComponent_of_subset (a : finiteDegreePart 𝒜) {t : Finset ℕ} + (ht : finiteDegreeSupport 𝒜 a ⊆ t) : + ∑ n ∈ t, (finiteDegreeComponent 𝒜 n a : R) = a := by + rw [← sum_finiteDegreeComponent 𝒜 a] + symm + refine Finset.sum_subset ht fun n _ hn ↦ ?_ + rw [mem_finiteDegreeSupport_iff, not_not] at hn + rw [hn, Submodule.coe_zero] + +theorem eq_zero_of_finiteDegreeComponent_eq_zero {a : finiteDegreePart 𝒜} + (h : ∀ n, finiteDegreeComponent 𝒜 n a = 0) : a = 0 := by + apply Subtype.ext + rw [← sum_finiteDegreeComponent 𝒜 a] + simp [h] + +theorem finiteDegreeComponent_eq_self {n : ℕ} (a : finiteDegreePart 𝒜) + (ha : (a : R) ∈ 𝒜 (n : NatOrdinal)) : (finiteDegreeComponent 𝒜 n a : R) = a := + DirectSum.decompose_of_mem_same 𝒜 ha + +theorem finiteDegreeComponent_eq_zero_of_ne {m n : ℕ} (a : finiteDegreePart 𝒜) + (ha : (a : R) ∈ 𝒜 (m : NatOrdinal)) (h : m ≠ n) : (finiteDegreeComponent 𝒜 n a : R) = 0 := + DirectSum.decompose_of_mem_ne 𝒜 ha (by exact_mod_cast h) + +/-- The inclusion `A_j → A_{<ω}`. -/ +def natInclusion (j : ℕ) : 𝒜 (j : NatOrdinal) →ₗ[E] finiteDegreePart 𝒜 where + toFun a := ⟨a, mem_finiteDegreePart_of_mem 𝒜 a.2⟩ + map_add' _ _ := rfl + map_smul' _ _ := rfl + +theorem coe_natInclusion (j : ℕ) (a : 𝒜 (j : NatOrdinal)) : + (natInclusion 𝒜 j a : R) = a := (rfl) + +/-- An element of `A_{<ω}` is the sum of its homogeneous components, in `A_{<ω}`. -/ +theorem sum_natInclusion_finiteDegreeComponent (a : finiteDegreePart 𝒜) {t : Finset ℕ} + (ht : finiteDegreeSupport 𝒜 a ⊆ t) : + ∑ n ∈ t, natInclusion 𝒜 n (finiteDegreeComponent 𝒜 n a) = a := by + apply Subtype.ext + rw [AddSubmonoidClass.coe_finsetSum] + simp only [coe_natInclusion] + exact sum_finiteDegreeComponent_of_subset 𝒜 a ht + +/-! ### A homogeneous basis `𝓒` of `A/I` and its homogeneous lifts -/ + +/-- The index type of the chosen homogeneous basis `𝓒` of `A/I`: a degree `β` together with a +basis index of `(A/I)_β`. -/ +abbrev QuotientBasisIndex := + Σ β : NatOrdinal, Module.Basis.ofVectorSpaceIndex E (fibreGrade 𝒜 β) + +/-- The degree of a basis index. -/ +abbrev quotientBasisDegree (i : QuotientBasisIndex 𝒜) : NatOrdinal := i.1 + +/-- A chosen homogeneous `E`-basis `𝓒` of `A/I`. -/ +def fibreBasis : Module.Basis (QuotientBasisIndex 𝒜) E (Fibre 𝒜) := + (fibreGrade_isInternal 𝒜).collectedBasis fun β ↦ Module.Basis.ofVectorSpace E (fibreGrade 𝒜 β) + +theorem fibreBasis_mem (i : QuotientBasisIndex 𝒜) : + fibreBasis 𝒜 i ∈ fibreGrade 𝒜 (quotientBasisDegree 𝒜 i) := + (fibreGrade_isInternal 𝒜).collectedBasis_mem _ i + +/-- The expansion in `𝓒` of a homogeneous element of `A/I` involves only basis vectors of its +degree. -/ +theorem fibreBasis_repr_eq_zero {β : NatOrdinal} {c : Fibre 𝒜} (hc : c ∈ fibreGrade 𝒜 β) + (i : QuotientBasisIndex 𝒜) (hi : quotientBasisDegree 𝒜 i ≠ β) : (fibreBasis 𝒜).repr c i = 0 := + (fibreGrade_isInternal 𝒜).collectedBasis_repr_of_mem_ne _ (Ne.symm hi) hc + +/-- A chosen homogeneous lift `s(C) ∈ A` of each basis vector `C ∈ 𝓒`. -/ +def quotientBasisLift (i : QuotientBasisIndex 𝒜) : R := + (exists_mem_of_mem_fibreGrade 𝒜 (fibreBasis_mem 𝒜 i)).choose + +theorem quotientBasisLift_mem (i : QuotientBasisIndex 𝒜) : quotientBasisLift 𝒜 i ∈ 𝒜 + (quotientBasisDegree 𝒜 i) := + (exists_mem_of_mem_fibreGrade 𝒜 (fibreBasis_mem 𝒜 i)).choose_spec.1 + +theorem fibreMap_quotientBasisLift (i : QuotientBasisIndex 𝒜) : fibreMap 𝒜 (quotientBasisLift 𝒜 i) = + fibreBasis 𝒜 i := + (exists_mem_of_mem_fibreGrade 𝒜 (fibreBasis_mem 𝒜 i)).choose_spec.2 + +theorem quotientBasisLift_ne_zero (i : QuotientBasisIndex 𝒜) : quotientBasisLift 𝒜 i ≠ 0 := fun h ↦ + (fibreBasis 𝒜).ne_zero i (by rw [← fibreMap_quotientBasisLift, h, map_zero]) + +/-- The graded `E`-linear section `s : A/I → A` of `π` sending each `C ∈ 𝓒` to its chosen lift +`s(C)`. -/ +def fibreSection : Fibre 𝒜 →ₗ[E] R := (fibreBasis 𝒜).constr E (quotientBasisLift 𝒜) + +theorem fibreSection_basis (i : QuotientBasisIndex 𝒜) : + fibreSection 𝒜 (fibreBasis 𝒜 i) = quotientBasisLift 𝒜 i := + (fibreBasis 𝒜).constr_basis E _ i + +theorem fibreMap_fibreSection (c : Fibre 𝒜) : fibreMap 𝒜 (fibreSection 𝒜 c) = c := by + have h : (fibreMap 𝒜).toLinearMap ∘ₗ fibreSection 𝒜 = LinearMap.id := + (fibreBasis 𝒜).ext fun i ↦ by + rw [LinearMap.comp_apply, fibreSection_basis, AlgHom.toLinearMap_apply, + fibreMap_quotientBasisLift, + LinearMap.id_apply] + exact LinearMap.congr_fun h c + +/-- The section `s` is graded: `s((A/I)_β) ⊆ A_β`. -/ +theorem fibreSection_mem {β : NatOrdinal} {c : Fibre 𝒜} (hc : c ∈ fibreGrade 𝒜 β) : + fibreSection 𝒜 c ∈ 𝒜 β := by + rw [fibreSection, Module.Basis.constr_apply, Finsupp.sum] + refine Submodule.sum_mem _ fun i hi ↦ Submodule.smul_mem _ _ ?_ + have hgrade : quotientBasisDegree 𝒜 i = β := by + by_contra hne + exact (Finsupp.mem_support_iff.mp hi) (fibreBasis_repr_eq_zero 𝒜 hc i hne) + rw [← hgrade] + exact quotientBasisLift_mem 𝒜 i + +/-! ### The filtered `A_{<ω}`-module `A` -/ + +/-- A graded `E`-linear section `s : A/I → A` of the quotient map `π`: `π ∘ s = id` and `s` +carries `(A/I)_β` into `A_β`. -/ +structure IsGradedFibreSection (s : Fibre 𝒜 →ₗ[E] R) : Prop where + /-- `π ∘ s = id`. -/ + fibreMap_apply : ∀ c, fibreMap 𝒜 (s c) = c + /-- `s` is graded. -/ + mem : ∀ {β : NatOrdinal} {c : Fibre 𝒜}, c ∈ fibreGrade 𝒜 β → s c ∈ 𝒜 β + +/-- The chosen section `fibreSection` is a graded section of `π`. -/ +theorem fibreSection_isGradedFibreSection : IsGradedFibreSection 𝒜 (fibreSection 𝒜) where + fibreMap_apply := fibreMap_fibreSection 𝒜 + mem := fibreSection_mem 𝒜 + +/-- The paper's `μ_s : A_{<ω} ⊗_E A/I → A`, `B ⊗ C ↦ B s(C)`, as an `A_{<ω}`-linear map. -/ +def muOfSection (s : Fibre 𝒜 →ₗ[E] R) : + finiteDegreePart 𝒜 ⊗[E] Fibre 𝒜 →ₗ[finiteDegreePart 𝒜] R := + TensorProduct.AlgebraTensorModule.lift + (LinearMap.toSpanSingleton (finiteDegreePart 𝒜) (Fibre 𝒜 →ₗ[E] R) s) + +theorem muOfSection_tmul (s : Fibre 𝒜 →ₗ[E] R) (a : finiteDegreePart 𝒜) (c : Fibre 𝒜) : + muOfSection 𝒜 s (a ⊗ₜ[E] c) = (a : R) * s c := by + rw [muOfSection, TensorProduct.AlgebraTensorModule.lift_tmul, + LinearMap.toSpanSingleton_apply, LinearMap.smul_apply, Subalgebra.smul_def, smul_eq_mul] + +/-- The restriction of `μ_s` to `A_j ⊗ A/I`, `B ⊗ C ↦ B s(C)`. -/ +def gradeSectionMul (s : Fibre 𝒜 →ₗ[E] R) (j : ℕ) : 𝒜 (j : NatOrdinal) ⊗[E] Fibre 𝒜 →ₗ[E] R := + TensorProduct.lift ((LinearMap.mul E R).compl₁₂ (𝒜 (j : NatOrdinal)).subtype s) + +omit [GradedAlgebra 𝒜] in +theorem gradeSectionMul_tmul (s : Fibre 𝒜 →ₗ[E] R) (j : ℕ) (a : 𝒜 (j : NatOrdinal)) + (c : Fibre 𝒜) : gradeSectionMul 𝒜 s j (a ⊗ₜ[E] c) = (a : R) * s c := by + rw [gradeSectionMul, TensorProduct.lift.tmul] + rfl + +theorem muOfSection_rTensor_natInclusion (s : Fibre 𝒜 →ₗ[E] R) (j : ℕ) + (T : 𝒜 (j : NatOrdinal) ⊗[E] Fibre 𝒜) : + muOfSection 𝒜 s ((natInclusion 𝒜 j).rTensor _ T) = gradeSectionMul 𝒜 s j T := by + induction T using TensorProduct.inductionOn with + | tmul a c => + rw [LinearMap.rTensor_tmul, muOfSection_tmul, gradeSectionMul_tmul, coe_natInclusion] + | add x y hx hy => rw [map_add, map_add, hx, hy, map_add] + +omit [GradedAlgebra 𝒜] in +theorem gradeSectionMul_mem_idealGE (s : Fibre 𝒜 →ₗ[E] R) (j : ℕ) + (T : 𝒜 (j : NatOrdinal) ⊗[E] Fibre 𝒜) : gradeSectionMul 𝒜 s j T ∈ idealGE 𝒜 j := by + induction T using TensorProduct.inductionOn with + | tmul a c => + rw [gradeSectionMul_tmul] + exact Ideal.mul_mem_right _ _ (mem_idealGE_of_mem 𝒜 le_rfl a.2) + | add x y hx hy => rw [map_add]; exact add_mem hx hy + +/-- For a section `s` of `π`, `μ_s(T)` represents `μ_j(T)`: its class modulo `I_{≥j+1}` is +`μ_j(T)`. -/ +theorem mk_gradeSectionMul {s : Fibre 𝒜 →ₗ[E] R} (hs : IsGradedFibreSection 𝒜 s) (j : ℕ) + (T : 𝒜 (j : NatOrdinal) ⊗[E] Fibre 𝒜) : + (Submodule.Quotient.mk (gradeSectionMul 𝒜 s j T) : R ⧸ idealGE 𝒜 (j + 1)) = + mu 𝒜 j T := by + induction T using TensorProduct.inductionOn with + | tmul a c => + rw [gradeSectionMul_tmul, ← hs.fibreMap_apply c, mu_tmul, hs.fibreMap_apply] + | add x y hx hy => rw [map_add, map_add, Submodule.Quotient.mk_add, hx, hy] + +/-- For a graded section, `μ_s` carries `A_j ⊗ (A/I)_β` into `A_{j ⊕ β}`. -/ +theorem gradeSectionMul_lTensor_mem {s : Fibre 𝒜 →ₗ[E] R} (hs : IsGradedFibreSection 𝒜 s) + (j : ℕ) (β : NatOrdinal) (T : 𝒜 (j : NatOrdinal) ⊗[E] fibreGrade 𝒜 β) : + gradeSectionMul 𝒜 s j ((fibreGrade 𝒜 β).subtype.lTensor _ T) ∈ 𝒜 ((j : NatOrdinal) + β) := by + induction T using TensorProduct.inductionOn with + | tmul a c => + rw [LinearMap.lTensor_tmul, gradeSectionMul_tmul, Submodule.subtype_apply] + exact SetLike.mul_mem_graded a.2 (hs.mem c.2) + | add x y hx hy => rw [map_add, map_add]; exact add_mem hx hy + +/-- The submodule `(A_{<ω})_{≥j} ⊗_E A/I = ∑_{n ≥ j} A_n ⊗ A/I` of `A_{<ω} ⊗_E A/I`. -/ +def tensorIdealGEFiltration (j : ℕ) : Submodule E (finiteDegreePart 𝒜 ⊗[E] Fibre 𝒜) := + ⨆ (e : ℕ) (_ : j ≤ e), LinearMap.range ((natInclusion 𝒜 e).rTensor (Fibre 𝒜)) + +theorem rTensor_natInclusion_mem_tensorIdealGEFiltration {j e : ℕ} (hje : j ≤ e) + (T : 𝒜 (e : NatOrdinal) ⊗[E] Fibre 𝒜) : + (natInclusion 𝒜 e).rTensor _ T ∈ tensorIdealGEFiltration 𝒜 j := + Submodule.mem_iSup_of_mem e (Submodule.mem_iSup_of_mem hje ⟨T, rfl⟩) + +theorem tensorIdealGEFiltration_antitone {i j : ℕ} (hij : i ≤ j) : + tensorIdealGEFiltration 𝒜 j ≤ tensorIdealGEFiltration 𝒜 i := + iSup₂_le fun e hje ↦ le_iSup₂_of_le e (hij.trans hje) le_rfl + +/-- `μ_s` carries `(A_{<ω})_{≥j} ⊗_E A/I` into `I_{≥j}`. -/ +theorem muOfSection_mem_idealGE (s : Fibre 𝒜 →ₗ[E] R) {j : ℕ} + {u : finiteDegreePart 𝒜 ⊗[E] Fibre 𝒜} (hu : u ∈ tensorIdealGEFiltration 𝒜 j) : + muOfSection 𝒜 s u ∈ idealGE 𝒜 j := by + have hle : tensorIdealGEFiltration 𝒜 j ≤ + ((idealGE 𝒜 j).restrictScalars E).comap ((muOfSection 𝒜 s).restrictScalars E) := by + refine iSup₂_le fun e hje ↦ ?_ + rintro _ ⟨T, rfl⟩ + rw [Submodule.mem_comap, LinearMap.restrictScalars_apply, Submodule.restrictScalars_mem, + muOfSection_rTensor_natInclusion] + exact idealGE_antitone 𝒜 hje (gradeSectionMul_mem_idealGE 𝒜 s e T) + exact hle hu + +/-- Every homogeneous element of `I_{≥j}` lies in `μ_s((A_{<ω})_{≥j} ⊗_E A/I)`: descending +induction on `j`, using the surjectivity of `μ_j` and the vanishing `I_{≥j} ∩ A_δ = 0` for `j` +beyond the finite part of `δ`. -/ +theorem mem_map_tensorIdealGEFiltration_of_mem_idealGE {s : Fibre 𝒜 →ₗ[E] R} + (hs : IsGradedFibreSection 𝒜 s) {δ : NatOrdinal} (d : ℕ) : + ∀ j : ℕ, δ.constantCoeff + 1 ≤ j + d → ∀ H ∈ 𝒜 δ, H ∈ idealGE 𝒜 j → + H ∈ (tensorIdealGEFiltration 𝒜 j).map ((muOfSection 𝒜 s).restrictScalars E) := by + induction d with + | zero => + intro j hj H hHδ hH + rw [eq_zero_of_mem_idealGE_of_constantCoeff_lt 𝒜 hHδ hH (by omega)] + exact zero_mem _ + | succ d ih => + intro j hj H hHδ hH + by_cases hjδ : δ.constantCoeff < j + · rw [eq_zero_of_mem_idealGE_of_constantCoeff_lt 𝒜 hHδ hH hjδ] + exact zero_mem _ + obtain ⟨T, hT⟩ := exists_mu_lTensor_eq 𝒜 hHδ hH + set G := gradeSectionMul 𝒜 s j ((fibreGrade 𝒜 (δ.removeNat j)).subtype.lTensor _ T) with hG + have hsum : (j : NatOrdinal) + δ.removeNat j = δ := by + rw [add_comm] + exact NatOrdinal.removeNat_add_natCast (by omega) + have hGδ : G ∈ 𝒜 δ := hsum ▸ gradeSectionMul_lTensor_mem 𝒜 hs j _ T + have hdiff : H - G ∈ idealGE 𝒜 (j + 1) := by + rw [← mk_gradeSectionMul 𝒜 hs] at hT + exact (Submodule.Quotient.eq _).mp hT.symm + have h1 := ih (j + 1) (by omega) _ (sub_mem hHδ hGδ) hdiff + have h2 : G ∈ (tensorIdealGEFiltration 𝒜 j).map ((muOfSection 𝒜 s).restrictScalars E) := + ⟨_, rTensor_natInclusion_mem_tensorIdealGEFiltration 𝒜 le_rfl _, + by rw [LinearMap.restrictScalars_apply, muOfSection_rTensor_natInclusion]⟩ + have h1' := Submodule.map_mono (tensorIdealGEFiltration_antitone 𝒜 (Nat.le_succ j)) h1 + simpa using add_mem h1' h2 + +/-- `μ_s` carries `(A_{<ω})_{≥j} ⊗_E A/I` onto `I_{≥j}`. -/ +theorem map_tensorIdealGEFiltration {s : Fibre 𝒜 →ₗ[E] R} (hs : IsGradedFibreSection 𝒜 s) + (j : ℕ) : + (tensorIdealGEFiltration 𝒜 j).map ((muOfSection 𝒜 s).restrictScalars E) = + (idealGE 𝒜 j).restrictScalars E := by + classical + apply le_antisymm + · rintro _ ⟨u, hu, rfl⟩ + rw [LinearMap.restrictScalars_apply, Submodule.restrictScalars_mem] + exact muOfSection_mem_idealGE 𝒜 s hu + · intro H hH + rw [Submodule.restrictScalars_mem] at hH + rw [← DirectSum.sum_support_decompose 𝒜 H] + refine Submodule.sum_mem _ fun δ _ ↦ ?_ + exact mem_map_tensorIdealGEFiltration_of_mem_idealGE 𝒜 hs (δ.constantCoeff + 1) j + (by omega) _ (DirectSum.decompose 𝒜 H δ).2 (idealGE_isHomogeneous 𝒜 j δ hH) + +/-- Every tensor in `A_{<ω} ⊗_E A/I` is a finite sum of pieces `(ι_n ⊗ 1) t_n` with +`t_n ∈ A_n ⊗ A/I`, `ι_n : A_n → A_{<ω}` the inclusion. -/ +theorem exists_eq_sum_rTensor_natInclusion (u : finiteDegreePart 𝒜 ⊗[E] Fibre 𝒜) : + ∃ (N : Finset ℕ) (t : ∀ n : ℕ, 𝒜 (n : NatOrdinal) ⊗[E] Fibre 𝒜), + u = ∑ n ∈ N, (natInclusion 𝒜 n).rTensor _ (t n) := by + classical + obtain ⟨P, rfl⟩ := TensorProduct.exists_finset u + refine ⟨P.biUnion fun p ↦ finiteDegreeSupport 𝒜 p.1, + fun n ↦ ∑ p ∈ P, finiteDegreeComponent 𝒜 n p.1 ⊗ₜ[E] p.2, + ?_⟩ + have : ∀ p ∈ P, p.1 ⊗ₜ[E] p.2 = ∑ n ∈ P.biUnion fun p ↦ finiteDegreeSupport 𝒜 p.1, + natInclusion 𝒜 n (finiteDegreeComponent 𝒜 n p.1) ⊗ₜ[E] p.2 := fun p hp ↦ by + rw [← TensorProduct.sum_tmul, sum_natInclusion_finiteDegreeComponent 𝒜 p.1 + fun n hn ↦ Finset.mem_biUnion.mpr ⟨p, hp, hn⟩] + rw [Finset.sum_congr rfl this, Finset.sum_comm] + exact Finset.sum_congr rfl fun n _ ↦ by simp only [map_sum, LinearMap.rTensor_tmul] + +/-- `μ_s` is injective: in a kernel element, the piece of least finite degree `d` gives a +relation in the kernel of `μ_d`. -/ +theorem muOfSection_injective (h0 : GradeZeroScalars 𝒜) {Δ : R →ₗ[E] FunAtZeroMinus R} + (hΔ : IsLoweringDerivation 𝒜 Δ) {s : Fibre 𝒜 →ₗ[E] R} (hs : IsGradedFibreSection 𝒜 s) : + Function.Injective (muOfSection 𝒜 s) := by + classical + rw [injective_iff_map_eq_zero] + intro u hu + obtain ⟨N, t, rfl⟩ := exists_eq_sum_rTensor_natInclusion 𝒜 u + by_contra hne + -- a least finite degree `d` with a non-zero piece + have hex : ∃ n ∈ N, t n ≠ 0 := by + by_contra hall + push Not at hall + exact hne (Finset.sum_eq_zero fun n hn ↦ by rw [hall n hn, map_zero]) + obtain ⟨d, hdN, hdmin⟩ := (N.filter fun n ↦ t n ≠ 0).exists_min_image id + (by obtain ⟨n, hn, hn'⟩ := hex; exact ⟨n, Finset.mem_filter.mpr ⟨hn, hn'⟩⟩) + simp only [id, Finset.mem_filter] at hdmin + obtain ⟨hdN', hd0⟩ := Finset.mem_filter.mp hdN + -- the remaining pieces lie in `I_{≥d+1}` + have hrest : ∑ n ∈ N.erase d, gradeSectionMul 𝒜 s n (t n) ∈ idealGE 𝒜 (d + 1) := by + refine Submodule.sum_mem _ fun n hn ↦ ?_ + by_cases hn0 : t n = 0 + · rw [hn0, map_zero]; exact zero_mem _ + · have hdn : d < n := lt_of_le_of_ne (hdmin n ⟨Finset.mem_of_mem_erase hn, hn0⟩) + (Finset.ne_of_mem_erase hn).symm + exact idealGE_antitone 𝒜 hdn (gradeSectionMul_mem_idealGE 𝒜 s n (t n)) + have hlead : gradeSectionMul 𝒜 s d (t d) ∈ idealGE 𝒜 (d + 1) := by + have hsum : ∑ n ∈ N, gradeSectionMul 𝒜 s n (t n) = 0 := by + rw [← hu, map_sum] + exact Finset.sum_congr rfl fun n _ ↦ (muOfSection_rTensor_natInclusion 𝒜 s n _).symm + rw [← Finset.add_sum_erase N _ hdN'] at hsum + rw [eq_neg_of_add_eq_zero_left hsum] + exact neg_mem hrest + have hchar : mu 𝒜 d (t d) = 0 := by + rw [← mk_gradeSectionMul 𝒜 hs, Submodule.Quotient.mk_eq_zero] + exact hlead + exact hd0 ((injective_iff_map_eq_zero _).mp (hΔ.mu_injective h0 d) _ hchar) + +/-- `μ_s` is bijective for every graded section `s` of `π`. -/ +theorem muOfSection_bijective (h0 : GradeZeroScalars 𝒜) {Δ : R →ₗ[E] FunAtZeroMinus R} + (hΔ : IsLoweringDerivation 𝒜 Δ) {s : Fibre 𝒜 →ₗ[E] R} (hs : IsGradedFibreSection 𝒜 s) : + Function.Bijective (muOfSection 𝒜 s) := by + refine ⟨muOfSection_injective 𝒜 h0 hΔ hs, fun y ↦ ?_⟩ + have hy : y ∈ (idealGE 𝒜 0).restrictScalars E := by + rw [Submodule.restrictScalars_mem, idealGE_zero] + exact Submodule.mem_top + rw [← map_tensorIdealGEFiltration 𝒜 hs 0] at hy + obtain ⟨u, -, hu⟩ := hy + exact ⟨u, hu⟩ + +/-! ### The basis of `A` over `A_{<ω}` -/ + +/-- The chosen homogeneous lifts `s(C)`, `C ∈ 𝓒`, form a basis of `A` over `A_{<ω}`: the image +under `μ_s`, for the section `s = fibreSection`, of the basis `1 ⊗ C` of `A_{<ω} ⊗_E A/I` over +`A_{<ω}`. -/ +def basisOverFiniteDegreePart (h0 : GradeZeroScalars 𝒜) {Δ : R →ₗ[E] FunAtZeroMinus R} + (hΔ : IsLoweringDerivation 𝒜 Δ) : + Module.Basis (QuotientBasisIndex 𝒜) (finiteDegreePart 𝒜) R := + (Algebra.TensorProduct.basis (finiteDegreePart 𝒜) (fibreBasis 𝒜)).map + (LinearEquiv.ofBijective (muOfSection 𝒜 (fibreSection 𝒜)) + (muOfSection_bijective 𝒜 h0 hΔ (fibreSection_isGradedFibreSection 𝒜))) + +theorem basisOverFiniteDegreePart_apply (h0 : GradeZeroScalars 𝒜) {Δ : R →ₗ[E] FunAtZeroMinus R} + (hΔ : IsLoweringDerivation 𝒜 Δ) (i : QuotientBasisIndex 𝒜) : + basisOverFiniteDegreePart 𝒜 h0 hΔ i = quotientBasisLift 𝒜 i := by + rw [basisOverFiniteDegreePart, Module.Basis.map_apply, Algebra.TensorProduct.basis_apply, + LinearEquiv.ofBijective_apply, muOfSection_tmul, OneMemClass.coe_one, one_mul, + fibreSection_basis] + +end LoweringDerivation diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/LoweringDerivation/Grading.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/LoweringDerivation/Grading.lean new file mode 100644 index 0000000000..43abcdd1b2 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/LoweringDerivation/Grading.lean @@ -0,0 +1,322 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.FinitePart +public import Mathlib.RingTheory.GradedAlgebra.Basic +public import Mathlib.RingTheory.GradedAlgebra.Homogeneous.Ideal +public import Mathlib.RingTheory.Ideal.Quotient.Operations + +import Mathlib.LinearAlgebra.DFinsupp + +/-! +# Graded algebras over countable ordinals: the ideals `I_{≥j}` and the quotient `A/I` + +Let `A` (Lean `R`) be a commutative algebra over a field `E`, graded by the natural numbers' +ordinal extension `NatOrdinal` with its natural sum `⊕` (Lean `+`). The paper's setting has +`A_0 = E`; this file uses only the grading. For `j ∈ ℕ`, the ideal `I_{≥j}` is generated by the +homogeneous elements of finite degree at least `j`, + +`I_{≥j} = ∑_{j ≤ n < ω} A_n A`, + +with `I_{≥0} = A` and `I_{≥i} I_{≥j} ⊆ I_{≥i+j}`; the `I_{≥j}` are homogeneous and decreasing. +Every homogeneous element of `I_{≥j}` is a finite sum of products `B C` with `B ∈ A_e`, `e ≥ j` +finite, and `C` homogeneous of complementary degree, so `I_{≥j} ∩ A_δ = 0` as soon as `j` exceeds +the finite part of `δ` (the constant Cantor coefficient, Lean `δ.constantCoeff`). The quotient +`A/I`, `I = I_{≥1}`, inherits the grading: the images `(A/I)_β = π(A_β)` form an internal direct +sum decomposition of `A/I`, making it a graded `E`-algebra. + +The paper writes `A/I` (in the application, `P̂/I`) and calls it the quotient; its one use of +the word "fibre" is "`P̂/I ≅ P̂ ⊗_{P̂_{<ω}} K`, the fibre of `P̂` over the quotient map +`P̂_{<ω} → P̂_{<ω}/(P̂_{<ω})₊ = K`". "Fibre" is this Lean's noun for it: `Fibre 𝒜` is `A/I`, +`fibreIdeal 𝒜` is `I`, `fibreMap 𝒜` is `π`, and `fibreGrade 𝒜 β` is `(A/I)_β`. +-/ + +universe u v + +open scoped DirectSum + +public noncomputable section + +namespace LoweringDerivation + +variable {E : Type u} {R : Type v} [Field E] [CommRing R] [Algebra E R] +variable (𝒜 : NatOrdinal → Submodule E R) [GradedAlgebra 𝒜] + +/-! ### The ideals `I_{≥j}` -/ + +/-- The generators of `I_{≥j}`: the homogeneous elements of finite degree at least `j`. -/ +def idealGEGenerators (j : ℕ) : Set R := + ⋃ e : ℕ, ⋃ (_ : j ≤ e), (𝒜 (e : NatOrdinal) : Set R) + +/-- The ideal `I_{≥j} = ∑_{j ≤ n < ω} A_n A` generated by the homogeneous elements of finite degree +at least `j`. -/ +def idealGE (j : ℕ) : Ideal R := + Ideal.span (idealGEGenerators 𝒜 j) + +omit [GradedAlgebra 𝒜] in +theorem idealGE_eq_span (j : ℕ) : idealGE 𝒜 j = Ideal.span (idealGEGenerators 𝒜 j) := (rfl) + +omit [GradedAlgebra 𝒜] in +theorem mem_idealGEGenerators_iff (j : ℕ) (x : R) : + x ∈ idealGEGenerators 𝒜 j ↔ ∃ e : ℕ, j ≤ e ∧ x ∈ 𝒜 (e : NatOrdinal) := by + simp [idealGEGenerators] + +omit [GradedAlgebra 𝒜] in +theorem mem_idealGE_of_mem {j e : ℕ} (hje : j ≤ e) {x : R} + (hx : x ∈ 𝒜 (e : NatOrdinal)) : + x ∈ idealGE 𝒜 j := + Ideal.subset_span ((mem_idealGEGenerators_iff 𝒜 j x).mpr ⟨e, hje, hx⟩) + +omit [GradedAlgebra 𝒜] in +theorem idealGE_antitone {i j : ℕ} (hij : i ≤ j) : + idealGE 𝒜 j ≤ idealGE 𝒜 i := + Ideal.span_mono fun x hx ↦ by + obtain ⟨e, hje, hxe⟩ := (mem_idealGEGenerators_iff 𝒜 j x).mp hx + exact (mem_idealGEGenerators_iff 𝒜 i x).mpr ⟨e, hij.trans hje, hxe⟩ + +theorem idealGE_zero : idealGE 𝒜 0 = ⊤ := + (Ideal.eq_top_iff_one _).mpr (mem_idealGE_of_mem 𝒜 (e := 0) le_rfl + (by simpa using SetLike.one_mem_graded 𝒜)) + +theorem idealGE_mul_le (i j : ℕ) : + idealGE 𝒜 i * idealGE 𝒜 j ≤ idealGE 𝒜 (i + j) := by + rw [idealGE, idealGE, Ideal.span_mul_span] + refine Ideal.span_le.mpr ?_ + rintro _ ⟨x, hx, y, hy, rfl⟩ + obtain ⟨e, hie, hxe⟩ := (mem_idealGEGenerators_iff 𝒜 i x).mp hx + obtain ⟨e', hje', hye'⟩ := (mem_idealGEGenerators_iff 𝒜 j y).mp hy + refine Ideal.subset_span ((mem_idealGEGenerators_iff 𝒜 (i + j) (x * y)).mpr + ⟨e + e', Nat.add_le_add hie hje', ?_⟩) + rw [Nat.cast_add] + exact SetLike.mul_mem_graded hxe hye' + +theorem mul_mem_idealGE {i j : ℕ} {x y : R} (hx : x ∈ idealGE 𝒜 i) + (hy : y ∈ idealGE 𝒜 j) : x * y ∈ idealGE 𝒜 (i + j) := + idealGE_mul_le 𝒜 i j (Ideal.mul_mem_mul hx hy) + +theorem idealGE_isHomogeneous (j : ℕ) : (idealGE 𝒜 j).IsHomogeneous 𝒜 := + Ideal.homogeneous_span 𝒜 _ fun x hx ↦ by + obtain ⟨e, -, hxe⟩ := (mem_idealGEGenerators_iff 𝒜 j x).mp hx + exact ⟨(e : NatOrdinal), hxe⟩ + +/-! ### Homogeneous presentations and the vanishing `I_{≥j} ∩ A_δ = 0` -/ + +/-- The degree-`δ` component of a product `r * g` with `g` homogeneous of degree `e` is +`r_β * g` when `β ⊕ e = δ`. -/ +theorem decompose_mul_of_right_mem_eq {r g : R} {e β δ : NatOrdinal} (hg : g ∈ 𝒜 e) + (hβ : β + e = δ) : + (DirectSum.decompose 𝒜 (r * g) δ : R) = (DirectSum.decompose 𝒜 r β : R) * g := by + rw [DirectSum.decompose_mul, DirectSum.decompose_of_mem 𝒜 hg] + exact DirectSum.coe_mul_of_apply_aux 𝒜 _ _ fun x ↦ + ⟨fun hx ↦ add_right_cancel (hx.trans hβ.symm), fun hx ↦ hx ▸ hβ⟩ + +/-- The degree-`δ` component of `r * g`, with `g` homogeneous of degree `e`, vanishes when no +degree `β` satisfies `β ⊕ e = δ`. -/ +theorem decompose_mul_of_right_mem_eq_zero {r g : R} {e δ : NatOrdinal} (hg : g ∈ 𝒜 e) + (h : ∀ β, β + e ≠ δ) : (DirectSum.decompose 𝒜 (r * g) δ : R) = 0 := by + classical + rw [DirectSum.decompose_mul, DirectSum.decompose_of_mem 𝒜 hg, + DirectSum.coe_mul_apply_eq_dfinsuppSum, DFinsupp.sum_comm] + refine (DFinsupp.sum_single_index ?_).trans (DFinsupp.sum_eq_zero fun β ↦ ite_eq_right (h β)) + simp + +/-- The degree-`δ` component of an element of the span of homogeneous generators is a finite sum +of products `r_k * g_k`, with `g_k` a generator, of degree `e g_k`, and `r_k` a homogeneous +component, of degree `β_k` with `β_k ⊕ e g_k = δ`, of the coefficient of `g_k`. -/ +theorem exists_decompose_eq_sum_of_mem_span {S : Set R} (e : S → NatOrdinal) + (hS : ∀ g : S, (g : R) ∈ 𝒜 (e g)) {x : R} (hx : x ∈ Ideal.span S) (δ : NatOrdinal) : + ∃ (κ : Type) (_ : Fintype κ) (g : κ → S) (r : κ → R) (β : κ → NatOrdinal), + (∀ k, r k ∈ 𝒜 (β k)) ∧ (∀ k, β k + e (g k) = δ) ∧ + (DirectSum.decompose 𝒜 x δ : R) = ∑ k, r k * g k := by + classical + obtain ⟨n, c, g, hsum⟩ := Submodule.mem_span_set'.mp hx + let κ := {i : Fin n // ∃ β, β + e (g i) = δ} + choose β hβ using fun k : κ ↦ k.2 + refine ⟨κ, inferInstance, fun k ↦ g k.1, fun k ↦ (DirectSum.decompose 𝒜 (c k.1) (β k) : R), β, + fun k ↦ (DirectSum.decompose 𝒜 (c k.1) (β k)).2, hβ, ?_⟩ + let β' : Fin n → NatOrdinal := fun i ↦ + if hP : ∃ β, β + e (g i) = δ then β ⟨i, hP⟩ else 0 + have hterm : ∀ i : Fin n, (DirectSum.decompose 𝒜 (c i • (g i : R)) δ : R) = + if ∃ β, β + e (g i) = δ then (DirectSum.decompose 𝒜 (c i) (β' i) : R) * g i else 0 := by + intro i + rw [smul_eq_mul] + split_ifs with hP + · rw [show β' i = β ⟨i, hP⟩ from dite_eq_left hP] + exact decompose_mul_of_right_mem_eq 𝒜 (hS (g i)) (hβ ⟨i, hP⟩) + · exact decompose_mul_of_right_mem_eq_zero 𝒜 (hS (g i)) fun β hβ ↦ hP ⟨β, hβ⟩ + rw [← hsum, DirectSum.decompose_sum, DirectSum.sum_apply, Submodule.coe_sum, + Finset.sum_congr rfl fun i _ ↦ hterm i, ← Finset.sum_filter, + Finset.sum_subtype (Finset.univ.filter fun i : Fin n ↦ ∃ β, β + e (g i) = δ) + (p := fun i : Fin n ↦ ∃ β, β + e (g i) = δ) (fun i ↦ by simp)] + exact Finset.sum_congr rfl fun k _ ↦ by rw [show β' k.1 = β k from dite_eq_left k.2] + +/-- A homogeneous element of `I_{≥j} ∩ A_δ` is a finite sum of products `a * b` with `a ∈ A_e`, +`e ≥ j` finite, and `b` homogeneous of a degree `β` with `e ⊕ β = δ`. -/ +theorem exists_homogeneous_presentation {j : ℕ} {δ : NatOrdinal} {x : R} (hxδ : x ∈ 𝒜 δ) + (hx : x ∈ idealGE 𝒜 j) : + ∃ (κ : Type) (_ : Fintype κ) (e : κ → ℕ) (a b : κ → R) (β : κ → NatOrdinal), + (∀ k, j ≤ e k) ∧ (∀ k, a k ∈ 𝒜 (e k : NatOrdinal)) ∧ + (∀ k, b k ∈ 𝒜 (β k)) ∧ (∀ k, (e k : NatOrdinal) + β k = δ) ∧ + x = ∑ k, a k * b k := by + choose e hje hge using fun g : idealGEGenerators 𝒜 j ↦ (mem_idealGEGenerators_iff 𝒜 j g).mp g.2 + obtain ⟨κ, _, g, r, β, hr, hβ, hx'⟩ := exists_decompose_eq_sum_of_mem_span 𝒜 + (fun g ↦ (e g : NatOrdinal)) hge (by rwa [idealGE_eq_span] at hx) δ + refine ⟨κ, inferInstance, fun k ↦ e (g k), fun k ↦ g k, r, β, fun k ↦ hje (g k), + fun k ↦ hge (g k), hr, fun k ↦ by rw [add_comm]; exact hβ k, ?_⟩ + rw [← DirectSum.decompose_of_mem_same 𝒜 hxδ, hx'] + exact Finset.sum_congr rfl fun k _ ↦ mul_comm _ _ + +/-- `I_{≥j} ∩ A_δ = 0` once `j` exceeds the finite part of `δ` (its constant Cantor +coefficient): for `δ = λ + n` with `n < j`, no product `B C` with `B ∈ A_e`, `e ≥ j` finite, has +degree `δ`. -/ +theorem eq_zero_of_mem_idealGE_of_constantCoeff_lt {j : ℕ} {δ : NatOrdinal} {x : R} + (hxδ : x ∈ 𝒜 δ) (hx : x ∈ idealGE 𝒜 j) (hj : δ.constantCoeff < j) : x = 0 := by + obtain ⟨κ, _, e, a, b, β, hje, -, -, heβ, rfl⟩ := + exists_homogeneous_presentation 𝒜 hxδ hx + refine Finset.sum_eq_zero fun k _ ↦ (absurd ?_ (not_lt.mpr (hje k))) + have h := congrArg NatOrdinal.constantCoeff (heβ k) + rw [NatOrdinal.constantCoeff_add, NatOrdinal.constantCoeff_natCast] at h + omega + +/-! ### The quotient `A/I` and its grading -/ + +/-- The ideal `I = I_{≥1}` generated by the elements of positive finite degree. -/ +abbrev fibreIdeal : Ideal R := idealGE 𝒜 1 + +/-- The quotient `A/I`, `I = I_{≥1}`; for `A = P̂` the paper's `P̂/I`. -/ +abbrev Fibre : Type v := R ⧸ fibreIdeal 𝒜 + +/-- The quotient map `π : A → A/I`. -/ +abbrev fibreMap : R →ₐ[E] Fibre 𝒜 := Ideal.Quotient.mkₐ E (fibreIdeal 𝒜) + +omit [GradedAlgebra 𝒜] in +theorem fibreMap_surjective : Function.Surjective (fibreMap 𝒜) := + Ideal.Quotient.mkₐ_surjective E _ + +omit [GradedAlgebra 𝒜] in +theorem fibreMap_eq_zero_iff (x : R) : fibreMap 𝒜 x = 0 ↔ x ∈ fibreIdeal 𝒜 := + Ideal.Quotient.eq_zero_iff_mem + +/-- The degree-`β` part `(A/I)_β = π(A_β)` of the quotient. -/ +def fibreGrade (β : NatOrdinal) : Submodule E (Fibre 𝒜) := + (𝒜 β).map (fibreMap 𝒜).toLinearMap + +omit [GradedAlgebra 𝒜] in +theorem fibreMap_mem_fibreGrade {β : NatOrdinal} {x : R} (hx : x ∈ 𝒜 β) : + fibreMap 𝒜 x ∈ fibreGrade 𝒜 β := + ⟨x, hx, rfl⟩ + +omit [GradedAlgebra 𝒜] in +theorem exists_mem_of_mem_fibreGrade {β : NatOrdinal} {c : Fibre 𝒜} + (hc : c ∈ fibreGrade 𝒜 β) : + ∃ x ∈ 𝒜 β, fibreMap 𝒜 x = c := + hc + +omit [GradedAlgebra 𝒜] in +/-- `(A/I)_n = 0` for `1 ≤ n < ω`: the positive finite degrees vanish in `A/I`. -/ +theorem fibreGrade_natCast_eq_bot {n : ℕ} (hn : 1 ≤ n) : fibreGrade 𝒜 (n : NatOrdinal) = ⊥ := by + rw [eq_bot_iff] + rintro c ⟨x, hx, rfl⟩ + rw [Submodule.mem_bot, AlgHom.toLinearMap_apply, fibreMap_eq_zero_iff] + exact mem_idealGE_of_mem 𝒜 hn hx + +theorem fibreGrade_mul_le (α β : NatOrdinal) : + fibreGrade 𝒜 α * fibreGrade 𝒜 β ≤ fibreGrade 𝒜 (α + β) := by + rw [fibreGrade, fibreGrade, fibreGrade] + refine Submodule.mul_le.mpr ?_ + rintro _ ⟨x, hx, rfl⟩ _ ⟨y, hy, rfl⟩ + exact ⟨x * y, SetLike.mul_mem_graded hx hy, map_mul (fibreMap 𝒜) x y⟩ + +theorem mul_mem_fibreGrade {α β : NatOrdinal} {c d : Fibre 𝒜} (hc : c ∈ fibreGrade 𝒜 α) + (hd : d ∈ fibreGrade 𝒜 β) : c * d ∈ fibreGrade 𝒜 (α + β) := + fibreGrade_mul_le 𝒜 α β (Submodule.mul_mem_mul hc hd) + +theorem pow_mem_fibreGrade {α : NatOrdinal} {c : Fibre 𝒜} (hc : c ∈ fibreGrade 𝒜 α) + (n : ℕ) : + c ^ n ∈ fibreGrade 𝒜 (n • α) := by + induction n with + | zero => + rw [pow_zero, zero_smul] + exact fibreMap_mem_fibreGrade 𝒜 (SetLike.one_mem_graded 𝒜) + | succ n ih => + rw [pow_succ, succ_nsmul] + exact mul_mem_fibreGrade 𝒜 ih hc + +/-- `I ∩ A_0 = 0`. -/ +theorem fibreIdeal_inf_grade_zero : (fibreIdeal 𝒜).restrictScalars E ⊓ 𝒜 0 = ⊥ := by + rw [eq_bot_iff] + intro y hy + obtain ⟨hyW, hyδ⟩ := Submodule.mem_inf.mp hy + rw [Submodule.restrictScalars_mem] at hyW + rw [Submodule.mem_bot] + exact eq_zero_of_mem_idealGE_of_constantCoeff_lt 𝒜 hyδ hyW + (by rw [NatOrdinal.constantCoeff_zero]; exact Nat.one_pos) + +/-- `A/I ≠ 0`: `1 ∉ I`. -/ +theorem one_notMem_fibreIdeal [Nontrivial R] : (1 : R) ∉ fibreIdeal 𝒜 := fun h ↦ + one_ne_zero ((Submodule.mem_bot E).mp ((fibreIdeal_inf_grade_zero 𝒜).le + (Submodule.mem_inf.mpr ⟨(Submodule.restrictScalars_mem E _ _).mpr h, + SetLike.one_mem_graded 𝒜⟩))) + +instance [Nontrivial R] : Nontrivial (Fibre 𝒜) := + Ideal.Quotient.nontrivial_iff.mpr fun h ↦ one_notMem_fibreIdeal 𝒜 (h ▸ Submodule.mem_top) + +/-- `I` is homogeneous: the homogeneous components of an element of `I` lie in `I`. -/ +theorem decompose_mem_fibreIdeal {x : R} (hx : x ∈ fibreIdeal 𝒜) (δ : NatOrdinal) : + (DirectSum.decompose 𝒜 x δ : R) ∈ fibreIdeal 𝒜 := + idealGE_isHomogeneous 𝒜 1 δ hx + +/-! ### `A/I` is internally graded -/ + +/-- The `(A/I)_β` form an internal direct sum decomposition of `A/I`. -/ +theorem fibreGrade_isInternal : DirectSum.IsInternal (fibreGrade 𝒜) := by + classical + refine DirectSum.isInternal_submodule_of_iSupIndep_of_iSup_eq_top ?_ ?_ + · refine iSupIndep_of_dfinsupp_lsum_injective _ ?_ + rw [injective_iff_map_eq_zero] + intro v hv + choose x hx hxv using fun α ↦ exists_mem_of_mem_fibreGrade 𝒜 (v α).2 + -- the sum of the lifts lies in `I`, hence so does each homogeneous component + have hsum : ∑ α ∈ v.support, x α ∈ fibreIdeal 𝒜 := by + rw [← fibreMap_eq_zero_iff, map_sum] + simp only [hxv] + rw [← hv, DFinsupp.lsum_apply_apply, DFinsupp.sumAddHom_apply] + rfl + ext α + by_cases hα : α ∈ v.support + · have hcomp : (DirectSum.decompose 𝒜 (∑ β ∈ v.support, x β) α : R) = x α := by + rw [DirectSum.decompose_sum, DirectSum.sum_apply, Submodule.coe_sum, + Finset.sum_eq_single α] + · exact DirectSum.decompose_of_mem_same 𝒜 (hx α) + · intro β _ hβ + exact DirectSum.decompose_of_mem_ne 𝒜 (hx β) hβ + · intro h; exact absurd hα h + have : fibreMap 𝒜 (x α) = 0 := by + rw [fibreMap_eq_zero_iff, ← hcomp] + exact decompose_mem_fibreIdeal 𝒜 hsum α + rw [hxv] at this + rw [DFinsupp.zero_apply, Submodule.coe_zero] + exact this + · rw [DFinsupp.notMem_support_iff.mp hα] + rfl + · rw [eq_top_iff] + intro c _ + obtain ⟨x, rfl⟩ := fibreMap_surjective 𝒜 c + rw [← DirectSum.sum_support_decompose 𝒜 x, map_sum] + exact Submodule.sum_mem _ fun α _ ↦ Submodule.mem_iSup_of_mem α + (fibreMap_mem_fibreGrade 𝒜 (DirectSum.decompose 𝒜 x α).2) + +instance : SetLike.GradedMonoid (fibreGrade 𝒜) where + one_mem := by + rw [← map_one (fibreMap 𝒜)] + exact fibreMap_mem_fibreGrade 𝒜 (SetLike.one_mem_graded 𝒜) + mul_mem _ _ _ _ hc hd := mul_mem_fibreGrade 𝒜 hc hd + +/-- `A/I` is a graded `E`-algebra, graded by the `(A/I)_β = π(A_β)`. -/ +instance : GradedAlgebra (fibreGrade 𝒜) := { (fibreGrade_isInternal 𝒜).chooseDecomposition with } + +end LoweringDerivation diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/LoweringDerivation/IdealGEGraded.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/LoweringDerivation/IdealGEGraded.lean new file mode 100644 index 0000000000..f1daed64ac --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/LoweringDerivation/IdealGEGraded.lean @@ -0,0 +1,383 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.LoweringDerivation.FilteredModule +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.FiltrationDegree +public import Mathlib.RingTheory.TensorProduct.Basic + +import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.BasisOver + +/-! +# The associated graded ring `gr_{I_•} A` + +The ideals `I_{≥j}` of a `NatOrdinal`-graded algebra `A` (Lean `R`) with a lowering derivation +form a decreasing multiplicative filtration which is separated, so it defines a max-additive +degree valued in `ℕᵒᵈ` and an associated graded ring `gr_{I_•} A = ⨁_j I_{≥j}/I_{≥j+1}`. The +finite-degree part `A_{<ω}` maps to `gr_{I_•} A` by sending a homogeneous element of degree +`j < ω` to its class in `I_{≥j}/I_{≥j+1}`, and the quotient `A/I` is the degree-zero part +`I_{≥0}/I_{≥1}`. Multiplication induces an isomorphism of `E`-algebras + +`A_{<ω} ⊗_E A/I ≃ gr_{I_•} A` + +whose degree-`j` component is `μ_j`: surjectivity is the surjectivity of the `μ_j`, and +injectivity follows from their injectivity by reading off the components of the image of a tensor +written as a sum of pieces in the `A_j ⊗ A/I`. +-/ + +universe u v + +open scoped DirectSum TensorProduct + +public noncomputable section + +namespace LoweringDerivation + +variable {E : Type u} {R : Type v} [Field E] [CommRing R] [Algebra E R] +variable (𝒜 : NatOrdinal → Submodule E R) [GradedAlgebra 𝒜] + +/-! ### The degree attached to the filtration `I_{≥•}` -/ + +/-- The filtration `I_{≥•}` is separated, `⋂_j I_{≥j} = 0`: a non-zero element leaves `I_{≥j}` +once `j` exceeds the finite parts of its degrees. -/ +theorem idealGE_isSeparatedFiltration : IsSeparatedFiltration (idealGE 𝒜) where + antitone _ _ h := idealGE_antitone 𝒜 h + top := idealGE_zero 𝒜 + mul_le := idealGE_mul_le 𝒜 + exists_not_mem {x} hx := by + classical + refine ⟨(DirectSum.decompose 𝒜 x).support.sup (fun δ ↦ δ.constantCoeff) + 1, fun hmem ↦ ?_⟩ + apply hx + rw [← DirectSum.sum_support_decompose 𝒜 x] + refine Finset.sum_eq_zero fun δ hδ ↦ ?_ + refine eq_zero_of_mem_idealGE_of_constantCoeff_lt 𝒜 (DirectSum.decompose 𝒜 x δ).2 + (idealGE_isHomogeneous 𝒜 _ δ hmem) ?_ + exact Nat.lt_succ_of_le (Finset.le_sup (f := fun δ ↦ δ.constantCoeff) hδ) + +/-- The max-additive degree attached to `I_{≥•}`, valued in `ℕᵒᵈ`: its weak filtration at `j` is +`I_{≥j}`. -/ +def filtrationIndex : MaxAddDegree R (OrderDual ℕ) := + (idealGE_isSeparatedFiltration 𝒜).degree + +/-- The associated graded ring `gr_{I_•} A = ⨁_j I_{≥j}/I_{≥j+1}`. -/ +abbrev IdealGEGraded := (filtrationIndex 𝒜).AssociatedGraded + +theorem mem_filtrationIndex_filtrationLE_iff (j : ℕ) (x : R) : + x ∈ (filtrationIndex 𝒜).filtrationLE (OrderDual.toDual j) ↔ x ∈ idealGE 𝒜 j := + (idealGE_isSeparatedFiltration 𝒜).mem_degree_filtrationLE_iff j x + +theorem filtrationIndex_isSeparated : (filtrationIndex 𝒜).IsSeparated := + (idealGE_isSeparatedFiltration 𝒜).degree_isSeparated + +/-- An element of `I_{≥j}`, as an element of the weak filtration at `j`. -/ +def idealGEFiltrationMk (j : ℕ) {x : R} (hx : x ∈ idealGE 𝒜 j) : + (filtrationIndex 𝒜).filtrationLE (OrderDual.toDual j) := + ⟨x, (mem_filtrationIndex_filtrationLE_iff 𝒜 j x).mpr hx⟩ + +theorem coe_idealGEFiltrationMk (j : ℕ) {x : R} (hx : x ∈ idealGE 𝒜 j) : + (idealGEFiltrationMk 𝒜 j hx : R) = x := (rfl) + +/-- The class in `I_{≥j}/I_{≥j+1}` of an element of `I_{≥j}`, as an element of `gr_{I_•} A`. -/ +def idealGEMk (j : ℕ) {x : R} (hx : x ∈ idealGE 𝒜 j) : IdealGEGraded 𝒜 := + (filtrationIndex 𝒜).homogeneousMk (OrderDual.toDual j) (idealGEFiltrationMk 𝒜 j hx) + +/-- The class in `I_{≥j}/I_{≥j+1}` is the direct-sum element concentrated in degree `j`. -/ +theorem idealGEMk_eq_of (j : ℕ) {x : R} (hx : x ∈ idealGE 𝒜 j) : + idealGEMk 𝒜 j hx = DirectSum.of (filtrationIndex 𝒜).Component (OrderDual.toDual j) + ((filtrationIndex 𝒜).componentMk (OrderDual.toDual j) (idealGEFiltrationMk 𝒜 j hx)) := + (filtrationIndex 𝒜).homogeneousMk_apply _ _ + +theorem idealGEMk_eq_zero_iff (j : ℕ) {x : R} (hx : x ∈ idealGE 𝒜 j) : + idealGEMk 𝒜 j hx = 0 ↔ x ∈ idealGE 𝒜 (j + 1) := by + rw [idealGEMk, MaxAddDegree.homogeneousMk_eq_zero_iff, coe_idealGEFiltrationMk, + filtrationIndex, IsSeparatedFiltration.degree_apply] + exact (idealGE_isSeparatedFiltration 𝒜).value_lt_toDual_iff x j + +theorem idealGEMk_add (j : ℕ) {x y : R} (hx : x ∈ idealGE 𝒜 j) (hy : y ∈ idealGE 𝒜 j) : + idealGEMk 𝒜 j (add_mem hx hy) = idealGEMk 𝒜 j hx + idealGEMk 𝒜 j hy := by + rw [idealGEMk, idealGEMk, idealGEMk, ← map_add] + rfl + +theorem idealGEMk_mul {i j : ℕ} {x y : R} (hx : x ∈ idealGE 𝒜 i) (hy : y ∈ idealGE 𝒜 j) : + idealGEMk 𝒜 (i + j) (mul_mem_idealGE 𝒜 hx hy) = idealGEMk 𝒜 i hx * idealGEMk 𝒜 j hy := by + rw [idealGEMk, idealGEMk, idealGEMk] + exact (filtrationIndex 𝒜).homogeneousMk_mul_of_coe_eq rfl _ _ _ rfl + +theorem idealGEMk_congr (j : ℕ) {x y : R} (hx : x ∈ idealGE 𝒜 j) (hy : y ∈ idealGE 𝒜 j) + (h : x - y ∈ idealGE 𝒜 (j + 1)) : idealGEMk 𝒜 j hx = idealGEMk 𝒜 j hy := by + have := (idealGEMk_eq_zero_iff 𝒜 j (sub_mem hx hy)).mpr h + rw [idealGEMk, idealGEMk, ← sub_eq_zero, ← map_sub] + exact this + +theorem mem_idealGE_zero (x : R) : x ∈ idealGE 𝒜 0 := by + rw [idealGE_zero]; exact Submodule.mem_top + +theorem idealGEMk_one : idealGEMk 𝒜 0 (mem_idealGE_zero 𝒜 1) = 1 := by + rw [idealGEMk, MaxAddDegree.homogeneousMk_apply, DirectSum.one_def] + congr 1 + rw [show GradedMonoid.GOne.one = (filtrationIndex 𝒜).componentOne from rfl, + MaxAddDegree.componentOne_eq_componentMk] + rfl + +/-- A sum of classes in distinct `I_{≥n}/I_{≥n+1}` vanishes only if each does. -/ +theorem idealGEMk_eq_zero_of_sum_eq_zero {s : Finset ℕ} {x : ℕ → R} + (hx : ∀ n, x n ∈ idealGE 𝒜 n) (h : ∑ n ∈ s, idealGEMk 𝒜 n (hx n) = 0) : + ∀ n ∈ s, idealGEMk 𝒜 n (hx n) = 0 := by + classical + intro n hn + have := congrArg (fun g : IdealGEGraded 𝒜 ↦ g (OrderDual.toDual n)) h + simp only [DirectSum.sum_apply, DirectSum.zero_apply] at this + rw [Finset.sum_eq_single n] at this + · rw [idealGEMk, MaxAddDegree.homogeneousMk_apply, DirectSum.of_eq_same] at this + rw [idealGEMk, MaxAddDegree.homogeneousMk_apply, this, map_zero] + · intro m _ hmn + rw [idealGEMk, MaxAddDegree.homogeneousMk_apply, DirectSum.of_eq_of_ne] + exact fun h' ↦ hmn (OrderDual.toDual.injective h').symm + · intro h'; exact absurd hn h' + +/-- The class in `I_{≥j}/I_{≥j+1}` of a finite sum is the sum of the classes. -/ +theorem idealGEMk_sum {ι : Type*} (s : Finset ι) (j : ℕ) {x : ι → R} + (hx : ∀ i, x i ∈ idealGE 𝒜 j) (hs : ∑ i ∈ s, x i ∈ idealGE 𝒜 j) : + idealGEMk 𝒜 j hs = ∑ i ∈ s, idealGEMk 𝒜 j (hx i) := by + classical + induction s using Finset.induction_on with + | empty => + conv_rhs => rw [Finset.sum_empty] + exact (idealGEMk_eq_zero_iff 𝒜 j _).mpr (by rw [Finset.sum_empty]; exact zero_mem _) + | insert i s hi ih => + have hs' : ∑ i ∈ s, x i ∈ idealGE 𝒜 j := Submodule.sum_mem _ fun i _ ↦ hx i + conv_rhs => rw [Finset.sum_insert hi, ← ih hs', ← idealGEMk_add] + exact idealGEMk_congr 𝒜 j _ _ (by rw [Finset.sum_insert hi, sub_self]; exact zero_mem _) + +theorem idealGEMk_congr_index {i j : ℕ} (h : i = j) {x : R} (hx : x ∈ idealGE 𝒜 i) : + idealGEMk 𝒜 i hx = idealGEMk 𝒜 j (h ▸ hx) := by + subst h + rfl + +theorem idealGEMk_zero (j : ℕ) : idealGEMk 𝒜 j (zero_mem _) = 0 := + (idealGEMk_eq_zero_iff 𝒜 j _).mpr (zero_mem _) + +/-! ### The degree-zero part: `A/I` -/ + +/-- The class in `I_{≥0}/I_{≥1}`, as a ring homomorphism `A → gr_{I_•} A`. -/ +def idealGEZeroHom : R →+* IdealGEGraded 𝒜 where + toFun x := idealGEMk 𝒜 0 (mem_idealGE_zero 𝒜 x) + map_one' := idealGEMk_one 𝒜 + map_mul' x y := idealGEMk_mul 𝒜 (mem_idealGE_zero 𝒜 x) (mem_idealGE_zero 𝒜 y) + map_zero' := idealGEMk_zero 𝒜 0 + map_add' x y := idealGEMk_add 𝒜 0 (mem_idealGE_zero 𝒜 x) (mem_idealGE_zero 𝒜 y) + +theorem idealGEZeroHom_apply (x : R) : + idealGEZeroHom 𝒜 x = idealGEMk 𝒜 0 (mem_idealGE_zero 𝒜 x) := (rfl) + +/-- The `E`-algebra structure on `gr_{I_•} A`, through the classes of the scalars in degree zero. -/ +instance : Algebra E (IdealGEGraded 𝒜) := ((idealGEZeroHom 𝒜).comp (algebraMap E R)).toAlgebra + +theorem idealGEGraded_algebraMap_apply (e : E) : + algebraMap E (IdealGEGraded 𝒜) e = idealGEZeroHom 𝒜 (algebraMap E R e) := (rfl) + +/-- The quotient `A/I = I_{≥0}/I_{≥1}` maps to degree zero of `gr_{I_•} A`. -/ +def fibreInitialHom : Fibre 𝒜 →+* IdealGEGraded 𝒜 := + Ideal.Quotient.lift (fibreIdeal 𝒜) (idealGEZeroHom 𝒜) fun _ hx ↦ + (idealGEMk_eq_zero_iff 𝒜 0 _).mpr hx + +theorem fibreInitialHom_fibreMap (x : R) : + fibreInitialHom 𝒜 (fibreMap 𝒜 x) = idealGEMk 𝒜 0 (mem_idealGE_zero 𝒜 x) := + Ideal.Quotient.lift_mk _ _ _ + +/-- The map `A/I → gr_{I_•} A` onto degree zero, as an `E`-algebra homomorphism. -/ +def fibreInitialAlgHom : Fibre 𝒜 →ₐ[E] IdealGEGraded 𝒜 := + { fibreInitialHom 𝒜 with + commutes' := fun e ↦ by + change fibreInitialHom 𝒜 (fibreMap 𝒜 (algebraMap E R e)) = _ + rw [fibreInitialHom_fibreMap] + rfl } + +theorem fibreInitialAlgHom_fibreMap (x : R) : + fibreInitialAlgHom 𝒜 (fibreMap 𝒜 x) = idealGEMk 𝒜 0 (mem_idealGE_zero 𝒜 x) := + fibreInitialHom_fibreMap 𝒜 x + +/-! ### The finite degrees -/ + +/-- The class in `gr_{I_•} A` of a homogeneous element of degree `α`: its class in +`I_{≥n}/I_{≥n+1}` when `α = n < ω`, and zero otherwise. -/ +def gradeInitial (α : NatOrdinal) : 𝒜 α →+ IdealGEGraded 𝒜 := + if h : α = (α.constantCoeff : NatOrdinal) then + { toFun := fun a ↦ idealGEMk 𝒜 α.constantCoeff + (mem_idealGE_of_mem 𝒜 le_rfl (show (a : R) ∈ 𝒜 (α.constantCoeff : NatOrdinal) from + h ▸ a.2)) + map_zero' := idealGEMk_zero 𝒜 _ + map_add' := fun _ _ ↦ idealGEMk_add 𝒜 _ _ _ } + else 0 + +theorem gradeInitial_natCast (n : ℕ) (a : 𝒜 (n : NatOrdinal)) : + gradeInitial 𝒜 (n : NatOrdinal) a = idealGEMk 𝒜 n (mem_idealGE_of_mem 𝒜 le_rfl a.2) := by + have h : (n : NatOrdinal) = ((n : NatOrdinal).constantCoeff : NatOrdinal) := by + rw [NatOrdinal.constantCoeff_natCast] + rw [gradeInitial, dite_eq_left h] + exact idealGEMk_congr_index 𝒜 (NatOrdinal.constantCoeff_natCast n) _ + +theorem gradeInitial_of_not_natCast {α : NatOrdinal} (hα : ¬ ∃ n : ℕ, α = n) (a : 𝒜 α) : + gradeInitial 𝒜 α a = 0 := by + rw [gradeInitial, dite_eq_right fun h ↦ hα ⟨_, h⟩] + rfl + +/-- The sum of the classes in `gr_{I_•} A` of the homogeneous components of finite degree. -/ +def finiteDegreeInitialAdd : R →+ IdealGEGraded 𝒜 := + (DirectSum.toAddMonoid (gradeInitial 𝒜)).comp (DirectSum.decomposeAddEquiv 𝒜).toAddMonoidHom + +theorem finiteDegreeInitialAdd_coe {α : NatOrdinal} (a : 𝒜 α) : + finiteDegreeInitialAdd 𝒜 a = gradeInitial 𝒜 α a := by + rw [finiteDegreeInitialAdd, AddMonoidHom.comp_apply, AddEquiv.coe_toAddMonoidHom, + DirectSum.decomposeAddEquiv_apply, DirectSum.decompose_coe, DirectSum.toAddMonoid_of] + +theorem finiteDegreeInitialAdd_of_mem {n : ℕ} {x : R} (hx : x ∈ 𝒜 (n : NatOrdinal)) : + finiteDegreeInitialAdd 𝒜 x = idealGEMk 𝒜 n (mem_idealGE_of_mem 𝒜 le_rfl hx) := + (finiteDegreeInitialAdd_coe 𝒜 (⟨x, hx⟩ : 𝒜 (n : NatOrdinal))).trans (gradeInitial_natCast 𝒜 n _) + +theorem finiteDegreeInitialAdd_of_mem_of_not_natCast {α : NatOrdinal} (hα : ¬ ∃ n : ℕ, α = n) + {x : R} + (hx : x ∈ 𝒜 α) : finiteDegreeInitialAdd 𝒜 x = 0 := + (finiteDegreeInitialAdd_coe 𝒜 (⟨x, hx⟩ : 𝒜 α)).trans (gradeInitial_of_not_natCast 𝒜 hα _) + +/-- The finite-degree part `A_{<ω}` maps to `gr_{I_•} A`, a homogeneous element of degree `j` +going to its class in `I_{≥j}/I_{≥j+1}`. -/ +def finiteDegreeInitialHom : finiteDegreePart 𝒜 →+* IdealGEGraded 𝒜 where + toFun a := finiteDegreeInitialAdd 𝒜 a + map_zero' := by rw [Subalgebra.coe_zero, map_zero] + map_add' a b := by rw [Subalgebra.coe_add, map_add] + map_one' := by + rw [Subalgebra.coe_one, finiteDegreeInitialAdd_of_mem 𝒜 (n := 0) + (by rw [Nat.cast_zero]; exact SetLike.one_mem_graded 𝒜)] + exact idealGEMk_one 𝒜 + map_mul' a b := by + rw [Subalgebra.coe_mul] + refine finiteDegreeSubmodule_induction 𝒜 + (p := fun x _ ↦ + finiteDegreeInitialAdd 𝒜 (x * b) = finiteDegreeInitialAdd 𝒜 x * finiteDegreeInitialAdd 𝒜 b) + ?_ ?_ ?_ ((mem_finiteDegreePart_iff 𝒜 _).mp a.2) + · intro m x hx + refine finiteDegreeSubmodule_induction 𝒜 + (p := fun y _ ↦ + finiteDegreeInitialAdd 𝒜 (x * y) = + finiteDegreeInitialAdd 𝒜 x * finiteDegreeInitialAdd 𝒜 y) + ?_ ?_ ?_ ((mem_finiteDegreePart_iff 𝒜 _).mp b.2) + · intro n y hy + have hxy : x * y ∈ 𝒜 ((m + n : ℕ) : NatOrdinal) := by + rw [Nat.cast_add]; exact SetLike.mul_mem_graded hx hy + rw [finiteDegreeInitialAdd_of_mem 𝒜 hxy, finiteDegreeInitialAdd_of_mem 𝒜 hx, + finiteDegreeInitialAdd_of_mem 𝒜 hy, ← idealGEMk_mul] + · rw [mul_zero, map_zero, mul_zero] + · intro y z _ _ hy hz + rw [mul_add, map_add, map_add, hy, hz, mul_add] + · rw [zero_mul, map_zero, zero_mul] + · intro x y _ _ hx hy + rw [add_mul, map_add, map_add, hx, hy, add_mul] + +theorem finiteDegreeInitialHom_apply (a : finiteDegreePart 𝒜) : + finiteDegreeInitialHom 𝒜 a = finiteDegreeInitialAdd 𝒜 a := (rfl) + +/-- The map `A_{<ω} → gr_{I_•} A`, as an `E`-algebra homomorphism. -/ +def finiteDegreeInitialAlgHom : finiteDegreePart 𝒜 →ₐ[E] IdealGEGraded 𝒜 := + { finiteDegreeInitialHom 𝒜 with + commutes' := fun e ↦ by + change finiteDegreeInitialAdd 𝒜 (algebraMap E R e) = _ + rw [finiteDegreeInitialAdd_of_mem 𝒜 (n := 0) + (by rw [Nat.cast_zero]; exact SetLike.algebraMap_mem_graded 𝒜 e)] + rfl } + +theorem finiteDegreeInitialAlgHom_apply (a : finiteDegreePart 𝒜) : + finiteDegreeInitialAlgHom 𝒜 a = finiteDegreeInitialAdd 𝒜 a := (rfl) + +/-! ### The multiplication map `A_{<ω} ⊗_E A/I → gr_{I_•} A` -/ + +/-- Multiplication of the classes, `A_{<ω} ⊗_E A/I →ₐ[E] gr_{I_•} A`; the paper's `⨁_j μ_j`. -/ +def idealGETensorHom : finiteDegreePart 𝒜 ⊗[E] Fibre 𝒜 →ₐ[E] IdealGEGraded 𝒜 := + Algebra.TensorProduct.productMap (finiteDegreeInitialAlgHom 𝒜) (fibreInitialAlgHom 𝒜) + +theorem idealGETensorHom_tmul (a : finiteDegreePart 𝒜) (c : Fibre 𝒜) : + idealGETensorHom 𝒜 (a ⊗ₜ[E] c) = finiteDegreeInitialAlgHom 𝒜 a * fibreInitialAlgHom 𝒜 c := + Algebra.TensorProduct.productMap_apply_tmul _ _ _ _ + +theorem idealGETensorHom_natInclusion_tmul (j : ℕ) (a : 𝒜 (j : NatOrdinal)) (b : R) : + idealGETensorHom 𝒜 (natInclusion 𝒜 j a ⊗ₜ[E] fibreMap 𝒜 b) = + idealGEMk 𝒜 j (Ideal.mul_mem_right b _ (mem_idealGE_of_mem 𝒜 le_rfl a.2)) := by + rw [idealGETensorHom_tmul, finiteDegreeInitialAlgHom_apply, coe_natInclusion, + finiteDegreeInitialAdd_of_mem 𝒜 a.2, fibreInitialAlgHom_fibreMap, ← idealGEMk_mul] + exact idealGEMk_congr_index 𝒜 (Nat.add_zero j) _ + +/-- Tensors in `A_j ⊗ A/I` map to degree `j`, compatibly with `μ_j`. -/ +theorem exists_idealGETensorHom_rTensor_eq (j : ℕ) (T : 𝒜 (j : NatOrdinal) ⊗[E] Fibre 𝒜) : + ∃ x, ∃ hx : x ∈ idealGE 𝒜 j, + mu 𝒜 j T = (Submodule.Quotient.mk x : R ⧸ idealGE 𝒜 (j + 1)) ∧ + idealGETensorHom 𝒜 ((natInclusion 𝒜 j).rTensor _ T) = idealGEMk 𝒜 j hx := by + induction T using TensorProduct.inductionOn with + | tmul a c => + obtain ⟨b, rfl⟩ := fibreMap_surjective 𝒜 c + exact ⟨(a : R) * b, Ideal.mul_mem_right _ _ (mem_idealGE_of_mem 𝒜 le_rfl a.2), + mu_tmul 𝒜 j a b, by rw [LinearMap.rTensor_tmul, idealGETensorHom_natInclusion_tmul]⟩ + | add x y hx hy => + obtain ⟨x', hx', hcx, hwx⟩ := hx + obtain ⟨y', hy', hcy, hwy⟩ := hy + exact ⟨x' + y', add_mem hx' hy', by rw [map_add, hcx, hcy, Submodule.Quotient.mk_add], + by rw [map_add, map_add, hwx, hwy, idealGEMk_add]⟩ + +/-- The class in `I_{≥j}/I_{≥j+1}` of any element of `I_{≥j}` is in the image of +`A_{<ω} ⊗_E A/I`. -/ +theorem exists_idealGETensorHom_eq_idealGEMk (j : ℕ) {x : R} (hx : x ∈ idealGE 𝒜 j) : + ∃ u, idealGETensorHom 𝒜 u = idealGEMk 𝒜 j hx := by + obtain ⟨T, hT⟩ := exists_mu_eq 𝒜 hx + obtain ⟨x', hx', hcx, hwx⟩ := exists_idealGETensorHom_rTensor_eq 𝒜 j T + refine ⟨_, hwx.trans (idealGEMk_congr 𝒜 j hx' hx ?_)⟩ + rw [hT] at hcx + exact (Submodule.Quotient.eq _).mp hcx.symm + +theorem idealGETensorHom_surjective : Function.Surjective (idealGETensorHom 𝒜) := by + intro g + induction g using DirectSum.induction_on with + | zero => exact ⟨0, map_zero _⟩ + | of j c => + induction c using MaxAddDegree.componentInductionOn with + | _ x => + obtain ⟨u, hu⟩ := exists_idealGETensorHom_eq_idealGEMk 𝒜 (OrderDual.ofDual j) + ((mem_filtrationIndex_filtrationLE_iff 𝒜 _ x).mp x.2) + refine ⟨u, hu.trans ?_⟩ + rw [idealGEMk, MaxAddDegree.homogeneousMk_apply] + rfl + | add x y hx hy => + obtain ⟨u, rfl⟩ := hx + obtain ⟨v, rfl⟩ := hy + exact ⟨u + v, map_add _ _ _⟩ + +/-- Injectivity: write `u = ∑_n (ι_n ⊗ 1) t_n` with `t_n ∈ A_n ⊗ A/I`; the degree-`n` component +of the image is the class of a lift of `μ_n(t_n)`, so it vanishes only if `μ_n(t_n) = 0`, that is, +`t_n = 0`. -/ +theorem idealGETensorHom_injective (h0 : GradeZeroScalars 𝒜) {Δ : R →ₗ[E] FunAtZeroMinus R} + (hΔ : IsLoweringDerivation 𝒜 Δ) : Function.Injective (idealGETensorHom 𝒜) := by + rw [injective_iff_map_eq_zero] + intro u hu + obtain ⟨N, t, rfl⟩ := exists_eq_sum_rTensor_natInclusion 𝒜 u + choose x hx hchar hw using fun n ↦ exists_idealGETensorHom_rTensor_eq 𝒜 n (t n) + rw [map_sum, Finset.sum_congr rfl fun n _ ↦ hw n] at hu + refine Finset.sum_eq_zero fun n hn ↦ ?_ + have hW := (idealGEMk_eq_zero_iff 𝒜 n (hx n)).mp (idealGEMk_eq_zero_of_sum_eq_zero 𝒜 hx hu n hn) + have hT : mu 𝒜 n (t n) = 0 := by + rw [hchar n, Submodule.Quotient.mk_eq_zero] + exact hW + rw [(injective_iff_map_eq_zero _).mp (hΔ.mu_injective h0 n) _ hT, map_zero] + +/-- Multiplication induces a graded `E`-algebra isomorphism `A_{<ω} ⊗_E A/I ≃ gr_{I_•} A`. -/ +def idealGETensorEquiv (h0 : GradeZeroScalars 𝒜) {Δ : R →ₗ[E] FunAtZeroMinus R} + (hΔ : IsLoweringDerivation 𝒜 Δ) : + finiteDegreePart 𝒜 ⊗[E] Fibre 𝒜 ≃ₐ[E] IdealGEGraded 𝒜 := + AlgEquiv.ofBijective (idealGETensorHom 𝒜) + ⟨idealGETensorHom_injective 𝒜 h0 hΔ, idealGETensorHom_surjective 𝒜⟩ + +theorem coe_idealGETensorEquiv (h0 : GradeZeroScalars 𝒜) {Δ : R →ₗ[E] FunAtZeroMinus R} + (hΔ : IsLoweringDerivation 𝒜 Δ) : + ⇑(idealGETensorEquiv 𝒜 h0 hΔ) = ⇑(idealGETensorHom 𝒜) := (rfl) + +end LoweringDerivation diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/LoweringDerivation/Mu.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/LoweringDerivation/Mu.lean new file mode 100644 index 0000000000..f85ff1be6c --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/LoweringDerivation/Mu.lean @@ -0,0 +1,526 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.LoweringDerivation.Grading +public import LeanPool.ConwayRefinement.ConwayRefinement.Order.Filter.FunAtZeroMinus + +import Mathlib.LinearAlgebra.TensorProduct.RightExactness +import Mathlib.LinearAlgebra.TensorProduct.Finiteness + +/-! +# Lowering derivations and the maps `μ_j` + +A *lowering derivation* of a `NatOrdinal`-graded algebra `A` (Lean `R`) over a field `E` is an +`E`-linear derivation `∂ : A → Fun_{0⁻}(A)` with values in functions at `0⁻` which lowers the +degree by one — `∂(A_{α+1}) ⊆ Fun_{0⁻}(A_α)`, and `∂(A_α) = 0` for `α` zero or a limit — and is +injective on every `A_{α+1}`. The Lean variable for `∂` is `Δ`. + +For such a derivation `∂(I_{≥j}) ⊆ Fun_{0⁻}(I_{≥j-1})` for `j ≥ 1`, and the maps + +`μ_j : A_j ⊗_E A/I → I_{≥j}/I_{≥j+1}`, `B ⊗ π(C) ↦ BC + I_{≥j+1}`, + +are injective: for `j = 0` this is `I = ker π`, and the inductive step applies `∂` to a relation +and uses the compatibility `μ_{j-1}((∂ ⊗ 1) T) = ∂H + I_{≥j}` for `μ_j(T) = H + I_{≥j+1}`. The +maps `μ_j` are also compatible with the action of `A/I` on the second factor, and they are graded: +a homogeneous element of `I_{≥j} ∩ A_δ` has class in `μ_j(A_j ⊗ (A/I)_β)` for the `β` with +`j ⊕ β = δ`, and conversely every such tensor is the class of a homogeneous element of +`I_{≥j} ∩ A_δ`. +-/ + +universe u v + +open scoped DirectSum TensorProduct +open Filter Topology + +public noncomputable section + +namespace LoweringDerivation + +variable {E : Type u} {R : Type v} [Field E] [CommRing R] [Algebra E R] +variable (𝒜 : NatOrdinal → Submodule E R) [GradedAlgebra 𝒜] + +/-- The hypothesis `A_0 = E`: every element of degree zero is a scalar. -/ +def GradeZeroScalars : Prop := ∀ x ∈ 𝒜 0, ∃ e : E, x = algebraMap E R e + +omit [GradedAlgebra 𝒜] in +theorem gradeZeroScalars_iff : + GradeZeroScalars 𝒜 ↔ ∀ x ∈ 𝒜 0, ∃ e : E, x = algebraMap E R e := Iff.rfl + +/-- A lowering derivation `∂` (Lean `Δ`) of `A`: an `E`-linear derivation with values in functions +at `0⁻` (D1), which lowers the degree by one — it carries each `A_{α+1}` into `Fun_{0⁻}(A_α)` and +vanishes on `A_α` for `α` zero or a limit (D2) — and is injective on every `A_{α+1}` (D3). -/ +structure IsLoweringDerivation (Δ : R →ₗ[E] FunAtZeroMinus R) : Prop where + map_mul : ∀ x y : R, Δ (x * y) = Δ x * (y : FunAtZeroMinus R) + (x : FunAtZeroMinus R) * Δ y + mem_lower : ∀ {α : NatOrdinal}, 0 < α.constantCoeff → ∀ {x : R}, x ∈ 𝒜 α → + Δ x ∈ funAtZeroMinusSubmodule (𝒜 (α.removeNat 1)) + eq_zero : ∀ {α : NatOrdinal}, α.constantCoeff = 0 → ∀ {x : R}, x ∈ 𝒜 α → Δ x = 0 + injective : ∀ {α : NatOrdinal}, 0 < α.constantCoeff → ∀ {x : R}, x ∈ 𝒜 α → Δ x = 0 → x = 0 + +variable {𝒜} +variable {Δ : R →ₗ[E] FunAtZeroMinus R} (hΔ : IsLoweringDerivation 𝒜 Δ) + +namespace IsLoweringDerivation + +theorem natCast_removeNat_one (j : ℕ) (hj : 1 ≤ j) : + (j : NatOrdinal).removeNat 1 = ((j - 1 : ℕ) : NatOrdinal) := by + have hcoeff : 1 ≤ (j : NatOrdinal).constantCoeff := by + rwa [NatOrdinal.constantCoeff_natCast] + symm + apply (NatOrdinal.eq_removeNat_iff_add_natCast_eq hcoeff).mpr + rw [← Nat.cast_add, Nat.sub_add_cancel hj] + +theorem natCast_constantCoeff_pos (j : ℕ) (hj : 1 ≤ j) : + 0 < (j : NatOrdinal).constantCoeff := by + rw [NatOrdinal.constantCoeff_natCast] + exact hj + +include hΔ + +omit [GradedAlgebra 𝒜] in +theorem mem_lower_natCast {j : ℕ} (hj : 1 ≤ j) {x : R} (hx : x ∈ 𝒜 (j : NatOrdinal)) : + Δ x ∈ funAtZeroMinusSubmodule (𝒜 ((j - 1 : ℕ) : NatOrdinal)) := by + rw [← natCast_removeNat_one j hj] + exact hΔ.mem_lower (natCast_constantCoeff_pos j hj) hx + +omit [GradedAlgebra 𝒜] in +theorem map_one : Δ 1 = 0 := by + have h := hΔ.map_mul 1 1 + rw [one_mul] at h + have h1 : ((1 : R) : FunAtZeroMinus R) = 1 := rfl + rw [h1, mul_one, one_mul] at h + exact (add_eq_left.mp h.symm) + +end IsLoweringDerivation + +/-! ### Functions at `0⁻` with values in an ideal -/ + +variable (E) in +/-- `Fun_{0⁻}(I)`: the functions at `0⁻` with values in the ideal `I`. -/ +abbrev funAtZeroMinusIdeal (I : Ideal R) : Submodule E (FunAtZeroMinus R) := + funAtZeroMinusSubmodule (I.restrictScalars E) + +theorem coe_mem_funAtZeroMinusIdeal_iff (I : Ideal R) (f : ℝ → R) : + (f : FunAtZeroMinus R) ∈ funAtZeroMinusIdeal E I ↔ ∀ᶠ γ in 𝓝[<] (0 : ℝ), f γ ∈ I := + coe_mem_funAtZeroMinusSubmodule_iff _ f + +theorem const_mem_funAtZeroMinusIdeal {I : Ideal R} {x : R} (hx : x ∈ I) : + (x : FunAtZeroMinus R) ∈ funAtZeroMinusIdeal E I := + (coe_mem_funAtZeroMinusIdeal_iff I _).mpr (Eventually.of_forall fun _ ↦ hx) + +theorem mul_const_mem_funAtZeroMinusIdeal {I : Ideal R} {g : FunAtZeroMinus R} + (hg : g ∈ funAtZeroMinusIdeal E I) (y : R) : + g * (y : FunAtZeroMinus R) ∈ funAtZeroMinusIdeal E I := by + induction g using Filter.Germ.inductionOn with + | _ f => + rw [coe_mem_funAtZeroMinusIdeal_iff] at hg + change ((f * fun _ ↦ y : ℝ → R) : FunAtZeroMinus R) ∈ _ + rw [coe_mem_funAtZeroMinusIdeal_iff] + exact hg.mono fun γ hγ ↦ I.mul_mem_right y hγ + +theorem const_mul_mem_funAtZeroMinusIdeal {I : Ideal R} {g : FunAtZeroMinus R} + (hg : g ∈ funAtZeroMinusIdeal E I) (y : R) : + (y : FunAtZeroMinus R) * g ∈ funAtZeroMinusIdeal E I := by + rw [mul_comm] + exact mul_const_mem_funAtZeroMinusIdeal hg y + +theorem mul_mem_funAtZeroMinusIdeal_of_const_mem {I : Ideal R} {y : R} (hy : y ∈ I) + (g : FunAtZeroMinus R) : + g * (y : FunAtZeroMinus R) ∈ funAtZeroMinusIdeal E I := by + induction g using Filter.Germ.inductionOn with + | _ f => + change ((f * fun _ ↦ y : ℝ → R) : FunAtZeroMinus R) ∈ _ + rw [coe_mem_funAtZeroMinusIdeal_iff] + exact Eventually.of_forall fun γ ↦ I.mul_mem_left (f γ) hy + +theorem funAtZeroMinusIdeal_mono {I J : Ideal R} (h : I ≤ J) : + funAtZeroMinusIdeal E I ≤ funAtZeroMinusIdeal E J := + fun _ hg ↦ funAtZeroMinusSubmodule_mono (W := I.restrictScalars E) (W' := J.restrictScalars E) + (fun _ hx ↦ h hx) hg + +omit [GradedAlgebra 𝒜] in +theorem funAtZeroMinusSubmodule_grade_le_funAtZeroMinusIdeal {e j : ℕ} (hje : j ≤ e) : + funAtZeroMinusSubmodule (𝒜 (e : NatOrdinal)) ≤ funAtZeroMinusIdeal E (idealGE 𝒜 j) := + fun _ hg ↦ funAtZeroMinusSubmodule_mono (W := 𝒜 (e : NatOrdinal)) + (W' := (idealGE 𝒜 j).restrictScalars E) + (fun x hx ↦ (Submodule.restrictScalars_mem E _ x).mpr (mem_idealGE_of_mem 𝒜 hje hx)) hg + +namespace IsLoweringDerivation +include hΔ + +omit [GradedAlgebra 𝒜] in +/-- The power rule. -/ +theorem map_pow_succ (x : R) (n : ℕ) : + Δ (x ^ (n + 1)) = (n + 1) • (((x ^ n : R) : FunAtZeroMinus R) * Δ x) := by + induction n with + | zero => + rw [zero_add, pow_one, pow_zero, one_smul] + change Δ x = (1 : FunAtZeroMinus R) * Δ x + rw [one_mul] + | succ n ih => + rw [pow_succ, hΔ.map_mul, ih, smul_mul_assoc, mul_assoc] + have h1 : ((x ^ n : R) : FunAtZeroMinus R) * (x : FunAtZeroMinus R) = + ((x ^ (n + 1) : R) : FunAtZeroMinus R) := by + rw [pow_succ] + rfl + rw [mul_comm (Δ x) (x : FunAtZeroMinus R), ← mul_assoc, h1, succ_nsmul, succ_nsmul, succ_nsmul] + +omit [GradedAlgebra 𝒜] in +/-- `∂(I_{≥j}) ⊆ Fun_{0⁻}(I_{≥j-1})` for `j ≥ 1`. -/ +theorem map_mem_funAtZeroMinusIdeal_idealGE {j : ℕ} (hj : 1 ≤ j) {H : R} (hH : H ∈ idealGE 𝒜 j) : + Δ H ∈ funAtZeroMinusIdeal E (idealGE 𝒜 (j - 1)) := by + classical + rw [idealGE_eq_span] at hH + obtain ⟨n, c, g, rfl⟩ := Submodule.mem_span_set'.mp hH + rw [map_sum] + refine Submodule.sum_mem _ fun i _ ↦ ?_ + obtain ⟨e, hje, hge⟩ := (mem_idealGEGenerators_iff 𝒜 j (g i)).mp (g i).2 + rw [smul_eq_mul, hΔ.map_mul] + refine Submodule.add_mem _ ?_ ?_ + · exact mul_mem_funAtZeroMinusIdeal_of_const_mem + (mem_idealGE_of_mem 𝒜 (Nat.sub_le j 1 |>.trans hje) hge) _ + · refine const_mul_mem_funAtZeroMinusIdeal ?_ _ + refine funAtZeroMinusSubmodule_grade_le_funAtZeroMinusIdeal (e := e - 1) (by omega) ?_ + exact hΔ.mem_lower_natCast (hj.trans hje) hge + +end IsLoweringDerivation + +/-! ### The maps `μ_j` -/ + +section Characteristic + +variable (𝒜) + +/-- Multiplication by a homogeneous `B ∈ A_j`, descended to a map `A/I → A/I_{≥j+1}`. -/ +def muMulLeft (j : ℕ) (a : 𝒜 (j : NatOrdinal)) : + Fibre 𝒜 →ₗ[E] R ⧸ idealGE 𝒜 (j + 1) := + (Submodule.mapQ (fibreIdeal 𝒜) (idealGE 𝒜 (j + 1)) (LinearMap.mulLeft R (a : R)) + fun _ hx ↦ mul_mem_idealGE 𝒜 (mem_idealGE_of_mem 𝒜 le_rfl a.2) hx).restrictScalars E + +omit [GradedAlgebra 𝒜] in +theorem fibreMap_eq_mk (b : R) : fibreMap 𝒜 b = Submodule.Quotient.mk b := rfl + +theorem muMulLeft_mk (j : ℕ) (a : 𝒜 (j : NatOrdinal)) (b : R) : + muMulLeft 𝒜 j a (fibreMap 𝒜 b) = Submodule.Quotient.mk ((a : R) * b) := by + rfl + +/-- The bilinear map `A_j × A/I → A/I_{≥j+1}`, `(B, π(C)) ↦ BC + I_{≥j+1}`. -/ +def muBilinear (j : ℕ) : 𝒜 (j : NatOrdinal) →ₗ[E] Fibre 𝒜 →ₗ[E] R ⧸ idealGE 𝒜 (j + 1) where + toFun := muMulLeft 𝒜 j + map_add' a a' := LinearMap.ext fun c ↦ by + obtain ⟨b, rfl⟩ := fibreMap_surjective 𝒜 c + rw [LinearMap.add_apply, muMulLeft_mk, muMulLeft_mk, muMulLeft_mk, Submodule.coe_add, + add_mul, Submodule.Quotient.mk_add] + map_smul' e a := LinearMap.ext fun c ↦ by + obtain ⟨b, rfl⟩ := fibreMap_surjective 𝒜 c + rw [LinearMap.smul_apply, muMulLeft_mk, muMulLeft_mk, RingHom.id_apply, + Submodule.coe_smul, Algebra.smul_def, mul_assoc, ← Algebra.smul_def, + Submodule.Quotient.mk_smul] + +/-- The paper's `μ_j : A_j ⊗_E A/I → I_{≥j}/I_{≥j+1}`, `B ⊗ π(C) ↦ BC + I_{≥j+1}`, here with +codomain the quotient `A/I_{≥j+1}`. -/ +def mu (j : ℕ) : 𝒜 (j : NatOrdinal) ⊗[E] Fibre 𝒜 →ₗ[E] R ⧸ idealGE 𝒜 (j + 1) := + TensorProduct.lift (muBilinear 𝒜 j) + +theorem mu_tmul (j : ℕ) (a : 𝒜 (j : NatOrdinal)) (b : R) : + mu 𝒜 j (a ⊗ₜ[E] fibreMap 𝒜 b) = Submodule.Quotient.mk ((a : R) * b) := by + rw [mu, TensorProduct.lift.tmul] + exact muMulLeft_mk 𝒜 j a b + +/-- The quotient map `A → A/I_{≥j}`, as an `E`-linear map. -/ +def idealGEQuot (j : ℕ) : R →ₗ[E] R ⧸ idealGE 𝒜 j := + (idealGE 𝒜 j).mkQ.restrictScalars E + +omit [GradedAlgebra 𝒜] in +theorem idealGEQuot_apply (j : ℕ) (x : R) : + idealGEQuot 𝒜 j x = (Submodule.Quotient.mk x : R ⧸ idealGE 𝒜 j) := (rfl) + +omit [GradedAlgebra 𝒜] in +theorem mapLinear_idealGEQuot_coe (j : ℕ) (f : ℝ → R) : + Filter.Germ.mapLinear (idealGEQuot 𝒜 j) (f : FunAtZeroMinus R) = + ((fun γ ↦ (Submodule.Quotient.mk (f γ) : R ⧸ idealGE 𝒜 j)) : FunAtZeroMinus _) := by + rw [Filter.Germ.mapLinear_coe] + rfl + +omit [GradedAlgebra 𝒜] in +theorem mapLinear_idealGEQuot_eq_zero_iff (j : ℕ) (g : FunAtZeroMinus R) : + Filter.Germ.mapLinear (idealGEQuot 𝒜 j) g = 0 ↔ g ∈ funAtZeroMinusIdeal E (idealGE 𝒜 j) := by + induction g using Filter.Germ.inductionOn with + | _ f => + rw [mapLinear_idealGEQuot_coe, coe_mem_funAtZeroMinusIdeal_iff, + show (0 : FunAtZeroMinus (R ⧸ idealGE 𝒜 j)) = + ((fun _ ↦ (0 : R ⧸ idealGE 𝒜 j) : ℝ → _) : FunAtZeroMinus _) from rfl, + Filter.Germ.coe_eq] + exact ⟨fun h ↦ h.mono fun γ hγ ↦ (Submodule.Quotient.mk_eq_zero _).mp hγ, + fun h ↦ h.mono fun γ hγ ↦ (Submodule.Quotient.mk_eq_zero _).mpr hγ⟩ + +/-- Compatibility of `μ_j` with the action of `A/I` on the second factor: +`μ_j((1 ⊗ π(B)) T) = μ_j(T) · B`. -/ +theorem mu_lTensor_mulLeft (j : ℕ) (B : R) (T : 𝒜 (j : NatOrdinal) ⊗[E] Fibre 𝒜) : + mu 𝒜 j ((LinearMap.mulLeft E (fibreMap 𝒜 B)).lTensor _ T) = + mu 𝒜 j T * (Ideal.Quotient.mk (idealGE 𝒜 (j + 1)) B) := by + induction T using TensorProduct.inductionOn with + | tmul a c => + obtain ⟨b, rfl⟩ := fibreMap_surjective 𝒜 c + rw [LinearMap.lTensor_tmul, LinearMap.mulLeft_apply, ← map_mul, mu_tmul, mu_tmul] + change Ideal.Quotient.mk _ ((a : R) * (B * b)) = Ideal.Quotient.mk _ ((a : R) * b) * _ + rw [← map_mul] + congr 1 + ring + | add x y hx hy => rw [map_add, map_add, hx, hy, map_add, add_mul] + +/-- `μ_j` is onto `I_{≥j}/I_{≥j+1}`: the class of an element of `I_{≥j}` modulo `I_{≥j+1}` is in +the image of `μ_j`. -/ +theorem exists_mu_eq {j : ℕ} {H : R} (hH : H ∈ idealGE 𝒜 j) : + ∃ T : 𝒜 (j : NatOrdinal) ⊗[E] Fibre 𝒜, + mu 𝒜 j T = (Submodule.Quotient.mk H : R ⧸ idealGE 𝒜 (j + 1)) := by + classical + rw [idealGE_eq_span] at hH + obtain ⟨n, c, g, rfl⟩ := Submodule.mem_span_set'.mp hH + choose e hje hge using fun i ↦ (mem_idealGEGenerators_iff 𝒜 j (g i)).mp (g i).2 + let a : Fin n → 𝒜 (j : NatOrdinal) := fun i ↦ + if h : e i = j then ⟨g i, h ▸ hge i⟩ else 0 + refine ⟨∑ i ∈ Finset.univ.filter (fun i ↦ e i = j), a i ⊗ₜ[E] fibreMap 𝒜 (c i), ?_⟩ + rw [map_sum, ← Submodule.mkQ_apply, map_sum, Finset.sum_filter] + refine Finset.sum_congr rfl fun i _ ↦ ?_ + rw [Submodule.mkQ_apply, smul_eq_mul] + by_cases h : e i = j + · rw [ite_eq_left h, mu_tmul] + have ha : (a i : R) = g i := by simp [a, h] + rw [ha, mul_comm] + · rw [ite_eq_right h, eq_comm, Submodule.Quotient.mk_eq_zero] + exact Ideal.mul_mem_left _ _ (mem_idealGE_of_mem 𝒜 (by have := hje i; omega) (hge i)) + +/-- The class of a homogeneous element of `I_{≥j} ∩ A_δ` is in the image of `μ_j` restricted to +`A_j ⊗ (A/I)_β`, where `j ⊕ β = δ` (Lean `β = δ.removeNat j`). -/ +theorem exists_mu_lTensor_eq {j : ℕ} {δ : NatOrdinal} {H : R} (hHδ : H ∈ 𝒜 δ) + (hH : H ∈ idealGE 𝒜 j) : + ∃ T : 𝒜 (j : NatOrdinal) ⊗[E] fibreGrade 𝒜 (δ.removeNat j), + mu 𝒜 j ((fibreGrade 𝒜 (δ.removeNat j)).subtype.lTensor _ T) = + (Submodule.Quotient.mk H : R ⧸ idealGE 𝒜 (j + 1)) := by + classical + obtain ⟨κ, _, e, a, b, β, hje, ha, hb, heβ, rfl⟩ := exists_homogeneous_presentation 𝒜 hHδ hH + have hβ : ∀ k, e k = j → β k = δ.removeNat j := fun k hk ↦ by + have hc : j ≤ δ.constantCoeff := by + rw [← heβ k, NatOrdinal.constantCoeff_add, NatOrdinal.constantCoeff_natCast, hk] + exact Nat.le_add_right _ _ + rw [NatOrdinal.eq_removeNat_iff_add_natCast_eq hc, ← hk, add_comm] + exact heβ k + let a' : κ → 𝒜 (j : NatOrdinal) := fun k ↦ if h : e k = j then ⟨a k, h ▸ ha k⟩ else 0 + let b' : κ → fibreGrade 𝒜 (δ.removeNat j) := fun k ↦ if h : e k = j then + ⟨fibreMap 𝒜 (b k), hβ k h ▸ fibreMap_mem_fibreGrade 𝒜 (hb k)⟩ else 0 + refine ⟨∑ k ∈ Finset.univ.filter (fun k ↦ e k = j), a' k ⊗ₜ[E] b' k, ?_⟩ + rw [map_sum, map_sum, ← Submodule.mkQ_apply, map_sum, Finset.sum_filter] + refine Finset.sum_congr rfl fun k _ ↦ ?_ + rw [Submodule.mkQ_apply] + by_cases h : e k = j + · rw [ite_eq_left h, LinearMap.lTensor_tmul] + have ha' : (a' k : R) = a k := by simp [a', h] + have hb' : ((fibreGrade 𝒜 (δ.removeNat j)).subtype (b' k)) = fibreMap 𝒜 (b k) := by + simp [b', h] + rw [hb', mu_tmul, ha'] + · rw [ite_eq_right h, eq_comm, Submodule.Quotient.mk_eq_zero] + exact Ideal.mul_mem_right _ _ (mem_idealGE_of_mem 𝒜 (by have := hje k; omega) (ha k)) + +/-- Homogeneous lifting: a tensor in `A_j ⊗ (A/I)_β`, `j ⊕ β = α`, is the class modulo `I_{≥j+1}` +of a homogeneous element of `I_{≥j} ∩ A_α`, provided `j` is at most the finite part of `α`. -/ +theorem exists_homogeneous_mu_eq {j : ℕ} {α : NatOrdinal} (hj : j ≤ α.constantCoeff) + (T : 𝒜 (j : NatOrdinal) ⊗[E] fibreGrade 𝒜 (α.removeNat j)) : + ∃ G ∈ 𝒜 α, G ∈ idealGE 𝒜 j ∧ + mu 𝒜 j ((fibreGrade 𝒜 (α.removeNat j)).subtype.lTensor _ T) = + (Submodule.Quotient.mk G : R ⧸ idealGE 𝒜 (j + 1)) := by + classical + induction T using TensorProduct.inductionOn with + | tmul a c => + obtain ⟨b, hb, hbc⟩ := exists_mem_of_mem_fibreGrade 𝒜 c.2 + refine ⟨(a : R) * b, ?_, Ideal.mul_mem_right _ _ (mem_idealGE_of_mem 𝒜 le_rfl a.2), ?_⟩ + · have h := SetLike.mul_mem_graded a.2 hb + have hsum : (j : NatOrdinal) + α.removeNat j = α := by + rw [add_comm] + exact NatOrdinal.removeNat_add_natCast hj + rwa [hsum] at h + · rw [LinearMap.lTensor_tmul, Submodule.subtype_apply, ← hbc] + exact mu_tmul 𝒜 j a b + | add x y hx hy => + obtain ⟨G, hGα, hGW, hG⟩ := hx + obtain ⟨G', hG'α, hG'W, hG'⟩ := hy + exact ⟨G + G', add_mem hGα hG'α, add_mem hGW hG'W, by + rw [map_add, map_add, hG, hG', Submodule.Quotient.mk_add]⟩ + +end Characteristic + +/-! ### Injectivity of the maps `μ_j` -/ + +section Injectivity + +/-- A finite sum of functions at `0⁻` is the class of the pointwise sum. -/ +theorem coe_finset_sum {V : Type*} [AddCommMonoid V] {ι : Type*} (s : Finset ι) (f : ι → ℝ → V) : + ((fun γ ↦ ∑ i ∈ s, f i γ : ℝ → V) : FunAtZeroMinus V) = ∑ i ∈ s, (f i : FunAtZeroMinus V) := by + classical + induction s using Finset.induction_on with + | empty => + simp only [Finset.sum_empty] + rfl + | insert a s ha ih => + simp only [Finset.sum_insert ha] + rw [← ih] + rfl + +theorem coe_mul_const (f : ℝ → R) (y : R) : + (f : FunAtZeroMinus R) * (y : FunAtZeroMinus R) = + ((fun γ ↦ f γ * y : ℝ → R) : FunAtZeroMinus R) := rfl + +variable (𝒜) in +/-- The element `1 ∈ A_0`. -/ +def gradeZeroOne : 𝒜 ((0 : ℕ) : NatOrdinal) := ⟨1, by simp [SetLike.one_mem_graded 𝒜]⟩ + +theorem coe_gradeZeroOne : (gradeZeroOne 𝒜 : R) = 1 := (rfl) + +namespace IsLoweringDerivation +include hΔ + +/-- `∂` on `A_{j+1}`, as a map `A_{j+1} → Fun_{0⁻}(A_j)`. -/ +def derivLinear (j : ℕ) : + 𝒜 ((j + 1 : ℕ) : NatOrdinal) →ₗ[E] FunAtZeroMinus (𝒜 (j : NatOrdinal)) := + (funAtZeroMinusSubmoduleEquiv (𝒜 (j : NatOrdinal))).symm.toLinearMap.comp + ((Δ.comp (𝒜 ((j + 1 : ℕ) : NatOrdinal)).subtype).codRestrict _ fun a ↦ by + simpa using hΔ.mem_lower_natCast (j := j + 1) (Nat.le_add_left 1 j) a.2) + +omit [GradedAlgebra 𝒜] in +theorem funAtZeroMinusSubmoduleMap_derivLinear (j : ℕ) (a : 𝒜 ((j + 1 : ℕ) : NatOrdinal)) : + funAtZeroMinusSubmoduleMap _ (hΔ.derivLinear j a) = Δ a := by + rw [derivLinear, LinearMap.comp_apply, LinearEquiv.coe_coe, + ← coe_funAtZeroMinusSubmoduleEquiv_apply, LinearEquiv.apply_symm_apply] + rfl + +omit [GradedAlgebra 𝒜] in +theorem derivLinear_injective (j : ℕ) : Function.Injective (hΔ.derivLinear j) := by + intro a a' h + apply Subtype.ext + refine sub_eq_zero.mp (hΔ.injective (natCast_constantCoeff_pos (j + 1) (Nat.le_add_left 1 j)) + ((𝒜 ((j + 1 : ℕ) : NatOrdinal)).sub_mem a.2 a'.2) ?_) + rw [map_sub, ← hΔ.funAtZeroMinusSubmoduleMap_derivLinear j, + ← hΔ.funAtZeroMinusSubmoduleMap_derivLinear j, h, sub_self] + +/-- A representative `ℝ → A_j` of `∂(a)` for `a ∈ A_{j+1}`. -/ +def derivRep (j : ℕ) (a : 𝒜 ((j + 1 : ℕ) : NatOrdinal)) : ℝ → 𝒜 (j : NatOrdinal) := + Quotient.out (hΔ.derivLinear j a) + +omit [GradedAlgebra 𝒜] in +theorem coe_derivRep (j : ℕ) (a : 𝒜 ((j + 1 : ℕ) : NatOrdinal)) : + ((hΔ.derivRep j a : ℝ → 𝒜 (j : NatOrdinal)) : FunAtZeroMinus _) = hΔ.derivLinear j a := + Quotient.out_eq _ + +omit [GradedAlgebra 𝒜] in +theorem map_eq_coe_derivRep (j : ℕ) (a : 𝒜 ((j + 1 : ℕ) : NatOrdinal)) : + Δ a = ((fun γ ↦ (hΔ.derivRep j a γ : R) : ℝ → R) : FunAtZeroMinus R) := by + rw [← hΔ.funAtZeroMinusSubmoduleMap_derivLinear j, ← hΔ.coe_derivRep j, + funAtZeroMinusSubmoduleMap_coe] + +omit [GradedAlgebra 𝒜] in +/-- Pointwise form of `∂ ⊗ 1` on a finite sum of pure tensors. -/ +theorem funAtZeroMinusTensorId_derivLinear_sum {ι : Type*} (s : Finset ι) (j : ℕ) + (a : ι → 𝒜 ((j + 1 : ℕ) : NatOrdinal)) (c : ι → Fibre 𝒜) : + funAtZeroMinusTensorId (hΔ.derivLinear j) (∑ p ∈ s, a p ⊗ₜ[E] c p) = + ((fun γ ↦ ∑ p ∈ s, hΔ.derivRep j (a p) γ ⊗ₜ[E] c p : ℝ → _) : FunAtZeroMinus _) := by + rw [map_sum, coe_finset_sum] + exact Finset.sum_congr rfl fun p _ ↦ + funAtZeroMinusTensorId_tmul_of_eq_coe _ _ _ _ (hΔ.coe_derivRep j (a p)).symm + +omit [GradedAlgebra 𝒜] in +/-- `∂` of a finite sum `∑ aₚ bₚ` with `aₚ ∈ A_{j+1}` agrees, modulo `Fun_{0⁻}(I_{≥j+1})`, with +the function `γ ↦ ∑ ∂(aₚ)(γ) bₚ`. -/ +theorem map_sum_mul_sub_mem_funAtZeroMinusIdeal {ι : Type*} (s : Finset ι) (j : ℕ) + (a : ι → 𝒜 ((j + 1 : ℕ) : NatOrdinal)) (b : ι → R) : + Δ (∑ p ∈ s, (a p : R) * b p) - + ((fun γ ↦ ∑ p ∈ s, (hΔ.derivRep j (a p) γ : R) * b p : ℝ → R) : FunAtZeroMinus R) ∈ + funAtZeroMinusIdeal E (idealGE 𝒜 (j + 1)) := by + rw [map_sum] + simp only [hΔ.map_mul] + rw [Finset.sum_add_distrib, coe_finset_sum] + have h2 : ∑ p ∈ s, ((a p : R) : FunAtZeroMinus R) * Δ (b p) ∈ + funAtZeroMinusIdeal E (idealGE 𝒜 (j + 1)) := + Submodule.sum_mem _ fun p _ ↦ by + rw [mul_comm] + exact mul_mem_funAtZeroMinusIdeal_of_const_mem (mem_idealGE_of_mem 𝒜 le_rfl (a p).2) _ + have h1 : ∑ p ∈ s, Δ (a p : R) * (b p : FunAtZeroMinus R) = + ∑ p ∈ s, ((fun γ ↦ (hΔ.derivRep j (a p) γ : R) * b p : ℝ → R) : FunAtZeroMinus R) := + Finset.sum_congr rfl fun p _ ↦ by rw [hΔ.map_eq_coe_derivRep j (a p), coe_mul_const] + rw [h1, add_sub_cancel_left] + exact h2 + +/-- Compatibility of `μ` with `∂`: if `μ_{j+1}(T) = H + I_{≥j+2}`, then +`μ_j((∂ ⊗ 1) T) = ∂H + I_{≥j+1}` as functions at `0⁻` with values in `A/I_{≥j+1}`. -/ +theorem mapLinear_mu_funAtZeroMinusTensorId (j : ℕ) {T : 𝒜 ((j + 1 : ℕ) : NatOrdinal) ⊗[E] Fibre 𝒜} + {H : R} (hT : mu 𝒜 (j + 1) T = Submodule.Quotient.mk H) : + Filter.Germ.mapLinear (mu 𝒜 j) (funAtZeroMinusTensorId (hΔ.derivLinear j) T) = + Filter.Germ.mapLinear (idealGEQuot 𝒜 (j + 1)) (Δ H) := by + classical + obtain ⟨S, rfl⟩ := TensorProduct.exists_finset T + choose b hb using fun p : 𝒜 ((j + 1 : ℕ) : NatOrdinal) × Fibre 𝒜 ↦ fibreMap_surjective 𝒜 p.2 + have hT' : ∑ p ∈ S, p.1 ⊗ₜ[E] p.2 = ∑ p ∈ S, p.1 ⊗ₜ[E] fibreMap 𝒜 (b p) := + Finset.sum_congr rfl fun p _ ↦ by rw [hb p] + rw [hT'] at hT ⊢ + -- `H ≡ ∑ aₚ bₚ` modulo `I_{≥j+2}` + have hmem : H - ∑ p ∈ S, (p.1 : R) * b p ∈ idealGE 𝒜 (j + 1 + 1) := by + rw [map_sum] at hT + simp only [mu_tmul] at hT + simp only [← Submodule.mkQ_apply, ← map_sum] at hT + exact (Submodule.Quotient.eq _).mp hT.symm + have hΔH : Δ H - Δ (∑ p ∈ S, (p.1 : R) * b p) ∈ funAtZeroMinusIdeal E (idealGE 𝒜 (j + 1)) := by + rw [← map_sub] + have := hΔ.map_mem_funAtZeroMinusIdeal_idealGE (j := j + 1 + 1) (by omega) hmem + rwa [Nat.add_sub_cancel] at this + have hsum := hΔ.map_sum_mul_sub_mem_funAtZeroMinusIdeal S j (fun p ↦ p.1) b + have hdiff := Submodule.add_mem _ hΔH hsum + rw [sub_add_sub_cancel, ← mapLinear_idealGEQuot_eq_zero_iff, map_sub, sub_eq_zero] at hdiff + rw [hdiff, hΔ.funAtZeroMinusTensorId_derivLinear_sum, Filter.Germ.mapLinear_coe, + mapLinear_idealGEQuot_coe] + congr 1 + funext γ + simp only [Function.comp_apply, map_sum, mu_tmul] + simp only [← Submodule.mkQ_apply, ← map_sum] + +/-- The maps `μ_j` are injective. -/ +theorem mu_injective (h0 : GradeZeroScalars 𝒜) (j : ℕ) : Function.Injective (mu 𝒜 j) := by + classical + induction j with + | zero => + rw [injective_iff_map_eq_zero] + intro T hT + obtain ⟨S, rfl⟩ := TensorProduct.exists_finset T + choose b hb using fun p : 𝒜 ((0 : ℕ) : NatOrdinal) × Fibre 𝒜 ↦ fibreMap_surjective 𝒜 p.2 + choose e he using fun p : 𝒜 ((0 : ℕ) : NatOrdinal) × Fibre 𝒜 ↦ + h0 p.1 (Nat.cast_zero (R := NatOrdinal) ▸ p.1.2) + have hp : ∀ p : 𝒜 ((0 : ℕ) : NatOrdinal) × Fibre 𝒜, p.1 = e p • gradeZeroOne 𝒜 := fun p ↦ + Subtype.ext (by + rw [Submodule.coe_smul, coe_gradeZeroOne, ← Algebra.algebraMap_eq_smul_one] + exact he p) + have hT' : ∑ p ∈ S, p.1 ⊗ₜ[E] p.2 = + gradeZeroOne 𝒜 ⊗ₜ[E] fibreMap 𝒜 (∑ p ∈ S, e p • b p) := by + rw [map_sum, TensorProduct.tmul_sum] + refine Finset.sum_congr rfl fun p _ ↦ ?_ + rw [hp p, ← hb p, TensorProduct.smul_tmul, map_smul] + rw [hT'] at hT ⊢ + rw [mu_tmul, Submodule.Quotient.mk_eq_zero, coe_gradeZeroOne, one_mul, zero_add] at hT + rw [(fibreMap_eq_zero_iff 𝒜 _).mpr hT, TensorProduct.tmul_zero] + | succ j ih => + rw [injective_iff_map_eq_zero] + intro T hT + -- `∂H + I_{≥j+1} = 0` for `H = 0` representing `μ_{j+1}(T) = 0` + have h := hΔ.mapLinear_mu_funAtZeroMinusTensorId j (H := 0) + (by rw [hT, Submodule.Quotient.mk_zero]) + rw [map_zero, map_zero] at h + have hzero : funAtZeroMinusTensorId (hΔ.derivLinear j) T = 0 := + Filter.Germ.mapLinear_injective (mu 𝒜 j) ih (by rw [h, map_zero]) + exact funAtZeroMinusTensorId_injective_of_injective (E := Fibre 𝒜) _ + (hΔ.derivLinear_injective j) (by rw [hzero, map_zero]) + +end IsLoweringDerivation + +end Injectivity + +end LoweringDerivation diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/LoweringDerivation/Polynomial.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/LoweringDerivation/Polynomial.lean new file mode 100644 index 0000000000..d79a2e967a --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/LoweringDerivation/Polynomial.lean @@ -0,0 +1,218 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.LoweringDerivation.Mu +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.DirectSum.GermPolynomial + +/-! +# Polynomiality of the finite-degree part + +The real-line lowering derivation is an instance of the filter-germ lowering derivation. This file +keeps the original real-line interface and transports its polynomiality statements from the single +filter-generic algebraic-independence theorem. +-/ + +universe u v w + +open scoped DirectSum +open Filter Topology MvPolynomial + +public noncomputable section + +namespace LoweringDerivation + +variable {E : Type u} {R : Type v} [Field E] [CommRing R] [Algebra E R] +variable (A : NatOrdinal → Submodule E R) [GradedAlgebra A] + +/-! ### Homogeneous coordinates -/ + +/-- The decomposable part of degree `n`. -/ +abbrev decomposable (n : ℕ) : Submodule E R := + GermPolynomial.decomposable A n + +omit [GradedAlgebra A] in +theorem decomposable_le {n : ℕ} {N : Submodule E R} + (h : ∀ i j : ℕ, 1 ≤ i → 1 ≤ j → i + j = n → + A (i : NatOrdinal) * A (j : NatOrdinal) ≤ N) : + decomposable A n ≤ N := + GermPolynomial.decomposable_le A h + +omit [GradedAlgebra A] in +theorem mul_mem_decomposable {i j : ℕ} (hi : 1 ≤ i) (hj : 1 ≤ j) {a b : R} + (ha : a ∈ A (i : NatOrdinal)) (hb : b ∈ A (j : NatOrdinal)) : + a * b ∈ decomposable A (i + j) := + GermPolynomial.mul_mem_decomposable A hi hj ha hb + +variable {ι : Type w} (wt : ι → ℕ) (x : ι → R) + +/-- Positive homogeneous generators, independent modulo decomposables and generating each finite +grade. -/ +abbrev IsHomogeneousCoordinates : Prop := + GermPolynomial.IsHomogeneousCoordinates A wt x + +variable {A wt x} + +/-- Evaluation of a homogeneous polynomial lands in its prescribed grade. -/ +theorem aeval_mem_of_forall_mem (hmem : ∀ i, x i ∈ A (wt i : NatOrdinal)) + {F : MvPolynomial ι E} {n : ℕ} (hF : IsWeightedHomogeneous wt F n) : + aeval x F ∈ A (n : NatOrdinal) := + GermPolynomial.aeval_mem_of_forall_mem hmem hF + +/-- Evaluation at homogeneous coordinates commutes with taking a homogeneous component. -/ +theorem decompose_aeval (hmem : ∀ i, x i ∈ A (wt i : NatOrdinal)) + (F : MvPolynomial ι E) (n : ℕ) : + (DirectSum.decompose A (aeval x F) (n : NatOrdinal) : R) = + aeval x (weightedHomogeneousComponent wt n F) := + GermPolynomial.decompose_aeval hmem F n + +/-- Arbitrary polynomial generation may be replaced by homogeneous polynomial generation. -/ +theorem IsHomogeneousCoordinates.of_surjective (one_le : ∀ i, 1 ≤ wt i) + (hmem : ∀ i, x i ∈ A (wt i : NatOrdinal)) + (independent : ∀ (n : ℕ) (c : ι →₀ E), (∀ i ∈ c.support, wt i = n) → + Finsupp.linearCombination E x c ∈ decomposable A n → c = 0) + (surj : ∀ (n : ℕ), ∀ y ∈ A (n : NatOrdinal), + ∃ F : MvPolynomial ι E, aeval x F = y) : + IsHomogeneousCoordinates A wt x := + GermPolynomial.IsHomogeneousCoordinates.of_surjective one_le hmem independent surj + +variable (A wt x) in +/-- A minimal system of positive homogeneous generators. -/ +abbrev IsMinimalSystem : Prop := GermPolynomial.IsMinimalSystem A wt x + +/-- A minimal system generates every finite grade. -/ +theorem IsMinimalSystem.isHomogeneousCoordinates (h0 : GradeZeroScalars A) + (hx : IsMinimalSystem A wt x) : IsHomogeneousCoordinates A wt x := + GermPolynomial.IsMinimalSystem.isHomogeneousCoordinates h0 hx + +/-- A positive-degree homogeneous polynomial is its linear part modulo decomposables. -/ +theorem exists_linear_part (hwt : ∀ i, 1 ≤ wt i) + (hmem : ∀ i, x i ∈ A (wt i : NatOrdinal)) + {F : MvPolynomial ι E} {n : ℕ} (hn : 1 ≤ n) (hF : IsWeightedHomogeneous wt F n) : + ∃ c : ι →₀ E, (∀ i ∈ c.support, wt i = n) ∧ + aeval x F - Finsupp.linearCombination E x c ∈ decomposable A n ∧ + ∀ i, c i = F.coeff (Finsupp.single i 1) := by + exact GermPolynomial.exists_linear_part hwt hmem hn hF + +/-! ### The real-line derivation as a filter-germ derivation -/ + +variable {Δ : R →ₗ[E] FunAtZeroMinus R} + +private theorem smul_eq_const_mul (a : R) (f : FunAtZeroMinus R) : + a • f = (a : FunAtZeroMinus R) * f := by + induction f using Filter.Germ.inductionOn with + | h f => rfl + +/-- The real-line lowering map with its Leibniz law, regarded as a derivation. -/ +def IsLoweringDerivation.toDerivation (hΔ : IsLoweringDerivation A Δ) : + Derivation E R (FunAtZeroMinus R) := + Derivation.mk' Δ fun a b => by + rw [hΔ.map_mul, smul_eq_const_mul, smul_eq_const_mul, + mul_comm (Δ a) (b : FunAtZeroMinus R), add_comm] + +omit [GradedAlgebra A] in +@[simp] +theorem IsLoweringDerivation.toDerivation_apply (hΔ : IsLoweringDerivation A Δ) (a : R) : + hΔ.toDerivation a = Δ a := by + change Δ a = Δ a + rfl + +omit [GradedAlgebra A] in +private theorem germSubmodule_eq_funAtZeroMinusSubmodule (W : Submodule E R) : + GermPolynomial.germSubmodule (l := 𝓝[<] (0 : ℝ)) W = funAtZeroMinusSubmodule W := by + ext f + rw [GermPolynomial.mem_germSubmodule_iff, mem_funAtZeroMinusSubmodule_iff] + +omit [GradedAlgebra A] in +/-- The real-line lowering derivation satisfies the filter-germ lowering conditions. -/ +theorem IsLoweringDerivation.toGerm (hΔ : IsLoweringDerivation A Δ) : + GermPolynomial.IsLoweringDerivation A hΔ.toDerivation where + mem_lower {α} hα {a} ha := by + rw [IsLoweringDerivation.toDerivation_apply, + germSubmodule_eq_funAtZeroMinusSubmodule] + exact hΔ.mem_lower hα ha + eq_zero {α} hα {a} ha := by + rw [IsLoweringDerivation.toDerivation_apply] + exact hΔ.eq_zero hα ha + injective {α} hα {a} ha hzero := by + rw [IsLoweringDerivation.toDerivation_apply] at hzero + exact hΔ.injective hα ha hzero + +namespace IsHomogeneousCoordinates + +variable (hx : IsHomogeneousCoordinates A wt x) +include hx + +/-- Evaluation of a homogeneous polynomial lands in its prescribed grade. -/ +theorem aeval_mem {F : MvPolynomial ι E} {n : ℕ} (hF : IsWeightedHomogeneous wt F n) : + aeval x F ∈ A (n : NatOrdinal) := + GermPolynomial.IsHomogeneousCoordinates.aeval_mem hx hF + +variable (hΔ : IsLoweringDerivation A Δ) +include hΔ + +omit hx in +theorem map_algebraMap (e : E) : Δ (algebraMap E R e) = 0 := + GermPolynomial.IsHomogeneousCoordinates.map_algebraMap hΔ.toGerm e + +omit hx in +/-- The chain rule for evaluation along homogeneous coordinates. -/ +theorem map_aeval (g : ι → ℝ → MvPolynomial ι E) + (hg : ∀ i, Δ (x i) = ((fun γ ↦ aeval x (g i γ)) : FunAtZeroMinus R)) + (F : MvPolynomial ι E) : + Δ (aeval x F) = + ((fun γ ↦ aeval x (mkDerivation E (fun i ↦ g i γ) F)) : FunAtZeroMinus R) := + GermPolynomial.IsHomogeneousCoordinates.map_aeval hΔ.toGerm g hg F + +omit [GradedAlgebra A] in +/-- Polynomial representatives of the derivatives of the homogeneous coordinates. -/ +theorem exists_lifts : ∃ g : ι → ℝ → MvPolynomial ι E, + (∀ i γ, IsWeightedHomogeneous wt (g i γ) (wt i - 1)) ∧ + ∀ i, Δ (x i) = ((fun γ ↦ aeval x (g i γ)) : FunAtZeroMinus R) := + GermPolynomial.IsHomogeneousCoordinates.exists_lifts hx hΔ.toGerm + +end IsHomogeneousCoordinates + +/-- A positive-weight homogeneous polynomial of degree zero is constant. -/ +theorem eq_C_of_isWeightedHomogeneous_zero (hwt : ∀ i, 1 ≤ wt i) + {p : MvPolynomial ι E} (hp : IsWeightedHomogeneous wt p 0) : + p = C (p.coeff 0) := + GermPolynomial.eq_C_of_isWeightedHomogeneous_zero hwt hp + +/-- A positive-degree homogeneous polynomial in the joint kernel of the pointwise derivations is +zero. -/ +theorem eq_zero_of_eventually_mkDerivation_eq_zero [CharZero E] + (hwt : ∀ i, 1 ≤ wt i) (hmem : ∀ i, x i ∈ A (wt i : NatOrdinal)) + (hind : ∀ (n : ℕ) (c : ι →₀ E), (∀ i ∈ c.support, wt i = n) → + Finsupp.linearCombination E x c ∈ decomposable A n → c = 0) + (hΔ : IsLoweringDerivation A Δ) (g : ι → ℝ → MvPolynomial ι E) + (hghom : ∀ i γ, IsWeightedHomogeneous wt (g i γ) (wt i - 1)) + (hg : ∀ i, Δ (x i) = ((fun γ ↦ aeval x (g i γ)) : FunAtZeroMinus R)) (n : ℕ) : + ∀ F : MvPolynomial ι E, 1 ≤ n → IsWeightedHomogeneous wt F n → + (∀ᶠ γ in 𝓝[<] (0 : ℝ), mkDerivation E (fun i ↦ g i γ) F = 0) → F = 0 := by + apply GermPolynomial.eq_zero_of_eventually_mkDerivation_eq_zero hwt hmem hind + hΔ.toGerm g hghom hg n + +namespace IsHomogeneousCoordinates + +variable [CharZero E] (hx : IsHomogeneousCoordinates A wt x) + (hΔ : IsLoweringDerivation A Δ) +include hx hΔ + +/-- No nonzero homogeneous relation holds among the coordinates. -/ +theorem eq_zero_of_aeval_eq_zero_of_isWeightedHomogeneous [Nontrivial R] (n : ℕ) : + ∀ F : MvPolynomial ι E, IsWeightedHomogeneous wt F n → aeval x F = 0 → F = 0 := + GermPolynomial.IsHomogeneousCoordinates.eq_zero_of_aeval_eq_zero_of_isWeightedHomogeneous + hx hΔ.toGerm n + +/-- The homogeneous coordinates are algebraically independent. -/ +theorem aeval_injective [Nontrivial R] : + Function.Injective (aeval x : MvPolynomial ι E →ₐ[E] R) := + GermPolynomial.IsHomogeneousCoordinates.aeval_injective hx hΔ.toGerm + +end IsHomogeneousCoordinates + +end LoweringDerivation diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/MonoidAlgebra.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/MonoidAlgebra.lean new file mode 100644 index 0000000000..7a90b1635b --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/MonoidAlgebra.lean @@ -0,0 +1,12 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MonoidAlgebra.LatticeFunctional +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MonoidAlgebra.SingleZeroFactors + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/MonoidAlgebra/LatticeFunctional.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/MonoidAlgebra/LatticeFunctional.lean new file mode 100644 index 0000000000..c2e1c75e2a --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/MonoidAlgebra/LatticeFunctional.lean @@ -0,0 +1,115 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import Mathlib.Algebra.BigOperators.Fin +public import Mathlib.Algebra.Order.Ring.Abs +public import Mathlib.Data.Finsupp.Basic + +import Mathlib.Tactic.Ring +import Mathlib.Tactic.Linarith + +/-! +# A linear functional separating finitely many lattice points + +Finitely many points of a finite-rank lattice are separated by a single homomorphism to the +integers: evaluating coordinates in a base larger than twice every coordinate that occurs makes +the resulting integer determine the point, because a base-`N` representation with digits of +absolute value below `N` represents zero only if all its digits vanish. + +Such a functional collapses a finite-rank exponent lattice to a single variable while keeping +prescribed exponents distinct, which is what reduces a statement about group algebras of +finite-rank lattices to the one-variable case. +-/ + +universe u + +public section + +/-- Base-`N` digits with absolute value below `N` represent zero only if they all vanish. -/ +private theorem eq_zero_of_sum_mul_pow_eq_zero {k : ℕ} {N : ℤ} (hN : 0 < N) {d : Fin k → ℤ} + (hd : ∀ i, |d i| < N) (hsum : ∑ i, d i * N ^ (i : ℕ) = 0) : ∀ i, d i = 0 := by + induction k with + | zero => exact fun i ↦ i.elim0 + | succ k ih => + rw [Fin.sum_univ_succ] at hsum + have hshift : ∑ i : Fin k, d i.succ * N ^ ((i : ℕ) + 1) = + N * ∑ i : Fin k, d i.succ * N ^ (i : ℕ) := by + rw [Finset.mul_sum] + refine Finset.sum_congr rfl fun i _ ↦ ?_ + rw [pow_succ] + ring + simp only [Fin.val_zero, pow_zero, mul_one, Fin.val_succ] at hsum + rw [hshift] at hsum + have hd0 : d 0 = 0 := by + have hdvd : N ∣ d 0 := ⟨-(∑ i : Fin k, d i.succ * N ^ (i : ℕ)), by linarith [hsum]⟩ + rcases hdvd with ⟨t, ht⟩ + by_contra hne + have ht0 : t ≠ 0 := by + rintro rfl + rw [mul_zero] at ht + exact hne ht + have h1 : 1 ≤ |t| := Int.one_le_abs ht0 + have : N ≤ |d 0| := by + rw [ht, abs_mul, abs_of_pos hN] + exact le_mul_of_one_le_right hN.le h1 + exact absurd (hd 0) (not_lt.mpr this) + have hrest : ∑ i : Fin k, d i.succ * N ^ (i : ℕ) = 0 := by + rw [hd0, zero_add] at hsum + exact (mul_eq_zero.mp hsum).resolve_left hN.ne' + intro i + refine Fin.cases hd0 (fun j ↦ ?_) i + exact ih (fun j ↦ hd j.succ) hrest j +/-- A group homomorphism to `ℤ` that is injective on a prescribed finite set of lattice points: +evaluate in a base larger than twice every coordinate occurring. -/ +theorem AddMonoidHom.exists_injOn_finInt {k : ℕ} (S : Finset (Fin k → ℤ)) : + ∃ psi : (Fin k → ℤ) →+ ℤ, Set.InjOn psi (S : Set (Fin k → ℤ)) := by + classical + set M : ℕ := S.sup fun x ↦ Finset.univ.sup fun i ↦ (x i).natAbs with hM + set N : ℤ := 2 * (M : ℤ) + 1 with hNdef + have hNpos : (0 : ℤ) < N := by positivity + have hbound : ∀ x ∈ S, ∀ i, |x i| ≤ (M : ℤ) := by + intro x hx i + have h1 : (x i).natAbs ≤ M := by + refine le_trans (Finset.le_sup (f := fun j ↦ (x j).natAbs) (Finset.mem_univ i)) ?_ + exact Finset.le_sup (f := fun y ↦ Finset.univ.sup fun j ↦ (y j).natAbs) hx + rw [Int.abs_eq_natAbs] + exact_mod_cast h1 + refine ⟨{ toFun := fun x ↦ ∑ i, x i * N ^ (i : ℕ) + map_zero' := by simp + map_add' := fun x y ↦ by + simp only [Pi.add_apply, add_mul] + rw [Finset.sum_add_distrib] }, ?_⟩ + intro x hx y hy hxy + simp only [AddMonoidHom.coe_mk, ZeroHom.coe_mk] at hxy + have hzero : ∑ i, (x i - y i) * N ^ (i : ℕ) = 0 := by + simp only [sub_mul] + rw [Finset.sum_sub_distrib, hxy, sub_self] + have hdig : ∀ i, |x i - y i| < N := by + intro i + have h1 := abs_le.mp (hbound x hx i) + have h2 := abs_le.mp (hbound y hy i) + rw [abs_lt] + constructor <;> [linarith [h1.1, h2.2]; linarith [h1.2, h2.1]] + funext i + have := eq_zero_of_sum_mul_pow_eq_zero hNpos hdig hzero i + linarith [this] + +/-! ### Transferring coefficients along an injective relabelling of exponents -/ + +namespace Finsupp + +variable {H : Type*} {N : Type*} {L : Type*} [AddCommMonoid L] + +/-- Relabelling exponents injectively on the support preserves each coefficient. -/ +theorem mapDomain_apply_of_injOn {psi : H → N} {x : H →₀ L} + (hinj : Set.InjOn psi (x.support : Set H)) {g : H} (hg : g ∈ x.support) : + Finsupp.mapDomain psi x (psi g) = x g := + Finsupp.mapDomain_apply' (x.support : Set H) x subset_rfl hinj hg + +end Finsupp + +end diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/MonoidAlgebra/SingleZeroFactors.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/MonoidAlgebra/SingleZeroFactors.lean new file mode 100644 index 0000000000..29a159fff5 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/MonoidAlgebra/SingleZeroFactors.lean @@ -0,0 +1,135 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.DirectSum.TrailingGrade +public import Mathlib.Algebra.MonoidAlgebra.ToDirectSum + +import Mathlib.Algebra.MonoidAlgebra.NoZeroDivisors + +/-! +# Factors of a constant in an additive monoid algebra + +Suppose the grading monoid is linearly ordered, cancellative, and has zero as its largest element. +If a nonzero additive-monoid-algebra element has trailing grade zero, it is supported only at +zero. Consequently, over a coefficient semiring without zero divisors, both nonzero factors of a +monomial supported at zero are themselves supported at zero. +-/ + +open scoped DirectSum + +universe u v + +namespace AddMonoidAlgebra + +public noncomputable section + +variable {R : Type u} {M : Type v} + [Semiring R] [LinearOrder M] [AddCommMonoid M] [OrderTop M] + +private abbrev component (_ : M) := R + +/-- An element with trailing grade zero is supported only at zero when zero is the largest +grade. -/ +theorem exists_eq_single_zero_of_trailingGrade_eq_zero + (hzeroTop : (⊤ : M) = 0) {f : AddMonoidAlgebra R M} + (htrail : DirectSum.trailingGrade (fun _ : M ↦ R) f.toDirectSum = + (0 : WithTop M)) : + ∃ r : R, f = AddMonoidAlgebra.single 0 r := by + classical + refine ⟨f.toDirectSum 0, ?_⟩ + have hdirect : f.toDirectSum = DirectSum.of component 0 (f.toDirectSum 0) := by + apply DirectSum.ext + intro i + by_cases hi : i = 0 + · subst i + simp + · have hfi : f.toDirectSum i = 0 := by + by_contra hfi + have hzeroLe : (0 : M) ≤ i := + (DirectSum.trailingGrade_eq_coe_iff component f.toDirectSum 0).mp htrail |>.2 i hfi + have hiZero : i ≤ 0 := by + rw [← hzeroTop] + exact le_top + exact hi (le_antisymm hiZero hzeroLe) + rw [hfi, DirectSum.of_eq_of_ne 0 i _ hi] + have h := congrArg DirectSum.toAddMonoidAlgebra hdirect + simpa using h + +variable [NoZeroDivisors R] [IsOrderedCancelAddMonoid M] + +/-- If a product is supported only at zero, each nonzero factor is supported only at zero. -/ +theorem exists_eq_single_zero_of_mul_eq_single_zero + (hzeroTop : (⊤ : M) = 0) {f g : AddMonoidAlgebra R M} {r : R} + (hf : f ≠ 0) (hg : g ≠ 0) + (hfg : f * g = AddMonoidAlgebra.single 0 r) : + ∃ a b : R, + f = AddMonoidAlgebra.single 0 a ∧ + g = AddMonoidAlgebra.single 0 b := by + classical + have hr : r ≠ 0 := by + intro hr + subst r + have hzero : f * g = 0 := hfg.trans (AddMonoidAlgebra.single_zero 0) + exact (mul_eq_zero.mp hzero).elim hf hg + have hfDirect : f.toDirectSum ≠ 0 := by + intro hzero + apply hf + have := congrArg DirectSum.toAddMonoidAlgebra hzero + simpa using this + have hgDirect : g.toDirectSum ≠ 0 := by + intro hzero + apply hg + have := congrArg DirectSum.toAddMonoidAlgebra hzero + simpa using this + obtain ⟨m, hm, _⟩ := + DirectSum.exists_grade_eq_trailingGrade component hfDirect + obtain ⟨n, hn, _⟩ := + DirectSum.exists_grade_eq_trailingGrade component hgDirect + have hfgDirect : f.toDirectSum * g.toDirectSum = + DirectSum.of component 0 r := by + simpa using congrArg AddMonoidAlgebra.toDirectSum hfg + have hsumTop : ((m + n : M) : WithTop M) = (0 : M) := by + calc + ((m + n : M) : WithTop M) = + DirectSum.trailingGrade component f.toDirectSum + + DirectSum.trailingGrade component g.toDirectSum := by + rw [hm, hn, WithTop.coe_add] + _ = DirectSum.trailingGrade component + (f.toDirectSum * g.toDirectSum) := + (DirectSum.trailingGrade_mul component + (fun a b ha hb ↦ mul_ne_zero ha hb) f.toDirectSum g.toDirectSum).symm + _ = DirectSum.trailingGrade component (DirectSum.of component 0 r) := by + rw [hfgDirect] + _ = (0 : M) := DirectSum.trailingGrade_of component hr + have hsum : m + n = 0 := WithTop.coe_injective hsumTop + have hmLe : m ≤ 0 := by + rw [← hzeroTop] + exact le_top + have hnLe : n ≤ 0 := by + rw [← hzeroTop] + exact le_top + have hzeroLeM : 0 ≤ m := by + calc + 0 = m + n := hsum.symm + _ ≤ m + 0 := add_le_add_right hnLe m + _ = m := add_zero m + have hzeroLeN : 0 ≤ n := by + calc + 0 = m + n := hsum.symm + _ ≤ 0 + n := add_le_add_left hmLe n + _ = n := zero_add n + have hmZero : m = 0 := le_antisymm hmLe hzeroLeM + have hnZero : n = 0 := le_antisymm hnLe hzeroLeN + obtain ⟨a, ha⟩ := exists_eq_single_zero_of_trailingGrade_eq_zero + hzeroTop (hm.trans (congrArg WithTop.some hmZero)) + obtain ⟨b, hb⟩ := exists_eq_single_zero_of_trailingGrade_eq_zero + hzeroTop (hn.trans (congrArg WithTop.some hnZero)) + exact ⟨a, b, ha, hb⟩ + +end + +end AddMonoidAlgebra diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/MvPolynomial.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/MvPolynomial.lean new file mode 100644 index 0000000000..152588a89a --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/MvPolynomial.lean @@ -0,0 +1,26 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MvPolynomial.BaseChange +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MvPolynomial.Components +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MvPolynomial.ComponentsSpan +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MvPolynomial.Expansion +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MvPolynomial.FinitePartDecomposition +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MvPolynomial.FinitePartErasure +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MvPolynomial.FinitePartVars +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MvPolynomial.GCDMonoid +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MvPolynomial.LimitOrdinalContradiction +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MvPolynomial.MapWeight +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MvPolynomial.OrdinalDerivation +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MvPolynomial.OrdinalExpansion +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MvPolynomial.RemainderBound +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MvPolynomial.Syzygy +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MvPolynomial.TermDegree +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MvPolynomial.WeightedTotalDegree + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/MvPolynomial/BaseChange.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/MvPolynomial/BaseChange.lean new file mode 100644 index 0000000000..90bcb26fc9 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/MvPolynomial/BaseChange.lean @@ -0,0 +1,130 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import Mathlib.RingTheory.TensorProduct.MvPolynomial +public import Mathlib.RingTheory.Flat.Basic + +import Mathlib.RingTheory.MvPolynomial.Tower + +/-! +# Algebraic independence under a flat extension of scalars + +Let `A` be a commutative `K`-algebra and `y i ∈ A` algebraically independent over `K`: evaluation +`K[X_i] → A`, `X_i ↦ y i`, is injective. For a flat commutative `K`-algebra `L`, the elements +`y i ⊗ 1` of `A ⊗_K L` are algebraically independent over `L`: evaluation `L[X_i] → A ⊗_K L`, +`X_i ↦ y i ⊗ 1`, `l ↦ 1 ⊗ l`, is injective. Through the identification `K[X_i] ⊗_K L ≅ L[X_i]` +this evaluation is the base change of `K[X_i] → A` to `L`, which flatness keeps injective; and +if the `y i` generate `A` over `K`, the `y i ⊗ 1` generate `A ⊗_K L` over `L`. +-/ + +open scoped TensorProduct + +universe u v w x + +public noncomputable section + +namespace MvPolynomial + +variable {K : Type u} {A : Type v} {L : Type w} {σ : Type x} +variable [CommRing K] [CommRing A] [Algebra K A] [CommRing L] [Algebra K L] + +/-- Extending polynomial coefficients by a tensor factor on the right, as a `K`-algebra + equivalence. -/ +noncomputable def polynomialScalarTensorAlgEquiv : + MvPolynomial σ K ⊗[K] L ≃ₐ[K] MvPolynomial σ L := + (Algebra.TensorProduct.comm K _ _).trans + ((algebraTensorAlgEquiv (σ := σ) K L).restrictScalars K) + +/-- The identification `K[X_i] ⊗_K L ≅ L[X_i]` on a variable tensor. -/ +theorem scalarRTensorAlgEquiv_X_tmul_one (i : σ) : + polynomialScalarTensorAlgEquiv (σ := σ) (K := K) (L := L) (X i ⊗ₜ[K] 1) = X i := by + simp [polynomialScalarTensorAlgEquiv, algebraTensorAlgEquiv_tmul] + +/-- The identification `K[X_i] ⊗_K L ≅ L[X_i]` on a scalar tensor. -/ +theorem scalarRTensorAlgEquiv_one_tmul (l : L) : + polynomialScalarTensorAlgEquiv (σ := σ) (K := K) (L := L) (1 ⊗ₜ[K] l) = C l := by + simp [polynomialScalarTensorAlgEquiv, algebraTensorAlgEquiv_tmul, + MvPolynomial.smul_eq_C_mul] + +variable (K L) in +/-- Evaluation `L[X_i] → A ⊗_K L`, `X_i ↦ y i ⊗ 1`, `l ↦ 1 ⊗ l`, as a `K`-algebra +homomorphism. -/ +def aevalTmulOne (y : σ → A) : MvPolynomial σ L →ₐ[K] A ⊗[K] L := + aevalTower (Algebra.TensorProduct.includeRight : L →ₐ[K] A ⊗[K] L) fun i ↦ y i ⊗ₜ[K] 1 + +theorem aevalTmulOne_X (y : σ → A) (i : σ) : aevalTmulOne K L y (X i) = y i ⊗ₜ[K] 1 := + aevalTower_X _ _ i + +theorem aevalTmulOne_C (y : σ → A) (l : L) : aevalTmulOne K L y (C l) = (1 : A) ⊗ₜ[K] l := + aevalTower_C _ _ l + +/-- Through `K[X_i] ⊗_K L ≅ L[X_i]`, evaluation at the `y i ⊗ 1` is the base change to `L` of +evaluation at the `y i`. -/ +theorem aevalTmulOne_comp_scalarRTensorAlgEquiv (y : σ → A) : + (aevalTmulOne K L y).comp + (polynomialScalarTensorAlgEquiv (σ := σ) (K := K) (L := L)).toAlgHom = + Algebra.TensorProduct.map (aeval y : MvPolynomial σ K →ₐ[K] A) (AlgHom.id K L) := by + refine Algebra.TensorProduct.ext ?_ ?_ + · refine MvPolynomial.algHom_ext fun i ↦ ?_ + simp only [AlgHom.comp_apply, Algebra.TensorProduct.includeLeft_apply, AlgEquiv.coe_toAlgHom, + scalarRTensorAlgEquiv_X_tmul_one, aevalTmulOne_X, Algebra.TensorProduct.map_tmul, + aeval_X, AlgHom.coe_id, id_eq] + · refine AlgHom.ext fun l ↦ ?_ + simp only [AlgHom.coe_restrictScalars', AlgHom.comp_apply, + Algebra.TensorProduct.includeRight_apply, AlgEquiv.coe_toAlgHom, + scalarRTensorAlgEquiv_one_tmul, aevalTmulOne_C, Algebra.TensorProduct.map_tmul, + map_one, AlgHom.coe_id, id_eq] + +/-- Evaluation at the `y i ⊗ 1` of a polynomial with coefficients in `K` is the evaluation at the +`y i` tensored with `1`. -/ +theorem aevalTmulOne_map (y : σ → A) (G : MvPolynomial σ K) : + aevalTmulOne K L y (map (algebraMap K L) G) = aeval y G ⊗ₜ[K] 1 := by + induction G using MvPolynomial.induction_on with + | C c => + rw [map_C, aevalTmulOne_C, aeval_C, Algebra.algebraMap_eq_smul_one, + Algebra.algebraMap_eq_smul_one, TensorProduct.smul_tmul] + | add p q hp hq => rw [map_add, map_add, hp, hq, map_add, TensorProduct.add_tmul] + | mul_X p i hp => + rw [map_mul, map_mul, hp, map_X, aevalTmulOne_X, map_mul, aeval_X, + Algebra.TensorProduct.tmul_mul_tmul, mul_one] + +/-- Elements generating `A` over `K` generate `A ⊗_K L` over `L`. -/ +theorem aevalTmulOne_surjective {y : σ → A} + (hy : Function.Surjective (aeval y : MvPolynomial σ K →ₐ[K] A)) : + Function.Surjective (aevalTmulOne K L y) := by + intro z + induction z using TensorProduct.inductionOn with + | tmul a l => + obtain ⟨G, rfl⟩ := hy a + refine ⟨C l * map (algebraMap K L) G, ?_⟩ + rw [map_mul, aevalTmulOne_C, aevalTmulOne_map, Algebra.TensorProduct.tmul_mul_tmul, one_mul, + mul_one] + | add z w hz hw => + obtain ⟨F, rfl⟩ := hz + obtain ⟨G, rfl⟩ := hw + exact ⟨F + G, map_add _ _ _⟩ + +/-- Elements algebraically independent over `K` remain algebraically independent over `L` after +a flat extension of scalars `K → L`. -/ +theorem aevalTmulOne_injective [Module.Flat K L] {y : σ → A} + (hy : Function.Injective (aeval y : MvPolynomial σ K →ₐ[K] A)) : + Function.Injective (aevalTmulOne K L y) := by + classical + have hrt : Function.Injective + (Algebra.TensorProduct.map (aeval y : MvPolynomial σ K →ₐ[K] A) (AlgHom.id K L)) := + Module.Flat.rTensor_preserves_injective_linearMap (R := K) (M := L) + (aeval y : MvPolynomial σ K →ₐ[K] A).toLinearMap hy + set e := polynomialScalarTensorAlgEquiv (σ := σ) (K := K) (L := L) + have key : ∀ u, aevalTmulOne K L y (e u) = + Algebra.TensorProduct.map (aeval y : MvPolynomial σ K →ₐ[K] A) (AlgHom.id K L) u := + fun u ↦ congrFun (congrArg (fun f : _ →ₐ[K] _ ↦ (f : _ → _)) + (aevalTmulOne_comp_scalarRTensorAlgEquiv y)) u + intro a b hab + rw [← e.apply_symm_apply a, ← e.apply_symm_apply b, key, key] at hab + rw [← e.apply_symm_apply a, ← e.apply_symm_apply b, hrt hab] + +end MvPolynomial diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/MvPolynomial/Components.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/MvPolynomial/Components.lean new file mode 100644 index 0000000000..89d8480028 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/MvPolynomial/Components.lean @@ -0,0 +1,118 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import Mathlib.RingTheory.MvPolynomial.WeightedHomogeneous +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.FinitePart + +/-! +# The part of a polynomial of degree at least `τ` + +For `P ∈ R[X_i]` graded by `deg X_i = wt i` with ordinal degrees `wt : σ → NatOrdinal`, +`componentsGE wt τ P` is the sum of the monomials of `P` of degree at least `τ`: the part +`P_{≥τ} := ∑_{β ≥ τ} P_β` of `P` *at or above the degree `τ`* (by the degree of its monomials, not +by exponent as for the parts of an ordinal). It is additive, vanishes on polynomials of degree +below `τ`, and fixes homogeneous polynomials of degree at least `τ`. +-/ + +universe u v + +open Finsupp + +public section + +namespace MvPolynomial + +variable {σ : Type u} {R : Type v} [CommRing R] (wt : σ → NatOrdinal) + +/-- The part `P_{≥τ}` of `P` at or above the degree `τ`: the sum of the monomials of `P` of degree +at least `τ`. -/ +noncomputable def componentsGE (τ : NatOrdinal) (P : MvPolynomial σ R) : MvPolynomial σ R := by + classical + exact ∑ d ∈ P.support.filter fun d ↦ τ ≤ Finsupp.weight wt d, monomial d + (AddMonoidAlgebra.coeff P d) + +open Classical in +theorem coeff_componentsGE (τ : NatOrdinal) (P : MvPolynomial σ R) (d : σ →₀ ℕ) : + AddMonoidAlgebra.coeff (componentsGE wt τ P) d = if τ ≤ Finsupp.weight wt d then + AddMonoidAlgebra.coeff P d else 0 := by + classical + rw [componentsGE] + simp only [coeff_sum, coeff_monomial] + split_ifs with hτ + · rw [Finset.sum_eq_single d] + · rw [ite_eq_left rfl] + · intro d' _ hd' + rw [ite_eq_right hd'] + · intro hd + rw [ite_eq_left rfl] + by_contra h + exact hd (Finset.mem_filter.mpr ⟨mem_support_iff.mpr h, hτ⟩) + · refine Finset.sum_eq_zero fun d' hd' ↦ ?_ + rw [ite_eq_right] + rintro rfl + exact hτ (Finset.mem_filter.mp hd').2 + +theorem componentsGE_add (τ : NatOrdinal) (P Q : MvPolynomial σ R) : + componentsGE wt τ (P + Q) = componentsGE wt τ P + componentsGE wt τ Q := by + classical + ext d + simp only [AddMonoidAlgebra.coeff_add, Finsupp.add_apply, coeff_componentsGE] + split_ifs <;> simp + +theorem componentsGE_neg (τ : NatOrdinal) (P : MvPolynomial σ R) : + componentsGE wt τ (-P) = -componentsGE wt τ P := by + classical + ext d + have hneg : ∀ Q : MvPolynomial σ R, AddMonoidAlgebra.coeff (-Q) d = -AddMonoidAlgebra.coeff Q + d := fun Q ↦ by + change (coeffAddMonoidHom d) (-Q) = -(coeffAddMonoidHom d) Q + exact map_neg _ _ + rw [hneg, coeff_componentsGE, coeff_componentsGE, hneg] + split_ifs <;> simp + +theorem componentsGE_sub (τ : NatOrdinal) (P Q : MvPolynomial σ R) : + componentsGE wt τ (P - Q) = componentsGE wt τ P - componentsGE wt τ Q := by + rw [sub_eq_add_neg, componentsGE_add, componentsGE_neg, sub_eq_add_neg] + +theorem componentsGE_zero (τ : NatOrdinal) : componentsGE wt τ (0 : MvPolynomial σ R) = 0 := by + classical + ext d + simp [coeff_componentsGE] + +theorem componentsGE_sum {ι : Type*} (τ : NatOrdinal) (s : Finset ι) (f : ι → MvPolynomial σ R) : + componentsGE wt τ (∑ i ∈ s, f i) = ∑ i ∈ s, componentsGE wt τ (f i) := by + classical + induction s using Finset.induction_on with + | empty => rw [Finset.sum_empty, Finset.sum_empty, componentsGE_zero] + | insert a s ha ih => rw [Finset.sum_insert ha, Finset.sum_insert ha, componentsGE_add, ih] + +/-- The part at or above `τ` of a polynomial all of whose monomials have degree below `τ` is +`0`. -/ +theorem componentsGE_eq_zero_of_forall_lt {τ : NatOrdinal} {P : MvPolynomial σ R} + (hP : ∀ d ∈ P.support, Finsupp.weight wt d < τ) : componentsGE wt τ P = 0 := by + classical + ext d + rw [coeff_componentsGE, AddMonoidAlgebra.coeff_zero] + split_ifs with hτ + · by_contra h + exact absurd (hP d (mem_support_iff.mpr h)) (not_lt.mpr hτ) + · rfl + +/-- A homogeneous polynomial of degree at least `τ` is its own part at or above `τ`. -/ +theorem componentsGE_eq_self_of_isWeightedHomogeneous {τ β : NatOrdinal} {P : MvPolynomial σ R} + (hP : IsWeightedHomogeneous wt P β) (hβ : τ ≤ β) : componentsGE wt τ P = P := by + classical + ext d + rw [coeff_componentsGE] + split_ifs with hτ + · rfl + · by_contra h + exact hτ (hβ.trans_eq (hP (Ne.symm h)).symm) + +end MvPolynomial + +end diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/MvPolynomial/ComponentsSpan.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/MvPolynomial/ComponentsSpan.lean new file mode 100644 index 0000000000..494fafb5fe --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/MvPolynomial/ComponentsSpan.lean @@ -0,0 +1,109 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MvPolynomial.Components +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.GradedRing.HomogeneousSpan + +/-! +# The part at or above a degree of an element of a homogeneous ideal + +The part `P_{≥τ}` at or above a degree `τ` of an element `P` of the ideal generated by finitely +many homogeneous polynomials lies in that ideal: `componentsGE wt τ P` is the sum of the +homogeneous components of `P` of degree at least `τ`, and each homogeneous component of an element +of a homogeneous ideal lies in the ideal. +-/ + +universe u v w + +open Finsupp DirectSum + +public section + +namespace MvPolynomial + +variable {σ : Type u} {K : Type v} [Field K] (wt : σ → NatOrdinal) + +/-- The part at or above `τ` is the sum of the homogeneous components of degree at least `τ`. -/ +theorem componentsGE_eq_sum_weightedHomogeneousComponent (τ : NatOrdinal) (P : MvPolynomial σ K) : + componentsGE wt τ P = + ∑ e ∈ (P.support.image (Finsupp.weight wt)).filter fun e ↦ τ ≤ e, + weightedHomogeneousComponent wt e P := by + classical + ext d + rw [coeff_componentsGE, coeff_sum] + simp only [coeff_weightedHomogeneousComponent] + split_ifs with hτ + · by_cases hd : d ∈ P.support + · rw [Finset.sum_eq_single (Finsupp.weight wt d)] + · rw [ite_eq_left rfl] + · intro e _ he + rw [ite_eq_right (Ne.symm he)] + · intro h + exact absurd (Finset.mem_filter.mpr ⟨Finset.mem_image_of_mem _ hd, hτ⟩) h + · rw [notMem_support_iff.mp hd] + exact (Finset.sum_eq_zero fun e _ ↦ by split_ifs <;> rfl).symm + · refine (Finset.sum_eq_zero fun e he ↦ ?_).symm + rw [ite_eq_right] + rintro rfl + exact hτ (Finset.mem_filter.mp he).2 + +/-- A homogeneous component of an element of the ideal generated by homogeneous polynomials lies in +the ideal. -/ +theorem weightedHomogeneousComponent_mem_span {ι : Type w} [Finite ι] {q : ι → MvPolynomial σ K} + {c : ι → NatOrdinal} (hq : ∀ j, IsWeightedHomogeneous wt (q j) (c j)) {P : MvPolynomial σ K} + (hP : P ∈ Ideal.span (Set.range q)) (e : NatOrdinal) : + weightedHomogeneousComponent wt e P ∈ Ideal.span (Set.range q) := by + classical + cases nonempty_fintype ι + let := weightedGradedAlgebra K wt + obtain ⟨u, -, -, hsum⟩ := OrdinalGraded.exists_decompose_eq_sum_mul_of_mem_span + (𝒜 := weightedHomogeneousSubmodule K wt) + (fun j ↦ (mem_weightedHomogeneousSubmodule _ _ _ _).mpr (hq j)) hP e + have hdec : (decompose (weightedHomogeneousSubmodule K wt) P e : MvPolynomial σ K) = + weightedHomogeneousComponent wt e P := by + rw [← decompose'_apply] + rfl + rw [← hdec, hsum] + exact Ideal.sum_mem _ fun j _ ↦ Ideal.mul_mem_right _ _ (Ideal.subset_span ⟨j, rfl⟩) + +/-- The part at or above a degree `τ` of an element of the ideal generated by homogeneous +polynomials lies in the ideal. -/ +theorem componentsGE_mem_span {ι : Type w} [Finite ι] {q : ι → MvPolynomial σ K} + {c : ι → NatOrdinal} (hq : ∀ j, IsWeightedHomogeneous wt (q j) (c j)) {P : MvPolynomial σ K} + (hP : P ∈ Ideal.span (Set.range q)) (τ : NatOrdinal) : + componentsGE wt τ P ∈ Ideal.span (Set.range q) := by + rw [componentsGE_eq_sum_weightedHomogeneousComponent] + exact Ideal.sum_mem _ fun e _ ↦ weightedHomogeneousComponent_mem_span wt hq hP e + +/-- A homogeneous component of degree at least `τ` is unchanged by passing to the part at or +above `τ`. -/ +theorem weightedHomogeneousComponent_componentsGE_of_le {τ e : NatOrdinal} (hτe : τ ≤ e) + (P : MvPolynomial σ K) : + weightedHomogeneousComponent wt e (componentsGE wt τ P) = + weightedHomogeneousComponent wt e P := by + classical + ext d + rw [coeff_weightedHomogeneousComponent, coeff_weightedHomogeneousComponent, coeff_componentsGE] + split_ifs with h1 h2 + · rfl + · exact absurd (h1 ▸ hτe) h2 + · rfl + +/-- If the part at or above `τ` of `P` lies in the ideal generated by homogeneous polynomials, so +does every homogeneous component of `P` of degree at least `τ`. -/ +theorem weightedHomogeneousComponent_mem_span_of_componentsGE_mem {ι : Type w} [Finite ι] + {q : ι → MvPolynomial σ K} {c : ι → NatOrdinal} + (hq : ∀ j, IsWeightedHomogeneous wt (q j) (c j)) {P : MvPolynomial σ K} {τ e : NatOrdinal} + (hP : componentsGE wt τ P ∈ Ideal.span (Set.range q)) (hτe : τ ≤ e) : + weightedHomogeneousComponent wt e P ∈ Ideal.span (Set.range q) := by + rw [← weightedHomogeneousComponent_componentsGE_of_le wt hτe] + exact weightedHomogeneousComponent_mem_span wt hq hP e + +end MvPolynomial + +end diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/MvPolynomial/Expansion.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/MvPolynomial/Expansion.lean new file mode 100644 index 0000000000..53d446a2c8 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/MvPolynomial/Expansion.lean @@ -0,0 +1,263 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import Mathlib.Algebra.MvPolynomial.Derivation +public import Mathlib.Algebra.MvPolynomial.Equiv +public import Mathlib.Algebra.MvPolynomial.Supported +public import Mathlib.RingTheory.MvPolynomial.WeightedHomogeneous + +/-! +# Expansion of a multivariate polynomial in one variable + +Mathlib identifies `MvPolynomial (Option σ') R` with polynomials in one variable over +`MvPolynomial σ' R` (`MvPolynomial.optionEquivLeft`). Composing with the renaming along +`Option {y // y ≠ x} ≃ σ` gives, for a variable `x : σ`, the expansion of every +`p : MvPolynomial σ R` in powers of `X x`: `expandEquiv x p` is a polynomial over the polynomials in +the remaining variables, and `xCoeff x k p` is its `k`-th coefficient read back in +`MvPolynomial σ R`, a polynomial not involving `x` (an element of `supported R {x}ᶜ`). The lemmas +here translate the `Polynomial.coeff` API through that identification: the expansion +`p = ∑_k xCoeff x k p * X x ^ k`, the coefficients of such an expansion, the nonvanishing of the +leading coefficient, and the behaviour of the coefficients under weighted homogeneity. + +The file also records how weighted homogeneity interacts with derivations `mkDerivation R f` whose +values on the variables have weight `wt i - 1`: such a derivation lowers weight by one, and it +preserves "does not involve `x`" on polynomials whose variables all have weight at most `wt x`. +-/ + +universe u v + +public noncomputable section + +namespace MvPolynomial + +variable {σ : Type u} {R : Type v} [CommRing R] + +/-! ### Weighted homogeneity and the variables -/ + +variable (wt : σ → ℕ) + +/-- A variable of a weighted-homogeneous polynomial has weight at most the polynomial's. -/ +theorem IsWeightedHomogeneous.weight_le_of_mem_vars {p : MvPolynomial σ R} {w : ℕ} + (hp : IsWeightedHomogeneous wt p w) {i : σ} (hi : i ∈ p.vars) : wt i ≤ w := by + obtain ⟨m, hm, hmi⟩ := (mem_vars_iff_mem_support i).mp hi + rw [← hp (mem_support_iff.mp hm)] + exact Finsupp.le_weight_of_ne_zero' wt (Finsupp.mem_support_iff.mp hmi) + +/-- A weighted-homogeneous polynomial of weight less than `wt x` does not involve `x`. -/ +theorem IsWeightedHomogeneous.mem_supported_of_lt {p : MvPolynomial σ R} {w : ℕ} + (hp : IsWeightedHomogeneous wt p w) {x : σ} (hx : w < wt x) : p ∈ supported R {x}ᶜ := by + rw [mem_supported] + intro y hy + rw [Set.mem_compl_singleton_iff] + rintro rfl + exact absurd (hp.weight_le_of_mem_vars wt hy) (not_le.mpr hx) + +/-- A derivation whose values on the variables are weighted-homogeneous of weight `wt i - 1` +lowers the weight of weighted-homogeneous polynomials by one. -/ +theorem mkDerivation_isWeightedHomogeneous (f : σ → MvPolynomial σ R) + (hf : ∀ i, IsWeightedHomogeneous wt (f i) (wt i - 1)) (hwt : ∀ i, 1 ≤ wt i) + {p : MvPolynomial σ R} {w : ℕ} (hp : IsWeightedHomogeneous wt p w) : + IsWeightedHomogeneous wt (mkDerivation R f p) (w - 1) := by + induction hp using IsWeightedHomogeneous.induction_on with + | zero => rw [map_zero]; exact isWeightedHomogeneous_zero R wt _ + | add p q hp hq ihp ihq => rw [map_add]; exact ihp.add ihq + | monomial d r hr => + rw [mkDerivation_monomial, smul_eq_C_mul] + refine IsWeightedHomogeneous.C_mul ?_ r + unfold Finsupp.sum + refine IsWeightedHomogeneous.sum _ _ _ fun i hi ↦ ?_ + have hd := Finsupp.weight_sub_single_add (w := wt) (Finsupp.mem_support_iff.mp hi) + change IsWeightedHomogeneous wt (monomial (d - Finsupp.single i 1) (d i : R) • f i) (w - 1) + rw [smul_eq_mul] + have hw : w - 1 = Finsupp.weight wt (d - Finsupp.single i 1) + (wt i - 1) := by + have := hwt i + omega + rw [hw] + exact (isWeightedHomogeneous_monomial wt _ _ rfl).mul (hf i) + +/-- Such a derivation preserves "does not involve `x`" on polynomials whose variables all have +weight at most `wt x`. -/ +theorem mkDerivation_mem_supported (hwt : ∀ i, 1 ≤ wt i) (f : σ → MvPolynomial σ R) + (hf : ∀ i, IsWeightedHomogeneous wt (f i) (wt i - 1)) {x : σ} {p : MvPolynomial σ R} + (hp : p ∈ supported R {x}ᶜ) (hvars : ∀ i ∈ p.vars, wt i ≤ wt x) : + mkDerivation R f p ∈ supported R {x}ᶜ := by + have hs : {i | i ≠ x ∧ wt i ≤ wt x} ⊆ {x}ᶜ := fun i hi ↦ hi.1 + have hp' : p ∈ Algebra.adjoin R (X '' {i | i ≠ x ∧ wt i ≤ wt x}) := + mem_supported.mpr fun i hi ↦ ⟨(mem_supported.mp hp) hi, hvars i hi⟩ + clear hp hvars + induction hp' using Algebra.adjoin_induction with + | mem q hq => + obtain ⟨i, hi, rfl⟩ := hq + rw [mkDerivation_X] + exact (hf i).mem_supported_of_lt wt (by have := hwt x; have := hi.2; omega) + | algebraMap r => rw [Derivation.map_algebraMap]; exact zero_mem _ + | add a b _ _ ha hb => rw [map_add]; exact add_mem ha hb + | mul a b ha' hb' ha hb => + rw [Derivation.leibniz, smul_eq_mul, smul_eq_mul] + exact add_mem (mul_mem (supported_mono hs ha') hb) (mul_mem (supported_mono hs hb') ha) + +/-! ### The expansion in powers of one variable -/ + +variable (x : σ) + +/-- Polynomials in the variables other than `x` do not involve `x`. -/ +theorem rename_val_mem_supported (q : MvPolynomial {y // y ≠ x} R) : + rename Subtype.val q ∈ supported R {x}ᶜ := by + classical + rw [mem_supported] + intro y hy + obtain ⟨z, -, rfl⟩ := Finset.mem_image.mp (vars_rename _ _ hy) + exact z.2 + +theorem exists_rename_val_eq_of_mem_supported {a : MvPolynomial σ R} (ha : a ∈ supported R {x}ᶜ) : + ∃ q : MvPolynomial {y // y ≠ x} R, rename Subtype.val q = a := by + rw [supported_eq_range_rename] at ha + obtain ⟨q, hq⟩ := ha + exact ⟨q, hq⟩ + +variable [DecidableEq σ] + +/-- `MvPolynomial σ R` as polynomials in `X x` over the polynomials in the other variables. -/ +def expandEquiv : MvPolynomial σ R ≃ₐ[R] Polynomial (MvPolynomial {y // y ≠ x} R) := + (renameEquiv R (Equiv.optionSubtypeNe x).symm).trans (optionEquivLeft R _) + +theorem expandEquiv_rename_val (q : MvPolynomial {y // y ≠ x} R) : + expandEquiv x (rename Subtype.val q) = Polynomial.C q := by + rw [expandEquiv, AlgEquiv.trans_apply, renameEquiv_apply, rename_rename] + have : (Equiv.optionSubtypeNe x).symm ∘ Subtype.val = some := + funext fun y ↦ Equiv.optionSubtypeNe_symm_of_ne y.2 + rw [this] + induction q using MvPolynomial.induction_on with + | C r => rw [rename_C, optionEquivLeft_C] + | add p q hp hq => rw [map_add, map_add, hp, hq, Polynomial.C_add] + | mul_X p i hp => rw [map_mul, map_mul, hp, rename_X, optionEquivLeft_X_some, Polynomial.C_mul] + +theorem expandEquiv_symm_C (q : MvPolynomial {y // y ≠ x} R) : + (expandEquiv x).symm (Polynomial.C q) = rename Subtype.val q := by + rw [← expandEquiv_rename_val, AlgEquiv.symm_apply_apply] + +theorem expandEquiv_X_self : expandEquiv x (X x : MvPolynomial σ R) = Polynomial.X := by + rw [expandEquiv, AlgEquiv.trans_apply, renameEquiv_apply, rename_X, + Equiv.optionSubtypeNe_symm_self, optionEquivLeft_X_none] + +theorem expandEquiv_symm_X : (expandEquiv x).symm Polynomial.X = (X x : MvPolynomial σ R) := by + rw [← expandEquiv_X_self, AlgEquiv.symm_apply_apply] + +/-- The degree of the expansion is the degree in `x`. -/ +theorem natDegree_expandEquiv (p : MvPolynomial σ R) : + (expandEquiv x p).natDegree = p.degreeOf x := by + rw [expandEquiv, AlgEquiv.trans_apply, natDegree_optionEquivLeft, renameEquiv_apply] + have := degreeOf_rename_of_injective (Equiv.optionSubtypeNe x).symm.injective (p := p) x + rwa [Equiv.optionSubtypeNe_symm_self] at this + +/-- The coefficient of `X x ^ k`, read back as a polynomial in all the variables; it does not +involve `x`. -/ +def xCoeff (k : ℕ) : MvPolynomial σ R →ₗ[R] MvPolynomial σ R := + (rename (Subtype.val : {y // y ≠ x} → σ)).toLinearMap ∘ₗ + Polynomial.lcoeff (MvPolynomial {y // y ≠ x} R) k ∘ₗ (expandEquiv x).toLinearEquiv.toLinearMap + +theorem xCoeff_apply (k : ℕ) (p : MvPolynomial σ R) : + xCoeff x k p = rename Subtype.val ((expandEquiv x p).coeff k) := (rfl) + +theorem xCoeff_mem_supported (k : ℕ) (p : MvPolynomial σ R) : xCoeff x k p ∈ supported R {x}ᶜ := + rename_val_mem_supported x _ + +theorem coeff_xCoeff (k : ℕ) (p : MvPolynomial σ R) (m : σ →₀ ℕ) : + AddMonoidAlgebra.coeff (xCoeff x k p) m = if m x = 0 then AddMonoidAlgebra.coeff p (m + + Finsupp.single x k) else 0 := by + rw [xCoeff_apply] + split_ifs with hm + · have hsub : (m.support : Set σ) ⊆ Set.range (Subtype.val : {y // y ≠ x} → σ) := fun y hy ↦ + ⟨⟨y, fun h ↦ (Finsupp.mem_support_iff.mp hy) (h ▸ hm)⟩, rfl⟩ + conv_lhs => rw [← Finsupp.mapDomain_comapDomain Subtype.val Subtype.val_injective m hsub] + rw [coeff_rename_mapDomain _ Subtype.val_injective, expandEquiv, AlgEquiv.trans_apply, + optionEquivLeft_coeff_coeff, renameEquiv_apply, + ← coeff_rename_mapDomain _ (Equiv.optionSubtypeNe x).symm.injective] + congr 2 + ext (_ | y) + · rw [Finsupp.mapDomain_equiv_apply, Finsupp.optionElim_apply_none, Equiv.symm_symm, + Equiv.optionSubtypeNe_none, Finsupp.add_apply, Finsupp.single_eq_same, hm, zero_add] + · rw [Finsupp.mapDomain_equiv_apply, Equiv.symm_symm, Equiv.optionSubtypeNe_some, + Finsupp.optionElim_apply_some, Finsupp.add_apply, Finsupp.single_eq_of_ne y.2, + add_zero, Finsupp.comapDomain_apply] + · refine coeff_rename_eq_zero _ _ _ fun u hu ↦ (hm ?_).elim + rw [← hu, Finsupp.mapDomain_of_notMem_range] + rintro ⟨y, hy⟩ + exact y.2 hy + +/-- The coefficient of `X x ^ k` in `a * X x ^ d`, for `a` not involving `x`. -/ +theorem xCoeff_mul_X_pow {a : MvPolynomial σ R} (ha : a ∈ supported R {x}ᶜ) (k d : ℕ) : + xCoeff x k (a * X x ^ d) = if k = d then a else 0 := by + obtain ⟨q, rfl⟩ := exists_rename_val_eq_of_mem_supported x ha + rw [xCoeff_apply, map_mul, map_pow, expandEquiv_rename_val, expandEquiv_X_self, + Polynomial.coeff_C_mul_X_pow] + split_ifs <;> simp + +/-- The coefficients of an expansion in powers of `X x` whose coefficients do not involve `x`. -/ +theorem xCoeff_sum_mul_X_pow (s : Finset ℕ) {q : ℕ → MvPolynomial σ R} + (hq : ∀ d ∈ s, q d ∈ supported R {x}ᶜ) (k : ℕ) : + xCoeff x k (∑ d ∈ s, q d * X x ^ d) = if k ∈ s then q k else 0 := by + rw [map_sum, Finset.sum_congr rfl fun d hd ↦ xCoeff_mul_X_pow x (hq d hd) k d, Finset.sum_ite_eq] + +/-- Expansion of a polynomial in powers of `X x`. -/ +theorem sum_xCoeff_mul_X_pow (p : MvPolynomial σ R) : + ∑ d ∈ Finset.range (p.degreeOf x + 1), xCoeff x d p * X x ^ d = p := by + conv_rhs => rw [← (expandEquiv x).symm_apply_apply p, (expandEquiv x p).as_sum_range_C_mul_X_pow] + rw [map_sum, natDegree_expandEquiv] + refine Finset.sum_congr rfl fun d _ ↦ ?_ + rw [map_mul, map_pow, expandEquiv_symm_C, expandEquiv_symm_X, xCoeff_apply] + +theorem xCoeff_eq_zero_of_degreeOf_lt {p : MvPolynomial σ R} {k : ℕ} (h : p.degreeOf x < k) : + xCoeff x k p = 0 := by + rw [xCoeff_apply, Polynomial.coeff_eq_zero_of_natDegree_lt (by rwa [natDegree_expandEquiv]), + map_zero] + +/-- The leading coefficient in `X x` is nonzero. -/ +theorem xCoeff_degreeOf_ne_zero {p : MvPolynomial σ R} (hp : p ≠ 0) : + xCoeff x (p.degreeOf x) p ≠ 0 := by + rw [xCoeff_apply, ← natDegree_expandEquiv, ← Polynomial.leadingCoeff, + map_ne_zero_iff _ (rename_injective _ Subtype.val_injective), Polynomial.leadingCoeff_ne_zero] + exact (map_ne_zero_iff _ (expandEquiv x).injective).mpr hp + +theorem vars_xCoeff_subset (k : ℕ) (p : MvPolynomial σ R) : (xCoeff x k p).vars ⊆ p.vars := by + intro i hi + obtain ⟨m, hm, hmi⟩ := (mem_vars_iff_mem_support i).mp hi + have hc := mem_support_iff.mp hm + rw [coeff_xCoeff] at hc + split_ifs at hc with hmx + · refine (mem_vars_iff_mem_support i).mpr ⟨m + Finsupp.single x k, mem_support_iff.mpr hc, ?_⟩ + rw [Finsupp.mem_support_iff, Finsupp.add_apply] + have := Finsupp.mem_support_iff.mp hmi + omega + · exact absurd rfl hc + +/-- The coefficient of `X x ^ k` in a weighted-homogeneous polynomial of weight `w` is +weighted-homogeneous of weight `w - k · wt x`. -/ +theorem xCoeff_isWeightedHomogeneous {p : MvPolynomial σ R} {w : ℕ} + (hp : IsWeightedHomogeneous wt p w) (k : ℕ) : + IsWeightedHomogeneous wt (xCoeff x k p) (w - k * wt x) := by + intro m hm + rw [coeff_xCoeff] at hm + split_ifs at hm with h + · have := hp hm + rw [map_add, Finsupp.weight_single, smul_eq_mul] at this + omega + · exact absurd rfl hm + +/-- A nonzero coefficient of `X x ^ k` in a weighted-homogeneous polynomial of weight `w` forces +`k · wt x ≤ w`. -/ +theorem le_of_xCoeff_ne_zero {p : MvPolynomial σ R} {w : ℕ} (hp : IsWeightedHomogeneous wt p w) + {k : ℕ} (h : xCoeff x k p ≠ 0) : k * wt x ≤ w := by + obtain ⟨m, hm⟩ := exists_coeff_ne_zero h + rw [coeff_xCoeff] at hm + split_ifs at hm with hmx + · have := hp hm + rw [map_add, Finsupp.weight_single, smul_eq_mul] at this + omega + · exact absurd rfl hm + +end MvPolynomial diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/MvPolynomial/FinitePartDecomposition.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/MvPolynomial/FinitePartDecomposition.lean new file mode 100644 index 0000000000..ea395e5059 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/MvPolynomial/FinitePartDecomposition.lean @@ -0,0 +1,126 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.GradedRing.HomogeneousSpan +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MvPolynomial.FinitePartErasure + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint + +/-! +# A weighted-homogeneous polynomial in the ideal of selected partial derivatives + +Suppose `F` is weighted homogeneous of degree `δ`, the coefficient `n` of `1 = ω^0` in the Cantor +normal form of `δ` is positive, and `F` lies in the ideal generated by the partial derivatives at +variables whose weights have constant Cantor coefficient `n`. Then + +`F = ∑_t (∂F/∂X_t) (X_t + V_t)`, + +where each `V_t` is weighted homogeneous of degree `wt t` and contains no variable whose weight has +constant Cantor coefficient `n`. + +Homogeneous ideal membership supplies the cofactors. Setting the selected variables to zero in +each cofactor gives the polynomials `V_t`; the polynomial identity in +`FinitePartErasure` then supplies the terms `X_t`. +-/ + +universe u v + +open scoped NatOrdinal + +open OrdinalGraded + +public noncomputable section + +namespace MvPolynomial + +variable {σ : Type u} {K : Type v} [Field K] {wt : σ → NatOrdinal} + +/-- Decompose a weighted-homogeneous polynomial that belongs to the ideal generated by the partial +derivatives at variables carrying its positive constant Cantor coefficient. -/ +@[blueprint "lem:successor-relation-decomposition" + (phase := "Algebraic and ordinal preliminaries") + (title := "Partial-derivative decomposition of a homogeneous ideal relation") + (statement := /-- + Let $F$ be weighted homogeneous of degree $\delta$, and let $n>0$ be the + coefficient of $1=\omega^0$ in the Cantor normal form of $\delta$. Suppose + \[ + F\in\bigl(\partial_iF:i\in\operatorname{vars}(F),\ + \operatorname{coeff}_{\omega^0}(\operatorname{wt}(i))=n\bigr). + \] + Then there are weighted-homogeneous polynomials $V_i$ of degree + $\operatorname{wt}(i)$, involving no variable whose weight has constant + Cantor coefficient $n$, such that + \[ + F=\sum_{\substack{i\in\operatorname{vars}(F)\\ + \operatorname{coeff}_{\omega^0}(\operatorname{wt}(i))=n}} + \frac{\partial F}{\partial X_i}(X_i+V_i). + \] + -/) + (proof := /-- + By \ref{lem:homogeneous-element-of-generated-ideal}, homogeneous ideal + membership writes $F=\sum_i(\partial_iF)U_i$, with $U_i$ weighted homogeneous + of degree $\operatorname{wt}(i)$. Let $V_i$ be obtained from $U_i$ by setting + to zero every variable whose weight has constant Cantor coefficient $n$. + Applying the same substitution to the displayed ideal identity and combining + it with \ref{lem:relation-shape} gives the required formula. + -/)] +theorem exists_eq_sum_pderiv_mul_X_add_of_mem_span {δ : NatOrdinal} + (hδ : 0 < δ.constantCoeff) {F : MvPolynomial σ K} (hF : IsWeightedHomogeneous wt F δ) + (hFI : F ∈ Ideal.span ((fun t ↦ pderiv t F) '' (varsOfFinitePart wt F δ : Set σ))) : + ∃ V : σ → MvPolynomial σ K, + (∀ t ∈ varsOfFinitePart wt F δ, IsWeightedHomogeneous wt (V t) (wt t) ∧ + V t ∈ supported K {i | (wt i).constantCoeff ≠ δ.constantCoeff}) ∧ + F = ∑ t ∈ varsOfFinitePart wt F δ, pderiv t F * (X t + V t) := by + classical + let := weightedGradedAlgebra K wt + -- naming the index set keeps later rewrites from reaching inside it + set T := varsOfFinitePart wt F δ with hT + have hmemT : ∀ t : ↥T, (t : σ) ∈ F.vars ∧ (wt t).constantCoeff = δ.constantCoeff := fun t ↦ + mem_varsOfFinitePart_iff.mp (hT ▸ t.2) + obtain ⟨lam, hlam⟩ : ∃ lam : ↥T → NatOrdinal, ∀ t, lam t + wt t = δ := + ⟨_, fun t ↦ (exists_add_wt_eq_of_mem_vars hF (hmemT t).1).choose_spec⟩ + -- `F = ∑_t (∂F/∂X_t) U_t` with `U_t` homogeneous of degree `wt t` + have hFI' : F ∈ Ideal.span (Set.range fun t : ↥T ↦ pderiv (t : σ) F) := by + rwa [Set.image_eq_range] at hFI + obtain ⟨U, hU, -, hFU⟩ := exists_eq_sum_mul_of_mem_span + (𝒜 := weightedHomogeneousSubmodule K wt) + (q := fun t : ↥T ↦ pderiv (t : σ) F) (c := lam) + (fun t ↦ (mem_weightedHomogeneousSubmodule _ _ _ _).mpr + (isWeightedHomogeneous_pderiv_of_add_wt_eq hF (hlam t))) + ((mem_weightedHomogeneousSubmodule _ _ _ _).mpr hF) hFI' + have hUt : ∀ t : ↥T, IsWeightedHomogeneous wt (U t) (wt t) := fun t ↦ + (mem_weightedHomogeneousSubmodule _ _ _ _).mp (hU t (wt t) (by rw [add_comm]; exact hlam t)) + -- the partial derivatives are already free of the variables carrying the finite part + have hc : ∀ t : ↥T, eraseFinitePart wt δ.constantCoeff (pderiv (t : σ) F) = + pderiv (t : σ) F := fun t ↦ + eraseFinitePart_eq_self wt δ.constantCoeff fun i hi ↦ by + rw [constantCoeff_wt_eq_zero_of_mem_vars (isWeightedHomogeneous_pderiv_of_add_wt_eq hF + (hlam t)) (NatOrdinal.constantCoeff_eq_zero_of_add_eq (hmemT t).2 (hlam t)) hi] + exact hδ.ne + have hκF : eraseFinitePart wt δ.constantCoeff F = + ∑ t : ↥T, pderiv (t : σ) F * eraseFinitePart wt δ.constantCoeff (U t) := by + conv_lhs => rw [hFU] + rw [map_sum] + exact Finset.sum_congr rfl fun t _ ↦ by rw [map_mul, hc] + refine ⟨fun t ↦ if h : t ∈ T then eraseFinitePart wt δ.constantCoeff (U ⟨t, h⟩) else 0, + fun t ht ↦ ?_, ?_⟩ + · beta_reduce + rw [dite_eq_left ht] + exact ⟨isWeightedHomogeneous_eraseFinitePart wt _ (hUt ⟨t, ht⟩), + eraseFinitePart_mem_supported wt _ _⟩ + · have hshape := eraseFinitePart_add_sum_X_mul_pderiv hδ hF + rw [← hT, hκF, ← Finset.sum_coe_sort T] at hshape + rw [← Finset.sum_coe_sort T] + conv_lhs => rw [← hshape] + rw [← Finset.sum_add_distrib] + refine Finset.sum_congr rfl fun t _ ↦ ?_ + beta_reduce + rw [dite_eq_left t.2, mul_add, mul_comm (X (t : σ)), add_comm] + +end MvPolynomial + +end diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/MvPolynomial/FinitePartErasure.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/MvPolynomial/FinitePartErasure.lean new file mode 100644 index 0000000000..b08c88097e --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/MvPolynomial/FinitePartErasure.lean @@ -0,0 +1,200 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint +public import Mathlib.Algebra.MvPolynomial.Supported +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MvPolynomial.FinitePartVars + +/-! +# Erasing variables with a fixed constant Cantor coefficient + +Setting `X_i` to zero whenever the coefficient of `1 = ω^0` in the Cantor normal form of its weight +is `k` defines the algebra map `eraseFinitePart wt k`. It preserves weighted homogeneity and its +image contains none of those variables. + +Its defect from the identity is exactly the monomials the successor step needs to see. In a +monomial whose degree `δ` has positive constant Cantor coefficient `n`, a variable with constant +Cantor coefficient `n` occupies the whole coefficient on its own: it occurs to the first power, +and no other such variable occurs beside it. This gives the identity + +`F' + ∑_i X_i ∂F/∂X_i = F`, + +the sum over the variables of `F` carrying the finite part. + +Nothing here depends on where the variables are evaluated, so both the real-exponent development +and the Cantor–Bendixson germ argument use it unchanged. +-/ + +universe u v + +open scoped NatOrdinal + +public noncomputable section + +namespace Finsupp + +variable {ι : Type u} {wt : ι → NatOrdinal} + +/-- In a monomial whose degree `δ` has positive constant Cantor coefficient `n`, a variable whose +weight has constant Cantor coefficient `n` occurs with multiplicity one, and no other such variable +occurs. -/ +theorem eq_one_and_eq_zero_of_constantCoeff_eq {d : ι →₀ ℕ} {δ : NatOrdinal} + (hδ : 0 < δ.constantCoeff) (hd : Finsupp.weight wt d = δ) {i : ι} (hi : i ∈ d.support) + (hik : (wt i).constantCoeff = δ.constantCoeff) : + d i = 1 ∧ ∀ j, j ≠ i → (wt j).constantCoeff = δ.constantCoeff → d j = 0 := by + classical + have hsum : ∑ j ∈ d.support, d j * (wt j).constantCoeff = δ.constantCoeff := by + rw [← Finsupp.constantCoeff_weight, hd] + have hterm : ∀ j ∈ d.support, d j * (wt j).constantCoeff ≤ δ.constantCoeff := fun j hj ↦ + hsum ▸ Finset.single_le_sum (f := fun j ↦ d j * (wt j).constantCoeff) + (fun _ _ ↦ Nat.zero_le _) hj + have hdi : d i = 1 := by + have h1 := hterm i hi + rw [hik] at h1 + have h2 : 1 ≤ d i := Nat.one_le_iff_ne_zero.mpr (Finsupp.mem_support_iff.mp hi) + nlinarith + refine ⟨hdi, fun j hji hjk ↦ ?_⟩ + by_contra hdj + have hj : j ∈ d.support := Finsupp.mem_support_iff.mpr hdj + -- two distinct variables carrying the finite part would contribute at least twice it + have h2 : d i * (wt i).constantCoeff + d j * (wt j).constantCoeff ≤ δ.constantCoeff := by + rw [← hsum] + exact Finset.add_le_sum (f := fun j ↦ d j * (wt j).constantCoeff) + (fun _ _ ↦ Nat.zero_le _) hi hj hji.symm + rw [hdi, one_mul, hik, hjk] at h2 + have h3 : 1 ≤ d j := Nat.one_le_iff_ne_zero.mpr hdj + nlinarith + +end Finsupp + +namespace MvPolynomial + +variable {σ : Type u} {R : Type v} [CommRing R] (wt : σ → NatOrdinal) (k : ℕ) + +/-- Set `X_i` to zero when the constant Cantor coefficient of its weight is `k`. -/ +def eraseFinitePart : MvPolynomial σ R →ₐ[R] MvPolynomial σ R := + aeval fun i ↦ if (wt i).constantCoeff = k then 0 else X i + +theorem eraseFinitePart_X {i : σ} : + eraseFinitePart (R := R) wt k (X i) = if (wt i).constantCoeff = k then 0 else X i := by + rw [eraseFinitePart, aeval_X] + +theorem eraseFinitePart_monomial (d : σ →₀ ℕ) (r : R) : + eraseFinitePart wt k (monomial d r) = + if ∃ i ∈ d.support, (wt i).constantCoeff = k then 0 else monomial d r := by + classical + rw [eraseFinitePart, aeval_monomial] + split_ifs with h + · obtain ⟨i, hi, hik⟩ := h + rw [Finsupp.prod, Finset.prod_eq_zero hi (by + rw [ite_eq_left hik, zero_pow (Finsupp.mem_support_iff.mp hi)]), mul_zero] + · rw [monomial_eq, algebraMap_eq] + congr 1 + refine Finset.prod_congr rfl fun i hi ↦ ?_ + beta_reduce + rw [ite_eq_right fun hik ↦ h ⟨i, hi, hik⟩] + +/-- The substitution fixes a polynomial none of whose variable weights has constant Cantor +coefficient `k`. -/ +theorem eraseFinitePart_eq_self {G : MvPolynomial σ R} + (hG : ∀ i ∈ G.vars, (wt i).constantCoeff ≠ k) : + eraseFinitePart wt k G = G := by + classical + conv_rhs => rw [G.as_sum] + conv_lhs => rw [G.as_sum, map_sum] + refine Finset.sum_congr rfl fun d hd ↦ ?_ + rw [eraseFinitePart_monomial, ite_eq_right] + rintro ⟨i, hi, hik⟩ + exact hG i ((mem_vars_iff_mem_support i).mpr ⟨d, hd, hi⟩) hik + +/-- The substitution preserves homogeneity of any degree. -/ +theorem isWeightedHomogeneous_eraseFinitePart {G : MvPolynomial σ R} {β : NatOrdinal} + (hG : IsWeightedHomogeneous wt G β) : IsWeightedHomogeneous wt (eraseFinitePart wt k G) β := by + classical + induction hG using IsWeightedHomogeneous.induction_on with + | zero => rw [map_zero]; exact isWeightedHomogeneous_zero R wt β + | add p q _ _ ihp ihq => rw [map_add]; exact ihp.add ihq + | monomial d r hd => + rw [eraseFinitePart_monomial] + split_ifs + · exact isWeightedHomogeneous_zero R wt β + · exact isWeightedHomogeneous_monomial wt d r hd + +/-- The image contains no variable whose weight has constant Cantor coefficient `k`. -/ +theorem eraseFinitePart_mem_supported [Nontrivial R] (G : MvPolynomial σ R) : + eraseFinitePart wt k G ∈ supported R {i | (wt i).constantCoeff ≠ k} := by + classical + induction G using MvPolynomial.induction_on with + | C r => rw [← algebraMap_eq, AlgHom.commutes]; exact Subalgebra.algebraMap_mem _ r + | add p q hp hq => rw [map_add]; exact add_mem hp hq + | mul_X p i ih => + rw [map_mul, eraseFinitePart_X] + split_ifs with hi + · rw [mul_zero]; exact zero_mem _ + · exact mul_mem ih ((X_mem_supported (R := R)).mpr hi) + +variable {wt k} + +/-- Decomposition of a weighted-homogeneous polynomial using the variables whose weights have the +same positive constant Cantor coefficient as its degree. -/ +@[blueprint "lem:relation-shape" + (phase := "Algebraic and ordinal preliminaries") + (title := "Weighted Euler decomposition at the $\\omega^0$ coefficient") + (statement := /-- + Let $F$ be weighted homogeneous of degree $\delta$, and let $n>0$ be the + coefficient of $1=\omega^0$ in the Cantor normal form of $\delta$. Then + \[ + F_0+\sum_{\substack{i\in\operatorname{vars}(F)\\ + \operatorname{coeff}_{\omega^0}(\operatorname{wt}(i))=n}} + X_i\,\frac{\partial F}{\partial X_i}=F, + \] + where $F_0$ is obtained by setting precisely those variables to zero. + -/) + (proof := /-- + Expand $F$ into monomials. If a monomial contains a variable whose weight has + constant Cantor coefficient $n$, additivity of that coefficient under + Hessenberg sum shows that the variable occurs exactly once and all other + variable weights have constant Cantor coefficient zero. Otherwise the + monomial is fixed by the substitution. Summing over the monomials gives the + formula. + -/)] +theorem eraseFinitePart_add_sum_X_mul_pderiv {F : MvPolynomial σ R} {δ : NatOrdinal} + (hδ : 0 < δ.constantCoeff) (hF : IsWeightedHomogeneous wt F δ) : + eraseFinitePart wt δ.constantCoeff F + ∑ t ∈ varsOfFinitePart wt F δ, X t * pderiv t F = F := by + classical + -- naming the index set keeps the `as_sum` rewrite from reaching inside it + set T := varsOfFinitePart wt F δ with hT + conv_rhs => rw [F.as_sum] + conv_lhs => rw [F.as_sum, map_sum] + simp only [map_sum, Finset.mul_sum] + rw [Finset.sum_comm, ← Finset.sum_add_distrib] + refine Finset.sum_congr rfl fun d hd ↦ ?_ + have hwd : Finsupp.weight wt d = δ := hF (mem_support_iff.mp hd) + simp only [X_mul_pderiv_monomial, eraseFinitePart_monomial] + split_ifs with h + · obtain ⟨i, hi, hik⟩ := h + obtain ⟨hdi, hdj⟩ := Finsupp.eq_one_and_eq_zero_of_constantCoeff_eq hδ hwd hi hik + have hiT : i ∈ T := by + rw [hT] + exact mem_varsOfFinitePart_iff.mpr ⟨(mem_vars_iff_mem_support i).mpr ⟨d, hd, hi⟩, hik⟩ + rw [zero_add, Finset.sum_eq_single i] + · rw [hdi, one_smul] + · intro t ht hti + rw [hdj t hti (mem_varsOfFinitePart_iff.mp (hT ▸ ht)).2, zero_smul] + · intro hno + exact absurd hiT hno + · rw [Finset.sum_eq_zero, add_zero] + intro t ht + have hdt : d t = 0 := by + by_contra hdt + exact h ⟨t, Finsupp.mem_support_iff.mpr hdt, (mem_varsOfFinitePart_iff.mp (hT ▸ ht)).2⟩ + rw [hdt, zero_smul] + +end MvPolynomial + +end diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/MvPolynomial/FinitePartVars.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/MvPolynomial/FinitePartVars.lean new file mode 100644 index 0000000000..9d3ae1f104 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/MvPolynomial/FinitePartVars.lean @@ -0,0 +1,112 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MvPolynomial.OrdinalDerivation + +/-! +# Variables carrying the constant Cantor coefficient of a weighted degree + +The coefficient of `1 = ω^0` in the Cantor normal form of the degree of a monomial is the sum of +the corresponding coefficients of the degrees of its variables. Thus, in a polynomial homogeneous +of degree `δ`, a variable whose degree has the same constant Cantor coefficient as `δ` carries that +coefficient on its own. + +This module collects the elementary degree facts about those variables and the finite set +`varsOfFinitePart` that contains them. + +None of it depends on where the variables are evaluated. Both the real-exponent argument and the +Cantor–Bendixson germ argument need these statements, so they are stated once here over an +arbitrary commutative ring. +-/ + +universe u v + +open scoped NatOrdinal + +public section + +namespace NatOrdinal + +/-- If `b + a = c` and `a` and `c` have the same constant Cantor coefficient, then `b` has +constant Cantor coefficient zero. -/ +theorem constantCoeff_eq_zero_of_add_eq {a b c : NatOrdinal.{u}} + (ha : a.constantCoeff = c.constantCoeff) (h : b + a = c) : b.constantCoeff = 0 := by + have hc := congrArg NatOrdinal.constantCoeff h + rw [constantCoeff_add, ha] at hc + omega + +end NatOrdinal + +namespace MvPolynomial + +variable {σ : Type u} {R : Type v} [CommRing R] {wt : σ → NatOrdinal} + +/-- The constant Cantor coefficient of the degree of a variable of a homogeneous polynomial is at +most that of the degree of the polynomial. -/ +theorem constantCoeff_wt_le_of_mem_vars {F : MvPolynomial σ R} {δ : NatOrdinal} + (hF : IsWeightedHomogeneous wt F δ) {i : σ} (hi : i ∈ F.vars) : + (wt i).constantCoeff ≤ δ.constantCoeff := by + classical + obtain ⟨d, hd, hdi⟩ := (mem_vars_iff_mem_support i).mp hi + rw [← hF (mem_support_iff.mp hd), Finsupp.constantCoeff_weight] + calc (wt i).constantCoeff ≤ d i * (wt i).constantCoeff := + Nat.le_mul_of_pos_left _ (Nat.pos_of_ne_zero (Finsupp.mem_support_iff.mp hdi)) + _ ≤ _ := Finset.single_le_sum (f := fun i ↦ d i * (wt i).constantCoeff) + (fun _ _ ↦ Nat.zero_le _) hdi + +/-- The degree of a variable `X_i` in a homogeneous polynomial of degree `δ` precedes `δ` in the +algebraic order: there is `β` with `β + wt i = δ`. -/ +theorem exists_add_wt_eq_of_mem_vars {F : MvPolynomial σ R} {δ : NatOrdinal} + (hF : IsWeightedHomogeneous wt F δ) {i : σ} (hi : i ∈ F.vars) : ∃ β, β + wt i = δ := by + classical + obtain ⟨d, hd, hdi⟩ := (mem_vars_iff_mem_support i).mp hi + exact ⟨_, (Finsupp.weight_sub_single_add (w := wt) (Finsupp.mem_support_iff.mp hdi)).trans + (hF (mem_support_iff.mp hd))⟩ + +/-- If the degree of a homogeneous polynomial has constant Cantor coefficient zero, so does the +degree of each of its variables. -/ +theorem constantCoeff_wt_eq_zero_of_mem_vars {G : MvPolynomial σ R} {lam : NatOrdinal} + (hG : IsWeightedHomogeneous wt G lam) (hlam : lam.constantCoeff = 0) {i : σ} + (hi : i ∈ G.vars) : (wt i).constantCoeff = 0 := + Nat.eq_zero_of_le_zero ((constantCoeff_wt_le_of_mem_vars hG hi).trans hlam.le) + +/-- For `F` homogeneous of degree `δ` and `β + wt t = δ`, the partial derivative `∂F/∂X_t` is +homogeneous of degree `β`. -/ +theorem isWeightedHomogeneous_pderiv_of_add_wt_eq {F : MvPolynomial σ R} {δ : NatOrdinal} + (hF : IsWeightedHomogeneous wt F δ) {t : σ} {β : NatOrdinal} (hβ : β + wt t = δ) : + IsWeightedHomogeneous wt (pderiv t F) β := + isWeightedHomogeneous_pderiv wt hF t hβ + +/-- A homogeneous polynomial of nonzero degree has zero constant coefficient. -/ +theorem coeff_zero_eq_zero_of_isWeightedHomogeneous {p : MvPolynomial σ R} {β : NatOrdinal} + (hp : IsWeightedHomogeneous wt p β) (hβ : β ≠ 0) : AddMonoidAlgebra.coeff p 0 = 0 := by + by_contra h + exact hβ ((hp h).symm.trans (map_zero _)) + +/-- A polynomial whose variable degrees have constant Cantor coefficient zero has no homogeneous +component whose degree has nonzero constant Cantor coefficient. -/ +theorem weightedHomogeneousComponent_eq_zero_of_forall_vars {G : MvPolynomial σ R} + (hG : ∀ i ∈ G.vars, (wt i).constantCoeff = 0) {β : NatOrdinal} (hβ : β.constantCoeff ≠ 0) : + weightedHomogeneousComponent wt β G = 0 := by + classical + refine weightedHomogeneousComponent_eq_zero' β G fun d hd hw ↦ hβ ?_ + rw [← hw, Finsupp.constantCoeff_weight] + exact Finset.sum_eq_zero fun i hi ↦ by + rw [hG i ((mem_vars_iff_mem_support i).mpr ⟨d, hd, hi⟩), mul_zero] + +variable (wt) in +/-- The variables of `F` whose degrees have the same constant Cantor coefficient as `δ`. -/ +noncomputable def varsOfFinitePart (F : MvPolynomial σ R) (δ : NatOrdinal) : Finset σ := + F.vars.filter fun i ↦ (wt i).constantCoeff = δ.constantCoeff + +theorem mem_varsOfFinitePart_iff {F : MvPolynomial σ R} {δ : NatOrdinal} {i : σ} : + i ∈ varsOfFinitePart wt F δ ↔ i ∈ F.vars ∧ (wt i).constantCoeff = δ.constantCoeff := by + rw [varsOfFinitePart, Finset.mem_filter] + +end MvPolynomial + +end diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/MvPolynomial/GCDMonoid.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/MvPolynomial/GCDMonoid.lean new file mode 100644 index 0000000000..612e5c719e --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/MvPolynomial/GCDMonoid.lean @@ -0,0 +1,190 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import Mathlib.Algebra.GCDMonoid.Basic +public import Mathlib.Algebra.MvPolynomial.CommRing + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint +import Mathlib.Algebra.MvPolynomial.NoZeroDivisors +import Mathlib.RingTheory.Polynomial.Basic +import Mathlib.RingTheory.Polynomial.Content + +/-! +# Greatest common divisors in multivariate polynomial rings + +A polynomial ring in an arbitrary type of variables over a normalized GCD domain is a GCD +domain. Each pair of polynomials uses only finitely many variables. Mathlib's univariate +polynomial GCD structure gives a GCD in that finite-variable ring. Splitting off the remaining +variables and applying `MvPolynomial.dvd_C_iff_exists` shows that the same element remains a GCD +in the full polynomial ring. + +Gilmer and Parker (1974), Corollary 4.5 gives the classical result for an arbitrary GCD +coefficient domain. The theorem here assumes a normalized GCD structure, which is the form used +by Mathlib's univariate content theory and is sufficient for the finite-support Hahn-series ring. + +The result is stated through `Nonempty (GCDMonoid R)` because `GCDMonoid` contains a choice of +greatest common divisors rather than a proposition alone. +-/ + +public noncomputable section + +universe u v + +variable {A B : Type*} +variable [CommMonoidWithZero A] [CommMonoidWithZero B] + +private theorem existsGCD_pullback (e : A ≃* B) + (h : ∀ a b : B, ∃ c : B, ∀ d : B, d ∣ a ∧ d ∣ b ↔ d ∣ c) : + ∀ a b : A, ∃ c : A, ∀ d : A, d ∣ a ∧ d ∣ b ↔ d ∣ c := by + intro a b + obtain ⟨c, hc⟩ := h (e a) (e b) + refine ⟨e.symm c, fun d ↦ ?_⟩ + simpa only [← map_dvd_iff e, e.apply_symm_apply] using hc (e d) + +/-- The existence of greatest common divisors transfers across a multiplicative equivalence. -/ +theorem MulEquiv.nonemptyGCDMonoid (e : A ≃* B) [IsCancelMulZero A] + [Nonempty (GCDMonoid B)] : Nonempty (GCDMonoid A) := by + classical + let : GCDMonoid B := Classical.choice inferInstance + exact ⟨gcdMonoidOfExistsGCD (existsGCD_pullback e fun a b ↦ + ⟨gcd a b, fun d ↦ (dvd_gcd_iff d a b).symm⟩)⟩ + +@[implicit_reducible] +private noncomputable def pullbackNormalizationMonoid (e : A ≃* B) + [NormalizationMonoid B] : NormalizationMonoid A where + normUnit a := Units.map e.symm.toMonoidHom (normUnit (e a)) + normUnit_zero := by simp + normUnit_one := by simp + normUnit_mul_units {a} u ha := by + apply Units.ext + have he : e a ≠ 0 := by simpa using ha + change e.symm ↑(normUnit (e (a * ↑u))) = + ↑(u⁻¹ * Units.map e.symm.toMonoidHom (normUnit (e a))) + rw [map_mul, show e ↑u = ↑(Units.map e.toMonoidHom u) from rfl, + normUnit_mul_units _ he] + simp + +@[implicit_reducible] +private noncomputable def pullbackNormalizedGCDMonoid (e : A ≃* B) + [IsCancelMulZero A] [NormalizedGCDMonoid B] : NormalizedGCDMonoid A := by + classical + letI : NormalizationMonoid A := pullbackNormalizationMonoid e + exact normalizedGCDMonoidOfExistsGCD (existsGCD_pullback e fun a b ↦ + ⟨gcd a b, fun d ↦ (dvd_gcd_iff d a b).symm⟩) + +namespace MvPolynomial + +variable {R : Type u} {σ : Type v} +variable [CommRing R] [IsDomain R] + +@[implicit_reducible] +private noncomputable def normalizedGCDMonoidFin [NormalizedGCDMonoid R] : + (n : ℕ) → NormalizedGCDMonoid (MvPolynomial (Fin n) R) + | 0 => pullbackNormalizedGCDMonoid (isEmptyRingEquiv R (Fin 0)).toMulEquiv + | n + 1 => by + letI : NormalizedGCDMonoid (MvPolynomial (Fin n) R) := normalizedGCDMonoidFin n + exact pullbackNormalizedGCDMonoid (finSuccEquiv R n).toMulEquiv + +@[implicit_reducible] +private noncomputable def normalizedGCDMonoidOfFinite [NormalizedGCDMonoid R] + (τ : Type v) [Finite τ] : NormalizedGCDMonoid (MvPolynomial τ R) := by + letI := Fintype.ofFinite τ + letI : NormalizedGCDMonoid (MvPolynomial (Fin (Fintype.card τ)) R) := + normalizedGCDMonoidFin (Fintype.card τ) + exact pullbackNormalizedGCDMonoid + (renameEquiv R (Fintype.equivFin τ)).toMulEquiv + +private noncomputable def adjoiningVariablesEquiv (S : Set σ) : + MvPolynomial (↥(Sᶜ : Set σ)) (MvPolynomial S R) ≃ₐ[R] MvPolynomial σ R := by + classical + exact (sumAlgEquiv R (↥(Sᶜ : Set σ)) S).symm.trans + (renameEquiv R + ((Equiv.sumComm (↥(Sᶜ : Set σ)) S).trans (Equiv.Set.sumCompl S))) + +omit [IsDomain R] in +private theorem adjoiningVariablesEquiv_C (S : Set σ) (p : MvPolynomial S R) : + adjoiningVariablesEquiv S (C p) = rename ((↑) : S → σ) p := by + let eqv := adjoiningVariablesEquiv (R := R) S + have h : (rename ((↑) : S → σ)).toRingHom = + eqv.toAlgHom.toRingHom.comp C := by + apply ringHom_ext + · intro r + simp [eqv, adjoiningVariablesEquiv] + · intro i + simp [eqv, adjoiningVariablesEquiv] + exact (DFunLike.congr_fun h p).symm + +private theorem existsGCD [NormalizedGCDMonoid R] (a b : MvPolynomial σ R) : + ∃ c : MvPolynomial σ R, ∀ d : MvPolynomial σ R, d ∣ a ∧ d ∣ b ↔ d ∣ c := by + classical + obtain ⟨s, p, q, rfl, rfl⟩ := exists_finset_rename₂ a b + let : NormalizedGCDMonoid (MvPolynomial s R) := normalizedGCDMonoidOfFinite s + let S : Set σ := s + let E := adjoiningVariablesEquiv (R := R) S + have hrename (f : MvPolynomial s R) : E (C f) = rename ((↑) : s → σ) f := + adjoiningVariablesEquiv_C S f + refine ⟨rename ((↑) : s → σ) (gcd p q), fun e ↦ ?_⟩ + constructor + · rintro ⟨hep, heq⟩ + by_cases hp : p = 0 + · by_cases hq : q = 0 + · subst p + subst q + simp + · have heq' : E.symm e ∣ C q := by + rw [← map_dvd_iff E, E.apply_symm_apply, hrename q] + exact heq + obtain ⟨c, hcq, hec⟩ := (dvd_C_iff_exists hq).mp heq' + have hcp : c ∣ p := by simp [hp] + have hcd : c ∣ gcd p q := dvd_gcd hcp hcq + rw [← hrename (gcd p q), ← E.apply_symm_apply e, map_dvd_iff E, hec] + exact map_dvd C hcd + · have hep' : E.symm e ∣ C p := by + rw [← map_dvd_iff E, E.apply_symm_apply, hrename p] + exact hep + obtain ⟨c, hcp, hec⟩ := (dvd_C_iff_exists hp).mp hep' + have heq' : E.symm e ∣ C q := by + rw [← map_dvd_iff E, E.apply_symm_apply, hrename q] + exact heq + rw [hec] at heq' + have hcq : c ∣ q := by + rw [C_dvd_iff_dvd_coeff] at heq' + simpa using heq' 0 + have hcd : c ∣ gcd p q := dvd_gcd hcp hcq + rw [← hrename (gcd p q), ← E.apply_symm_apply e, map_dvd_iff E, hec] + exact map_dvd C hcd + · intro he + exact ⟨he.trans (map_dvd (rename ((↑) : s → σ)) (gcd_dvd_left p q)), + he.trans (map_dvd (rename ((↑) : s → σ)) (gcd_dvd_right p q))⟩ + +/-- A polynomial ring in an arbitrary type of variables over a normalized GCD domain has +greatest common divisors. -/ +@[blueprint "lem:multivariate-polynomial-gcd" + (phase := "Algebraic and ordinal preliminaries") + (title := "Greatest common divisors in multivariate polynomial rings") + (statement := /-- + Let $R$ be a commutative domain admitting a normalized GCD structure, and + let $I$ be any type. Then $R[X_i:i\in I]$ admits greatest common divisors. + -/) + (proof := /-- + A pair of polynomials involves only finitely many variables. Regard their + finite-variable ring as an iterated univariate polynomial ring and choose a + greatest common divisor there. View the full ring as the polynomial ring in + the complementary variables over this finite-variable ring. If at least one + of the original polynomials is non-zero, a common divisor of their constant + images is associated to a constant polynomial; its coefficient divides both + finite-variable polynomials and hence their greatest common divisor. The + case where both polynomials vanish is immediate. Thus the finite-variable + greatest common divisor remains one in the full polynomial ring. + -/)] +theorem nonemptyGCDMonoid [Nonempty (NormalizedGCDMonoid R)] : + Nonempty (GCDMonoid (MvPolynomial σ R)) := by + classical + let : NormalizedGCDMonoid R := Classical.choice inferInstance + exact ⟨gcdMonoidOfExistsGCD existsGCD⟩ + +end MvPolynomial diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/MvPolynomial/LimitOrdinalContradiction.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/MvPolynomial/LimitOrdinalContradiction.lean new file mode 100644 index 0000000000..174f1449e2 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/MvPolynomial/LimitOrdinalContradiction.lean @@ -0,0 +1,625 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MvPolynomial.RemainderBound +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MvPolynomial.MapWeight +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.Split +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.PairBounds + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint + +/-! +# The contradiction when the degree is a limit ordinal + +The limit step of the injectivity induction ends in a purely polynomial argument, and this file +isolates it from the analysis that supplies its hypotheses. + +Fix ordinal degrees `wt` for the variables, a cutoff exponent `β`, and write `a_{<β}` for the part +of `a` below `ω^β` (Lean `NatOrdinal.partLT β a`). Let `F` be homogeneous of degree `α`, let `B₀` +be a variable occurring in `F` to degree at most one with `(wt B₀)_{<β} = α_{<β}`, and set +`H := ∂F/∂X_{B₀}`. + +Then every variable of `H` has vanishing part below `ω^β` +(`partLT_eq_zero_of_mem_vars_pderiv`), because the parts below `ω^β` of a monomial of `F` add up +to `α_{<β}`, all of which is already used by the single occurrence of `X_{B₀}`. In characteristic +zero this makes the classification of variables by their parts below `ω^β` cut `H` off from every +variable with a nonzero part: `pderiv_eq_zero_of_partLT_ne_zero`. + +The contradiction (`false_of_pderiv_eq_sum_of_partLT_ne_zero`) follows: some variable `B'` of `H` +has `∂H/∂X_{B'} ≠ 0`, and `B'` has vanishing part below `ω^β`. Hence +`0 + lam₀ = lam₀`, so the assumed derivative identity applies at `B'`. It writes +`∂F/∂X_{B'} = ∑_B (∂F/∂X_B) U_B` over variables `B` with nonzero part below `ω^β` and with +`∂U_B/∂X_{B₀} = 0`. Differentiating in `X_{B₀}` sends the left side to `∂H/∂X_{B'}` and kills +every summand on the right. +-/ + +universe u v + +open scoped NatOrdinal + +public noncomputable section + +namespace MvPolynomial + +variable {σ : Type u} {R : Type v} [CommRing R] {wt : σ → NatOrdinal} + +/-- **Variables of `∂F/∂X_{B₀}` have vanishing part below `ω^β`.** In every monomial of a +homogeneous `F` the parts below `ω^β` add up to `α_{<β}`; if `X_{B₀}` occurs to degree at most one +and already accounts for all of `α_{<β}`, no other variable of the monomial can contribute. -/ +theorem partLT_eq_zero_of_mem_vars_pderiv {β α : NatOrdinal} {F : MvPolynomial σ R} {B₀ : σ} + (hF : IsWeightedHomogeneous wt F α) (hdeg : degreeOf B₀ F ≤ 1) + (hB₀ : NatOrdinal.partLT β (wt B₀) = NatOrdinal.partLT β α) + {i : σ} (hi : i ∈ (pderiv B₀ F).vars) : NatOrdinal.partLT β (wt i) = 0 := by + classical + obtain ⟨d', hd', hid'⟩ := (mem_vars_iff_mem_support i).mp hi + obtain ⟨d, hd, hdv, rfl⟩ := exists_mem_support_of_mem_support_pderiv hd' + have hd1 : d B₀ = 1 := + le_antisymm ((monomial_le_degreeOf B₀ hd).trans hdeg) (Nat.one_le_iff_ne_zero.mpr hdv) + -- `X_{B₀}` occurs exactly once, so it is gone from the monomial of the derivative + have hi0 : i ≠ B₀ := by + rintro rfl + rw [Finsupp.mem_support_iff, Finsupp.tsub_apply, Finsupp.single_eq_same, hd1] at hid' + exact hid' rfl + have hid : i ∈ d.support := by + rw [Finsupp.mem_support_iff] at hid' ⊢ + rw [Finsupp.tsub_apply, Finsupp.single_apply, ite_eq_right hi0.symm, Nat.sub_zero] at hid' + exact hid' + -- the parts below `ω^β` of the monomial add up to `α_{<β}` + have hsum : ∑ j ∈ d.support, d j • NatOrdinal.partLT β (wt j) = NatOrdinal.partLT β α := by + simpa [Finsupp.weight_apply, Finsupp.sum] using + (hF.map_weight (NatOrdinal.partLTAddMonoidHom β) (mem_support_iff.mp hd)) + -- and `X_{B₀}` alone already accounts for all of it + have hB₀d : B₀ ∈ d.support := Finsupp.mem_support_iff.mpr hdv + rw [← Finset.add_sum_erase _ _ hB₀d, hd1, one_smul, hB₀] at hsum + have hrest : ∑ j ∈ d.support.erase B₀, d j • NatOrdinal.partLT β (wt j) = 0 := + add_eq_left.mp hsum + rw [Finset.sum_eq_zero_iff_of_nonneg fun j _ ↦ zero_le (a := _)] at hrest + rcases smul_eq_zero.mp (hrest i (Finset.mem_erase.mpr ⟨hi0, hid⟩)) with h | h + · exact absurd h (Finsupp.mem_support_iff.mp hid) + · exact h + +/-- **The parts below `ω^β` of a monomial's factors add up.** In a monomial of a homogeneous +polynomial that contains two named variables once each, the part below `ω^β` of the rest of the +monomial, together with the parts of those two variables, is the part below `ω^β` of the +polynomial's degree. -/ +theorem partLT_weight_add_partLT_add_partLT {β α : NatOrdinal} {F : MvPolynomial σ R} + (hF : IsWeightedHomogeneous wt F α) {d : σ →₀ ℕ} {i u : σ} + (hd : d + Finsupp.single i 1 + Finsupp.single u 1 ∈ F.support) : + NatOrdinal.partLT β (Finsupp.weight wt d) + NatOrdinal.partLT β (wt i) + + NatOrdinal.partLT β (wt u) = NatOrdinal.partLT β α := by + have hw : NatOrdinal.partLT β (Finsupp.weight wt + (d + Finsupp.single i 1 + Finsupp.single u 1)) = NatOrdinal.partLT β α := + congrArg _ (hF (mem_support_iff.mp hd)) + rw [← hw, map_add, map_add, Finsupp.weight_single, Finsupp.weight_single, one_smul, one_smul, + NatOrdinal.partLT_add, NatOrdinal.partLT_add] + +/-- Both named variables of a decomposed monomial occur in it. -/ +theorem mem_support_of_eq_add_single_add_single {d m : σ →₀ ℕ} {i u : σ} + (h : m = d + Finsupp.single i 1 + Finsupp.single u 1) : + i ∈ m.support ∧ u ∈ m.support := by + classical + constructor <;> rw [Finsupp.mem_support_iff, h] <;> + simp only [Finsupp.add_apply, Finsupp.single_eq_same, Finsupp.single_apply] <;> omega + +/-- The rest of a decomposed monomial is determined by the monomial and the two variables. -/ +theorem eq_of_eq_add_single_add_single {d d' m : σ →₀ ℕ} {i u : σ} + (h : m = d + Finsupp.single i 1 + Finsupp.single u 1) + (h' : m = d' + Finsupp.single i 1 + Finsupp.single u 1) : d' = d := + add_right_cancel (add_right_cancel (h'.symm.trans h)) + +/-- **The pair bound from the two-truncation remainder bound.** If every term of the expansion of a +monomial of `F` with at least two truncated factors has degree below `α_{≥β} ⊕ λ`, then lowering +the parts below `ω^β` of two variables of a monomial keeps the sum of those parts, together with +the part of the rest of the monomial, at or below `λ`. + +Truncating exactly those two factors exhibits such a term, and its part at or above `ω^β` is +already `α_{≥β}`, so the bound falls entirely on the parts below. -/ +theorem pair_bound_of_forall_termDegree_lt {β α lam : NatOrdinal} + {F : MvPolynomial σ R} (hF : IsWeightedHomogeneous wt F α) + (hlam : lam < NatOrdinal.partLT β α) + (hrem : ∀ d ∈ F.support, ∀ (k : ℕ) (ρ : NatOrdinal), 2 ≤ k → TermDegree wt d k ρ → + ρ < NatOrdinal.partGE β α + lam) + {d : σ →₀ ℕ} {i j : σ} + (hd : d + Finsupp.single i 1 + Finsupp.single j 1 ∈ F.support) + {ρᵢ ρⱼ : NatOrdinal} (hρᵢ : ρᵢ < NatOrdinal.partLT β (wt i)) + (hρⱼ : ρⱼ < NatOrdinal.partLT β (wt j)) : + NatOrdinal.partLT β (Finsupp.weight wt d) + ρᵢ + ρⱼ ≤ lam := by + have hlamβ : lam < ω^ β := hlam.trans (NatOrdinal.partLT_lt _ _) + have hzeroGE : ∀ a : NatOrdinal, NatOrdinal.partLT β (NatOrdinal.partGE β a) = 0 := fun _ ↦ + NatOrdinal.partLT_eq_zero_of_forall_le + fun _ hs ↦ NatOrdinal.wpow_le_of_mem_additivePrincipalTerms_partGE hs + have hGE : NatOrdinal.partGE β (NatOrdinal.partGE β α + lam) = NatOrdinal.partGE β α := by + rw [NatOrdinal.partGE_add, NatOrdinal.partGE_partGE, + NatOrdinal.partGE_eq_zero_of_lt hlamβ, add_zero] + have hLT : NatOrdinal.partLT β (NatOrdinal.partGE β α + lam) = lam := by + rw [NatOrdinal.partLT_add, NatOrdinal.partLT_eq_self_of_lt hlamβ, hzeroGE, zero_add] + -- truncating exactly the two factors exhibits a term of the expansion + have hρᵢ' : NatOrdinal.partGE β (wt i) + ρᵢ < wt i := by + conv_rhs => rw [← NatOrdinal.partGE_add_partLT β (wt i)] + exact add_lt_add_of_le_of_lt le_rfl hρᵢ + have hρⱼ' : NatOrdinal.partGE β (wt j) + ρⱼ < wt j := by + conv_rhs => rw [← NatOrdinal.partGE_add_partLT β (wt j)] + exact add_lt_add_of_le_of_lt le_rfl hρⱼ + have hlt := hrem _ hd 2 _ le_rfl (termDegree_pair (wt := wt) d hρᵢ' hρⱼ') + set ρ := Finsupp.weight wt d + (NatOrdinal.partGE β (wt i) + ρᵢ) + + (NatOrdinal.partGE β (wt j) + ρⱼ) with hρdef + have hρᵢβ : ρᵢ < ω^ β := hρᵢ.trans (NatOrdinal.partLT_lt β _) + have hρⱼβ : ρⱼ < ω^ β := hρⱼ.trans (NatOrdinal.partLT_lt β _) + -- its part at or above `ω^β` is already the whole of `α_{≥β}` + have hhigh : NatOrdinal.partGE β ρ = NatOrdinal.partGE β (NatOrdinal.partGE β α + lam) := by + have hα : NatOrdinal.partGE β α = NatOrdinal.partGE β + (Finsupp.weight wt (d + Finsupp.single i 1 + Finsupp.single j 1)) := + congrArg _ (hF (mem_support_iff.mp hd)).symm + rw [hGE, hα, hρdef, map_add, map_add, Finsupp.weight_single, Finsupp.weight_single, + one_smul, one_smul] + simp only [NatOrdinal.partGE_add, NatOrdinal.partGE_partGE, + NatOrdinal.partGE_eq_zero_of_lt hρᵢβ, NatOrdinal.partGE_eq_zero_of_lt hρⱼβ, add_zero] + have hlow := NatOrdinal.partLT_lt_of_lt_of_partGE_eq hlt hhigh + rw [hLT, hρdef] at hlow + simp only [NatOrdinal.partLT_add, NatOrdinal.partLT_eq_self_of_lt hρᵢβ, + NatOrdinal.partLT_eq_self_of_lt hρⱼβ, hzeroGE, zero_add] at hlow + exact hlow.le + +/-- **The pair bound from a bound on the parts below the cutoff.** The same conclusion from the +form the term-degree analysis actually delivers: a bound on the part below the cutoff of every +term with at least two truncated factors that keeps the whole part above it. -/ +theorem pair_bound_of_forall_partLT_le {β α lam : NatOrdinal} + {F : MvPolynomial σ R} (hF : IsWeightedHomogeneous wt F α) + (hrem : ∀ d ∈ F.support, ∀ (k : ℕ) (ρ : NatOrdinal), 2 ≤ k → TermDegree wt d k ρ → + NatOrdinal.partGE β ρ = NatOrdinal.partGE β α → NatOrdinal.partLT β ρ ≤ lam) + {d : σ →₀ ℕ} {i j : σ} + (hd : d + Finsupp.single i 1 + Finsupp.single j 1 ∈ F.support) + {ρᵢ ρⱼ : NatOrdinal} (hρᵢ : ρᵢ < NatOrdinal.partLT β (wt i)) + (hρⱼ : ρⱼ < NatOrdinal.partLT β (wt j)) : + NatOrdinal.partLT β (Finsupp.weight wt d) + ρᵢ + ρⱼ ≤ lam := by + have hzeroGE : ∀ a : NatOrdinal, NatOrdinal.partLT β (NatOrdinal.partGE β a) = 0 := fun _ ↦ + NatOrdinal.partLT_eq_zero_of_forall_le + fun _ hs ↦ NatOrdinal.wpow_le_of_mem_additivePrincipalTerms_partGE hs + have hρᵢ' : NatOrdinal.partGE β (wt i) + ρᵢ < wt i := by + conv_rhs => rw [← NatOrdinal.partGE_add_partLT β (wt i)] + exact add_lt_add_of_le_of_lt le_rfl hρᵢ + have hρⱼ' : NatOrdinal.partGE β (wt j) + ρⱼ < wt j := by + conv_rhs => rw [← NatOrdinal.partGE_add_partLT β (wt j)] + exact add_lt_add_of_le_of_lt le_rfl hρⱼ + set ρ := Finsupp.weight wt d + (NatOrdinal.partGE β (wt i) + ρᵢ) + + (NatOrdinal.partGE β (wt j) + ρⱼ) with hρdef + have hρᵢβ : ρᵢ < ω^ β := hρᵢ.trans (NatOrdinal.partLT_lt β _) + have hρⱼβ : ρⱼ < ω^ β := hρⱼ.trans (NatOrdinal.partLT_lt β _) + have hhigh : NatOrdinal.partGE β ρ = NatOrdinal.partGE β α := by + have hα : NatOrdinal.partGE β α = NatOrdinal.partGE β + (Finsupp.weight wt (d + Finsupp.single i 1 + Finsupp.single j 1)) := + congrArg _ (hF (mem_support_iff.mp hd)).symm + rw [hα, hρdef, map_add, map_add, Finsupp.weight_single, Finsupp.weight_single, + one_smul, one_smul] + simp only [NatOrdinal.partGE_add, NatOrdinal.partGE_partGE, + NatOrdinal.partGE_eq_zero_of_lt hρᵢβ, NatOrdinal.partGE_eq_zero_of_lt hρⱼβ, add_zero] + have hlow := hrem _ hd 2 _ le_rfl (termDegree_pair (wt := wt) d hρᵢ' hρⱼ') hhigh + simp only [NatOrdinal.partLT_add, NatOrdinal.partLT_eq_self_of_lt hρᵢβ, + NatOrdinal.partLT_eq_self_of_lt hρⱼβ, hzeroGE, zero_add] at hlow + exact hlow + +/-- **The pair bound, unconditionally.** For a homogeneous polynomial whose degree has a nonzero +part below the cutoff, and whose variables with a nonzero part below it have a last Cantor term of +nonzero exponent, there is a bound strictly below the polynomial's part at the cutoff that +dominates every sum obtained by lowering the parts of two variables of a monomial. + +The term-degree analysis supplies the bound and the previous theorem consumes it, so the second +case's pair bound needs no analytic input at all -- only that its variables are of limit weight +below the cutoff. -/ +theorem exists_lt_forall_pair_bound {β α : NatOrdinal} {F : MvPolynomial σ R} + (hF : IsWeightedHomogeneous wt F α) (hμ : NatOrdinal.partLT β α ≠ 0) + (htail : ∀ i ∈ F.vars, NatOrdinal.partLT β (wt i) ≠ 0 → + ∃ e, e ≠ 0 ∧ NatOrdinal.leastTerm (NatOrdinal.partLT β (wt i)) = ω^ e) : + ∃ lam : NatOrdinal, lam < NatOrdinal.partLT β α ∧ + ∀ (d : σ →₀ ℕ) (i j : σ), + d + Finsupp.single i 1 + Finsupp.single j 1 ∈ F.support → + ∀ ρᵢ ρⱼ : NatOrdinal, ρᵢ < NatOrdinal.partLT β (wt i) → + ρⱼ < NatOrdinal.partLT β (wt j) → + NatOrdinal.partLT β (Finsupp.weight wt d) + ρᵢ + ρⱼ ≤ lam := by + obtain ⟨lam, hlam, hrem⟩ := + exists_forall_partLT_le_of_termDegree (K := R) F (fun _ hd ↦ hF (mem_support_iff.mp hd)) + hμ htail + exact ⟨lam, hlam, fun d i j hd ρᵢ ρⱼ hρᵢ hρⱼ ↦ + pair_bound_of_forall_partLT_le hF hrem hd hρᵢ hρⱼ⟩ + +/-- **A uniform pair bound over the support.** For a homogeneous polynomial whose degree has a +nonzero part below `ω^β`, one bound strictly below that part dominates every sum obtained, at any +monomial, by lowering the parts of two of its variables. + +At a single monomial the two-summand lemma supplies such a bound, the parts of the monomial's +factors adding up to the polynomial's; the monomials are finitely many and so are the pairs of +variables in each, and finitely many bounds below a common ceiling collapse to one. -/ +theorem exists_lt_forall_add_add_le_of_isWeightedHomogeneous {β α : NatOrdinal} + {F : MvPolynomial σ R} (hF : IsWeightedHomogeneous wt F α) + (hα : 0 < NatOrdinal.partLT β α) : + ∃ lam : NatOrdinal, lam < NatOrdinal.partLT β α ∧ + ∀ (d : σ →₀ ℕ) (i u : σ), + d + Finsupp.single i 1 + Finsupp.single u 1 ∈ F.support → + NatOrdinal.partLT β (wt i) ≠ 0 → NatOrdinal.partLT β (wt u) ≠ 0 → + ∀ ρ₁ ρ₂ : NatOrdinal, ρ₁ < NatOrdinal.partLT β (wt i) → + ρ₂ < NatOrdinal.partLT β (wt u) → + NatOrdinal.partLT β (Finsupp.weight wt d) + ρ₁ + ρ₂ ≤ lam := by + classical + set P : (σ →₀ ℕ) → NatOrdinal → Prop := fun m B ↦ + ∀ (d : σ →₀ ℕ) (i u : σ), m = d + Finsupp.single i 1 + Finsupp.single u 1 → + NatOrdinal.partLT β (wt i) ≠ 0 → NatOrdinal.partLT β (wt u) ≠ 0 → + ∀ ρ₁ ρ₂ : NatOrdinal, ρ₁ < NatOrdinal.partLT β (wt i) → + ρ₂ < NatOrdinal.partLT β (wt u) → + NatOrdinal.partLT β (Finsupp.weight wt d) + ρ₁ + ρ₂ ≤ B with hPdef + have hPmono : ∀ m, ∀ {B B' : NatOrdinal}, B ≤ B' → P m B → P m B' := + fun m _ _ hBB' hP d i u hd hi hu ρ₁ ρ₂ hρ₁ hρ₂ ↦ + (hP d i u hd hi hu ρ₁ ρ₂ hρ₁ hρ₂).trans hBB' + refine (NatOrdinal.exists_lt_forall_of_forall_exists_lt F.support hα P hPmono ?_).imp + fun lam hlam ↦ ⟨hlam.1, fun d i u hd hi hu ρ₁ ρ₂ hρ₁ hρ₂ ↦ + hlam.2 _ hd d i u rfl hi hu ρ₁ ρ₂ hρ₁ hρ₂⟩ + -- at each monomial, index by the pairs of its variables + intro m hm + set Q : σ × σ → NatOrdinal → Prop := fun p B ↦ + ∀ d : σ →₀ ℕ, m = d + Finsupp.single p.1 1 + Finsupp.single p.2 1 → + NatOrdinal.partLT β (wt p.1) ≠ 0 → NatOrdinal.partLT β (wt p.2) ≠ 0 → + ∀ ρ₁ ρ₂ : NatOrdinal, ρ₁ < NatOrdinal.partLT β (wt p.1) → + ρ₂ < NatOrdinal.partLT β (wt p.2) → + NatOrdinal.partLT β (Finsupp.weight wt d) + ρ₁ + ρ₂ ≤ B with hQdef + have hQmono : ∀ p, ∀ {B B' : NatOrdinal}, B ≤ B' → Q p B → Q p B' := + fun p _ _ hBB' hQ d hd hi hu ρ₁ ρ₂ hρ₁ hρ₂ ↦ (hQ d hd hi hu ρ₁ ρ₂ hρ₁ hρ₂).trans hBB' + -- at each pair, the two-summand lemma, or nothing to prove + have hQmem : ∀ p ∈ m.support ×ˢ m.support, ∃ B, B < NatOrdinal.partLT β α ∧ Q p B := by + rintro p - + by_cases hdec : ∃ d : σ →₀ ℕ, m = d + Finsupp.single p.1 1 + Finsupp.single p.2 1 + · obtain ⟨d, hdm⟩ := hdec + by_cases hi : NatOrdinal.partLT β (wt p.1) = 0 + · exact ⟨0, hα, fun _ _ hi' _ _ _ _ _ ↦ absurd hi hi'⟩ + by_cases hu : NatOrdinal.partLT β (wt p.2) = 0 + · exact ⟨0, hα, fun _ _ _ hu' _ _ _ _ ↦ absurd hu hu'⟩ + obtain ⟨e₁, he₁⟩ := NatOrdinal.exists_leastTerm_eq_wpow hi + obtain ⟨e₂, he₂⟩ := NatOrdinal.exists_leastTerm_eq_wpow hu + obtain ⟨B, hB, hall⟩ := NatOrdinal.exists_lt_forall_add_add_le + (O := NatOrdinal.partLT β (Finsupp.weight wt d)) hi hu he₁ he₂ + have hsum := partLT_weight_add_partLT_add_partLT (β := β) hF (hdm ▸ hm) + refine ⟨B, hsum ▸ hB, fun d' hd' _ _ ρ₁ ρ₂ hρ₁ hρ₂ ↦ ?_⟩ + rw [eq_of_eq_add_single_add_single hdm hd'] + exact hall ρ₁ ρ₂ hρ₁ hρ₂ + · exact ⟨0, hα, fun d hd _ _ _ _ _ _ ↦ absurd ⟨d, hd⟩ hdec⟩ + obtain ⟨B, hB, hQ⟩ := + NatOrdinal.exists_lt_forall_of_forall_exists_lt (m.support ×ˢ m.support) hα Q hQmono hQmem + refine ⟨B, hB, fun d i u hd hi hu ρ₁ ρ₂ hρ₁ hρ₂ ↦ ?_⟩ + obtain ⟨him, hum⟩ := mem_support_of_eq_add_single_add_single hd + exact hQ (i, u) (Finset.mem_product.mpr ⟨him, hum⟩) d hd hi hu ρ₁ ρ₂ hρ₁ hρ₂ + +/-- **The agreement one level up, from a pair bound.** Take two variables occurring once each in a +monomial of a homogeneous polynomial, both with nonzero part below `ω^β`. If a bound below the +polynomial's own part below `ω^β` dominates every sum obtained by lowering those two parts, and the +first variable's part does not precede the bound in the algebraic order, then the exponent of that +part's last Cantor term is below the second's, and the bound agrees with the polynomial's part at +or above the second exponent. + +Everything here except the pair bound is forced: the parts of the monomial's factors add up, and +the ordering of the exponents is what the failed algebraic-order comparison leaves. -/ +theorem partGE_eq_of_forall_add_add_le_of_not_algebraicLE {β α lam : NatOrdinal} + {F : MvPolynomial σ R} (hF : IsWeightedHomogeneous wt F α) + {d : σ →₀ ℕ} {i u : σ} (hd : d + Finsupp.single i 1 + Finsupp.single u 1 ∈ F.support) + (hti : NatOrdinal.partLT β (wt i) ≠ 0) (htu : NatOrdinal.partLT β (wt u) ≠ 0) + {ei eu : NatOrdinal} (hei : NatOrdinal.leastTerm (NatOrdinal.partLT β (wt i)) = ω^ ei) + (heu : NatOrdinal.leastTerm (NatOrdinal.partLT β (wt u)) = ω^ eu) (hei0 : ei ≠ 0) + (hlam : lam < NatOrdinal.partLT β α) + (hall : ∀ ρ₁ ρ₂ : NatOrdinal, ρ₁ < NatOrdinal.partLT β (wt i) → + ρ₂ < NatOrdinal.partLT β (wt u) → + NatOrdinal.partLT β (Finsupp.weight wt d) + ρ₁ + ρ₂ ≤ lam) + (hdiff : ¬ NatOrdinal.AlgebraicLE (NatOrdinal.partLT β (wt i)) lam) : + ei < eu ∧ NatOrdinal.partGE eu lam = NatOrdinal.partGE eu (NatOrdinal.partLT β α) := by + have hsum := partLT_weight_add_partLT_add_partLT (β := β) hF hd + rw [← hsum] + exact NatOrdinal.lt_and_partGE_eq_of_not_algebraicLE hti htu hei heu hei0 (hsum ▸ hlam) hall + hdiff + +/-- A variable with nonzero part below `ω^β` does not occur in `∂F/∂X_{B₀}`, so differentiating +`∂F/∂X_{B₀}` with respect to it gives zero. -/ +theorem pderiv_eq_zero_of_partLT_ne_zero {β α : NatOrdinal} {F : MvPolynomial σ R} {B₀ : σ} + (hF : IsWeightedHomogeneous wt F α) (hdeg : degreeOf B₀ F ≤ 1) + (hB₀ : NatOrdinal.partLT β (wt B₀) = NatOrdinal.partLT β α) + {v : σ} (hv : NatOrdinal.partLT β (wt v) ≠ 0) : + pderiv v (pderiv B₀ F) = 0 := + pderiv_eq_zero_of_notMem_vars fun hmem ↦ + hv (partLT_eq_zero_of_mem_vars_pderiv hF hdeg hB₀ hmem) + +variable [NoZeroDivisors R] [CharZero R] + +/-- Let `F` be homogeneous of degree `α`, let `B₀` occur in `F` to +degree at most one with `(wt B₀)_{<β} = α_{<β}`, and suppose `H := ∂F/∂X_{B₀}` is nonzero of +nonzero degree `δ`. Suppose that for every variable `B'` of `F` whose part below `ω^β` is a +summand of `lam₀`, in the sense that it adds to `lam₀` under Hessenberg sum, there is a relation +expressing `∂F/∂X_{B'}` as a combination of the `∂F/∂X_B` over variables `B` with nonzero part +below `ω^β`, whose cofactors are free of `X_{B₀}`. This is impossible. + +Applied at a variable `B'` of `H` with `∂H/∂X_{B'} ≠ 0` — which exists in characteristic zero, +and whose part below `ω^β` vanishes, hence adds to `lam₀` to give `lam₀` — differentiating the +relation in `X_{B₀}` turns the left side into `∂H/∂X_{B'}` and every right-hand summand into +`(∂H/∂X_B) U_B = 0`, since no `B` with nonzero part below `ω^β` is a variable of `H`. -/ +@[blueprint "lem:relation-at-limit-ordinal-partial-contradiction" + (phase := "Algebraic and ordinal preliminaries") + (title := "Partial-derivative obstruction to a linear variable") + (statement := /-- + For an ordinal $\xi$, let $\xi_{<\beta}$ be the Hessenberg sum of the + terms in its Cantor normal form whose exponents are below $\beta$. + + Let $R$ be a commutative ring of characteristic zero without zero + divisors. Give the variables $X_i$ ordinal weights $w_i$, and let + $F\in R[X_i:i\in I]$ be weighted homogeneous of degree $\alpha$. Suppose + that $X_{B_0}$ occurs in $F$ with degree at most one and + $(w_{B_0})_{<\beta}=\alpha_{<\beta}$. Put + $H=\partial_{B_0}F$, and suppose that $H\ne0$ is weighted homogeneous of + some nonzero degree $\delta$. + + Fix an ordinal $\lambda_0$. Suppose that for every variable $X_{B'}$ + occurring in $F$ such that + $(w_{B'})_{<\beta}\oplus\eta=\lambda_0$ for some ordinal $\eta$, there + are a finite set $S$ and polynomials $U_B$ satisfying + \[ + (w_B)_{<\beta}\ne0,\qquad \partial_{B_0}U_B=0\quad(B\in S), + \qquad + \partial_{B'}F=\sum_{B\in S}(\partial_BF)U_B. + \] + These hypotheses are inconsistent. + -/) + (proof := /-- + Choose a variable $X_{B'}$ occurring in the nonzero homogeneous polynomial + $H$. Its degree is nonzero, so $H$ has a nonconstant monomial and $B'$ can + be chosen with $\partial_{B'}H\ne0$. Because $X_{B_0}$ occurs at most once + and already accounts for every Cantor term below $\omega^\beta$ in the + degree of $F$, every variable of $H$ has + $(w_{B'})_{<\beta}=0$. The equation + $0\oplus\lambda_0=\lambda_0$ therefore supplies the assumed identity for + $\partial_{B'}F$. + + Differentiate this identity with respect to $X_{B_0}$. The left side is + $\partial_{B'}H\ne0$. On the right, every $U_B$ is independent of + $X_{B_0}$, while $(w_B)_{<\beta}\ne0$ prevents $X_B$ from occurring in + $H$; the Leibniz rule therefore makes every summand zero, a contradiction. + -/)] +theorem false_of_pderiv_eq_sum_of_partLT_ne_zero {β α δ lam₀ : NatOrdinal} + {F : MvPolynomial σ R} {B₀ : σ} + (hF : IsWeightedHomogeneous wt F α) (hdeg : degreeOf B₀ F ≤ 1) + (hB₀ : NatOrdinal.partLT β (wt B₀) = NatOrdinal.partLT β α) + (hH : IsWeightedHomogeneous wt (pderiv B₀ F) δ) (hH0 : pderiv B₀ F ≠ 0) (hδ : δ ≠ 0) + (hsyz : ∀ B' ∈ F.vars, NatOrdinal.AlgebraicLE (NatOrdinal.partLT β (wt B')) lam₀ → + ∃ (s : Finset σ) (U : σ → MvPolynomial σ R), + (∀ B ∈ s, NatOrdinal.partLT β (wt B) ≠ 0) ∧ (∀ B ∈ s, pderiv B₀ (U B) = 0) ∧ + pderiv B' F = ∑ B ∈ s, pderiv B F * U B) : + False := by + classical + -- a variable `B'` of `H` with `∂H/∂X_{B'} ≠ 0` + obtain ⟨d, hd⟩ := exists_coeff_ne_zero hH0 + have hdne : d ≠ 0 := by + rintro rfl + exact hδ (by rw [← hH hd, map_zero]) + obtain ⟨B', hB'd⟩ := Finsupp.support_nonempty_iff.mpr hdne + have hB'H : B' ∈ (pderiv B₀ F).vars := + (mem_vars_iff_mem_support B').mpr ⟨d, mem_support_iff.mpr hd, hB'd⟩ + -- `B'` is a variable of `F` with vanishing part below `ω^β` + have hB'F : B' ∈ F.vars := vars_pderiv_subset B₀ F hB'H + have hB'LT : NatOrdinal.partLT β (wt B') = 0 := + partLT_eq_zero_of_mem_vars_pderiv hF hdeg hB₀ hB'H + obtain ⟨s, U, hs, hU, heq⟩ := + hsyz B' hB'F (hB'LT ▸ NatOrdinal.algebraicLE_zero lam₀) + -- differentiating the relation in `X_{B₀}` kills the right side + exact pderiv_ne_zero_of_mem_vars hB'H + (pderiv_pderiv_eq_zero_of_sum_of_notMem_vars heq hU fun B hB hmem ↦ + hs B hB (partLT_eq_zero_of_mem_vars_pderiv hF hdeg hB₀ hmem)) + +/-- **The polynomials free of a variable form a subring.** The kernel of a derivation is closed +under the ring operations, since a product is annihilated as soon as both factors are. -/ +def freeOf (B₀ : σ) : Subring (MvPolynomial σ R) where + carrier := {p | pderiv B₀ p = 0} + zero_mem' := map_zero _ + one_mem' := pderiv_one + add_mem' hp hq := by + rw [Set.mem_ofPred_eq, map_add, hp, hq, add_zero] + neg_mem' hp := by + rw [Set.mem_ofPred_eq, map_neg, hp, neg_zero] + mul_mem' hp hq := by + rw [Set.mem_ofPred_eq, pderiv_mul, hp, hq, zero_mul, mul_zero, add_zero] + +omit [NoZeroDivisors R] [CharZero R] in +@[simp] +theorem mem_freeOf {B₀ : σ} {p : MvPolynomial σ R} : p ∈ freeOf B₀ ↔ pderiv B₀ p = 0 := + Iff.rfl + +omit [NoZeroDivisors R] [CharZero R] in +/-- A polynomial all of whose monomials weigh less than a variable does not involve it. -/ +theorem pderiv_eq_zero_of_forall_weight_lt {P : MvPolynomial σ R} {g : NatOrdinal} + (hP : ∀ d ∈ P.support, Finsupp.weight wt d < g) {v : σ} (hg : g ≤ wt v) : + pderiv v P = 0 := by + by_contra h + obtain ⟨d', hd'⟩ := support_nonempty.mpr h + obtain ⟨d, hd, hw⟩ := exists_add_eq_weight_of_mem_support_pderiv wt hd' + have h1 := hP d hd + rw [← hw] at h1 + exact absurd (hg.trans (le_add_of_nonneg_left zero_le)) (not_le.mpr h1) + +omit [NoZeroDivisors R] [CharZero R] in +/-- A homogeneous polynomial lighter than a variable is free of it. -/ +theorem mem_freeOf_of_isWeightedHomogeneous {c : MvPolynomial σ R} {b : NatOrdinal} + (hc : IsWeightedHomogeneous wt c b) {B₀ : σ} (hb : b < wt B₀) : c ∈ freeOf (R := R) B₀ := + mem_freeOf.mpr (pderiv_eq_zero_of_forall_weight_lt (g := wt B₀) + (fun d hd ↦ by rw [hc (mem_support_iff.mp hd)]; exact hb) le_rfl) + +omit [NoZeroDivisors R] [CharZero R] in +/-- **A combination with cofactors free of a variable lies in the span over them.** This is the +bridge from the identity the syzygy produces to the membership the propagation consumes. -/ +theorem mem_span_of_eq_sum_mul {B₀ : σ} {Θ : MvPolynomial σ R} {κ' : Type*} [Fintype κ'] + {c Q : κ' → MvPolynomial σ R} (hc : ∀ j, c j ∈ freeOf (R := R) B₀) + (heq : Θ = ∑ j, c j * Q j) : + Θ ∈ Submodule.span (freeOf (R := R) B₀) (Set.range Q) := by + rw [heq] + exact Submodule.sum_mem _ fun j _ ↦ + Submodule.smul_mem _ (⟨c j, hc j⟩ : freeOf (R := R) B₀) (Submodule.subset_span ⟨j, rfl⟩) + +/-- The partial derivatives of `F` at the variables heavier than a given one. -/ +def higherPartials (F : MvPolynomial σ R) (wt : σ → NatOrdinal) (v : σ) : + Set (MvPolynomial σ R) := + (fun j ↦ pderiv j F) '' {j | j ∈ F.vars ∧ wt v < wt j} + +omit [NoZeroDivisors R] [CharZero R] in +/-- **Propagation to the variables that do not step further.** If at every variable satisfying a +predicate the partial derivative of `F` is a combination, over the polynomials free of `X_{B₀}`, of +the partial derivatives at heavier variables, then it is such a combination of the partial +derivatives at heavier variables that fail the predicate. + +Each step replaces a generator that satisfies the predicate by generators strictly heavier than it, +and the variables of `F` heavier than a given one shrink strictly with every step, so the process +terminates. -/ +theorem pderiv_mem_span_of_forall_mem_span_higher (B₀ : σ) + (wt : σ → NatOrdinal) {F : MvPolynomial σ R} (Good : σ → Prop) + (hstep : ∀ v ∈ F.vars, Good v → + pderiv v F ∈ Submodule.span (freeOf (R := R) B₀) (higherPartials F wt v)) + {v' : σ} (hv' : v' ∈ F.vars) (hg : Good v') : + pderiv v' F ∈ Submodule.span (freeOf (R := R) B₀) + ((fun j ↦ pderiv j F) '' {j | j ∈ F.vars ∧ ¬ Good j ∧ wt v' < wt j}) := by + classical + suffices H : ∀ n : ℕ, ∀ v' ∈ F.vars, (F.vars.filter fun v ↦ wt v' < wt v).card = n → Good v' → + pderiv v' F ∈ Submodule.span (freeOf (R := R) B₀) + ((fun j ↦ pderiv j F) '' {j | j ∈ F.vars ∧ ¬ Good j ∧ wt v' < wt j}) from + H _ v' hv' rfl hg + intro n + induction n using Nat.strong_induction_on with + | _ n ih => + intro v' hv' hn hgood + refine Submodule.span_le.mpr ?_ (hstep v' hv' hgood) + rintro _ ⟨j, ⟨hjv, hjwt⟩, rfl⟩ + by_cases hj : Good j + · -- a generator that steps further is replaced by strictly heavier ones + have hsub : F.vars.filter (fun v ↦ wt j < wt v) ⊂ F.vars.filter fun v ↦ wt v' < wt v := by + refine Finset.ssubset_iff_of_subset (fun k hk ↦ ?_) |>.mpr ⟨j, ?_, ?_⟩ + · rw [Finset.mem_filter] at hk ⊢ + exact ⟨hk.1, hjwt.trans hk.2⟩ + · exact Finset.mem_filter.mpr ⟨hjv, hjwt⟩ + · rw [Finset.mem_filter] + exact fun h ↦ absurd h.2 (lt_irrefl _) + have hcard := Finset.card_lt_card hsub + rw [hn] at hcard + refine Submodule.span_le.mpr ?_ (ih _ hcard j hjv rfl hj) + rintro _ ⟨k, ⟨hkv, hkg, hkwt⟩, rfl⟩ + exact Submodule.subset_span ⟨k, ⟨hkv, hkg, hjwt.trans hkwt⟩, rfl⟩ + · exact Submodule.subset_span ⟨j, ⟨hjv, hj, hjwt⟩, rfl⟩ + +omit [NoZeroDivisors R] [CharZero R] in +/-- Differentiating at a variable is linear over the polynomials free of that variable, since a +factor it annihilates passes through the Leibniz rule. -/ +theorem pderiv_smul_freeOf (B₀ : σ) (r : freeOf (R := R) B₀) (p : MvPolynomial σ R) : + pderiv B₀ (r • p) = r • pderiv B₀ p := by + have hsmul : ∀ q : MvPolynomial σ R, r • q = (r : MvPolynomial σ R) * q := fun _ ↦ rfl + rw [hsmul, hsmul, pderiv_mul, mem_freeOf.mp r.2, zero_mul, zero_add] + +/-- Differentiating at a variable, as a map linear over the polynomials free of it. -/ +@[expose] +def pderivFreeOf (B₀ : σ) : + MvPolynomial σ R →ₗ[freeOf (R := R) B₀] MvPolynomial σ R where + toFun := pderiv B₀ + map_add' _ _ := map_add _ _ _ + map_smul' := pderiv_smul_freeOf B₀ + +omit [NoZeroDivisors R] [CharZero R] in +@[simp] +theorem pderivFreeOf_apply (B₀ : σ) (p : MvPolynomial σ R) : + pderivFreeOf (R := R) B₀ p = pderiv B₀ p := + rfl + +omit [NoZeroDivisors R] [CharZero R] in +/-- **The differentiated syzygy contradiction, in span form.** If a partial derivative of `F` lies +in the span, over the polynomials free of `X_{B₀}`, of the partial derivatives at a set of +variables none of which occurs in `∂F/∂X_{B₀}`, then that partial derivative of `F` is annihilated +by the distinguished variable. + +Differentiating at `B₀` is linear over that subring, so it carries the span to the span of the +differentiated generators, and each of those vanishes. -/ +theorem pderiv_pderiv_eq_zero_of_mem_span (B₀ : σ) {F : MvPolynomial σ R} {B' : σ} {S : Set σ} + (hmem : pderiv B' F ∈ + Submodule.span (freeOf (R := R) B₀) ((fun j ↦ pderiv j F) '' S)) + (hvars : ∀ j ∈ S, j ∉ (pderiv B₀ F).vars) : + pderiv B' (pderiv B₀ F) = 0 := by + have hker : ∀ q ∈ (fun j ↦ pderiv j F) '' S, pderivFreeOf (R := R) B₀ q = 0 := by + rintro _ ⟨j, hj, rfl⟩ + rw [pderivFreeOf_apply, pderiv_pderiv_comm, pderiv_eq_zero_of_notMem_vars (hvars j hj)] + have hzero : pderivFreeOf (R := R) B₀ (pderiv B' F) = 0 := by + refine Submodule.span_induction (p := fun q _ ↦ pderivFreeOf (R := R) B₀ q = 0) hker ?_ ?_ ?_ + hmem + · exact map_zero _ + · intro a b _ _ ha hb + rw [map_add, ha, hb, add_zero] + · intro a b _ hb + rw [map_smul, hb, smul_zero] + rwa [pderivFreeOf_apply, pderiv_pderiv_comm] at hzero + +/-- **The limit contradiction from a step at every light variable.** Suppose that at every variable +of `F` whose part below `ω^β` vanishes, the partial derivative of `F` is a combination, over the +polynomials free of `X_{B₀}`, of the partial derivatives at heavier variables. With `B₀` occurring +to degree at most one and carrying all of `α_{<β}`, and `H := ∂F/∂X_{B₀}` nonzero of nonzero +degree, this is impossible. + +Every variable of `H` has vanishing part below `ω^β`, so the step applies at one of them with +`∂H/∂X_{B'} ≠ 0`; propagating leaves only variables with nonzero part below `ω^β`, and none of +those occurs in `H`, so differentiating in `X_{B₀}` annihilates `H` at `B'`. -/ +theorem false_of_forall_mem_span_higher {β α δ : NatOrdinal} + {F : MvPolynomial σ R} {B₀ : σ} + (hF : IsWeightedHomogeneous wt F α) (hdeg : degreeOf B₀ F ≤ 1) + (hB₀ : NatOrdinal.partLT β (wt B₀) = NatOrdinal.partLT β α) + (hH : IsWeightedHomogeneous wt (pderiv B₀ F) δ) (hH0 : pderiv B₀ F ≠ 0) (hδ : δ ≠ 0) + (hstep : ∀ v ∈ F.vars, NatOrdinal.partLT β (wt v) = 0 → + pderiv v F ∈ Submodule.span (freeOf (R := R) B₀) (higherPartials F wt v)) : + False := by + classical + -- a variable `B'` of `H` with `∂H/∂X_{B'} ≠ 0` + obtain ⟨d, hd⟩ := exists_coeff_ne_zero hH0 + have hdne : d ≠ 0 := by + rintro rfl + exact hδ (by rw [← hH hd, map_zero]) + obtain ⟨B', hB'd⟩ := Finsupp.support_nonempty_iff.mpr hdne + have hB'H : B' ∈ (pderiv B₀ F).vars := + (mem_vars_iff_mem_support B').mpr ⟨d, mem_support_iff.mpr hd, hB'd⟩ + have hB'F : B' ∈ F.vars := vars_pderiv_subset B₀ F hB'H + have hB'LT : NatOrdinal.partLT β (wt B') = 0 := + partLT_eq_zero_of_mem_vars_pderiv hF hdeg hB₀ hB'H + -- propagating leaves only variables with nonzero part below `ω^β` + have hspan := pderiv_mem_span_of_forall_mem_span_higher B₀ wt + (fun v ↦ NatOrdinal.partLT β (wt v) = 0) hstep hB'F hB'LT + exact pderiv_ne_zero_of_mem_vars hB'H + (pderiv_pderiv_eq_zero_of_mem_span B₀ hspan fun j hj hmem ↦ + hj.2.1 (partLT_eq_zero_of_mem_vars_pderiv hF hdeg hB₀ hmem)) + +omit [NoZeroDivisors R] [CharZero R] in +/-- **The step at a light variable, from a syzygy identity.** If the partial derivative at a +variable is a combination of the partial derivatives at heavier variables, with cofactors +homogeneous of the complementary degrees, then it lies in the span of those partial derivatives +over the polynomials free of `X_{B₀}` -- provided `B₀` is of maximal weight, which makes every +cofactor lighter than it and so free of it. + +This is the join between the analysis, which delivers an identity with graded cofactors, and the +propagation, which consumes a span membership. -/ +theorem mem_span_higherPartials_of_eq_sum_mul {B₀ : σ} {F : MvPolynomial σ R} + {v : σ} {κ' : Type*} [Fintype κ'] {c : κ' → MvPolynomial σ R} {g : κ' → σ} + (hg : ∀ j, g j ∈ F.vars ∧ wt v < wt (g j)) + (hmax : ∀ i ∈ F.vars, wt i ≤ wt B₀) (hv : 0 < wt v) + (hchom : ∀ j, ∃ b, b + wt v = wt (g j) ∧ IsWeightedHomogeneous wt (c j) b) + (heq : pderiv v F = ∑ j, c j * pderiv (g j) F) : + pderiv v F ∈ Submodule.span (freeOf (R := R) B₀) (higherPartials F wt v) := by + classical + have hfree : ∀ j, c j ∈ freeOf (R := R) B₀ := by + intro j + obtain ⟨b, hb, hbhom⟩ := hchom j + refine mem_freeOf_of_isWeightedHomogeneous hbhom ?_ + have h1 : b < wt (g j) := by + rw [← hb] + exact lt_add_of_pos_right _ hv + exact h1.trans_le (hmax _ (hg j).1) + have hspan := mem_span_of_eq_sum_mul (B₀ := B₀) (Q := fun j ↦ pderiv (g j) F) hfree heq + refine Submodule.span_le.mpr ?_ hspan + rintro _ ⟨j, rfl⟩ + exact Submodule.subset_span ⟨g j, ⟨(hg j).1, (hg j).2⟩, rfl⟩ + +end MvPolynomial + +end diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/MvPolynomial/MapWeight.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/MvPolynomial/MapWeight.lean new file mode 100644 index 0000000000..505d8bc1fb --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/MvPolynomial/MapWeight.lean @@ -0,0 +1,46 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import Mathlib.RingTheory.MvPolynomial.WeightedHomogeneous + +/-! +# Changing the grading of a weighted homogeneous polynomial + +Weighted homogeneity is preserved when every weight and the total degree are mapped by the same +additive homomorphism. +-/ + +universe u v w + +public section + +namespace Finsupp + +variable {M : Type v} {N : Type w} [AddCommMonoid M] [AddCommMonoid N] {σ : Type*} + +/-- Applying an additive homomorphism to every weight applies it to the weight of the monomial. -/ +theorem weight_comp_addMonoidHom (f : M →+ N) (wt : σ → M) (d : σ →₀ ℕ) : + weight (fun i ↦ f (wt i)) d = f (weight wt d) := by + rw [weight_apply, weight_apply, sum, sum, map_sum] + exact Finset.sum_congr rfl fun i _ ↦ (f.map_nsmul (d i) (wt i)).symm + +end Finsupp + +namespace MvPolynomial + +variable {R : Type u} [CommSemiring R] {M : Type v} {N : Type w} +variable [AddCommMonoid M] [AddCommMonoid N] {σ : Type*} + +/-- Map the grading of a weighted homogeneous polynomial through an additive homomorphism. -/ +theorem IsWeightedHomogeneous.map_weight {wt : σ → M} {F : MvPolynomial σ R} {m : M} + (hF : IsWeightedHomogeneous wt F m) (f : M →+ N) : + IsWeightedHomogeneous (fun i ↦ f (wt i)) F (f m) := by + intro d hd + rw [Finsupp.weight_comp_addMonoidHom] + exact congrArg f (hF hd) + +end MvPolynomial diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/MvPolynomial/OrdinalDerivation.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/MvPolynomial/OrdinalDerivation.lean new file mode 100644 index 0000000000..1b9a4eae26 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/MvPolynomial/OrdinalDerivation.lean @@ -0,0 +1,416 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint +public import Mathlib.Algebra.MvPolynomial.PDeriv +public import Mathlib.Algebra.MvPolynomial.Derivation +public import Mathlib.Algebra.MvPolynomial.Variables +public import Mathlib.RingTheory.MvPolynomial.WeightedHomogeneous +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.FinitePart + +/-! +# Derivations of polynomial rings graded by ordinals + +Polynomial rings `R[X_i]` graded by `deg X_i = wt i` for ordinal degrees `wt : σ → NatOrdinal` +(Mathlib's `IsWeightedHomogeneous wt`). This file collects the degree bookkeeping for the +derivations `∂_g = ∑_i g_i ∂/∂X_i` (Lean `mkDerivation R g`) of such a ring: + +* a variable of a homogeneous polynomial has degree at most the polynomial's, and the finite part + of the degree of a monomial is the sum of the finite parts of the degrees of its variables; +* `∂/∂X_j ∘ ∂_g = ∂_{∂_j g} + ∂_g ∘ ∂/∂X_j`, and `∂_g F = ∑_{i ∈ S} g_i ∂F/∂X_i` for every finite + `S` containing the variables of `F`; +* the partial derivative `∂F/∂X_i` of a homogeneous `F` of degree `δ` is homogeneous of degree + `δ ⊖ wt i` when `wt i ≼ δ` in the algebraic order (there is `β` with + `β ⊕ wt i = δ`), and zero + otherwise; a derivation whose value on `X_i` is homogeneous of degree `wt i ⊖ 1` for `wt i` a + successor and zero otherwise sends homogeneous polynomials of degree `δ` to homogeneous + polynomials of degree `δ.removeNat 1`, which is `δ ⊖ 1` for a successor `δ`; +* Euler's identity `∑_i (wt i)_{<1} X_i ∂F/∂X_i = δ_{<1} F` for `F` homogeneous of degree `δ`, + where `α_{<1}` is the finite part of `α` (Lean `constantCoeff`, the constant term of the Cantor + normal form). +-/ + +universe u v + +open Finsupp + +public section + +namespace Finsupp + +variable {ι : Type u} (wt : ι → NatOrdinal) + +/-- The finite part of the degree of a monomial is the sum of the finite parts of the degrees of +its variables. -/ +theorem constantCoeff_weight (d : ι →₀ ℕ) : + (Finsupp.weight wt d).constantCoeff = ∑ i ∈ d.support, d i * (wt i).constantCoeff := by + classical + rw [Finsupp.weight_apply, Finsupp.sum] + induction d.support using Finset.induction_on with + | empty => simp + | insert a s ha ih => + rw [Finset.sum_insert ha, Finset.sum_insert ha, NatOrdinal.constantCoeff_add, + NatOrdinal.constantCoeff_nsmul, ih] + +/-- The degree of a monomial is at least the degree of each of its variables. -/ +theorem le_weight_of_mem_support (d : ι →₀ ℕ) {i : ι} (hi : i ∈ d.support) : + wt i ≤ Finsupp.weight wt d := by + classical + rw [Finsupp.weight_apply, Finsupp.sum] + refine le_trans ?_ (Finset.single_le_sum (fun j _ ↦ zero_le) hi) + have h1 : 1 ≤ d i := Nat.one_le_iff_ne_zero.mpr (Finsupp.mem_support_iff.mp hi) + calc wt i = 1 • wt i := (one_nsmul _).symm + _ ≤ d i • wt i := nsmul_le_nsmul_left zero_le h1 + +end Finsupp + +namespace MvPolynomial + +variable {σ : Type u} {R : Type v} [CommRing R] (wt : σ → NatOrdinal) + +/-! ### Variables and degrees -/ + +/-- A variable of a homogeneous polynomial has degree at most the polynomial's. -/ +theorem IsWeightedHomogeneous.wt_le_of_mem_vars {p : MvPolynomial σ R} {δ : NatOrdinal} + (hp : IsWeightedHomogeneous wt p δ) {i : σ} (hi : i ∈ p.vars) : wt i ≤ δ := by + obtain ⟨d, hd, hdi⟩ := (mem_vars_iff_mem_support i).mp hi + rw [← hp (mem_support_iff.mp hd)] + exact Finsupp.le_weight_of_mem_support wt d hdi + +/-! ### Derivations -/ + +/-- A finite sum of derivations, applied. -/ +theorem _root_.Derivation.finset_sum_apply {ι : Type*} (s : Finset ι) + (D : ι → Derivation R (MvPolynomial σ R) (MvPolynomial σ R)) (p : MvPolynomial σ R) : + (∑ i ∈ s, D i) p = ∑ i ∈ s, D i p := by + classical + induction s using Finset.induction_on with + | empty => simp + | insert a s ha ih => rw [Finset.sum_insert ha, Finset.sum_insert ha, Derivation.add_apply, ih] + +/-- `∂_g F = ∑_{i ∈ S} g_i ∂F/∂X_i` for every finite set `S` of variables containing those of +`F`. -/ +theorem mkDerivation_eq_sum (g : σ → MvPolynomial σ R) {p : MvPolynomial σ R} {S : Finset σ} + (hS : ∀ i ∈ p.vars, i ∈ S) : mkDerivation R g p = ∑ i ∈ S, g i * pderiv i p := by + classical + have h : mkDerivation R g p = (∑ i ∈ S, g i • pderiv i) p := by + refine derivation_eq_of_forall_mem_vars fun i hi ↦ ?_ + rw [mkDerivation_X, Derivation.finset_sum_apply, Finset.sum_eq_single i] + · rw [Derivation.smul_apply, pderiv_X_self, smul_eq_mul, mul_one] + · intro j _ hji + rw [Derivation.smul_apply, pderiv_X_of_ne hji.symm, smul_zero] + · intro hiS + exact absurd (hS i hi) hiS + rw [h, Derivation.finset_sum_apply] + exact Finset.sum_congr rfl fun i _ ↦ by rw [Derivation.smul_apply, smul_eq_mul] + +/-- `∂/∂X_j ∘ ∂_g = ∂_{∂_j g} + ∂_g ∘ ∂/∂X_j`. -/ +theorem pderiv_mkDerivation (g : σ → MvPolynomial σ R) (j : σ) (p : MvPolynomial σ R) : + pderiv j (mkDerivation R g p) = + mkDerivation R (fun i ↦ pderiv j (g i)) p + mkDerivation R g (pderiv j p) := by + classical + induction p using MvPolynomial.induction_on with + | C r => simp [derivation_C] + | add p q hp hq => simp only [map_add, hp, hq]; abel + | mul_X p i ih => + have hc : mkDerivation R g (pderiv j (X i)) = 0 := by + by_cases hij : i = j + · subst hij; rw [pderiv_X_self, ← C_1, derivation_C] + · rw [pderiv_X_of_ne hij, map_zero] + rw [Derivation.leibniz, Derivation.leibniz, smul_eq_mul, smul_eq_mul, smul_eq_mul, smul_eq_mul, + map_add, pderiv_mul, pderiv_mul, ih, mkDerivation_X, mkDerivation_X, pderiv_mul, map_add, + Derivation.leibniz, Derivation.leibniz, hc, smul_eq_mul, smul_eq_mul, smul_eq_mul, + smul_eq_mul, mkDerivation_X] + ring + +/-- Partial derivatives commute. -/ +theorem pderiv_pderiv_comm (i j : σ) (p : MvPolynomial σ R) : + pderiv i (pderiv j p) = pderiv j (pderiv i p) := by + classical + have hX : ∀ a b k : σ, pderiv a (pderiv b (X k : MvPolynomial σ R)) = 0 := fun a b k ↦ by + rcases eq_or_ne k b with rfl | h + · rw [pderiv_X_self, pderiv_one] + · rw [pderiv_X_of_ne h, map_zero] + induction p using MvPolynomial.induction_on with + | C r => simp + | add p q hp hq => simp only [map_add, hp, hq] + | mul_X p k ih => + rw [pderiv_mul, pderiv_mul, map_add, map_add, pderiv_mul, pderiv_mul, pderiv_mul, pderiv_mul, + ih, hX, hX] + ring + +/-- The variables of a partial derivative are among those of the polynomial. -/ +theorem vars_pderiv_subset (i : σ) (p : MvPolynomial σ R) : (pderiv i p).vars ⊆ p.vars := by + classical + intro j hj + obtain ⟨d', hd', hjd'⟩ := (mem_vars_iff_mem_support j).mp hj + -- `d'` is `d - single i 1` for a monomial `d` of `p` with `d i ≠ 0` + have : d' ∈ (p.support.image fun d ↦ d - Finsupp.single i 1) := by + have hsum : pderiv i p = + ∑ d ∈ p.support, monomial (d - Finsupp.single i 1) (AddMonoidAlgebra.coeff p d * d i) := by + conv_lhs => rw [p.as_sum, map_sum] + exact Finset.sum_congr rfl fun d _ ↦ pderiv_monomial + rw [hsum] at hd' + obtain ⟨d, hd, hd'd⟩ := Finset.mem_biUnion.mp (support_sum hd') + rw [support_monomial] at hd'd + split_ifs at hd'd with h0 + · exact absurd hd'd (Finset.notMem_empty d') + · rw [Finset.mem_singleton] at hd'd + subst hd'd + exact Finset.mem_image_of_mem _ hd + obtain ⟨d, hd, rfl⟩ := Finset.mem_image.mp this + exact (mem_vars_iff_mem_support j).mpr ⟨d, hd, Finsupp.support_tsub hjd'⟩ + +/-- A monomial of `∂_i p` comes from a monomial of `p` containing `X_i`, with one occurrence of +`X_i` removed. -/ +theorem exists_mem_support_of_mem_support_pderiv {i : σ} + {p : MvPolynomial σ R} {d' : σ →₀ ℕ} (hd' : d' ∈ (pderiv i p).support) : + ∃ d ∈ p.support, d i ≠ 0 ∧ d' = d - Finsupp.single i 1 := by + classical + have hsum : pderiv i p = + ∑ d ∈ p.support, monomial (d - Finsupp.single i 1) (AddMonoidAlgebra.coeff p d * d i) := by + conv_lhs => rw [p.as_sum, map_sum] + exact Finset.sum_congr rfl fun d _ ↦ pderiv_monomial + rw [hsum] at hd' + obtain ⟨d, hd, hd'd⟩ := Finset.mem_biUnion.mp (support_sum hd') + rw [support_monomial] at hd'd + split_ifs at hd'd with h0 + · exact absurd hd'd (Finset.notMem_empty d') + · rw [Finset.mem_singleton] at hd'd + exact ⟨d, hd, fun h ↦ h0 (by rw [h, Nat.cast_zero, mul_zero]), hd'd⟩ + +/-- A monomial of `∂_i p` comes from a monomial of `p` containing `X_i`, with the degree of +`X_i` removed. -/ +theorem exists_add_eq_weight_of_mem_support_pderiv (wt : σ → NatOrdinal) {i : σ} + {p : MvPolynomial σ R} {d' : σ →₀ ℕ} (hd' : d' ∈ (pderiv i p).support) : + ∃ d ∈ p.support, Finsupp.weight wt d' + wt i = Finsupp.weight wt d := by + obtain ⟨d, hd, hdi, rfl⟩ := exists_mem_support_of_mem_support_pderiv hd' + exact ⟨d, hd, Finsupp.weight_sub_single_add (w := wt) hdi⟩ + +/-! ### Nonvanishing of partial derivatives in characteristic zero -/ + +/-- The coefficient of `d - X_v` in `∂_v p`, for a monomial `d` containing `X_v`. -/ +theorem coeff_sub_single_pderiv {v : σ} {p : MvPolynomial σ R} {d : σ →₀ ℕ} (hd : d v ≠ 0) : + AddMonoidAlgebra.coeff (pderiv v p) (d - Finsupp.single v 1) = AddMonoidAlgebra.coeff p d * + (d v : R) := by + classical + have hsum : pderiv v p = + ∑ d' ∈ p.support, monomial (d' - Finsupp.single v 1) (AddMonoidAlgebra.coeff p d' * d' v) + := by + conv_lhs => rw [p.as_sum, map_sum] + exact Finset.sum_congr rfl fun d' _ ↦ pderiv_monomial + rw [hsum, MvPolynomial.coeff_sum] + by_cases hdp : d ∈ p.support + · rw [Finset.sum_eq_single d] + · rw [coeff_monomial, ite_eq_left rfl] + · intro d' _ hne + rw [coeff_monomial] + split_ifs with h + · by_cases hd'v : d' v = 0 + · rw [hd'v, Nat.cast_zero, mul_zero] + · exfalso + apply hne + have h1 := tsub_add_cancel_of_le + (Finsupp.single_le_iff.mpr (Nat.one_le_iff_ne_zero.mpr hd'v)) + have h2 := tsub_add_cancel_of_le + (Finsupp.single_le_iff.mpr (Nat.one_le_iff_ne_zero.mpr hd)) + rw [← h1, ← h2, h] + · rfl + · intro h; exact absurd hdp h + · rw [Finset.sum_eq_zero, notMem_support_iff.mp hdp, zero_mul] + intro d' hd' + rw [coeff_monomial] + split_ifs with h + · by_cases hd'v : d' v = 0 + · rw [hd'v, Nat.cast_zero, mul_zero] + · exfalso + have h1 := tsub_add_cancel_of_le + (Finsupp.single_le_iff.mpr (Nat.one_le_iff_ne_zero.mpr hd'v)) + have h2 := tsub_add_cancel_of_le (Finsupp.single_le_iff.mpr (Nat.one_le_iff_ne_zero.mpr hd)) + have : d' = d := by rw [← h1, ← h2, h] + exact hdp (this ▸ hd') + · rfl + +/-- In characteristic zero, the partial derivative with respect to a variable that occurs is +nonzero. -/ +theorem pderiv_ne_zero_of_mem_vars [NoZeroDivisors R] [CharZero R] {v : σ} + {p : MvPolynomial σ R} (hv : v ∈ p.vars) : pderiv v p ≠ 0 := by + obtain ⟨d, hd, hdv⟩ := (mem_vars_iff_mem_support v).mp hv + have hdv' : d v ≠ 0 := Finsupp.mem_support_iff.mp hdv + intro h + have := coeff_sub_single_pderiv (p := p) hdv' + rw [h, AddMonoidAlgebra.coeff_zero] at this + exact mul_ne_zero (mem_support_iff.mp hd) (Nat.cast_ne_zero.mpr hdv') this.symm + +/-! ### Homogeneity -/ + +/-- The partial derivative `∂/∂X_i` of a homogeneous polynomial of degree `δ` is homogeneous of +degree `β = δ ⊖ wt i` when `β ⊕ wt i = δ`. -/ +theorem isWeightedHomogeneous_pderiv {p : MvPolynomial σ R} {δ : NatOrdinal} + (hp : IsWeightedHomogeneous wt p δ) (i : σ) {β : NatOrdinal} (hβ : β + wt i = δ) : + IsWeightedHomogeneous wt (pderiv i p) β := by + classical + induction hp using IsWeightedHomogeneous.induction_on with + | zero => rw [map_zero]; exact isWeightedHomogeneous_zero R wt _ + | add p q _ _ ihp ihq => rw [map_add]; exact ihp.add ihq + | monomial d r hd => + rw [pderiv_monomial] + by_cases hdi : d i = 0 + · rw [hdi, Nat.cast_zero, mul_zero, monomial_zero] + exact isWeightedHomogeneous_zero R wt _ + · refine isWeightedHomogeneous_monomial wt _ _ ?_ + have h := Finsupp.weight_sub_single_add (w := wt) hdi + rw [hd] at h + exact add_right_cancel (h.trans hβ.symm) + +/-- If `p` is weighted-homogeneous of degree `δ` and `δ ≠ β + wt i` for every `β`, then the +partial derivative of `p` with respect to `X_i` vanishes. -/ +@[blueprint "lem:partial-derivative-vanishes" + (phase := "Algebraic and ordinal preliminaries") + (title := "Vanishing criterion for partial derivatives of weighted-homogeneous polynomials") + (statement := /-- + If $F$ is weighted-homogeneous of degree $\delta$ and + $\delta\ne\beta\oplus w(i)$ for every $\beta$, then $\partial_iF=0$. + -/) + (proof := /-- + Any monomial containing $X_i$ would express $\delta$ as the natural sum of + $w(i)$ and the weight left after removing one occurrence of $X_i$. + -/)] +theorem pderiv_eq_zero_of_isWeightedHomogeneous {p : MvPolynomial σ R} {δ : NatOrdinal} + (hp : IsWeightedHomogeneous wt p δ) (i : σ) (h : ¬ ∃ β, β + wt i = δ) : pderiv i p = 0 := by + classical + induction hp using IsWeightedHomogeneous.induction_on with + | zero => rw [map_zero] + | add p q _ _ ihp ihq => rw [map_add, ihp, ihq, add_zero] + | monomial d r hd => + rw [pderiv_monomial] + by_cases hdi : d i = 0 + · rw [hdi, Nat.cast_zero, mul_zero, monomial_zero] + · exact absurd ⟨_, (Finsupp.weight_sub_single_add (w := wt) hdi).trans hd⟩ h + +/-- Suppose `g i` is weighted-homogeneous of the degree obtained from `wt i` by subtracting one +from its positive constant Cantor coefficient, and is zero when that coefficient vanishes. The +derivation determined by `g` sends weight `δ` to the weight obtained by truncated subtraction of +one from the constant Cantor coefficient of `δ`. -/ +@[blueprint "lem:polynomial-vector-field-lowers-degree" + (phase := "Algebraic and ordinal preliminaries") + (title := "Weighted degree of polynomial derivations") + (statement := /-- + Suppose $g_i$ is weighted-homogeneous of the degree obtained from $w(i)$ by + subtracting one from its positive constant Cantor coefficient, and is zero + when that coefficient vanishes. If $F$ is weighted-homogeneous of degree + $\delta$, then $D_g(F)$ is weighted-homogeneous of the degree obtained by + truncated subtraction of one from the constant Cantor coefficient of + $\delta$ (so the degree remains $\delta$ when that coefficient is zero). + -/) + (proof := /-- + For a monomial, $\partial_iF$ removes $w(i)$ from the weight, while + multiplication by $g_i$ restores it with one subtracted from its constant + Cantor coefficient. Hessenberg addition therefore subtracts one from the + constant Cantor coefficient of $\delta$. Linearity handles sums. + -/)] +theorem mkDerivation_isWeightedHomogeneous_removeNat (g : σ → MvPolynomial σ R) + (hg : ∀ i, 0 < (wt i).constantCoeff → + IsWeightedHomogeneous wt (g i) ((wt i).removeNat 1)) + (hg0 : ∀ i, (wt i).constantCoeff = 0 → g i = 0) {p : MvPolynomial σ R} {δ : NatOrdinal} + (hp : IsWeightedHomogeneous wt p δ) : + IsWeightedHomogeneous wt (mkDerivation R g p) (δ.removeNat 1) := by + classical + induction hp using IsWeightedHomogeneous.induction_on with + | zero => rw [map_zero]; exact isWeightedHomogeneous_zero R wt _ + | add p q _ _ ihp ihq => rw [map_add]; exact ihp.add ihq + | monomial d r hd => + rw [mkDerivation_monomial, smul_eq_C_mul] + refine IsWeightedHomogeneous.C_mul ?_ r + unfold Finsupp.sum + refine IsWeightedHomogeneous.sum _ _ _ fun i hi ↦ ?_ + change IsWeightedHomogeneous wt (monomial (d - Finsupp.single i 1) (d i : R) • g i) _ + rw [smul_eq_mul] + by_cases hci : (wt i).constantCoeff = 0 + · rw [hg0 i hci, mul_zero] + exact isWeightedHomogeneous_zero R wt _ + · have hpos : 0 < (wt i).constantCoeff := Nat.pos_of_ne_zero hci + have hw : δ.removeNat 1 = + Finsupp.weight wt (d - Finsupp.single i 1) + (wt i).removeNat 1 := by + rw [← hd, ← Finsupp.weight_sub_single_add (w := wt) (Finsupp.mem_support_iff.mp hi), + add_comm, NatOrdinal.removeNat_add_right _ _ hpos, add_comm] + rw [hw] + exact (isWeightedHomogeneous_monomial wt _ _ rfl).mul (hg i hpos) + +/-! ### Euler's identity -/ + +/-- **Euler's identity** for constant Cantor coefficients. If `p` is weighted-homogeneous of +degree `δ` and `S` contains the variables of `p`, then +`∑ i ∈ S, (wt i).constantCoeff • (X i * pderiv i p) = δ.constantCoeff • p`. -/ +@[blueprint "lem:weighted-euler-identity" + (phase := "Algebraic and ordinal preliminaries") + (title := "Weighted Euler identity") + (statement := /-- + If $F$ is weighted-homogeneous of degree $\delta$ and $S$ is any finite + set containing its variables, then + \[ + \sum_{i\in S} n_iX_i\frac{\partial F}{\partial X_i}=nF, + \] + where $n_i$ and $n$ are the constant Cantor coefficients of $w(i)$ and + $\delta$. + -/) + (proof := /-- + On a monomial, the coefficient contributed by $X_i\partial_i$ is the + multiplicity of $X_i$. Weighted by the constant Cantor coefficient of + $w(i)$ and summed over $i$, this is the constant Cantor coefficient of the + monomial's total weight, namely $n$. Extend by linearity. + -/)] +theorem IsWeightedHomogeneous.sum_constantCoeff_X_mul_pderiv {p : MvPolynomial σ R} + {δ : NatOrdinal} (hp : IsWeightedHomogeneous wt p δ) {S : Finset σ} + (hS : ∀ i ∈ p.vars, i ∈ S) : + ∑ i ∈ S, (wt i).constantCoeff • (X i * pderiv i p) = δ.constantCoeff • p := by + classical + conv_lhs => rw [p.as_sum] + conv_rhs => rw [p.as_sum] + simp only [map_sum, Finset.mul_sum, Finset.smul_sum] + rw [Finset.sum_comm] + refine Finset.sum_congr rfl fun d hd ↦ ?_ + have hdsupp : ∀ i ∈ d.support, i ∈ S := fun i hi ↦ + hS i ((mem_vars_iff_mem_support i).mpr ⟨d, hd, hi⟩) + have hδ : δ.constantCoeff = ∑ i ∈ S, (wt i).constantCoeff * d i := by + rw [← hp (mem_support_iff.mp hd), Finsupp.constantCoeff_weight] + rw [← Finset.sum_subset (fun i hi ↦ hdsupp i hi) fun i _ hi ↦ by + rw [Finsupp.notMem_support_iff.mp hi, mul_zero]] + exact Finset.sum_congr rfl fun i _ ↦ mul_comm _ _ + rw [hδ, Finset.sum_smul] + refine Finset.sum_congr rfl fun i _ ↦ ?_ + rw [X_mul_pderiv_monomial, mul_smul, smul_comm] + +/-- **The differentiated syzygy contradiction.** Suppose a partial derivative of `F` is a +combination of other partial derivatives of `F` whose cofactors are free of a distinguished +variable, and suppose none of the differentiating variables occurs in the partial derivative of +`F` at that distinguished variable. Then that partial derivative of `F` is annihilated by the +differentiating variable: applying the distinguished derivation to the combination kills every +cofactor term and every remaining factor. + +This is the shape of the final contradiction of the limit step, where the annihilated partial is +known to be nonzero. -/ +theorem pderiv_pderiv_eq_zero_of_sum_of_notMem_vars {σ : Type*} + {R : Type*} [CommRing R] {F : MvPolynomial σ R} {B₀ B' : σ} {s : Finset σ} + {U : σ → MvPolynomial σ R} + (hsyz : pderiv B' F = ∑ B ∈ s, pderiv B F * U B) + (hU : ∀ B ∈ s, pderiv B₀ (U B) = 0) + (hvars : ∀ B ∈ s, B ∉ (pderiv B₀ F).vars) : + pderiv B' (pderiv B₀ F) = 0 := by + classical + have hkey : pderiv B₀ (pderiv B' F) = pderiv B₀ (∑ B ∈ s, pderiv B F * U B) := + congrArg (fun p ↦ pderiv B₀ p) hsyz + rw [pderiv_pderiv_comm, map_sum] at hkey + rw [hkey] + refine Finset.sum_eq_zero fun B hB ↦ ?_ + rw [pderiv_mul, hU B hB, mul_zero, add_zero, pderiv_pderiv_comm, + pderiv_eq_zero_of_notMem_vars (hvars B hB), zero_mul] + +end MvPolynomial + +end diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/MvPolynomial/OrdinalExpansion.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/MvPolynomial/OrdinalExpansion.lean new file mode 100644 index 0000000000..244b149238 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/MvPolynomial/OrdinalExpansion.lean @@ -0,0 +1,124 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MvPolynomial.Expansion +public import LeanPool.ConwayRefinement.CombinatorialGames.NatOrdinal.Basic + +/-! +# Expansion in one variable, for ordinal degrees + +The coefficient `xCoeff x k p` of `X x ^ k` in `p` +(`ConwayRefinement.Algebra.MvPolynomial.Expansion`) for a polynomial graded by ordinal +degrees `wt : σ → NatOrdinal`: homogeneity of the coefficients, +`xCoeff` of a product with a factor not involving `x`, `xCoeff` of `X x * p`, and the fact that a +polynomial of degree below `wt x` does not involve `x`. +-/ + +universe u v + +open MvPolynomial + +public noncomputable section + +namespace MvPolynomial + +variable {σ : Type u} {R : Type v} [CommRing R] [DecidableEq σ] (x : σ) (wt : σ → NatOrdinal) + +omit [DecidableEq σ] in +/-- A monomial involving `x` has degree at least `wt x`. -/ +theorem le_weight_of_ne_zero {d : σ →₀ ℕ} (hd : d x ≠ 0) : wt x ≤ Finsupp.weight wt d := by + calc wt x ≤ d x • wt x := by + simpa using nsmul_le_nsmul_left (bot_le : (0 : NatOrdinal) ≤ wt x) + (Nat.one_le_iff_ne_zero.mpr hd) + _ ≤ Finsupp.weight wt d := by + rw [Finsupp.weight_apply, Finsupp.sum] + exact Finset.single_le_sum (f := fun i ↦ d i • wt i) (fun _ _ ↦ bot_le) + (Finsupp.mem_support_iff.mpr hd) + +omit [DecidableEq σ] in +/-- A polynomial all of whose monomials have degree below `wt x` does not involve `x`. -/ +theorem mem_supported_of_forall_weight_lt {p : MvPolynomial σ R} + (hp : ∀ d ∈ p.support, Finsupp.weight wt d < wt x) : p ∈ supported R {x}ᶜ := by + rw [mem_supported] + intro y hy + rw [Set.mem_compl_iff, Set.mem_singleton_iff] + rintro rfl + obtain ⟨d, hd, hdy⟩ := (mem_vars_iff_mem_support y).mp hy + exact (hp d hd).not_ge (le_weight_of_ne_zero y wt (Finsupp.mem_support_iff.mp hdy)) + +omit [DecidableEq σ] in +/-- A polynomial homogeneous of degree below `wt x` does not involve `x`. -/ +theorem IsWeightedHomogeneous.mem_supported_of_lt' {p : MvPolynomial σ R} {w : NatOrdinal} + (hp : IsWeightedHomogeneous wt p w) (hw : w < wt x) : p ∈ supported R {x}ᶜ := + mem_supported_of_forall_weight_lt x wt fun _ hd ↦ (hp (mem_support_iff.mp hd)).symm ▸ hw + +/-- The coefficient of `X x ^ k` in a polynomial homogeneous of degree `w' ⊕ k ⊙ wt x` is +homogeneous of degree `w'`. -/ +theorem xCoeff_isWeightedHomogeneous' {p : MvPolynomial σ R} {w w' : NatOrdinal} + (hp : IsWeightedHomogeneous wt p w) (k : ℕ) (hw : w' + k • wt x = w) : + IsWeightedHomogeneous wt (xCoeff x k p) w' := by + intro m hm + rw [coeff_xCoeff] at hm + split_ifs at hm with h + · have := hp hm + rw [map_add, Finsupp.weight_single, ← hw] at this + exact add_right_cancel this + · exact absurd rfl hm + +/-- A nonzero coefficient of `X x ^ k` in a polynomial homogeneous of degree `w` has a degree `w'` +with `w' ⊕ k ⊙ wt x = w`. -/ +theorem exists_add_nsmul_eq_of_xCoeff_ne_zero {p : MvPolynomial σ R} {w : NatOrdinal} + (hp : IsWeightedHomogeneous wt p w) {k : ℕ} (h : xCoeff x k p ≠ 0) : + ∃ w' : NatOrdinal, w' + k • wt x = w := by + obtain ⟨m, hm⟩ := exists_coeff_ne_zero h + rw [coeff_xCoeff] at hm + split_ifs at hm with hmx + · refine ⟨Finsupp.weight wt m, ?_⟩ + have := hp hm + rwa [map_add, Finsupp.weight_single] at this + · exact absurd rfl hm + +/-- `xCoeff` of a product with a factor not involving `x`. -/ +theorem xCoeff_mul_of_mem_supported {a : MvPolynomial σ R} (ha : a ∈ supported R {x}ᶜ) (k : ℕ) + (p : MvPolynomial σ R) : xCoeff x k (a * p) = a * xCoeff x k p := by + obtain ⟨q, rfl⟩ := exists_rename_val_eq_of_mem_supported x ha + rw [xCoeff_apply, xCoeff_apply, map_mul, expandEquiv_rename_val, Polynomial.coeff_C_mul, + map_mul] + +/-- `xCoeff` of `X x * p`, positive index. -/ +theorem xCoeff_succ_X_mul (k : ℕ) (p : MvPolynomial σ R) : + xCoeff x (k + 1) (X x * p) = xCoeff x k p := by + rw [xCoeff_apply, xCoeff_apply, map_mul, expandEquiv_X_self, Polynomial.coeff_X_mul] + +/-- `xCoeff` of `X x * p`, index zero. -/ +theorem xCoeff_zero_X_mul (p : MvPolynomial σ R) : xCoeff x 0 (X x * p) = 0 := by + rw [xCoeff_apply, map_mul, expandEquiv_X_self, Polynomial.coeff_X_mul_zero, map_zero] + +/-- `xCoeff` of a polynomial not involving `x`: itself in index zero, zero otherwise. -/ +theorem xCoeff_of_mem_supported {a : MvPolynomial σ R} (ha : a ∈ supported R {x}ᶜ) (k : ℕ) : + xCoeff x k a = if k = 0 then a else 0 := by + have := xCoeff_mul_X_pow x ha k 0 + rwa [pow_zero, mul_one] at this + +/-- The monomials of `xCoeff x k p * X x ^ k` are monomials of `p`. -/ +theorem support_xCoeff_mul_X_pow_subset (k : ℕ) (p : MvPolynomial σ R) : + (xCoeff x k p * X x ^ k).support ⊆ p.support := by + classical + intro m hm + rw [mem_support_iff] at hm ⊢ + rw [X_pow_eq_monomial, coeff_mul_monomial'] at hm + split_ifs at hm with h + · rw [coeff_xCoeff] at hm + split_ifs at hm with h0 + · have hm' : m - Finsupp.single x k + Finsupp.single x k = m := by + rw [tsub_add_cancel_of_le h] + rwa [hm', mul_one] at hm + · rw [zero_mul] at hm + exact absurd rfl hm + · exact absurd rfl hm + +end MvPolynomial diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/MvPolynomial/RemainderBound.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/MvPolynomial/RemainderBound.lean new file mode 100644 index 0000000000..b09a62f335 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/MvPolynomial/RemainderBound.lean @@ -0,0 +1,156 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MvPolynomial.TermDegree +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.PairBounds +import Mathlib.Tactic.Abel + +/-! +# A uniform degree bound for terms with two translated truncations + +Fix an exponent `β` in the Cantor normal form. For a weighted-homogeneous polynomial of degree +`α`, consider the terms produced by the convolution formula in which at least two factors are +replaced by translated truncations. Among the terms whose Cantor terms at exponents at least `β` +agree with those of `α`, the sums of the remaining Cantor terms admit one strict upper bound below +the corresponding part of `α`. +-/ + +universe u v + +open scoped NatOrdinal +open Finsupp + +public noncomputable section + +namespace MvPolynomial + +variable {ι : Type u} {K : Type v} [CommRing K] {wt : ι → NatOrdinal} + +/-! ### Equal sums of comparable summands -/ + +theorem _root_.NatOrdinal.eq_and_eq_of_add_eq_add_of_le {a a' b b' : NatOrdinal} (ha : a ≤ a') + (hb : b ≤ b') (h : a + b = a' + b') : a = a' ∧ b = b' := by + have h1 : a' + b ≤ a + b := by rw [h]; exact add_le_add_right hb _ + have h2 : a + b' ≤ a + b := by rw [h]; exact add_le_add_left ha _ + exact ⟨le_antisymm ha (le_of_add_le_add_right h1), le_antisymm hb (le_of_add_le_add_left h2)⟩ + +/-! ### The bound -/ + +/-- Uniform bound below the part of the weighted degree supported at Cantor exponents below `β` for +convolution terms containing at least two translated truncations. -/ +@[blueprint "lem:two-truncations-below" + (phase := "Algebraic and ordinal preliminaries") + (title := "Weighted-degree bound for terms with two translated truncations") + (statement := /-- + For an ordinal $\xi$, write $\xi_{<\beta}$ and $\xi_{\ge\beta}$ for the + Hessenberg sums of the terms in its Cantor normal form whose exponents are, + respectively, below $\beta$ and at least $\beta$. + + Let $K$ be a commutative ring, give each variable $X_i$ an ordinal weight + $w_i$, and let $F\in K[X_i:i\in I]$ be weighted homogeneous of degree + $\alpha$, with $\alpha_{<\beta}\ne0$. Suppose that whenever $X_i$ occurs + in $F$ and $(w_i)_{<\beta}\ne0$, the last term of the Cantor normal form of + $(w_i)_{<\beta}$ is $\omega^e$ for some $e\ne0$. + + There is $\lambda<\alpha_{<\beta}$ such that the following holds. For every + monomial $X^d$ occurring in $F$, every factorisation + $X^d=X^{d'}X_{i_1}\cdots X_{i_k}$ with $k\ge2$, and all + $\rho_j AddMonoidAlgebra.coeff p d)) hu + rw [coeff_sum, AddMonoidAlgebra.coeff_zero] at this + simpa only [coeff_C_mul, Finsupp.zero_apply] using this + · conv_lhs => rw [(u b).as_sum] + rw [Finset.sum_subset (Finset.subset_biUnion_of_mem (fun b ↦ (u b).support) + (Finset.mem_univ b))] + · exact Finset.sum_congr rfl fun d _ ↦ by rw [mul_comm, C_mul_monomial, mul_one] + · intro d _ hd + rw [MvPolynomial.notMem_support_iff.mp hd, monomial_zero] + +end BaseChange + +section Supported + +variable {K : Type u} [Field K] {ι : Type w} {B : Type v} [Fintype B] + +/-- The isomorphism `K[X_i : i ∈ ι] ≅ K[X_i : i ∈ Λ][X_i : i ∉ Λ]` separating the variables in +`Λ`. -/ +noncomputable def splitVariables (Λ : Set ι) [DecidablePred (· ∈ Λ)] : + MvPolynomial ι K ≃ₐ[K] MvPolynomial {i // i ∉ Λ} (MvPolynomial Λ K) := + (renameEquiv K ((Equiv.sumComm _ _).trans (Equiv.sumCompl (· ∈ Λ))).symm).trans + (sumAlgEquiv K _ _) + +/-- A polynomial in the variables of `Λ` becomes a constant. -/ +theorem splitVariables_rename (Λ : Set ι) [DecidablePred (· ∈ Λ)] (q : MvPolynomial Λ K) : + splitVariables Λ (rename (Subtype.val : Λ → ι) q) = C q := by + set f : {i // i ∉ Λ} ⊕ Λ ≃ ι := (Equiv.sumComm _ _).trans (Equiv.sumCompl (· ∈ Λ)) with hf + have hval : (Subtype.val : Λ → ι) = f ∘ Sum.inr := by + funext a + simp [hf] + have h1 : splitVariables (K := K) Λ (rename (Subtype.val : Λ → ι) q) = + sumAlgEquiv K {i // i ∉ Λ} Λ (rename Sum.inr q) := by + rw [splitVariables, AlgEquiv.trans_apply, hval, ← rename_rename, renameEquiv_apply, + rename_rename, Equiv.symm_comp_self] + simp + have h2 := AlgHom.congr_fun (sumAlgEquiv_comp_rename_inr K {i // i ∉ Λ} Λ) q + simp only [AlgHom.comp_apply, IsScalarTower.toAlgHom_apply, algebraMap_eq] at h2 + rw [h1] + exact h2 + +/-- A constant comes from a polynomial in the variables of `Λ`. -/ +theorem splitVariables_symm_C (Λ : Set ι) [DecidablePred (· ∈ Λ)] (q : MvPolynomial Λ K) : + (splitVariables Λ).symm (C q) = rename (Subtype.val : Λ → ι) q := by + rw [← splitVariables_rename Λ q, AlgEquiv.symm_apply_apply] + +/-- **Finitely many generating syzygies with entries in the variables of `Λ`.** For a finite set +`Λ` of variables and `c_b ∈ K[X_i : i ∈ Λ]`, there are finitely many syzygies of `c` with entries +in `K[X_i : i ∈ Λ]` generating the `K[X_i : i ∈ ι]`-module of all syzygies of `c`. -/ +@[blueprint "lem:syzygies-finite-variables" + (phase := "Algebraic and ordinal preliminaries") + (title := "Finite generation of polynomial syzygies") + (statement := /-- + Let $B$ be a finite set, let $\Lambda\subseteq I$ be finite, and let + $c_b\in K[X_i:i\in\Lambda]$ for every $b\in B$. There is a finite family + of tuples $\sigma\in K[X_i:i\in\Lambda]^B$ satisfying + $\sum_{b\in B}c_b\sigma_b=0$ that generates, over $K[X_i:i\in I]$, every + tuple $u\in K[X_i:i\in I]^B$ satisfying $\sum_{b\in B}c_bu_b=0$. + -/) + (proof := /-- + The ring $K[X_i:i\in\Lambda]$ is Noetherian, so the kernel of + $(u_b)\mapsto\sum_bc_bu_b$ is finitely generated. Identify + $K[X_i:i\in I]$ with a polynomial ring in the remaining variables over + $K[X_i:i\in\Lambda]$. Expanding an arbitrary syzygy in those variables makes + each coefficient tuple a syzygy over $K[X_i:i\in\Lambda]$. Express each such + tuple in the chosen finite generating family and reassemble the polynomial. + -/)] +theorem exists_finset_syzygy_span_supported (Λ : Set ι) [Finite Λ] (c : B → MvPolynomial ι K) + (hc : ∀ b, c b ∈ supported K Λ) : + ∃ L : Finset (B → MvPolynomial ι K), + (∀ σ ∈ L, (∀ b, σ b ∈ supported K Λ) ∧ ∑ b, c b * σ b = 0) ∧ + ∀ u : B → MvPolynomial ι K, ∑ b, c b * u b = 0 → + u ∈ Submodule.span (MvPolynomial ι K) (L : Set (B → MvPolynomial ι K)) := by + classical + -- lifts of the `c_b` to `K[X_i : i ∈ Λ]` + have hc' : ∀ b, ∃ q : MvPolynomial Λ K, rename (Subtype.val : Λ → ι) q = c b := fun b ↦ by + have := hc b + rwa [supported_eq_range_rename, AlgHom.mem_range] at this + choose c₀ hc₀ using hc' + obtain ⟨L₀, hL₀, hspan₀⟩ := exists_finset_syzygy_span c₀ + let ρ : (B → MvPolynomial Λ K) → (B → MvPolynomial ι K) := fun σ b ↦ rename Subtype.val (σ b) + refine ⟨L₀.image ρ, fun σ hσ ↦ ?_, fun u hu ↦ ?_⟩ + · obtain ⟨σ₀, hσ₀, rfl⟩ := Finset.mem_image.mp hσ + refine ⟨fun b ↦ ?_, ?_⟩ + · rw [supported_eq_range_rename] + exact ⟨σ₀ b, rfl⟩ + · have := congrArg (rename (Subtype.val : Λ → ι)) (hL₀ σ₀ hσ₀) + rw [map_sum, map_zero] at this + simpa only [map_mul, hc₀] using this + · -- separate the variables: the entries of `u` are polynomials over `K[X_i : i ∈ Λ]` + set e := splitVariables (K := K) Λ with hedef + have hu' : ∑ b, C (c₀ b) * e (u b) = 0 := by + have := congrArg e hu + rw [map_sum, map_zero] at this + simpa only [map_mul, ← hc₀, hedef, splitVariables_rename] using this + obtain ⟨m, v, hv, huv⟩ := + exists_eq_sum_monomial_mul_C_of_sum_C_mul_eq_zero c₀ (fun b ↦ e (u b)) hu' + -- the coefficient tuples are combinations of the generators + have hvspan : ∀ d, d ∈ m → ∃ r : (B → MvPolynomial Λ K) → MvPolynomial Λ K, + ∑ σ₀ ∈ L₀, r σ₀ • σ₀ = v d := fun d hd ↦ by + obtain ⟨f, _, hf⟩ := Submodule.mem_span_finset.mp (hspan₀ (v d) (hv d hd)) + exact ⟨f, hf⟩ + choose! r hr using hvspan + have hu_eq : u = ∑ d ∈ m, ∑ σ₀ ∈ L₀, + (e.symm (monomial d 1) * rename Subtype.val (r d σ₀)) • ρ σ₀ := by + funext b + have hvb : ∀ d ∈ m, v d b = ∑ σ₀ ∈ L₀, r d σ₀ * σ₀ b := fun d hd ↦ by + rw [← hr d hd, Finset.sum_apply] + rfl + calc u b = e.symm (e (u b)) := (e.symm_apply_apply _).symm + _ = ∑ d ∈ m, e.symm (monomial d 1) * rename Subtype.val (v d b) := by + rw [huv b, map_sum] + exact Finset.sum_congr rfl fun d _ ↦ by rw [map_mul, hedef, splitVariables_symm_C] + _ = ∑ d ∈ m, ∑ σ₀ ∈ L₀, + (e.symm (monomial d 1) * rename Subtype.val (r d σ₀)) * rename Subtype.val (σ₀ b) := by + refine Finset.sum_congr rfl fun d hd ↦ ?_ + rw [hvb d hd, map_sum, Finset.mul_sum] + exact Finset.sum_congr rfl fun σ₀ _ ↦ by rw [map_mul, mul_assoc] + _ = _ := by + simp only [Finset.sum_apply, Pi.smul_apply, smul_eq_mul, ρ] + rw [hu_eq] + exact Submodule.sum_mem _ fun d _ ↦ Submodule.sum_mem _ fun σ₀ hσ₀ ↦ + Submodule.smul_mem _ _ (Submodule.subset_span (Finset.mem_image_of_mem ρ hσ₀)) + +end Supported + +end MvPolynomial + +end diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/MvPolynomial/TermDegree.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/MvPolynomial/TermDegree.lean new file mode 100644 index 0000000000..8f570928a7 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/MvPolynomial/TermDegree.lean @@ -0,0 +1,148 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MvPolynomial.OrdinalDerivation + +/-! +# Degrees of the terms of a truncated expansion + +Expanding a monomial by the convolution formula produces terms in which some factors are truncated +and the rest are not. `MvPolynomial.TermDegree wt d k rho` records that `rho` is the degree of such +a term for the monomial `d` with exactly `k` truncated factors: an untruncated `X_i` contributes +`wt i`, a truncated one some smaller ordinal. + +This is bookkeeping about the weights alone, with no series in it, and the limit step needs it to +bound the terms with at least two truncated factors. +-/ + +universe u v + +open Finsupp + +public section + +namespace MvPolynomial + +variable {ι : Type u} {R : Type v} [CommRing R] {wt : ι → NatOrdinal} + +/-- `TermDegree wt d k ρ`: `ρ` is the degree of a term of the expansion of the monomial `d` by the +convolution formula in which exactly `k` factors are truncated — each untruncated factor `X_i` +contributes `wt i`, each truncated one some `ρ' < wt i`. -/ +inductive TermDegree (wt : ι → NatOrdinal) : (ι →₀ ℕ) → ℕ → NatOrdinal → Prop + | zero : TermDegree wt 0 0 0 + | untrunc {d : ι →₀ ℕ} {k : ℕ} {ρ : NatOrdinal} (i : ι) : + TermDegree wt d k ρ → TermDegree wt (d + Finsupp.single i 1) k (ρ + wt i) + | trunc {d : ι →₀ ℕ} {k : ℕ} {ρ ρ' : NatOrdinal} (i : ι) (h : ρ' < wt i) : + TermDegree wt d k ρ → TermDegree wt (d + Finsupp.single i 1) (k + 1) (ρ + ρ') + +/-- Appending untruncated factors. -/ +theorem TermDegree.add_right {d d' : ι →₀ ℕ} {k : ℕ} {ρ : NatOrdinal} + (h : TermDegree wt d k ρ) : TermDegree wt (d + d') k (ρ + Finsupp.weight wt d') := by + classical + induction d' using Finsupp.induction with + | zero => simpa using h + | single_add a b f haf hb ih => + rw [add_comm (Finsupp.single a b) f, ← add_assoc, map_add, ← add_assoc] + clear haf hb + induction b with + | zero => simpa using ih + | succ b ihb => + rw [show Finsupp.single a (b + 1) = Finsupp.single a b + Finsupp.single a 1 from + Finsupp.single_add a b 1, ← add_assoc, map_add, ← add_assoc, + Finsupp.weight_single wt a 1, one_smul] + exact TermDegree.untrunc a ihb + +/-- The term of a monomial with no truncated factor has the degree of the monomial. -/ +theorem termDegree_weight (wt : ι → NatOrdinal) (d : ι →₀ ℕ) : + TermDegree wt d 0 (Finsupp.weight wt d) := by + have := TermDegree.add_right (wt := wt) (d' := d) TermDegree.zero + rwa [zero_add, zero_add] at this + +/-- Appending untruncated factors on the left. -/ +theorem TermDegree.add_left {d d' : ι →₀ ℕ} {k : ℕ} {ρ : NatOrdinal} + (h : TermDegree wt d k ρ) : TermDegree wt (d' + d) k (Finsupp.weight wt d' + ρ) := by + rw [add_comm d' d, add_comm _ ρ] + exact h.add_right + +/-- A truncated factor `X_i`, appended on the left. -/ +theorem TermDegree.trunc_left {d : ι →₀ ℕ} {k : ℕ} {ρ ρ' : NatOrdinal} (i : ι) (h : ρ' < wt i) + (hd : TermDegree wt d k ρ) : TermDegree wt (Finsupp.single i 1 + d) (k + 1) (ρ' + ρ) := by + rw [add_comm (Finsupp.single i 1) d, add_comm ρ' ρ] + exact TermDegree.trunc i h hd + +/-- A monomial of a product of two polynomials has a degree that is the natural sum of degrees +of monomials of the factors. -/ +theorem exists_add_eq_weight_of_mem_support_mul {P Q : MvPolynomial ι R} {d : ι →₀ ℕ} + (hd : d ∈ (P * Q).support) : + ∃ d₁ ∈ P.support, ∃ d₂ ∈ Q.support, + Finsupp.weight wt d₁ + Finsupp.weight wt d₂ = Finsupp.weight wt d := by + classical + obtain ⟨d₁, hd₁, d₂, hd₂, rfl⟩ := Finset.mem_add.mp (support_mul P Q hd) + exact ⟨d₁, hd₁, d₂, hd₂, (map_add _ _ _).symm⟩ + +/-- Every term of the expansion has degree at most that of the monomial. -/ +theorem TermDegree.le_weight {d : ι →₀ ℕ} {k : ℕ} {ρ : NatOrdinal} (h : TermDegree wt d k ρ) : + ρ ≤ Finsupp.weight wt d := by + induction h with + | zero => simp + | untrunc i _ ih => rw [map_add, Finsupp.weight_single, one_smul]; exact add_le_add_left ih _ + | trunc i hlt _ ih => + rw [map_add, Finsupp.weight_single, one_smul] + exact add_le_add ih hlt.le + +/-- A term with a truncated factor: the monomial is `d' · X_i`, the degree at most `deg d' ⊕ ρ'` +with `ρ' < wt i`. -/ +theorem TermDegree.exists_single_truncated {d : ι →₀ ℕ} {k : ℕ} {ρ : NatOrdinal} + (h : TermDegree wt d k ρ) (hk : 1 ≤ k) : + ∃ (i : ι) (d' : ι →₀ ℕ) (ρ' : NatOrdinal), d = d' + Finsupp.single i 1 ∧ ρ' < wt i ∧ + ρ ≤ Finsupp.weight wt d' + ρ' := by + induction h with + | zero => exact absurd hk (by omega) + | untrunc i _ ih => + obtain ⟨i', d', ρ', rfl, hρ', hle⟩ := ih hk + refine ⟨i', d' + Finsupp.single i 1, ρ', by rw [add_right_comm], hρ', ?_⟩ + rw [map_add, Finsupp.weight_single, one_smul, add_right_comm] + exact add_le_add_left hle _ + | trunc i hlt hd _ => + exact ⟨i, _, _, rfl, hlt, add_le_add_left hd.le_weight _⟩ + +/-- A term with two truncated factors: the monomial is `d' · X_i · X_j`, the degree at most +`deg d' ⊕ ρ'_i ⊕ ρ'_j` with `ρ'_i < wt i`, `ρ'_j < wt j`. -/ +theorem TermDegree.exists_two_truncated {d : ι →₀ ℕ} {k : ℕ} {ρ : NatOrdinal} + (h : TermDegree wt d k ρ) (hk : 2 ≤ k) : + ∃ (i j : ι) (d' : ι →₀ ℕ) (ρᵢ ρⱼ : NatOrdinal), + d = d' + Finsupp.single i 1 + Finsupp.single j 1 ∧ ρᵢ < wt i ∧ ρⱼ < wt j ∧ + ρ ≤ Finsupp.weight wt d' + ρᵢ + ρⱼ := by + induction h with + | zero => exact absurd hk (by omega) + | untrunc i _ ih => + obtain ⟨i', j', d', ρᵢ, ρⱼ, rfl, hρᵢ, hρⱼ, hle⟩ := ih hk + refine ⟨i', j', d' + Finsupp.single i 1, ρᵢ, ρⱼ, by + rw [add_right_comm, add_right_comm d' (Finsupp.single i' 1)], hρᵢ, hρⱼ, ?_⟩ + rw [map_add, Finsupp.weight_single, one_smul] + calc _ ≤ Finsupp.weight wt d' + ρᵢ + ρⱼ + wt i := add_le_add_left hle _ + _ = Finsupp.weight wt d' + wt i + ρᵢ + ρⱼ := by abel + | trunc i hlt hd _ => + obtain ⟨i', d', ρ', rfl, hρ', hle⟩ := hd.exists_single_truncated (by omega) + exact ⟨i', i, d', ρ', _, rfl, hρ', hlt, add_le_add_left hle _⟩ + +/-- Truncating exactly two factors of a monomial `d' · X_i · X_j`. -/ +theorem termDegree_pair (d' : ι →₀ ℕ) {i j : ι} {ρᵢ ρⱼ : NatOrdinal} (hρᵢ : ρᵢ < wt i) + (hρⱼ : ρⱼ < wt j) : + TermDegree wt (d' + Finsupp.single i 1 + Finsupp.single j 1) 2 + (Finsupp.weight wt d' + ρᵢ + ρⱼ) := + TermDegree.trunc j hρⱼ (TermDegree.trunc i hρᵢ (termDegree_weight wt d')) + +/-- A term of the expansion of a monomial by the convolution formula in which at least one factor +is a translated truncation at a cutoff `ζ < 0` has degree below that of the monomial. -/ +theorem TermDegree.lt_weight {d : ι →₀ ℕ} {k : ℕ} {ρ : NatOrdinal} (h : TermDegree wt d k ρ) + (hk : 1 ≤ k) : ρ < Finsupp.weight wt d := by + obtain ⟨i, d', ρ', rfl, hρ', hle⟩ := h.exists_single_truncated hk + rw [map_add, Finsupp.weight_single, one_smul] + exact hle.trans_lt (add_lt_add_right hρ' _) + +end MvPolynomial diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/MvPolynomial/WeightedTotalDegree.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/MvPolynomial/WeightedTotalDegree.lean new file mode 100644 index 0000000000..a0aaff9316 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/MvPolynomial/WeightedTotalDegree.lean @@ -0,0 +1,177 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import Mathlib.RingTheory.MvPolynomial.WeightedHomogeneous +public import Mathlib.Algebra.MvPolynomial.CommRing +public import Mathlib.Data.Nat.Cast.Order.Basic + +import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MvPolynomial.MapWeight + +/-! +# The top weighted-homogeneous component + +For weights in a linearly ordered monoid with a bottom element, a nonzero multivariate polynomial +is the finite sum of its weighted-homogeneous components over the weights occurring in its +support, its component at the weighted total degree is nonzero, and removing that component +either leaves zero or strictly lowers the weighted total degree. Weights in `ℕ` read in the +monoid through `Nat.cast` have the cast weights, homogeneous components and weighted total +degree. +-/ + +universe u v w + +public noncomputable section + +namespace MvPolynomial + +variable {σ : Type u} {R : Type v} {M : Type w} +variable [AddCommMonoid M] [LinearOrder M] [OrderBot M] (w : σ → M) + +section CommSemiring + +variable [CommSemiring R] + +/-- The weighted-homogeneous component of a nonzero polynomial at its weighted total degree is +nonzero. -/ +theorem weightedHomogeneousComponent_weightedTotalDegree_ne_zero {F : MvPolynomial σ R} + (hF : F ≠ 0) : + weightedHomogeneousComponent w (weightedTotalDegree w F) F ≠ 0 := by + classical + obtain ⟨d, hd, hsup⟩ := Finset.exists_mem_eq_sup F.support (support_nonempty.mpr hF) + fun s ↦ Finsupp.weight w s + intro h0 + have := coeff_weightedHomogeneousComponent (w := w) (n := weightedTotalDegree w F) (φ := F) d + rw [h0, AddMonoidAlgebra.coeff_zero, weightedTotalDegree, hsup, ite_eq_left rfl] at this + exact mem_support_iff.mp hd this.symm + +omit [OrderBot M] in +/-- Every polynomial is the finite sum of its weighted-homogeneous components over the weights +occurring in its support. -/ +theorem eq_sum_weightedHomogeneousComponent (F : MvPolynomial σ R) : + F = ∑ m ∈ F.support.image (fun s ↦ Finsupp.weight w s), + weightedHomogeneousComponent w m F := by + classical + refine MvPolynomial.ext _ _ fun d ↦ ?_ + rw [coeff_sum] + simp only [coeff_weightedHomogeneousComponent] + by_cases hd : d ∈ F.support + · rw [Finset.sum_eq_single (Finsupp.weight w d)] + · rw [ite_eq_left rfl] + · intro m _ hm + rw [ite_eq_right (Ne.symm hm)] + · intro hnot + exact absurd (Finset.mem_image_of_mem _ hd) hnot + · rw [notMem_support_iff.mp hd] + exact (Finset.sum_eq_zero fun m _ ↦ ite_self 0).symm + +end CommSemiring + +section CommRing + +variable [CommRing R] + +/-- Removing the top weighted-homogeneous component of a polynomial leaves zero or a polynomial +of strictly smaller weighted total degree. -/ +theorem weightedTotalDegree_sub_weightedHomogeneousComponent_lt (F : MvPolynomial σ R) : + F - weightedHomogeneousComponent w (weightedTotalDegree w F) F = 0 ∨ + weightedTotalDegree w (F - weightedHomogeneousComponent w (weightedTotalDegree w F) F) < + weightedTotalDegree w F := by + classical + set d := weightedTotalDegree w F with hd + set G := weightedHomogeneousComponent w d F with hG + by_cases hFG : F - G = 0 + · exact Or.inl hFG + refine Or.inr (lt_of_le_of_ne (Finset.sup_le fun s hs ↦ ?_) fun heq ↦ ?_) + · have hs' : AddMonoidAlgebra.coeff (F - G) s ≠ 0 := mem_support_iff.mp hs + have hsub : AddMonoidAlgebra.coeff (F - G) s = + if Finsupp.weight w s = d then 0 else AddMonoidAlgebra.coeff F s := by + rw [coeff_sub, hG, coeff_weightedHomogeneousComponent] + split_ifs <;> simp + have hne : Finsupp.weight w s ≠ d := by + intro heq + rw [hsub, ite_eq_left heq] at hs' + exact hs' rfl + have hFne : AddMonoidAlgebra.coeff F s ≠ 0 := by + rw [hsub, ite_eq_right hne] at hs' + exact hs' + exact le_weightedTotalDegree _ (mem_support_iff.mpr hFne) + · obtain ⟨s, hs, hsup⟩ := Finset.exists_mem_eq_sup (F - G).support (support_nonempty.mpr hFG) + fun s ↦ Finsupp.weight w s + have hs' : AddMonoidAlgebra.coeff (F - G) s ≠ 0 := mem_support_iff.mp hs + have hweight : Finsupp.weight w s = d := by + rw [← heq, weightedTotalDegree, hsup] + rw [coeff_sub, hG, coeff_weightedHomogeneousComponent, ite_eq_left hweight, sub_self] at hs' + exact hs' rfl + +end CommRing + +end MvPolynomial + +/-! ### Weights in `ℕ` read in `M` through `Nat.cast` -/ + +namespace MvPolynomial + +variable {σ : Type u} {R : Type v} {M : Type w} + +section Cast + +variable [AddCommMonoidWithOne M] + +/-- For weights in `ℕ` read in `M` through `Nat.cast`, the weight of a monomial is the cast of its +weight in `ℕ`. -/ +theorem weight_natCast_comp (w : σ → ℕ) (e : σ →₀ ℕ) : + Finsupp.weight (fun i ↦ (w i : M)) e = ((Finsupp.weight w e : ℕ) : M) := by + simpa only [Nat.coe_castAddMonoidHom] using + Finsupp.weight_comp_addMonoidHom (Nat.castAddMonoidHom M) w e + +variable [CommSemiring R] + +/-- A nonzero polynomial homogeneous for cast natural weights has a cast natural degree. -/ +theorem IsWeightedHomogeneous.exists_degree_eq_natCast {w : σ → ℕ} + {F : MvPolynomial σ R} {d : M} + (hF : IsWeightedHomogeneous (fun i ↦ (w i : M)) F d) (hF0 : F ≠ 0) : + ∃ n : ℕ, d = (n : M) := by + obtain ⟨e, he⟩ := exists_coeff_ne_zero hF0 + refine ⟨Finsupp.weight w e, ?_⟩ + rw [← hF he, weight_natCast_comp] + +variable [CharZero M] + +/-- Homogeneity of degree `d` for weights read through `Nat.cast` is homogeneity of degree `d` for +the weights in `ℕ`. -/ +theorem isWeightedHomogeneous_natCast_comp_iff (w : σ → ℕ) {F : MvPolynomial σ R} {d : ℕ} : + IsWeightedHomogeneous (fun i ↦ (w i : M)) F (d : M) ↔ IsWeightedHomogeneous w F d := by + simp only [IsWeightedHomogeneous, weight_natCast_comp, Nat.cast_inj] + +/-- The homogeneous component of degree `d` for weights read through `Nat.cast` is the one for the +weights in `ℕ`. -/ +theorem weightedHomogeneousComponent_natCast_comp (w : σ → ℕ) (d : ℕ) (F : MvPolynomial σ R) : + weightedHomogeneousComponent (fun i ↦ (w i : M)) (d : M) F = + weightedHomogeneousComponent w d F := by + classical + ext e + rw [coeff_weightedHomogeneousComponent, coeff_weightedHomogeneousComponent, weight_natCast_comp, + Nat.cast_inj] + by_cases h : Finsupp.weight w e = d <;> simp [h] + +variable [LinearOrder M] [OrderBot M] [AddLeftMono M] [ZeroLEOneClass M] + +omit [CharZero M] in +/-- The weighted total degree for weights read through `Nat.cast` is the cast of the weighted +total degree for the weights in `ℕ`, when `⊥ = 0` in `M`. -/ +theorem weightedTotalDegree_natCast_comp (hbot : (⊥ : M) = 0) (w : σ → ℕ) + (F : MvPolynomial σ R) : + weightedTotalDegree (fun i ↦ (w i : M)) F = ((weightedTotalDegree w F : ℕ) : M) := by + change F.support.sup (fun s ↦ Finsupp.weight (fun i ↦ (w i : M)) s) = + ((F.support.sup fun s ↦ Finsupp.weight w s : ℕ) : M) + rw [Finset.apply_sup_eq_sup_comp_of_linearOrder (Nat.cast : ℕ → M) Nat.mono_cast + (by rw [Nat.bot_eq_zero, Nat.cast_zero, hbot])] + exact Finset.sup_congr rfl fun s _ ↦ weight_natCast_comp w s + +end Cast + +end MvPolynomial diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Order.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Order.lean new file mode 100644 index 0000000000..e31be8188a --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Order.lean @@ -0,0 +1,14 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Order.ArchimedeanBall +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Order.ArchimedeanQuotient +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Order.ConvexQuotient +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Order.Module + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Order/ArchimedeanBall.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Order/ArchimedeanBall.lean new file mode 100644 index 0000000000..71e513aec7 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Order/ArchimedeanBall.lean @@ -0,0 +1,52 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import Mathlib.Algebra.Order.Archimedean.Class +public import Mathlib.Order.Interval.Set.OrdConnected + +/-! +# Convex Archimedean balls + +Closed Archimedean balls are convex additive subgroups of the exponent group. +-/ + +public section + +namespace FiniteArchimedeanClass + +variable {G : Type*} [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + +private theorem archimedeanClosedBall_ordConnected (c : ArchimedeanClass G) : + (ArchimedeanClass.closedBallAddSubgroup c : Set G).OrdConnected := by + constructor + intro g hg h hh k hk + change g ∈ ArchimedeanClass.closedBallAddSubgroup c at hg + change h ∈ ArchimedeanClass.closedBallAddSubgroup c at hh + change k ∈ ArchimedeanClass.closedBallAddSubgroup c + rw [ArchimedeanClass.mem_closedBallAddSubgroup_iff] at hg hh ⊢ + exact (le_min hg hh).trans (ArchimedeanClass.min_le_mk_of_le_of_le hk.1 hk.2) + +private theorem finiteClosedBall_eq_closedBall (c : FiniteArchimedeanClass G) : + (FiniteArchimedeanClass.closedBallAddSubgroup c : Set G) = + (ArchimedeanClass.closedBallAddSubgroup c.1 : Set G) := by + ext g + rw [SetLike.mem_coe, SetLike.mem_coe, + FiniteArchimedeanClass.mem_closedBallAddSubgroup_iff, + ArchimedeanClass.mem_closedBallAddSubgroup_iff] + by_cases hg : g = 0 + · subst g + simp + · exact ⟨fun h ↦ h hg, fun h _ ↦ h⟩ + +/-- A finite Archimedean closed ball is order-connected. -/ +theorem closedBall_ordConnected (c : FiniteArchimedeanClass G) : + (closedBallAddSubgroup c : Set G).OrdConnected := by + rw [finiteClosedBall_eq_closedBall] + exact archimedeanClosedBall_ordConnected c.1 + +end FiniteArchimedeanClass diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Order/ArchimedeanQuotient.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Order/ArchimedeanQuotient.lean new file mode 100644 index 0000000000..6c296cc73b --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Order/ArchimedeanQuotient.lean @@ -0,0 +1,263 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Order.ConvexQuotient +public import Mathlib.Algebra.Group.Subgroup.Lattice +public import Mathlib.Algebra.Order.Archimedean.Class + +/-! +# Archimedean classes in subgroups and limit quotients + +A positively coinitial subgroup of an ordered abelian group inherits the absence of a largest +finite Archimedean class from the ambient group. The ambient hypothesis is essential: positive +coinitiality alone does not create new Archimedean classes. + +There is a separate construction suited to a limit family of classes. For a set `T` of finite +Archimedean classes, `FiniteArchimedeanClass.tailKernel T` is the intersection of their closed +Archimedean balls. If every member of `T` has a strictly later member, the quotient by this convex +subgroup has no largest finite Archimedean class. This is the quotient used at a limit of support +support classes. +-/ + +open Set + +universe u + +public noncomputable section + +namespace AddSubgroup + +variable {C : Type u} [AddCommGroup C] [LinearOrder C] [IsOrderedAddMonoid C] + +/-- An additive subgroup of an ordered abelian group inherits the ordered-additive structure. -/ +instance instIsOrderedAddMonoid (S : AddSubgroup C) : IsOrderedAddMonoid S where + add_le_add_left a b h z := + show (a : C) + (z : C) ≤ (b : C) + (z : C) from by + simpa [add_comm] using + add_le_add_left (show (a : C) ≤ (b : C) from h) (z : C) + +/-- A positively coinitial subgroup inherits the absence of a largest finite Archimedean class +from its ambient ordered group. -/ +theorem finiteArchimedeanClass_noMax_of_pos_coinitial + [NoMaxOrder (FiniteArchimedeanClass C)] (S : AddSubgroup C) + (hS : ∀ y : C, 0 < y → ∃ x : S, 0 < (x : C) ∧ (x : C) ≤ y) : + NoMaxOrder (FiniteArchimedeanClass S) := by + constructor + intro c + induction c using FiniteArchimedeanClass.ind with + | mk x hx => + obtain ⟨d, hxd⟩ := exists_gt + (FiniteArchimedeanClass.mk (x : C) (Subtype.coe_ne_coe.mpr hx)) + induction d using FiniteArchimedeanClass.ind with + | mk y hy => + obtain ⟨z, hzpos, hzy⟩ := hS |y| (abs_pos.mpr hy) + have hz0 : z ≠ 0 := fun hz ↦ hzpos.ne' (Subtype.ext_iff.mp hz) + refine ⟨FiniteArchimedeanClass.mk z hz0, ?_⟩ + let e : S →+o C := + { toFun := fun z ↦ (z : C) + map_zero' := rfl + map_add' := fun _ _ ↦ rfl + monotone' := fun _ _ h ↦ h } + change ArchimedeanClass.mk (e x) < ArchimedeanClass.mk (e z) + rw [← ArchimedeanClass.orderHom_mk e x, ← ArchimedeanClass.orderHom_mk e z] + apply ((ArchimedeanClass.orderHom e).monotone.strictMono_of_injective + (ArchimedeanClass.orderHom_injective Subtype.val_injective)).lt_iff_lt.mpr + change ArchimedeanClass.mk (x : C) < ArchimedeanClass.mk (z : C) + change ArchimedeanClass.mk (x : C) < ArchimedeanClass.mk y at hxd + refine hxd.trans_le ?_ + apply ArchimedeanClass.mk_le_mk_of_abs + simpa [abs_of_pos hzpos] using hzy + +end AddSubgroup + +namespace FiniteArchimedeanClass + +variable {G : Type u} [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + +/-- The elements lying in the closed ball of every class in `T`. -/ +def tailKernel (T : Set (FiniteArchimedeanClass G)) : AddSubgroup G := + ⨅ c : T, ArchimedeanClass.closedBallAddSubgroup c.1.1 + +/-- Membership in the tail kernel means having class at least every class in `T`. -/ +theorem mem_tailKernel_iff {T : Set (FiniteArchimedeanClass G)} {x : G} : + x ∈ tailKernel T ↔ ∀ c : T, c.1.1 ≤ ArchimedeanClass.mk x := by + rw [tailKernel, AddSubgroup.mem_iInf] + exact forall_congr' fun c ↦ ArchimedeanClass.mem_closedBallAddSubgroup_iff + +/-- The common tail kernel of a family of Archimedean classes is convex. -/ +instance tailKernel_isConvex (T : Set (FiniteArchimedeanClass G)) : + (tailKernel T).IsConvex where + ordConnected := by + constructor + intro a ha b hb x hx + apply mem_tailKernel_iff.mpr + intro c + exact (le_min (mem_tailKernel_iff.mp ha c) (mem_tailKernel_iff.mp hb c)).trans + (ArchimedeanClass.min_le_mk_of_le_of_le hx.1 hx.2) + +/-- Absolute value commutes with projection to a convex tail quotient. -/ +theorem quotient_abs (T : Set (FiniteArchimedeanClass G)) (x : G) : + |(x : G ⧸ tailKernel T)| = ((|x| : G) : G ⧸ tailKernel T) := by + rcases le_total 0 x with hx | hx + · have hxq : (0 : G ⧸ tailKernel T) ≤ (x : G ⧸ tailKernel T) := by + rw [← QuotientAddGroup.mk_zero] + exact ConvexQuotient.mk_le_mk hx + rw [abs_of_nonneg hx, abs_of_nonneg hxq] + · have hxq : (x : G ⧸ tailKernel T) ≤ (0 : G ⧸ tailKernel T) := by + rw [← QuotientAddGroup.mk_zero] + exact ConvexQuotient.mk_le_mk hx + rw [abs_of_nonpos hx, abs_of_nonpos hxq, ← QuotientAddGroup.mk_neg] + +/-- A strict comparison of Archimedean classes in a common-tail quotient reflects to any chosen +representatives. -/ +theorem archimedeanClass_mk_lt_of_quotient_mk_lt + (T : Set (FiniteArchimedeanClass G)) {x y : G} + (h : ArchimedeanClass.mk (x : G ⧸ tailKernel T) < + ArchimedeanClass.mk (y : G ⧸ tailKernel T)) : + ArchimedeanClass.mk x < ArchimedeanClass.mk y := by + rw [ArchimedeanClass.mk_lt_mk] at h ⊢ + intro n + have hn := h n + have hn' : ((n • |y| : G) : G ⧸ tailKernel T) < + ((|x| : G) : G ⧸ tailKernel T) := by + simpa only [quotient_abs, QuotientAddGroup.mk_nsmul] using hn + exact ConvexQuotient.lt_of_mk_lt_mk hn' + +/-- A nonzero natural multiple of an absolute value stays in the same Archimedean class. -/ +theorem mk_nsmul_abs {x : G} {n : ℕ} (hn : n ≠ 0) : + ArchimedeanClass.mk (n • |x|) = ArchimedeanClass.mk x := by + apply ArchimedeanClass.mk_eq_mk.mpr + constructor + · refine ⟨1, ?_⟩ + rw [one_nsmul, abs_nsmul, abs_abs] + obtain ⟨k, rfl⟩ := Nat.exists_eq_succ_of_ne_zero hn + simpa [succ_nsmul] using + (le_add_of_nonneg_left (nsmul_nonneg (abs_nonneg x) k) : + |x| ≤ k • |x| + |x|) + · refine ⟨n, ?_⟩ + rw [abs_nsmul, abs_abs] + +/-- If `T` has no least member in the magnitude order, its common tail quotient has no least +nonzero Archimedean class in the magnitude order. -/ +theorem quotient_noMax_of_forall_exists_gt (T : Set (FiniteArchimedeanClass G)) + (hT : ∀ c ∈ T, ∃ d ∈ T, c < d) : + NoMaxOrder (FiniteArchimedeanClass (G ⧸ tailKernel T)) := by + constructor + intro c + induction c using FiniteArchimedeanClass.ind with + | mk x hx => + induction x using QuotientAddGroup.induction_on with + | H x => + have hxH : x ∉ tailKernel T := by + simpa using (show (x : G ⧸ tailKernel T) ≠ 0 from hx) + rw [mem_tailKernel_iff] at hxH + push Not at hxH + obtain ⟨d, hxd⟩ := hxH + obtain ⟨e, heT, hde⟩ := hT d.1 d.2 + obtain ⟨f, hfT, hef⟩ := hT e heT + let y : G := e.1.out + have hyclass : ArchimedeanClass.mk y = e.1 := ArchimedeanClass.mk_out e.1 + have hy0 : y ≠ 0 := ArchimedeanClass.mk_eq_top_iff.not.mp + (hyclass.trans_ne e.2) + have hyH : y ∉ tailKernel T := by + intro hy + have hf_le_y : f.1 ≤ ArchimedeanClass.mk y := + mem_tailKernel_iff.mp hy ⟨f, hfT⟩ + rw [hyclass] at hf_le_y + exact (not_le_of_gt hef) hf_le_y + refine ⟨FiniteArchimedeanClass.mk (y : G ⧸ tailKernel T) (by simpa using hyH), ?_⟩ + change ArchimedeanClass.mk (x : G ⧸ tailKernel T) < + ArchimedeanClass.mk (y : G ⧸ tailKernel T) + rw [ArchimedeanClass.mk_lt_mk] + intro n + have hclass : ArchimedeanClass.mk x < ArchimedeanClass.mk y := by + rw [hyclass] + exact hxd.trans hde + have hxy : n • |y| < |x| := ArchimedeanClass.mk_lt_mk.mp hclass n + have hquot : ((n • |y| : G) : G ⧸ tailKernel T) < + ((|x| : G) : G ⧸ tailKernel T) := by + apply ConvexQuotient.mk_lt_mk_iff.mpr + refine ⟨hxy, ?_⟩ + intro hmem + have hdiff : d.1 ≤ ArchimedeanClass.mk (|x| - n • |y|) := + mem_tailKernel_iff.mp hmem d + have hdiffclass : ArchimedeanClass.mk (|x| - n • |y|) = + ArchimedeanClass.mk x := by + by_cases hn : n = 0 + · simp [hn] + rw [ArchimedeanClass.mk_sub_eq_mk_left] + · exact ArchimedeanClass.mk_abs x + · simpa only [ArchimedeanClass.mk_abs, mk_nsmul_abs hn] using hclass + rw [hdiffclass] at hdiff + exact (not_le_of_gt hxd) hdiff + simpa only [quotient_abs, QuotientAddGroup.mk_nsmul] using hquot + +/-- The no-largest-class theorem for a quotient by any additive subgroup whose carrier is the +tail kernel. -/ +theorem quotient_noMax_of_eq_tailKernel (T : Set (FiniteArchimedeanClass G)) + (H : AddSubgroup G) [H.IsConvex] (hH : H = tailKernel T) + (hT : ∀ c ∈ T, ∃ d ∈ T, c < d) : + NoMaxOrder (FiniteArchimedeanClass (G ⧸ H)) := by + subst H + exact quotient_noMax_of_forall_exists_gt T hT + +/-- A canonical positive representative of a finite Archimedean class. -/ +def positiveRepresentative (c : FiniteArchimedeanClass G) : G := + |c.1.out| + +/-- The canonical representative of a finite class is positive. -/ +theorem positiveRepresentative_pos (c : FiniteArchimedeanClass G) : + 0 < positiveRepresentative c := by + rw [positiveRepresentative, abs_pos] + intro h + have := congrArg ArchimedeanClass.mk h + rw [ArchimedeanClass.mk_out, ArchimedeanClass.mk_zero] at this + exact c.2 this + +/-- The canonical positive representative represents the requested class. -/ +theorem mk_positiveRepresentative (c : FiniteArchimedeanClass G) : + ArchimedeanClass.mk (positiveRepresentative c) = c.1 := by + rw [positiveRepresentative, ArchimedeanClass.mk_abs, ArchimedeanClass.mk_out] + +/-- At a limit family, each canonical representative survives the common tail quotient. -/ +theorem positiveRepresentative_not_mem_tailKernel {T : Set (FiniteArchimedeanClass G)} + (hT : ∀ c ∈ T, ∃ d ∈ T, c < d) (c : T) : + positiveRepresentative c.1 ∉ tailKernel T := by + obtain ⟨d, hdT, hcd⟩ := hT c.1 c.2 + intro hmem + have := mem_tailKernel_iff.mp hmem ⟨d, hdT⟩ + rw [mk_positiveRepresentative] at this + exact (not_le_of_gt hcd) this + +/-- The image of a canonical representative in its limit quotient is positive. -/ +theorem quotient_positiveRepresentative_pos {T : Set (FiniteArchimedeanClass G)} + (hT : ∀ c ∈ T, ∃ d ∈ T, c < d) (c : T) : + 0 < ((positiveRepresentative c.1 : G) : G ⧸ tailKernel T) := by + rw [← QuotientAddGroup.mk_zero] + exact ConvexQuotient.mk_lt_mk_iff.mpr ⟨positiveRepresentative_pos c.1, + by simpa using positiveRepresentative_not_mem_tailKernel hT c⟩ + +/-- The canonical representatives of a limit family are coinitial among the positive elements of +the common tail quotient. -/ +theorem exists_quotient_positiveRepresentative_le {T : Set (FiniteArchimedeanClass G)} + {x : G ⧸ tailKernel T} (hx : 0 < x) : + ∃ c : T, ((positiveRepresentative c.1 : G) : G ⧸ tailKernel T) ≤ x := by + induction x using QuotientAddGroup.induction_on with + | H x => + have hxq : ((0 : G) : G ⧸ tailKernel T) < (x : G ⧸ tailKernel T) := by + simpa using hx + have hx0 : 0 < x := ConvexQuotient.lt_of_mk_lt_mk hxq + have hxH : x ∉ tailKernel T := by + simpa using (ConvexQuotient.mk_lt_mk_iff.mp hxq).2 + rw [mem_tailKernel_iff] at hxH + push Not at hxH + obtain ⟨c, hxc⟩ := hxH + refine ⟨c, ConvexQuotient.mk_le_mk ?_⟩ + apply (ArchimedeanClass.lt_of_mk_lt_mk_of_nonneg ?_ hx0.le).le + rwa [mk_positiveRepresentative] + +end FiniteArchimedeanClass diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Order/ConvexQuotient.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Order/ConvexQuotient.lean new file mode 100644 index 0000000000..8242f23490 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Order/ConvexQuotient.lean @@ -0,0 +1,185 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import Mathlib.Algebra.Order.Group.Defs +public import Mathlib.GroupTheory.QuotientGroup.Defs +public import Mathlib.Order.Interval.Set.OrdConnected +import Mathlib.Tactic.Abel + +/-! +# The quotient of an ordered group by a convex subgroup + +A subgroup of a linearly ordered abelian group that is order-connected as a set is *convex*, and +the quotient by it inherits a linear order: one coset lies below another when some representative +of the first lies below some representative of the second. Convexity is exactly what makes that +relation antisymmetric, because an element trapped between zero and a subgroup element belongs to +the subgroup. + +The projection is monotone and reflects the strict order (`mk_le_mk`, `lt_of_mk_lt_mk`). Those +two facts are what let order-theoretic hypotheses be transported to the quotient — filling cuts, +in the intended application, where the quotient is taken to gain a small coinitial family of +positive elements that the group itself lacks. +-/ + +universe u + +open Set + +public section + +namespace AddSubgroup + +variable {G : Type u} [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + +/-- A subgroup of an ordered group is convex when it is order-connected. -/ +class IsConvex (H : AddSubgroup G) : Prop where + /-- The carrier of a convex subgroup is order-connected. -/ + ordConnected : (H : Set G).OrdConnected + +omit [IsOrderedAddMonoid G] in +/-- A nonnegative element below an element of a convex subgroup lies in the subgroup. -/ +theorem mem_of_nonneg_of_le (H : AddSubgroup G) [H.IsConvex] {x y : G} (hx : 0 ≤ x) + (hxy : x ≤ y) (hy : y ∈ H) : x ∈ H := + IsConvex.ordConnected.out H.zero_mem hy ⟨hx, hxy⟩ + +end AddSubgroup + +namespace ConvexQuotient + +variable {G : Type u} [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + {H : AddSubgroup G} [H.IsConvex] + +/-- One coset lies below another when some representative of the first lies below some +representative of the second. -/ +instance instLE : LE (G ⧸ H) where + le x y := ∃ a b : G, (a : G ⧸ H) = x ∧ (b : G ⧸ H) = y ∧ a ≤ b + +/-- **Comparing cosets.** One coset lies below another exactly when the chosen representatives are +already comparable or differ by a subgroup element. Convexity supplies the forward direction: were +the representatives reversed, their difference would be trapped between zero and the subgroup +element relating the two choices. -/ +theorem mk_le_mk_iff {a b : G} : + ((a : G ⧸ H) ≤ (b : G ⧸ H)) ↔ a ≤ b ∨ b - a ∈ H := by + constructor + · rintro ⟨a', b', ha', hb', hab⟩ + rw [QuotientAddGroup.eq_iff_sub_mem] at ha' hb' + rcases le_or_gt a b with h | h + · exact Or.inl h + refine Or.inr ?_ + have hsub : a - b ≤ (b' - b) - (a' - a) := by + rw [← sub_nonneg] + have heq : (b' - b) - (a' - a) - (a - b) = b' - a' := by abel + rw [heq] + exact sub_nonneg.mpr hab + have hmem := AddSubgroup.mem_of_nonneg_of_le H (sub_nonneg.mpr h.le) hsub + (H.sub_mem hb' ha') + simpa using H.neg_mem hmem + · rintro (h | h) + · exact ⟨a, b, rfl, rfl, h⟩ + · exact ⟨a, a, rfl, + QuotientAddGroup.eq_iff_sub_mem.mpr (by simpa using H.neg_mem h), le_rfl⟩ + +/-- The projection is monotone. -/ +theorem mk_le_mk {a b : G} (h : a ≤ b) : (a : G ⧸ H) ≤ (b : G ⧸ H) := + mk_le_mk_iff.mpr (Or.inl h) + +open Classical in +noncomputable instance instLinearOrder : LinearOrder (G ⧸ H) where + le := (· ≤ ·) + le_refl := by + refine fun x ↦ QuotientAddGroup.induction_on x fun a ↦ ?_ + exact mk_le_mk le_rfl + le_trans := by + refine fun x y z ↦ QuotientAddGroup.induction_on x fun a ↦ QuotientAddGroup.induction_on y + fun b ↦ QuotientAddGroup.induction_on z fun c hab hbc ↦ ?_ + rw [mk_le_mk_iff] at hab hbc ⊢ + rcases hab with hab | hab + · rcases hbc with hbc | hbc + · exact Or.inl (hab.trans hbc) + -- `c` and `b` differ in the subgroup, so `a ≤ c` unless `a - c` is trapped below `b - c`. + · rcases le_or_gt a c with h | h + · exact Or.inl h + refine Or.inr ?_ + have hbc' : b - c ∈ H := by simpa using H.neg_mem hbc + have hmem := AddSubgroup.mem_of_nonneg_of_le H (sub_nonneg.mpr h.le) + (sub_le_sub_right hab c) hbc' + simpa using H.neg_mem hmem + · rcases hbc with hbc | hbc + · rcases le_or_gt a c with h | h + · exact Or.inl h + refine Or.inr ?_ + have hab' : a - b ∈ H := by simpa using H.neg_mem hab + have hmem := AddSubgroup.mem_of_nonneg_of_le H (sub_nonneg.mpr h.le) + (sub_le_sub_left hbc a) hab' + simpa using H.neg_mem hmem + · exact Or.inr (by simpa using H.add_mem hbc hab) + le_antisymm := by + refine fun x y ↦ QuotientAddGroup.induction_on x fun a ↦ QuotientAddGroup.induction_on y + fun b hab hba ↦ ?_ + rw [mk_le_mk_iff] at hab hba + rw [QuotientAddGroup.eq_iff_sub_mem] + rcases hab with hab | hab + · rcases hba with hba | hba + · rw [le_antisymm hab hba, sub_self] + exact H.zero_mem + · exact hba + · simpa using H.neg_mem hab + le_total := by + refine fun x y ↦ QuotientAddGroup.induction_on x fun a ↦ QuotientAddGroup.induction_on y + fun b ↦ ?_ + rcases le_total a b with h | h + · exact Or.inl (mk_le_mk h) + · exact Or.inr (mk_le_mk h) + toDecidableLE := Classical.decRel _ + +instance instIsOrderedAddMonoid : IsOrderedAddMonoid (G ⧸ H) where + add_le_add_left := by + refine fun x y ↦ QuotientAddGroup.induction_on x fun a ↦ QuotientAddGroup.induction_on y + fun b hab z ↦ QuotientAddGroup.induction_on z fun c ↦ ?_ + rw [mk_le_mk_iff] at hab + have hc : ((a + c : G) : G ⧸ H) ≤ ((b + c : G) : G ⧸ H) := by + rw [mk_le_mk_iff] + rcases hab with hab | hab + · exact Or.inl (add_le_add hab le_rfl) + · exact Or.inr (by simpa using hab) + simpa using hc + +/-- **The projection reflects the strict order.** Two representatives whose cosets are strictly +comparable are themselves strictly comparable. -/ +theorem lt_of_mk_lt_mk {a b : G} (h : (a : G ⧸ H) < (b : G ⧸ H)) : a < b := by + rcases mk_le_mk_iff.mp h.le with hab | hab + · refine hab.lt_of_ne fun hEq ↦ ?_ + exact absurd (le_of_eq (congrArg _ hEq.symm)) (not_le.mpr h) + · exact absurd (mk_le_mk_iff.mpr (Or.inr (by simpa using H.neg_mem hab))) (not_le.mpr h) + +/-- One coset lies strictly below another exactly when the representatives do and their difference +escapes the subgroup. -/ +theorem mk_lt_mk_iff {a b : G} : + ((a : G ⧸ H) < (b : G ⧸ H)) ↔ a < b ∧ b - a ∉ H := by + refine ⟨fun h ↦ ⟨lt_of_mk_lt_mk h, fun hmem ↦ ?_⟩, fun ⟨hab, hmem⟩ ↦ ?_⟩ + · exact absurd (mk_le_mk_iff.mpr (Or.inr (by simpa using H.neg_mem hmem))) (not_le.mpr h) + · refine lt_of_le_of_ne (mk_le_mk hab.le) fun hEq ↦ hmem ?_ + simpa using H.neg_mem (QuotientAddGroup.eq_iff_sub_mem.mp hEq) + +/-- **Halving descends to the quotient.** If every positive element of `G` is twice a positive +element, the same holds in the quotient: a representative's half stays outside the subgroup, +since otherwise the representative itself would lie inside it. -/ +theorem exists_half_of_pos (hG : ∀ x : G, 0 < x → ∃ y, 0 < y ∧ y + y = x) {c : G ⧸ H} + (hc : 0 < c) : ∃ d : G ⧸ H, 0 < d ∧ d + d ≤ c := by + induction c using QuotientAddGroup.induction_on with + | H x => + have hpos : ((0 : G) : G ⧸ H) < (x : G ⧸ H) := by + rw [QuotientAddGroup.mk_zero] + exact hc + have hxH : x ∉ H := by simpa using (mk_lt_mk_iff.mp hpos).2 + obtain ⟨y, hy, hyx⟩ := hG x (lt_of_mk_lt_mk hpos) + have hyH : y ∉ H := fun hmem ↦ hxH (hyx ▸ H.add_mem hmem hmem) + refine ⟨(y : G ⧸ H), ?_, ?_⟩ + · exact mk_lt_mk_iff.mpr ⟨hy, by simpa using hyH⟩ + · rw [← QuotientAddGroup.mk_add, hyx] + +end ConvexQuotient diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Order/Module.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Order/Module.lean new file mode 100644 index 0000000000..e99bcddd41 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Order/Module.lean @@ -0,0 +1,13 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Order.Module.ArchimedeanBallSplitting +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Order.Module.ConvexQuotientSplitting +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Order.Module.Tests + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Order/Module/ArchimedeanBallSplitting.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Order/Module/ArchimedeanBallSplitting.lean new file mode 100644 index 0000000000..290e842e4b --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Order/Module/ArchimedeanBallSplitting.lean @@ -0,0 +1,165 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import Mathlib.Algebra.Order.Module.Archimedean +public import Mathlib.Algebra.Order.Module.HahnEmbedding +public import Mathlib.Algebra.Order.Monoid.Prod +public import Mathlib.Algebra.Order.Hom.Monoid + +/-! +# Ordered splitting along an Archimedean class + +Let `M` be an ordered vector space over an Archimedean ordered division ring `K`. A choice of +`HahnEmbedding.ArchimedeanStrata K M` complements each open Archimedean ball inside its closed +ball. This file upgrades that algebraic complement to an ordered additive equivalence: the closed +ball is the lexicographic product of the chosen stratum, as the dominant coordinate, and the open +ball, as the infinitesimal coordinate. + +This is the ordered splitting in LM24, Fact 2.4.2(2). Mathlib supplies the complement and proves +that every nonzero element of a stratum has the corresponding Archimedean class. The strict-order +argument here records the convention that Mathlib orders Archimedean classes oppositely to LM24: +a larger Mathlib class consists of smaller elements. +-/ + +public section + +namespace HahnEmbedding.ArchimedeanStrata + +open FiniteArchimedeanClass + +variable {K M : Type*} [DivisionRing K] [LinearOrder K] [IsOrderedRing K] [Archimedean K] +variable [AddCommGroup M] [LinearOrder M] [IsOrderedAddMonoid M] +variable [Module K M] [IsOrderedModule K M] + +private theorem abs_lt_abs_of_mk_lt_mk {s b : M} + (h : ArchimedeanClass.mk s < ArchimedeanClass.mk b) : |b| < |s| := by + simpa using ArchimedeanClass.mk_lt_mk.mp h 1 + +private theorem pos_add_of_abs_lt_abs {s b : M} (hs : 0 < s) (h : |b| < |s|) : + 0 < s + b := by + rw [abs_of_pos hs] at h + have hsb : -b < s := lt_of_le_of_lt (neg_le_abs b) h + have := add_lt_add_right hsb b + rwa [add_neg_cancel, add_comm] at this + +variable (u : HahnEmbedding.ArchimedeanStrata K M) (c : FiniteArchimedeanClass M) + +private theorem stratum_le_closedBall : u.stratum c ≤ closedBall K c := by + rw [← u.ball_sup_stratum_eq c] + exact le_sup_right + +private theorem ball_le_closedBall : ball K c ≤ closedBall K c := + (FiniteArchimedeanClass.ball_lt_closedBall (K := K)).le + +private theorem abs_lt_abs_of_mem {s b : M} (hs : s ∈ u.stratum c) (hs0 : s ≠ 0) + (hb : b ∈ ball K c) (hb0 : b ≠ 0) : |b| < |s| := by + refine abs_lt_abs_of_mk_lt_mk ?_ + have hsc : FiniteArchimedeanClass.mk s hs0 = c := + Subtype.ext (u.archimedeanClassMk_of_mem_stratum hs hs0) + have hcb : c < FiniteArchimedeanClass.mk b hb0 := + (FiniteArchimedeanClass.mem_ball_iff K).mp hb hb0 + rw [← hsc] at hcb + exact (FiniteArchimedeanClass.mk_lt_mk hs0 hb0).mp hcb + +private theorem pos_add_of_mem {s b : M} (hs : s ∈ u.stratum c) (hspos : 0 < s) + (hb : b ∈ ball K c) : 0 < s + b := by + rcases eq_or_ne b 0 with rfl | hb0 + · simpa using hspos + · exact pos_add_of_abs_lt_abs hspos (abs_lt_abs_of_mem u c hs hspos.ne' hb hb0) + +private def strataAdd : ((u.stratum c) ×ₗ (ball K c)) →+ (closedBall K c) where + toFun p := + ⟨((ofLex p).1 : M) + ((ofLex p).2 : M), + add_mem (stratum_le_closedBall u c (ofLex p).1.2) + (ball_le_closedBall c (ofLex p).2.2)⟩ + map_zero' := by ext; simp + map_add' p q := by + apply Subtype.ext + change ((ofLex p).1 : M) + (ofLex q).1 + (((ofLex p).2 : M) + (ofLex q).2) = + (((ofLex p).1 : M) + (ofLex p).2) + (((ofLex q).1 : M) + (ofLex q).2) + ac_rfl + +private theorem strataAdd_injective : Function.Injective (strataAdd u c) := by + intro p q hpq + have hdiff : ((ofLex p).1 : M) - (ofLex q).1 = (ofLex q).2 - (ofLex p).2 := by + have h := congrArg Subtype.val hpq + dsimp [strataAdd] at h + rw [sub_eq_sub_iff_add_eq_add] + simpa [add_comm] using h + have hzero : ((ofLex p).1 : M) - (ofLex q).1 = 0 := by + apply Submodule.disjoint_def.mp (u.disjoint_ball_stratum c) + · rw [hdiff] + exact sub_mem (ofLex q).2.2 (ofLex p).2.2 + · exact sub_mem (ofLex p).1.2 (ofLex q).1.2 + apply ofLex.injective + apply Prod.ext + · apply Subtype.ext + exact sub_eq_zero.mp hzero + · apply Subtype.ext + have h := congrArg Subtype.val hpq + dsimp [strataAdd] at h + rw [sub_eq_zero.mp hzero] at h + exact add_left_cancel h + +private theorem strataAdd_surjective : Function.Surjective (strataAdd u c) := by + intro x + have hx : (x : M) ∈ ball K c ⊔ u.stratum c := by + rw [u.ball_sup_stratum_eq c] + exact x.2 + obtain ⟨b, hb, s, hs, hbs⟩ := Submodule.mem_sup.mp hx + refine ⟨toLex (⟨s, hs⟩, ⟨b, hb⟩), ?_⟩ + apply Subtype.ext + dsimp [strataAdd] + simpa [add_comm] using hbs + +private theorem strataAdd_strictMono : StrictMono (strataAdd u c) := by + intro p q hpq + rcases Prod.Lex.lt_iff.mp hpq with hs | ⟨hs, hb⟩ + · rw [← sub_pos] + change 0 < (((ofLex q).1 : M) + (ofLex q).2) - + (((ofLex p).1 : M) + (ofLex p).2) + rw [show (((ofLex q).1 : M) + (ofLex q).2) - + (((ofLex p).1 : M) + (ofLex p).2) = + ((ofLex q).1 - (ofLex p).1 : M) + ((ofLex q).2 - (ofLex p).2) by abel] + apply pos_add_of_mem u c + · exact sub_mem (ofLex q).1.2 (ofLex p).1.2 + · exact sub_pos.mpr hs + · exact sub_mem (ofLex q).2.2 (ofLex p).2.2 + · change ((ofLex p).1 : M) + (ofLex p).2 < (ofLex q).1 + (ofLex q).2 + rw [hs] + have hb' : ((ofLex p).2 : M) < (ofLex q).2 := hb + simpa [add_comm] using add_lt_add_left hb' ((ofLex q).1 : M) + +/-- The lexicographic product of a chosen Archimedean stratum and its open ball is the +corresponding closed ball. The stratum is the dominant coordinate. -/ +noncomputable def stratumLexBallEquivClosedBall : + ((u.stratum c) ×ₗ (ball K c)) ≃+o (closedBall K c) := + { AddEquiv.ofBijective (strataAdd u c) ⟨strataAdd_injective u c, strataAdd_surjective u c⟩ with + map_le_map_iff' := (strataAdd_strictMono u c).le_iff_le } + +@[simp] +theorem stratumLexBallEquivClosedBall_apply (p : (u.stratum c) ×ₗ (ball K c)) : + stratumLexBallEquivClosedBall u c p = ((ofLex p).1 : M) + (ofLex p).2 := (rfl) + +/-- The closed Archimedean ball, split into its dominant stratum coordinate and infinitesimal +open-ball coordinate. -/ +noncomputable def closedBallEquivStratumLexBall : + (closedBall K c) ≃+o ((u.stratum c) ×ₗ (ball K c)) := + (stratumLexBallEquivClosedBall u c).symm + +@[simp] +theorem stratumLexBallEquivClosedBall_closedBallEquivStratumLexBall (x : closedBall K c) : + stratumLexBallEquivClosedBall u c (closedBallEquivStratumLexBall u c x) = x := + (stratumLexBallEquivClosedBall u c).apply_symm_apply x + +@[simp] +theorem closedBallEquivStratumLexBall_stratumLexBallEquivClosedBall + (p : (u.stratum c) ×ₗ (ball K c)) : + closedBallEquivStratumLexBall u c (stratumLexBallEquivClosedBall u c p) = p := + (stratumLexBallEquivClosedBall u c).symm_apply_apply p + +end HahnEmbedding.ArchimedeanStrata diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Order/Module/ConvexQuotientSplitting.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Order/Module/ConvexQuotientSplitting.lean new file mode 100644 index 0000000000..d5f71ced6c --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Order/Module/ConvexQuotientSplitting.lean @@ -0,0 +1,172 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Order.ArchimedeanQuotient +public import Mathlib.Algebra.Order.Module.Archimedean +public import Mathlib.Algebra.Order.Monoid.Prod +public import Mathlib.LinearAlgebra.Basis.VectorSpace +public import Mathlib.LinearAlgebra.Projection + +/-! +# Ordered splitting by a convex subspace + +A subspace of a vector space over a field has an algebraic complement. If the ambient additive +group is linearly ordered and the subspace is convex, this complement presents the ambient group +as the lexicographic product of the ordered quotient and the subspace. The quotient coordinate is +dominant. This additive splitting is what permits Hahn series to be regrouped by quotient cosets +without introducing a cocycle. + +For a family of finite Archimedean classes, `FiniteArchimedeanClass.tailSubmodule` equips their +common tail kernel with its natural subspace structure. Thus the generic splitting applies to the +limit-tail quotients used in the Cantor–Bendixson argument. +-/ + +open Set + +universe u v + +public noncomputable section + +namespace FiniteArchimedeanClass + +variable (K : Type v) {G : Type u} +variable [Field K] [LinearOrder K] [IsOrderedRing K] [Archimedean K] +variable [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] +variable [Module K G] [PosSMulMono K G] + +/-- The common tail kernel of `T`, equipped with its natural `K`-subspace structure. -/ +def tailSubmodule (T : Set (FiniteArchimedeanClass G)) : Submodule K G where + __ := tailKernel T + smul_mem' k x hx := by + apply mem_tailKernel_iff.mpr + intro c + exact (mem_tailKernel_iff.mp hx c).trans (ArchimedeanClass.mk_le_mk_smul x k) + +/-- Membership in the common-tail subspace is membership in the underlying common-tail +kernel. -/ +@[simp] +theorem mem_tailSubmodule_iff {T : Set (FiniteArchimedeanClass G)} {x : G} : + x ∈ tailSubmodule K T ↔ x ∈ tailKernel T := + (Iff.rfl) + +@[simp] +theorem tailSubmodule_toAddSubgroup (T : Set (FiniteArchimedeanClass G)) : + (tailSubmodule K T).toAddSubgroup = tailKernel T := + (rfl) + +/-- The subspace form of the common tail kernel is convex. -/ +instance tailSubmodule_isConvex (T : Set (FiniteArchimedeanClass G)) : + (tailSubmodule K T).toAddSubgroup.IsConvex := by + rw [tailSubmodule_toAddSubgroup K T] + infer_instance + +end FiniteArchimedeanClass + +namespace Submodule + +variable {K : Type v} {G : Type u} +variable [Field K] [AddCommGroup G] [Module K G] +variable [LinearOrder G] [IsOrderedAddMonoid G] + +variable (P : Submodule K G) + +/-- A chosen linear complement of `P`. -/ +noncomputable def linearComplement : Submodule K G := + Classical.choose P.exists_isCompl + +omit [LinearOrder G] [IsOrderedAddMonoid G] in +/-- The chosen complement is complementary to `P`. -/ +theorem isCompl_linearComplement : IsCompl P (linearComplement P) := + Classical.choose_spec P.exists_isCompl + +/-- The quotient by `P`, identified linearly with the chosen complement. -/ +noncomputable def quotientLinearEquivComplement : (G ⧸ P) ≃ₗ[K] linearComplement P := + P.quotientEquivOfIsCompl (linearComplement P) (isCompl_linearComplement P) + +/-- Reassemble a quotient coordinate and a `P`-coordinate in the ambient vector space. -/ +noncomputable def quotientProdLinearEquiv : ((G ⧸ P) × P) ≃ₗ[K] G := + ((quotientLinearEquivComplement P).prodCongr (LinearEquiv.refl K P)).trans + ((linearComplement P).prodEquivOfIsCompl P (isCompl_linearComplement P).symm) + +omit [LinearOrder G] [IsOrderedAddMonoid G] in +/-- Reassembly has the prescribed quotient coordinate. -/ +@[simp] +theorem mk_quotientProdLinearEquiv (x : (G ⧸ P) × P) : + Quotient.mk (quotientProdLinearEquiv P x) = x.1 := by + rw [quotientProdLinearEquiv, LinearEquiv.trans_apply, LinearEquiv.prodCongr_apply, + Submodule.coe_prodEquivOfIsCompl'] + change QuotientAddGroup.mk' P.toAddSubgroup + ((quotientLinearEquivComplement P x.1 : G) + (x.2 : G)) = x.1 + rw [map_add, show QuotientAddGroup.mk' P.toAddSubgroup (x.2 : G) = 0 by + exact (Submodule.Quotient.mk_eq_zero P).mpr x.2.property, add_zero] + exact P.mk_quotientEquivOfIsCompl_apply (isCompl_linearComplement P) x.1 + +omit [LinearOrder G] [IsOrderedAddMonoid G] in +/-- Reassembling a zero quotient coordinate returns the subspace coordinate. -/ +@[simp] +theorem quotientProdLinearEquiv_zero_left (p : P) : + quotientProdLinearEquiv P (0, p) = (p : G) := by + rw [quotientProdLinearEquiv, LinearEquiv.trans_apply, LinearEquiv.prodCongr_apply, + Submodule.coe_prodEquivOfIsCompl'] + simp [quotientLinearEquivComplement] + +/-- The linear order on the quotient induced by convexity of the subspace. -/ +noncomputable local instance quotientLinearOrder [P.toAddSubgroup.IsConvex] : + LinearOrder (G ⧸ P) := + ConvexQuotient.instLinearOrder (H := P.toAddSubgroup) + +local instance submoduleIsOrderedAddMonoid : IsOrderedAddMonoid P := + AddSubgroup.instIsOrderedAddMonoid P.toAddSubgroup + +/-- A linearly ordered vector space is the lexicographic product of the quotient by a convex +subspace and that subspace. The quotient is the dominant coordinate. -/ +noncomputable def quotientLexEquiv [P.toAddSubgroup.IsConvex] : + ((G ⧸ P) ×ₗ P) ≃+o G := + { (quotientProdLinearEquiv P).toAddEquiv with + map_le_map_iff' := by + intro x y + apply (show StrictMono + (fun x : ((G ⧸ P) ×ₗ P) ↦ quotientProdLinearEquiv P (ofLex x)) by + intro x y hxy + rcases Prod.Lex.lt_iff.mp hxy with houter | ⟨houter, hinner⟩ + · have hq : + ((quotientProdLinearEquiv P (ofLex x) : G) : G ⧸ P.toAddSubgroup) < + ((quotientProdLinearEquiv P (ofLex y) : G) : G ⧸ P.toAddSubgroup) := by + change (Quotient.mk (quotientProdLinearEquiv P (ofLex x)) : G ⧸ P) < + Quotient.mk (quotientProdLinearEquiv P (ofLex y)) + rw [mk_quotientProdLinearEquiv, mk_quotientProdLinearEquiv] + exact houter + exact ConvexQuotient.lt_of_mk_lt_mk hq + · change quotientProdLinearEquiv P (ofLex x) < quotientProdLinearEquiv P (ofLex y) + simp only [quotientProdLinearEquiv, LinearEquiv.trans_apply, + LinearEquiv.prodCongr_apply, Submodule.coe_prodEquivOfIsCompl'] + rw [show (ofLex x).1 = (ofLex y).1 from houter] + simpa only [LinearEquiv.refl_apply, add_comm] using + add_lt_add_left (show ((ofLex x).2 : G) < ((ofLex y).2 : G) from hinner) + (quotientLinearEquivComplement P (ofLex y).1 : G)).le_iff_le } + +@[simp] +theorem quotientLexEquiv_apply [P.toAddSubgroup.IsConvex] (x : (G ⧸ P) ×ₗ P) : + quotientLexEquiv P x = quotientProdLinearEquiv P (ofLex x) := + (rfl) + +end Submodule + +namespace FiniteArchimedeanClass + +variable (K : Type v) {G : Type u} +variable [Field K] [LinearOrder K] [IsOrderedRing K] [Archimedean K] +variable [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] +variable [Module K G] [PosSMulMono K G] + +/-- The ambient group split lexicographically into the quotient by its tail subspace and that +subspace. Its additive subgroup is propositionally equal to `tailKernel T`. -/ +noncomputable def tailQuotientLexEquiv (T : Set (FiniteArchimedeanClass G)) : + ((G ⧸ (tailSubmodule K T).toAddSubgroup) ×ₗ tailSubmodule K T) ≃+o G := + Submodule.quotientLexEquiv (tailSubmodule K T) + +end FiniteArchimedeanClass diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Order/Module/Tests.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Order/Module/Tests.lean new file mode 100644 index 0000000000..2ea7db7b92 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Order/Module/Tests.lean @@ -0,0 +1,11 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Order.Module.Tests.ArchimedeanBallSplitting + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Order/Module/Tests/ArchimedeanBallSplitting.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Order/Module/Tests/ArchimedeanBallSplitting.lean new file mode 100644 index 0000000000..16cc125168 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Order/Module/Tests/ArchimedeanBallSplitting.lean @@ -0,0 +1,58 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Order.Module.ArchimedeanBallSplitting + +/-! +# API checks for the ordered Archimedean splitting + +This file checks the public interface for the splitting of a closed Archimedean ball into its +stratum and open ball. The nondegenerate check has both coordinates unequal and moving in opposite +directions: the stratum coordinate increases while the open-ball coordinate decreases. The image +must increase, distinguishing the lexicographic order from the componentwise product order. +-/ + +public section + +namespace Tests + +open FiniteArchimedeanClass + +variable {K M : Type*} [DivisionRing K] [LinearOrder K] [IsOrderedRing K] [Archimedean K] +variable [AddCommGroup M] [LinearOrder M] [IsOrderedAddMonoid M] +variable [Module K M] [IsOrderedModule K M] + +open HahnEmbedding in +/-- A strict increase in the stratum dominates a strict decrease in the open-ball coordinate. + +The two strict inequalities exclude equality in either coordinate, so this is not a zero or +one-coordinate smoke test. -/ +theorem archimedeanSplitting_stratum_dominates_ball + (u : ArchimedeanStrata K M) (c : FiniteArchimedeanClass M) + (s₁ s₂ : u.stratum c) (b₁ b₂ : ball K c) (hs : s₁ < s₂) (hb : b₂ < b₁) : + ArchimedeanStrata.stratumLexBallEquivClosedBall u c (toLex (s₁, b₁)) < + ArchimedeanStrata.stratumLexBallEquivClosedBall u c (toLex (s₂, b₂)) := by + have _ := hb + rw [map_lt_map_iff, Prod.Lex.toLex_lt_toLex] + exact Or.inl hs + +open HahnEmbedding in +theorem archimedeanSplitting_addition_formula + (u : ArchimedeanStrata K M) (c : FiniteArchimedeanClass M) + (s : u.stratum c) (b : ball K c) : + ArchimedeanStrata.stratumLexBallEquivClosedBall u c (toLex (s, b)) = + (s : M) + (b : M) := by + simp + +open HahnEmbedding in +theorem archimedeanSplitting_roundtrip + (u : ArchimedeanStrata K M) (c : FiniteArchimedeanClass M) (x : closedBall K c) : + ArchimedeanStrata.stratumLexBallEquivClosedBall u c + (ArchimedeanStrata.closedBallEquivStratumLexBall u c x) = x := by + simp + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Ring.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Ring.lean new file mode 100644 index 0000000000..d3e1386e5a --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Ring.lean @@ -0,0 +1,11 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Ring.Hom + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Ring/Hom.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Ring/Hom.lean new file mode 100644 index 0000000000..7cbd15576c --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Ring/Hom.lean @@ -0,0 +1,11 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Ring.Hom.OfInjectiveComp + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Ring/Hom/OfInjectiveComp.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Ring/Hom/OfInjectiveComp.lean new file mode 100644 index 0000000000..934406e238 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Ring/Hom/OfInjectiveComp.lean @@ -0,0 +1,52 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import Mathlib.Algebra.Ring.Hom.Defs + +/-! +# Ring homomorphisms detected through an injective homomorphism + +A map `s : A → B` whose composite with an injective ring homomorphism `g : B →+* C` is a ring +homomorphism `A →+* C` is itself a ring homomorphism: each axiom for `s` is the corresponding +axiom for `g ∘ s`, read back through the injectivity of `g`. + +This is how a homomorphism into a subring of a subring is built without elaborating the +homomorphism axioms inside the nested coercions: the axioms are checked after composing out to +an ambient ring where they are already known. +-/ + +public section + +namespace RingHom + +variable {A B C : Type*} [NonAssocSemiring A] [NonAssocSemiring B] [NonAssocSemiring C] + +/-- The ring homomorphism `s : A → B` detected by an injective ring homomorphism `g : B →+* C` +through which it factors a ring homomorphism `f : A →+* C`, so that `g (s a) = f a`. -/ +def ofInjectiveComp (g : B →+* C) (hg : Function.Injective g) (f : A →+* C) (s : A → B) + (hs : ∀ a, g (s a) = f a) : A →+* B where + toFun := s + map_one' := hg <| by rw [hs, map_one, map_one] + map_mul' x y := hg <| by rw [hs, map_mul, map_mul, hs, hs] + map_zero' := hg <| by rw [hs, map_zero, map_zero] + map_add' x y := hg <| by rw [hs, map_add, map_add, hs, hs] + +/-- The detected homomorphism is the given map. -/ +@[simp] +theorem ofInjectiveComp_apply (g : B →+* C) (hg : Function.Injective g) (f : A →+* C) + (s : A → B) (hs : ∀ a, g (s a) = f a) (a : A) : ofInjectiveComp g hg f s hs a = s a := + (rfl) + +/-- Composing the detected homomorphism with the detecting one recovers the factored +homomorphism. -/ +theorem comp_ofInjectiveComp (g : B →+* C) (hg : Function.Injective g) (f : A →+* C) + (s : A → B) (hs : ∀ a, g (s a) = f a) : g.comp (ofInjectiveComp g hg f s hs) = f := + RingHom.ext hs + +end RingHom + +end diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Tests.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Tests.lean new file mode 100644 index 0000000000..248b6417ec --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Tests.lean @@ -0,0 +1,11 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Tests.GeometricIntegrality + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Tests/GeometricIntegrality.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Tests/GeometricIntegrality.lean new file mode 100644 index 0000000000..cc4df20bf4 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Tests/GeometricIntegrality.lean @@ -0,0 +1,65 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.GeometricIntegrality + +import Mathlib.Algebra.MvPolynomial.Division +import Mathlib.RingTheory.TensorProduct.Maps +import Mathlib.RingTheory.TensorProduct.MvPolynomial + +/-! +# API checks for geometric integrality + +The coefficient algebra is the nontrivial polynomial algebra `ℚ[V]`. After every field +extension `K / ℚ`, tensor commutativity and polynomial base change identify +`ℚ[V] ⊗[ℚ] K` with the domain `K[V]`. The geometric-integrality theorem is then applied to +the irreducible auxiliary polynomial `U`, proving that its coefficient extension generates a +prime ideal in `ℚ[V][U]`. + +Using a nontrivial coefficient algebra ensures that this client exercises scalar extension rather +than reducing geometric integrality to the base field itself. +-/ + +open scoped TensorProduct + +public noncomputable section + +namespace Tests + +/-- The polynomial coefficient algebra in the geometric-integrality fixture. -/ +abbrev GeometricCoefficientAlgebra := MvPolynomial (Fin 1) ℚ + +/-- A polynomial algebra over `ℚ` remains a domain after every field extension. -/ +theorem geometricCoefficientAlgebra_isGeometricallyIntegral : + Algebra.IsGeometricallyIntegral ℚ GeometricCoefficientAlgebra := by + rw [Algebra.isGeometricallyIntegral_iff] + intro K _ _ + let e : GeometricCoefficientAlgebra ⊗[ℚ] K ≃+* MvPolynomial (Fin 1) K := + (Algebra.TensorProduct.comm ℚ GeometricCoefficientAlgebra K).toRingEquiv.trans + (MvPolynomial.algebraTensorAlgEquiv ℚ K).toRingEquiv + exact e.toMulEquiv.isDomain (MvPolynomial (Fin 1) K) + +/-- The irreducible polynomial `U` over the base field. -/ +def geometricLinearPolynomial : MvPolynomial (Fin 1) ℚ := + MvPolynomial.X 0 + +theorem geometricLinearPolynomial_irreducible : + Irreducible geometricLinearPolynomial := by + exact MvPolynomial.X_prime.irreducible + +/-- Extending `U` to `ℚ[V][U]` and quotienting by it leaves a domain. -/ +theorem geometricLinearPolynomial_baseChange_quotient_isDomain : + IsDomain + (MvPolynomial (Fin 1) GeometricCoefficientAlgebra ⧸ + Ideal.span + {MvPolynomial.map (algebraMap ℚ GeometricCoefficientAlgebra) + geometricLinearPolynomial}) := + geometricCoefficientAlgebra_isGeometricallyIntegral + |>.isDomain_mvPolynomial_quotient_span_map + geometricLinearPolynomial_irreducible + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation.lean new file mode 100644 index 0000000000..f164fa9e58 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation.lean @@ -0,0 +1,32 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.AssociatedGradedDivisibility +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.AssociatedGradedValuation +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.BasisOver +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.DegreeAssociatedGraded +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.DegreeAssociatedGradedDomain +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.DegreeAssociatedGradedMap +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.DegreeAssociatedGradedQuotient +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.DegreeInitialForm +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.DegreeOver +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.DegreePrincipalInitialIdeal +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.DegreeRepresentatives +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.DegreeScalar +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.DegreeSum +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.DegreeWeightedPolynomial +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.FiltrationDegree +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.MaxAddDegree +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.OfValuation +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.QuotientDegree +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.RV +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.Residue +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.ResidueMathlib +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.Tests + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/AssociatedGradedDivisibility.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/AssociatedGradedDivisibility.lean new file mode 100644 index 0000000000..2b22524b9e --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/AssociatedGradedDivisibility.lean @@ -0,0 +1,268 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.AssociatedGradedValuation + +import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.DirectSum.HomogeneousDivisibility +import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.DirectSum.TrailingGrade +import Mathlib.Algebra.GroupWithZero.Divisibility +import Mathlib.Algebra.Ring.Divisibility.Basic + +/-! +# Divisibility in an associated graded ring + +This module equips an associated graded ring with its smallest nonzero grade and proves that this +grade is multiplicative. Comparing smallest and largest grades shows that nonzero factors of a +homogeneous product are themselves homogeneous. It follows that divisibility between homogeneous +classes is the same in the homogeneous-class monoid and in the ambient associated graded ring. +-/ + +universe u v + +public noncomputable section + +open scoped DirectSum + +namespace MaxAddDegree + +variable {R : Type u} {M : Type v} [CommRing R] [AddCommMonoid M] + [LinearOrder M] [IsOrderedCancelAddMonoid M] + +variable (ν : MaxAddDegree R M) + +/-- The smallest nonzero grade of an associated-graded element, with top at zero. -/ +def associatedGradedTrailingValue + (x : ν.AssociatedGraded) : WithTop M := + DirectSum.trailingGrade ν.Component x + +@[simp] +theorem associatedGradedTrailingValue_zero : + ν.associatedGradedTrailingValue 0 = ⊤ := + DirectSum.trailingGrade_zero ν.Component + +@[simp] +theorem associatedGradedTrailingValue_eq_top_iff + (x : ν.AssociatedGraded) : + ν.associatedGradedTrailingValue x = ⊤ ↔ x = 0 := + DirectSum.trailingGrade_eq_top_iff ν.Component x + +omit [IsOrderedCancelAddMonoid M] in +theorem associatedGradedTrailingValue_eq_coe_iff + (x : ν.AssociatedGraded) (m : M) : + ν.associatedGradedTrailingValue x = (m : WithTop M) ↔ + x m ≠ 0 ∧ ∀ i, x i ≠ 0 → m ≤ i := + DirectSum.trailingGrade_eq_coe_iff ν.Component x m + +theorem min_le_associatedGradedTrailingValue_add + (x y : ν.AssociatedGraded) : + min (ν.associatedGradedTrailingValue x) (ν.associatedGradedTrailingValue y) ≤ + ν.associatedGradedTrailingValue (x + y) := + DirectSum.min_le_trailingGrade_add ν.Component x y + +/-- A graded element is zero or homogeneous exactly when its trailing and leading grades agree. -/ +theorem mem_homogeneousClasses_iff_extremeGrades + (x : ν.AssociatedGraded) : + x ∈ ν.homogeneousClasses ↔ + x = 0 ∨ ∃ m : M, + ν.associatedGradedTrailingValue x = m ∧ + ν.associatedGradedValue x = m := by + classical + constructor + · intro hx + rw [ν.mem_homogeneousClasses_iff] at hx + rcases hx with rfl | ⟨m, c, rfl⟩ + · exact Or.inl rfl + by_cases hc : c = 0 + · subst c + exact Or.inl ((DirectSum.of ν.Component m).map_zero) + · refine Or.inr ⟨m, DirectSum.trailingGrade_of ν.Component hc, ?_⟩ + apply (ν.associatedGradedValue_eq_coe_iff _ m).mpr + refine ⟨by simpa, ?_⟩ + intro i hi + have him : i = m := by + by_contra him + rw [DirectSum.of_eq_of_ne m i c him] at hi + exact hi rfl + exact him.le + · rintro (rfl | ⟨m, htrail, hlead⟩) + · exact (ν.mem_homogeneousClasses_iff 0).mpr (Or.inl rfl) + · rw [ν.mem_homogeneousClasses_iff] + refine Or.inr ⟨m, x m, ?_⟩ + apply DirectSum.ext + intro i + by_cases hi : i = m + · subst i + simp + · have hxi : x i = 0 := by + by_contra hxi + have hmi : m ≤ i := + (ν.associatedGradedTrailingValue_eq_coe_iff x m).mp htrail |>.2 i hxi + have him : i ≤ m := + (ν.associatedGradedValue_eq_coe_iff x m).mp hlead |>.2 i hxi + exact hi (le_antisymm him hmi) + rw [hxi] + exact (DirectSum.of_eq_of_ne m i (x m) hi).symm + +/-- A homogeneous class divides a graded element exactly when it divides every component. -/ +theorem homogeneous_dvd_iff_dvd_components + (x : ν.HomogeneousClasses) + (y : ν.AssociatedGraded) : + (x : ν.AssociatedGraded) ∣ y ↔ + ∀ m, (x : ν.AssociatedGraded) ∣ DirectSum.of ν.Component m (y m) := by + classical + have hxMem := x.property + rw [ν.mem_homogeneousClasses_iff] at hxMem + rcases hxMem with hx | ⟨m, c, hx⟩ + · change (x : ν.AssociatedGraded) = 0 at hx + rw [hx] + simp only [zero_dvd_iff] + constructor + · rintro rfl + simp + · intro h + apply DirectSum.ext + intro m + simpa using congrArg (fun z : ν.AssociatedGraded ↦ z m) (h m) + · change (x : ν.AssociatedGraded) = DirectSum.of ν.Component m c at hx + rw [hx] + exact DirectSum.of_dvd_iff_dvd_components ν.Component c y + +variable [ν.IsMultiplicative] + +@[simp] +theorem associatedGradedTrailingValue_mul + (x y : ν.AssociatedGraded) : + ν.associatedGradedTrailingValue (x * y) = + ν.associatedGradedTrailingValue x + ν.associatedGradedTrailingValue y := + DirectSum.trailingGrade_mul ν.Component + (fun a b ha hb ↦ ν.componentMul_ne_zero a b ha hb) x y + +/-- Nonzero factors of a homogeneous product are homogeneous. -/ +theorem mem_homogeneousClasses_of_mul_mem + {x y : ν.AssociatedGraded} + (hx : x ≠ 0) (hy : y ≠ 0) (hxy : x * y ∈ ν.homogeneousClasses) : + x ∈ ν.homogeneousClasses ∧ y ∈ ν.homogeneousClasses := by + obtain ⟨lx, hlx, hxlx⟩ := + DirectSum.exists_grade_eq_trailingGrade ν.Component hx + obtain ⟨ly, hly, hyly⟩ := + DirectSum.exists_grade_eq_trailingGrade ν.Component hy + have hxValueNe : ν.associatedGradedValue x ≠ ⊥ := + (ν.associatedGradedValue_eq_bot_iff x).not.mpr hx + obtain ⟨ux, huxCoe⟩ := WithBot.ne_bot_iff_exists.mp hxValueNe + have hux : ν.associatedGradedValue x = (ux : WithBot M) := huxCoe.symm + have hxux : x ux ≠ 0 := (ν.associatedGradedValue_eq_coe_iff x ux).mp hux |>.1 + have hyValueNe : ν.associatedGradedValue y ≠ ⊥ := + (ν.associatedGradedValue_eq_bot_iff y).not.mpr hy + obtain ⟨uy, huyCoe⟩ := WithBot.ne_bot_iff_exists.mp hyValueNe + have huy : ν.associatedGradedValue y = (uy : WithBot M) := huyCoe.symm + have hyuy : y uy ≠ 0 := (ν.associatedGradedValue_eq_coe_iff y uy).mp huy |>.1 + have hxy0 : x * y ≠ 0 := mul_ne_zero hx hy + rcases (ν.mem_homogeneousClasses_iff_extremeGrades (x * y)).mp hxy with + hzero | ⟨k, htrail, hlead⟩ + · exact (hxy0 hzero).elim + have hlxux : lx ≤ ux := by + exact (ν.associatedGradedValue_eq_coe_iff x ux).mp hux |>.2 lx hxlx + have hlyuy : ly ≤ uy := by + exact (ν.associatedGradedValue_eq_coe_iff y uy).mp huy |>.2 ly hyly + have hlx' : ν.associatedGradedTrailingValue x = (lx : WithTop M) := hlx + have hly' : ν.associatedGradedTrailingValue y = (ly : WithTop M) := hly + have hux' : ν.associatedGradedValue x = (ux : WithBot M) := hux + have huy' : ν.associatedGradedValue y = (uy : WithBot M) := huy + have hlow : lx + ly = k := by + apply WithTop.coe_injective + calc + ((lx + ly : M) : WithTop M) = + ν.associatedGradedTrailingValue x + + ν.associatedGradedTrailingValue y := by + rw [hlx', hly', WithTop.coe_add] + _ = ν.associatedGradedTrailingValue (x * y) := + (ν.associatedGradedTrailingValue_mul x y).symm + _ = (k : WithTop M) := htrail + have hhigh : ux + uy = k := by + apply WithBot.coe_injective + calc + ((ux + uy : M) : WithBot M) = + ν.associatedGradedValue x + ν.associatedGradedValue y := by + rw [hux', huy', WithBot.coe_add] + _ = ν.associatedGradedValue (x * y) := + (ν.associatedGradedValue_mul x y).symm + _ = (k : WithBot M) := hlead + have hsum : lx + ly = ux + uy := hlow.trans hhigh.symm + have hlxEq : lx = ux := by + apply le_antisymm hlxux + apply le_of_not_gt + intro hlxux' + exact (add_lt_add_of_lt_of_le hlxux' hlyuy).ne hsum + have hlyEq : ly = uy := by + apply le_antisymm hlyuy + apply le_of_not_gt + intro hlyuy' + exact (add_lt_add_of_le_of_lt hlxux hlyuy').ne hsum + constructor + · apply (ν.mem_homogeneousClasses_iff_extremeGrades x).mpr + exact Or.inr ⟨lx, hlx', by simpa [hlxEq] using hux'⟩ + · apply (ν.mem_homogeneousClasses_iff_extremeGrades y).mpr + exact Or.inr ⟨ly, hly', by simpa [hlyEq] using huy'⟩ + +/-- Divisibility between homogeneous classes agrees with ambient graded-ring divisibility. -/ +theorem homogeneous_dvd_iff_associatedGraded_dvd + (x y : ν.HomogeneousClasses) : + x ∣ y ↔ (x : ν.AssociatedGraded) ∣ (y : ν.AssociatedGraded) := by + constructor + · rintro ⟨z, rfl⟩ + exact ⟨z, rfl⟩ + · rintro ⟨z, hz⟩ + by_cases hx : x = 0 + · subst x + have hy : y = 0 := by + apply Subtype.ext + change (y : ν.AssociatedGraded) = 0 + change (y : ν.AssociatedGraded) = 0 * z at hz + simpa only [zero_mul] using hz + subst y + exact dvd_zero 0 + by_cases hy : y = 0 + · subst y + exact dvd_zero x + have hxCoe : (x : ν.AssociatedGraded) ≠ 0 := fun h ↦ hx (Subtype.ext h) + have hyCoe : (y : ν.AssociatedGraded) ≠ 0 := fun h ↦ hy (Subtype.ext h) + have hz0 : z ≠ 0 := by + intro hz0 + rw [hz0, mul_zero] at hz + exact hyCoe hz + have hzMem : z ∈ ν.homogeneousClasses := + (ν.mem_homogeneousClasses_of_mul_mem hxCoe hz0 (hz ▸ y.2)).2 + refine ⟨⟨z, hzMem⟩, ?_⟩ + apply Subtype.ext + exact hz + +/-- Divisibility in RV agrees with divisibility after the canonical embedding into the +associated graded ring. -/ +theorem rv_dvd_iff_associatedGraded_dvd + (x y : ν.RV) : + x ∣ y ↔ ν.rvInitialFormHom x ∣ ν.rvInitialFormHom y := by + calc + x ∣ y ↔ ν.rvEquivHomogeneous x ∣ ν.rvEquivHomogeneous y := + (map_dvd_iff ν.rvEquivHomogeneous).symm + _ ↔ ((ν.rvEquivHomogeneous x : ν.HomogeneousClasses) : ν.AssociatedGraded) ∣ + ((ν.rvEquivHomogeneous y : ν.HomogeneousClasses) : ν.AssociatedGraded) := + ν.homogeneous_dvd_iff_associatedGraded_dvd + (ν.rvEquivHomogeneous x) (ν.rvEquivHomogeneous y) + _ ↔ ν.rvInitialFormHom x ∣ ν.rvInitialFormHom y := by + rw [ν.rvEquivHomogeneous_apply, ν.rvEquivHomogeneous_apply, + ν.coe_rvHomogeneous, ν.coe_rvHomogeneous] + +/-- An RV class divides a graded element exactly when it divides every homogeneous component +after the canonical embedding into the associated graded ring. -/ +theorem rv_dvd_iff_dvd_components + (x : ν.RV) (y : ν.AssociatedGraded) : + ν.rvInitialFormHom x ∣ y ↔ + ∀ m, ν.rvInitialFormHom x ∣ DirectSum.of ν.Component m (y m) := by + simpa only [ν.rvEquivHomogeneous_apply, ν.coe_rvHomogeneous] using + ν.homogeneous_dvd_iff_dvd_components (ν.rvEquivHomogeneous x) y + +end MaxAddDegree diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/AssociatedGradedValuation.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/AssociatedGradedValuation.lean new file mode 100644 index 0000000000..fd4a10a798 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/AssociatedGradedValuation.lean @@ -0,0 +1,136 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.DirectSum.LeadingGrade +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.RV +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.DegreeAssociatedGradedDomain + +/-! +# The valuation on an associated graded ring + +The largest nonzero grade of an associated-graded element is a max-additive degree on +`ν.AssociatedGraded` for every max-additive degree `ν`: products of homogeneous components land +in the sum grade, so the leading grade is submultiplicative. It is separated because direct-sum +support is finite, independently of whether `ν` is separated. For a multiplicative `ν`, +multiplication of nonzero homogeneous classes is nonzero, and the leading grade is multiplicative. + +This is the valuation constructed in LM24, Definition 4.3.4 and Proposition 4.3.5. The degree of +an initial form is the degree of its representative, so iteration retains the original +homogeneous data. +-/ + +universe u v + +public noncomputable section + +open scoped DirectSum + +namespace MaxAddDegree + +variable {R : Type u} {M : Type v} [CommRing R] [AddCommMonoid M] + [LinearOrder M] [IsOrderedCancelAddMonoid M] + +variable (ν : MaxAddDegree R M) + +/-- The largest nonzero grade of an associated-graded element. -/ +def associatedGradedValue (x : ν.AssociatedGraded) : WithBot M := + DirectSum.leadingGrade ν.Component x + +@[simp] +theorem associatedGradedValue_zero : ν.associatedGradedValue 0 = ⊥ := + DirectSum.leadingGrade_zero ν.Component + +@[simp] +theorem associatedGradedValue_eq_bot_iff (x : ν.AssociatedGraded) : + ν.associatedGradedValue x = ⊥ ↔ x = 0 := + DirectSum.leadingGrade_eq_bot_iff ν.Component x + +omit [IsOrderedCancelAddMonoid M] in +theorem associatedGradedValue_eq_coe_iff (x : ν.AssociatedGraded) (m : M) : + ν.associatedGradedValue x = (m : WithBot M) ↔ + x m ≠ 0 ∧ ∀ i, x i ≠ 0 → i ≤ m := + DirectSum.leadingGrade_eq_coe_iff ν.Component x m + +theorem associatedGradedValue_add_le_max (x y : ν.AssociatedGraded) : + ν.associatedGradedValue (x + y) ≤ + max (ν.associatedGradedValue x) (ν.associatedGradedValue y) := + DirectSum.leadingGrade_add_le_max ν.Component x y + +omit [IsOrderedCancelAddMonoid M] in +@[simp] +theorem associatedGradedValue_neg (x : ν.AssociatedGraded) : + ν.associatedGradedValue (-x) = ν.associatedGradedValue x := + DirectSum.leadingGrade_neg ν.Component x + +/-- The leading grade of an initial form is the degree of its representative. -/ +@[simp] +theorem associatedGradedValue_initialForm (x : R) : + ν.associatedGradedValue (ν.initialForm x) = ν x := by + by_cases hx : ν x = ⊥ + · rw [ν.initialForm_eq_zero_of_eq_bot hx, ν.associatedGradedValue_zero, hx] + · have hc : ν.componentMk ((ν x).unbot hx) (ν.initialRepresentative x hx) ≠ 0 := by + intro hzero + apply ν.initialForm_ne_zero_of_ne_bot hx + rw [ν.initialForm_eq_homogeneousMk_of_ne_bot hx, ν.homogeneousMk_apply, hzero, + (DirectSum.of ν.Component _).map_zero] + rw [ν.initialForm_eq_homogeneousMk_of_ne_bot hx, ν.homogeneousMk_apply, + associatedGradedValue] + rw [DirectSum.leadingGrade_of ν.Component hc, WithBot.coe_unbot] + +/-- The leading grade of the unit is the degree of the unit: zero, unless the degree is the +degenerate one that is bottom everywhere, in which case the graded ring is trivial. -/ +@[simp] +theorem associatedGradedValue_one : + ν.associatedGradedValue 1 = ν 1 := by + rw [← ν.initialForm_one, ν.associatedGradedValue_initialForm] + +/-- The leading grade of a product is at most the sum of the leading grades: products of +homogeneous components land in the sum grade. -/ +theorem associatedGradedValue_mul_le (x y : ν.AssociatedGraded) : + ν.associatedGradedValue (x * y) ≤ + ν.associatedGradedValue x + ν.associatedGradedValue y := + DirectSum.leadingGrade_mul_le ν.Component x y + +/-- The leading-grade degree on the associated graded ring, for LM24, Proposition 4.3.5. It is +a max-additive degree for every `ν`, and multiplicative when `ν` is. -/ +def associatedGradedValuation : MaxAddDegree ν.AssociatedGraded M where + toFun := ν.associatedGradedValue + map_zero' := ν.associatedGradedValue_zero + map_one_le_zero' := by + rw [ν.associatedGradedValue_one] + exact ν.map_one_le_zero + map_neg' := ν.associatedGradedValue_neg + map_add_le_max' := ν.associatedGradedValue_add_le_max + map_mul_le_add' := ν.associatedGradedValue_mul_le + +@[simp] +theorem associatedGradedValuation_apply (x : ν.AssociatedGraded) : + ν.associatedGradedValuation x = ν.associatedGradedValue x := + (rfl) + +@[simp] +theorem associatedGradedValue_mul [ν.IsMultiplicative] (x y : ν.AssociatedGraded) : + ν.associatedGradedValue (x * y) = + ν.associatedGradedValue x + ν.associatedGradedValue y := + DirectSum.leadingGrade_mul ν.Component (fun a b ha hb ↦ ν.componentMul_ne_zero a b ha hb) x y + +/-- The leading-grade valuation of LM24, Proposition 4.3.5, is multiplicative for a multiplicative +degree. -/ +instance [ν.IsMultiplicative] : ν.associatedGradedValuation.IsMultiplicative := + ⟨ν.associatedGradedValue_mul⟩ + +/-- The leading-grade valuation is separated, regardless of whether `ν` is separated. -/ +theorem associatedGradedValuation_isSeparated : ν.associatedGradedValuation.IsSeparated := by + rw [isSeparated_iff] + intro x + rw [ν.associatedGradedValuation_apply, ν.associatedGradedValue_eq_bot_iff] + +theorem associatedGradedValuation_initialForm (x : R) : + ν.associatedGradedValuation (ν.initialForm x) = ν x := by + rw [ν.associatedGradedValuation_apply, ν.associatedGradedValue_initialForm] + +end MaxAddDegree diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/BasisOver.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/BasisOver.lean new file mode 100644 index 0000000000..eeca7196f4 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/BasisOver.lean @@ -0,0 +1,687 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.DegreeOver +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.DegreeSum +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.DegreeAssociatedGradedDomain +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.DegreeScalar +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.DegreePrincipalInitialIdeal +public import Mathlib.LinearAlgebra.Basis.Basic +public import Mathlib.LinearAlgebra.Finsupp.LinearCombination +public import Mathlib.RingTheory.TensorProduct.Maps +public import Mathlib.RingTheory.TensorProduct.Free +public import Mathlib.RingTheory.TensorProduct.Quotient + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint + +/-! +# Bases over a subalgebra and the associated graded ring of the degree over it + +Let `ν` be a separated multiplicative degree on a commutative ring `R` containing a ring `L` in +degree zero, and let `P` be an `L`-subalgebra of `R`. Suppose given elements `β i ∈ R` of degrees +`γ i` whose initial forms, together with the initial forms of `P`, generate the associated graded +ring freely in the sense of `IsBasisOver`. This is the paper's "basis over `S`": for +`R = K((ℝ^{≤0}))`, `ν = deg`, `P = S` and `β = (c_C)_{C ∈ 𝓒}` it says that `(c_C)_{C ∈ 𝓒}` is a +basis of `K((ℝ^{≤0}))` over `S` with `deg(∑ p_C c_C) = max (deg p_C ⊕ deg C)`. + +Then: + +* the degree of a `P`-combination `∑ pᵢ βᵢ` is `max (ν(pᵢ) + γᵢ)`, so the `β i` are a `P`-basis + of `R` (`IsBasisOver.basis`); +* the degree over `P`, `ν_P`, is the largest degree `γ i` of a basis vector occurring in the + expansion (`IsBasisOver.degreeOver_le_iff_forall_repr`); +* the associated graded ring `gr_{ν_P} R` is free over `P`, which sits in degree zero, on the + classes `[β] i` of the `β i` in their degrees + (`IsBasisOver.closure_degreeOverSubalgebraHom_mul_layerClass_eq_top` and + `IsBasisOver.eq_zero_of_sum_degreeOverSubalgebraHom_mul_layerClass_eq_zero`); consequently every + additive map `C ⊗ P → gr_{ν_P} R` sending `c i ⊗ p` to `p [β] i`, for a basis `c` of `C`, is + bijective (`IsBasisOver.bijective_of_tmul`); +* an element `a ∈ P` is prime in `R` whenever `gr_{ν_P} R` is identified with a tensor product + `C ⊗ P` carrying `1 ⊗ a` to the initial form of `a` for `ν_P`, and `C ⊗ P` and `C ⊗ (P ⧸ (a))` + are domains (`prime_coe_of_degreeOverGradedRingEquiv`); for the paper, `Θ : (P̂/I) ⊗_K S ≅ + gr_{deg_S} K((ℝ^{≤0}))`. + +Freeness rests on one computation: the class of any `t ∈ R` in degree `d` for `ν_P` is the sum +of the terms `pᵢ [β]ᵢ` of its expansion whose degree `γ i` is exactly `d`. +-/ + +universe u v w x + +open scoped TensorProduct + +public noncomputable section + +namespace MaxAddDegree + +variable {R : Type u} {M : Type v} {L : Type w} +variable [CommRing R] [AddCommMonoid M] [LinearOrder M] [IsOrderedCancelAddMonoid M] + +/-! ### The basis-over-`P` data -/ + +section Data + +variable [CommRing L] [Algebra L R] [WellFoundedLT M] {ι : Type x} + +/-- The hypotheses of the basis-over-`P` theorem: `ν` is separated, the `β i` have degrees `γ i`, +and their initial forms are a basis of the associated graded ring over the initial forms of +`P`. -/ +structure IsBasisOver (ν : MaxAddDegree R M) (P : Subalgebra L R) + (γ : ι → M) (β : ι → R) : Prop where + separated : ν.IsSeparated + degree_beta : ∀ i, ν (β i) = γ i + independent : ∀ (s : Finset ι) (p : ι → P), + ∑ i ∈ s, ν.initialForm (p i) * ν.initialForm (β i) = 0 → + ∀ i ∈ s, (p i : R) = 0 + spanning : ∀ (d : M) (g : ν.Component d), ∃ t ∈ Submodule.span P (Set.range β), + ∃ ht : t ∈ ν.filtrationLE d, ν.componentMk d ⟨t, ht⟩ = g + +variable {ν : MaxAddDegree R M} {P : Subalgebra L R} {γ : ι → M} {β : ι → R} + +namespace IsBasisOver + +omit [WellFoundedLT M] in +/-- Independence follows from independence of the initial forms of the `β i` over any set +containing the initial forms of `P`. -/ +theorem independent_of_forall_mem (hν : ν.IsSeparated) (S' : Set ν.AssociatedGraded) + (hP : ∀ p : P, ν.initialForm (p : R) ∈ S') + (hind : ∀ (s : Finset ι) (x : ι → ν.AssociatedGraded), (∀ i ∈ s, x i ∈ S') → + ∑ i ∈ s, x i * ν.initialForm (β i) = 0 → ∀ i ∈ s, x i = 0) + (s : Finset ι) (p : ι → P) + (h : ∑ i ∈ s, ν.initialForm (p i) * ν.initialForm (β i) = 0) : + ∀ i ∈ s, (p i : R) = 0 := fun i hi ↦ + (ν.initialForm_eq_zero_iff_of_isSeparated hν _).mp (hind s (fun i ↦ ν.initialForm (p i)) + (fun i _ ↦ hP (p i)) h i hi) + +omit [WellFoundedLT M] in +/-- Spanning follows from the associated graded ring being generated, as an abelian group, by +products of initial forms of `P` with initial forms of the `β i`. -/ +theorem spanning_of_forall_exists_sum [ν.IsMultiplicative] + (hspan : ∀ g : ν.AssociatedGraded, ∃ (κ : Type x) (_ : Fintype κ) (p : κ → P) (idx : κ → ι), + g = ∑ k, ν.initialForm (p k) * ν.initialForm (β (idx k))) + (d : M) (g : ν.Component d) : + ∃ t ∈ Submodule.span P (Set.range β), ∃ ht : t ∈ ν.filtrationLE d, + ν.componentMk d ⟨t, ht⟩ = g := by + classical + obtain ⟨κ, _, p, idx, hg⟩ := hspan (DirectSum.of ν.Component d g) + set y : κ → R := fun k ↦ (p k : R) * β (idx k) with hy + have hg' : DirectSum.of ν.Component d g = ∑ k, ν.initialForm (y k) := by + rw [hg] + exact Finset.sum_congr rfl fun k _ ↦ (ν.initialForm_mul _ _).symm + have hcomp : (DirectSum.of ν.Component d g) d = (∑ k, ν.initialForm (y k)) d := + congrArg (fun z : ν.AssociatedGraded ↦ z d) hg' + rw [DirectSum.of_eq_same, DirectSum.sum_apply] at hcomp + simp only [ν.initialForm_apply] at hcomp + rw [Finset.sum_dite, Finset.sum_const_zero, add_zero, ← map_sum] at hcomp + refine ⟨∑ k ∈ Finset.univ.filter (fun k ↦ ν (y k) = (d : WithBot M)), y k, ?_, ?_, ?_⟩ + · refine Submodule.sum_mem _ fun k _ ↦ ?_ + rw [hy] + change (p k) • β (idx k) ∈ _ + exact Submodule.smul_mem _ _ (Submodule.subset_span ⟨idx k, rfl⟩) + · exact (ν.filtrationLE d).sum_mem fun k hk ↦ + (ν.mem_filtrationLE_iff _ _).mpr (Finset.mem_filter.mp hk).2.le + · rw [hcomp] + congr 1 + apply Subtype.ext + rw [AddSubmonoidClass.coe_finsetSum] + simp only + exact (Finset.sum_attach _ y).symm + +variable (H : IsBasisOver ν P γ β) [ν.IsMultiplicative] +include H + +omit [WellFoundedLT M] in +theorem degree_coe_mul_beta (p : P) (i : ι) : ν ((p : R) * β i) = ν p + γ i := by + rw [ν.map_mul, H.degree_beta] + +omit [WellFoundedLT M] in +/-- The degree of a finite `P`-combination of the `β i` is the maximum of the termwise degrees +`ν(p i) + γ i`. -/ +theorem degree_finsupp_sum (f : ι →₀ P) : + ν (f.sum fun i p ↦ (p : R) * β i) = f.support.sup fun i ↦ ν (f i) + γ i := by + classical + by_cases hf : f = 0 + · subst hf + simp + have hne : f.support.Nonempty := Finsupp.support_nonempty_iff.mpr hf + obtain ⟨i₀, hi₀, hsup⟩ := Finset.exists_mem_eq_sup f.support hne fun i ↦ ν (f i) + γ i + rw [hsup] + have hfi₀ : (f i₀ : R) ≠ 0 := fun h ↦ Finsupp.mem_support_iff.mp hi₀ (Subtype.ext h) + obtain ⟨m₀, hm₀⟩ := WithBot.ne_bot_iff_exists.mp (ν.map_ne_bot_of_ne_zero H.separated hfi₀) + set d : M := m₀ + γ i₀ with hd + have hdcoe : ν (f i₀) + (γ i₀ : WithBot M) = (d : WithBot M) := by + rw [← hm₀, hd, WithBot.coe_add] + rw [hdcoe] + -- split the sum into the top-degree terms and the rest + set top := f.support.filter fun i ↦ ν (f i) + γ i = (d : WithBot M) with htop + have hsplit : (f.sum fun i p ↦ (p : R) * β i) = + (∑ i ∈ top, (f i : R) * β i) + + ∑ i ∈ f.support.filter (fun i ↦ ¬ ν (f i) + γ i = d), (f i : R) * β i := by + rw [Finsupp.sum, Finset.sum_filter_add_sum_filter_not] + have hle : ∀ i ∈ f.support, ν (f i) + γ i ≤ (d : WithBot M) := fun i hi ↦ by + rw [← hdcoe, ← hsup] + exact Finset.le_sup (f := fun i ↦ ν (f i) + γ i) hi + have hrest : + ν (∑ i ∈ f.support.filter (fun i ↦ ¬ ν (f i) + γ i = d), (f i : R) * β i) < + (d : WithBot M) := by + refine ν.degree_finsetSum_lt _ _ fun i hi ↦ ?_ + rw [Finset.mem_filter] at hi + rw [H.degree_coe_mul_beta] + exact lt_of_le_of_ne (hle i hi.1) hi.2 + have htopmem : ∀ i ∈ top, (f i : R) * β i ∈ ν.filtrationLE d := fun i hi ↦ by + rw [htop, Finset.mem_filter] at hi + exact (ν.mem_filtrationLE_iff _ _).mpr (by rw [H.degree_coe_mul_beta, hi.2]) + have htopsum : ∑ i ∈ top, (f i : R) * β i ∈ ν.filtrationLE d := + (ν.filtrationLE d).sum_mem htopmem + have hclass : ν.homogeneousMk d ⟨∑ i ∈ top, (f i : R) * β i, htopsum⟩ ≠ 0 := by + rw [ν.homogeneousMk_finsetSum top _ htopmem htopsum] + intro hzero + have hi₀top : i₀ ∈ top := by + rw [htop, Finset.mem_filter] + exact ⟨hi₀, hdcoe⟩ + refine hfi₀ (H.independent top (fun i ↦ f i) ?_ i₀ hi₀top) + rw [← hzero, ← Finset.sum_attach top] + refine Finset.sum_congr rfl fun i _ ↦ ?_ + rw [ν.homogeneousMk_eq_initialForm_of_degree_eq (htopmem i i.2) + (by rw [H.degree_coe_mul_beta]; exact (Finset.mem_filter.mp i.2).2), + ν.initialForm_mul] + have htopdeg : ν (∑ i ∈ top, (f i : R) * β i) = (d : WithBot M) := by + refine le_antisymm ((ν.mem_filtrationLE_iff _ _).mp htopsum) (not_lt.mp fun hlt ↦ ?_) + exact hclass (ν.homogeneousMk_eq_zero_of_degree_lt htopsum hlt) + rw [hsplit, ν.degree_add_eq_of_lt (by rw [htopdeg]; exact hrest), htopdeg] + +omit [WellFoundedLT M] in +/-- The `β i` are linearly independent over `P`. -/ +theorem linearIndependent : LinearIndependent P β := by + classical + rw [LinearIndependent, injective_iff_map_eq_zero] + intro f hf + have hsum : (f.sum fun i p ↦ (p : R) * β i) = 0 := by + rw [← hf, Finsupp.linearCombination_apply] + exact Finsupp.sum_congr fun i _ ↦ by rw [Algebra.smul_def]; rfl + have hdeg := H.degree_finsupp_sum f + rw [hsum, ν.map_zero] at hdeg + by_contra hne + obtain ⟨i, hi⟩ := Finsupp.support_nonempty_iff.mpr hne + have hfi : (f i : R) ≠ 0 := fun h ↦ Finsupp.mem_support_iff.mp hi (Subtype.ext h) + have hle : ν (f i) + γ i ≤ ⊥ := by + rw [hdeg] + exact Finset.le_sup (f := fun i ↦ ν (f i) + γ i) hi + obtain ⟨m, hm⟩ := WithBot.ne_bot_iff_exists.mp (ν.map_ne_bot_of_ne_zero H.separated hfi) + rw [← hm, ← WithBot.coe_add] at hle + exact absurd hle (not_le.mpr (WithBot.bot_lt_coe _)) + +omit [ν.IsMultiplicative] in +/-- The `β i` span `R` over `P`, by well-founded induction on the degree. -/ +theorem span_eq_top : Submodule.span P (Set.range β) = ⊤ := by + rw [eq_top_iff] + intro t _ + suffices h : ∀ (d : WithBot M) (t : R), ν t = d → t ∈ Submodule.span P (Set.range β) from + h (ν t) t rfl + intro d + induction d using WellFoundedLT.induction with + | _ d ih => + intro t ht + cases d with + | bot => rw [((isSeparated_iff ν).mp H.separated t).mp ht]; exact Submodule.zero_mem _ + | coe m => + have hmem : t ∈ ν.filtrationLE m := (ν.mem_filtrationLE_iff _ _).mpr ht.le + obtain ⟨t', ht'span, ht'mem, ht'class⟩ := H.spanning m (ν.componentMk m ⟨t, hmem⟩) + have hdiff : ν (t - t') < (m : WithBot M) := by + have hsub : ν.componentMk m (⟨t, hmem⟩ - ⟨t', ht'mem⟩) = 0 := by + rw [map_sub, ht'class, sub_self] + exact (ν.componentMk_eq_zero_iff m _).mp hsub + have hrec := ih (ν (t - t')) hdiff (t - t') rfl + have : t = (t - t') + t' := by ring + rw [this] + exact Submodule.add_mem _ hrec ht'span + +/-- The basis of `R` over `P` given by the `β i`; for the paper, `(c_C)_{C ∈ 𝓒}` as a basis of +`K((ℝ^{≤0}))` over `S`. -/ +def basis : Module.Basis ι P R := + Module.Basis.mk H.linearIndependent (by rw [H.span_eq_top]) + +@[simp] +theorem basis_apply (i : ι) : H.basis i = β i := + Module.Basis.mk_apply _ _ i + +theorem sum_repr_mul_beta (t : R) : + (H.basis.repr t).sum (fun i p ↦ (p : R) * β i) = t := by + conv_rhs => rw [← H.basis.linearCombination_repr t] + rw [Finsupp.linearCombination_apply] + exact Finsupp.sum_congr fun i _ ↦ by rw [Algebra.smul_def, H.basis_apply]; rfl + +end IsBasisOver + +/-- A subalgebra `P` whose initial forms generate the associated graded ring as an abelian group +is the whole ring: the case `β = 1` of the basis-over-`P` theorem, proved directly by well-founded +induction on the degree. -/ +@[blueprint "lem:initial-forms-generate-subalgebra" + (phase := "Algebraic and ordinal preliminaries") + (title := "Lifting generation from the associated graded ring") + (statement := /-- + Let $\nu$ be a separated multiplicative degree on a ring $R$, with + well-founded value order, and let $P\subseteq R$ be a subalgebra. If every + element of $\operatorname{gr}_\nu R$ is a finite sum of initial forms of + elements of $P$, then $P=R$. + -/) + (proof := /-- + Use well-founded induction on $\nu(t)$. Express the initial form of $t$ as + a finite sum of initial forms of elements of $P$, and subtract their sum + $t'\in P$. Equality of initial forms gives $\nu(t-t')<\nu(t)$, so the + induction hypothesis puts $t-t'$ in $P$. Hence $t=(t-t')+t'$ lies in $P$. + Separatedness handles degree $\bot$. + -/)] +theorem mem_of_forall_exists_sum_initialForm [ν.IsMultiplicative] (hν : ν.IsSeparated) + (hspan : ∀ g : ν.AssociatedGraded, ∃ (κ : Type x) (_ : Fintype κ) (p : κ → P), + g = ∑ k, ν.initialForm (p k)) + (t : R) : t ∈ P := by + refine ν.mem_of_forall_exists_componentMk_eq hν P.toSubring.toAddSubgroup (fun d g ↦ ?_) t + obtain ⟨u, hu, hut, hmk⟩ := IsBasisOver.spanning_of_forall_exists_sum (ν := ν) (P := P) + (β := fun _ : PUnit.{x + 1} ↦ (1 : R)) + (fun g ↦ by + obtain ⟨κ, _, p, hg⟩ := hspan g + refine ⟨κ, inferInstance, p, fun _ ↦ PUnit.unit, ?_⟩ + simp only [ν.initialForm_one, mul_one] + exact hg) d g + refine ⟨u, ?_, hut, hmk⟩ + rw [Set.range_const, Submodule.mem_span_singleton] at hu + obtain ⟨a, rfl⟩ := hu + change (a : R) * 1 ∈ P + rw [mul_one] + exact a.2 + +end Data + +/-! ### Scalars on the associated graded ring `gr_{ν_P} R` -/ + +section Scalars + +variable [CommRing L] [Algebra L R] [FaithfulSMul L R] [Nontrivial R] [WellFoundedLT M] + [Fact (∀ m : M, 0 ≤ m)] +variable (ν : MaxAddDegree R M) (P : Subalgebra L R) + +omit [IsOrderedCancelAddMonoid M] [WellFoundedLT M] in +theorem zero_le_of_fact (m : M) : 0 ≤ m := (Fact.out : ∀ m : M, 0 ≤ m) m + +omit [Nontrivial R] in +theorem degreeOver_algebraMap_eq_zero' {l : L} (hl : l ≠ 0) : + ν.degreeOver P (algebraMap L R l) = 0 := + ν.degreeOver_algebraMap_eq_zero P (zero_le_of_fact) + (fun h ↦ hl ((FaithfulSMul.algebraMap_injective L R) + (h.trans (RingHom.map_zero (algebraMap L R)).symm))) + +omit [Nontrivial R] [FaithfulSMul L R] in +theorem degreeOver_coe_eq_zero' {p : P} (hp : p ≠ 0) : ν.degreeOver P (p : R) = 0 := + ν.degreeOver_coe_eq_zero P (zero_le_of_fact) fun h ↦ hp (Subtype.ext h) + +/-- The scalar homomorphism from `L` to `gr_{ν_P} R`. -/ +def degreeOverScalarHom : L →+* (ν.degreeOver P).AssociatedGraded := + degreeZeroScalarHom (ν.degreeOver P) (algebraMap L R) + fun _ hl ↦ ν.degreeOver_algebraMap_eq_zero' P hl + +/-- The `L`-algebra structure on `gr_{ν_P} R`. -/ +instance degreeOverAlgebra : Algebra L (ν.degreeOver P).AssociatedGraded := + (degreeOverScalarHom ν P).toAlgebra + +omit [Nontrivial R] in +theorem degreeOver_algebraMap_apply (l : L) (x : (ν.degreeOver P).filtrationLE 0) + (hx : (x : R) = algebraMap L R l) : + algebraMap L (ν.degreeOver P).AssociatedGraded l = (ν.degreeOver P).homogeneousMk 0 x := + degreeZeroScalarHom_apply _ _ _ l x hx + +/-- The homomorphism from `P` to degree zero of `gr_{ν_P} R`; for the paper, +`ψ : S → (gr_{deg_S})_0`. -/ +def degreeOverSubalgebraHom : P →+* (ν.degreeOver P).AssociatedGraded := + degreeZeroScalarHom (ν.degreeOver P) (algebraMap P R) + fun _ hp ↦ ν.degreeOver_coe_eq_zero' P hp + +omit [Nontrivial R] [FaithfulSMul L R] in +theorem degreeOverSubalgebraHom_apply (p : P) (x : (ν.degreeOver P).filtrationLE 0) + (hx : (x : R) = p) : degreeOverSubalgebraHom ν P p = (ν.degreeOver P).homogeneousMk 0 x := + degreeZeroScalarHom_apply _ _ _ p x hx + +omit [Nontrivial R] [Fact (∀ m : M, 0 ≤ m)] [FaithfulSMul L R] in +theorem coe_mem_degreeOver_filtrationLE_zero (p : P) : (p : R) ∈ (ν.degreeOver P).filtrationLE 0 := + ((ν.degreeOver P).mem_filtrationLE_iff 0 p).mpr (ν.degreeOver_coe_le_zero P p) + +/-- The homomorphism `P → gr_{ν_P} R` as an `L`-algebra homomorphism. -/ +def degreeOverSubalgebraAlgHom : P →ₐ[L] (ν.degreeOver P).AssociatedGraded := + { degreeOverSubalgebraHom ν P with + commutes' := fun l ↦ by + change degreeOverSubalgebraHom ν P (algebraMap L P l) = algebraMap L _ l + rw [degreeOverSubalgebraHom_apply ν P (algebraMap L P l) + ⟨algebraMap L R l, (ν.coe_mem_degreeOver_filtrationLE_zero P (algebraMap L P l))⟩ rfl, + degreeOver_algebraMap_apply ν P l + ⟨algebraMap L R l, (ν.coe_mem_degreeOver_filtrationLE_zero P (algebraMap L P l))⟩ rfl] } + +omit [Nontrivial R] in +theorem degreeOverSubalgebraAlgHom_apply (p : P) : + degreeOverSubalgebraAlgHom ν P p = degreeOverSubalgebraHom ν P p := (rfl) + +end Scalars + +/-! ### Freeness of `gr_{ν_P} R` over `P` -/ + +section Freeness + +variable [CommRing L] [Algebra L R] [WellFoundedLT M] [Fact (∀ m : M, 0 ≤ m)] +variable {ι : Type x} +variable {ν : MaxAddDegree R M} {P : Subalgebra L R} {γ : ι → M} {β : ι → R} + +namespace IsBasisOver + +variable (H : IsBasisOver ν P γ β) +include H + +omit [Fact (∀ m : M, 0 ≤ m)] in +theorem degreeOver_coe_mul_beta_le (p : P) (i : ι) : + ν.degreeOver P ((p : R) * β i) ≤ γ i := by + refine ((ν.degreeOver P).map_mul_le_add _ _).trans ?_ + calc ν.degreeOver P (p : R) + ν.degreeOver P (β i) ≤ 0 + (γ i : WithBot M) := + add_le_add (ν.degreeOver_coe_le_zero P p) + (ν.degreeOver_le_of_degree_le P (H.degree_beta i).le) + _ = γ i := zero_add _ + +omit [Fact (∀ m : M, 0 ≤ m)] in +theorem beta_mem_degreeOver_filtrationLE (i : ι) : β i ∈ (ν.degreeOver P).filtrationLE (γ i) := + ((ν.degreeOver P).mem_filtrationLE_iff _ _).mpr + (ν.degreeOver_le_of_degree_le P (H.degree_beta i).le) + +/-- The class `[β] i` of `β i` in degree `γ i` of `gr_{ν_P} R`. -/ +def layerClass (i : ι) : (ν.degreeOver P).AssociatedGraded := + (ν.degreeOver P).homogeneousMk (γ i) ⟨β i, H.beta_mem_degreeOver_filtrationLE i⟩ + +omit [Fact (∀ m : M, 0 ≤ m)] in +theorem layerClass_eq (i : ι) : + H.layerClass i = + (ν.degreeOver P).homogeneousMk (γ i) ⟨β i, H.beta_mem_degreeOver_filtrationLE i⟩ := + (rfl) + +/-- The product of the degree-zero class of `p ∈ P` with `[β] i` is the class of `p β i`. -/ +theorem degreeOverSubalgebraHom_mul_layerClass (p : P) (i : ι) : + degreeOverSubalgebraHom ν P p * H.layerClass i = + (ν.degreeOver P).homogeneousMk (γ i) + ⟨(p : R) * β i, ((ν.degreeOver P).mem_filtrationLE_iff _ _).mpr + (H.degreeOver_coe_mul_beta_le p i)⟩ := by + rw [degreeOverSubalgebraHom_apply ν P p ⟨(p : R), ν.coe_mem_degreeOver_filtrationLE_zero P p⟩ rfl, + layerClass] + exact ((ν.degreeOver P).homogeneousMk_mul_of_coe_eq (zero_add _).symm _ _ _ rfl).symm + +variable [ν.IsMultiplicative] + +/-- The `P`-submodule of elements whose expansion involves only `β i` with `γ i ≤ d`. -/ +private def coordSubmodule (d : M) : Submodule P R where + carrier := {t | ∀ i ∈ (H.basis.repr t).support, γ i ≤ d} + zero_mem' := by simp + add_mem' {a b} ha hb i hi := by + classical + rw [map_add] at hi + rcases Finset.mem_union.mp (Finsupp.support_add hi) with h | h + · exact ha i h + · exact hb i h + smul_mem' p t ht i hi := by + rw [map_smul] at hi + exact ht i (Finsupp.support_smul hi) + +theorem gamma_le_of_degree_le {t : R} {d : M} (ht : ν t ≤ d) : + ∀ i ∈ (H.basis.repr t).support, γ i ≤ d := by + intro i hi + have hdeg := H.degree_finsupp_sum (H.basis.repr t) + rw [H.sum_repr_mul_beta] at hdeg + have hfi : ((H.basis.repr t) i : R) ≠ 0 := + fun h ↦ Finsupp.mem_support_iff.mp hi (Subtype.ext h) + have h1 : ν ((H.basis.repr t) i) + γ i ≤ ν t := by + rw [hdeg] + exact Finset.le_sup (f := fun i ↦ ν ((H.basis.repr t) i) + γ i) hi + have h2 : ((γ i : M) : WithBot M) ≤ ν ((H.basis.repr t) i) + γ i := by + calc ((γ i : M) : WithBot M) = 0 + (γ i : WithBot M) := (zero_add _).symm + _ ≤ _ := add_le_add (ν.zero_le_degree H.separated (zero_le_of_fact) hfi) le_rfl + exact WithBot.coe_le_coe.mp (h2.trans (h1.trans ht)) + +/-- An element of degree at most `d` lies in `P` provided every `β i` with `γ i ≤ d` does. -/ +theorem mem_of_degree_le {t : R} {d : M} (ht : ν t ≤ d) + (hβ : ∀ i, γ i ≤ d → β i ∈ P) : t ∈ P := by + rw [← H.sum_repr_mul_beta t, Finsupp.sum] + exact Subalgebra.sum_mem _ fun i hi ↦ Subalgebra.mul_mem _ (Subtype.mem _) + (hβ i (H.gamma_le_of_degree_le ht i hi)) + +/-- The degree over `P` in the basis: `ν_P(t) ≤ d` exactly when every `β i` occurring in the +expansion of `t` has `γ i ≤ d`. -/ +theorem degreeOver_le_iff_forall_repr (t : R) (d : M) : + ν.degreeOver P t ≤ d ↔ ∀ i ∈ (H.basis.repr t).support, γ i ≤ d := by + rw [ν.degreeOver_le_iff] + constructor + · intro ht + refine ((ν.degreeOverStage_le_iff P (coordSubmodule H d) d).mpr ?_) ht + intro x hx + exact H.gamma_le_of_degree_le ((ν.mem_filtrationLE_iff d x).mp hx) + · intro h + rw [← H.sum_repr_mul_beta t, Finsupp.sum] + refine Submodule.sum_mem _ fun i hi ↦ ?_ + change ((H.basis.repr t) i) • β i ∈ _ + exact Submodule.smul_mem _ _ (ν.degreeOverStage_mono P (h i hi) + (ν.mem_degreeOverStage_of_degree_le P (H.degree_beta i).le)) + +theorem gamma_lt_of_degreeOver_lt {t : R} {d : M} (h : ν.degreeOver P t < d) : + ∀ i ∈ (H.basis.repr t).support, γ i < d := by + by_cases ht : t = 0 + · subst ht + simp + obtain ⟨m, hm, hmem⟩ := ν.exists_mem_degreeOverStage_of_degreeOver_lt P ht h + intro i hi + exact lt_of_le_of_lt ((H.degreeOver_le_iff_forall_repr t m).mp + ((ν.degreeOver_le_iff P t m).mpr hmem) i hi) hm + +/-- The class of `t` in degree `d` for `ν_P` is the sum of the terms `pᵢ [β]ᵢ` of its expansion +with `γ i = d`. -/ +theorem homogeneousMk_eq_sum (t : R) (d : M) + (ht : t ∈ (ν.degreeOver P).filtrationLE d) : + (ν.degreeOver P).homogeneousMk d ⟨t, ht⟩ = + ∑ i ∈ (H.basis.repr t).support.filter (fun i ↦ γ i = d), + degreeOverSubalgebraHom ν P ((H.basis.repr t) i) * H.layerClass i := by + classical + set f := H.basis.repr t with hf + have hγ : ∀ i ∈ f.support, γ i ≤ d := + (H.degreeOver_le_iff_forall_repr t d).mp + (((ν.degreeOver P).mem_filtrationLE_iff _ _).mp ht) + have hmem : ∀ i ∈ f.support, (f i : R) * β i ∈ (ν.degreeOver P).filtrationLE d := + fun i hi ↦ + ((ν.degreeOver P).mem_filtrationLE_iff _ _).mpr + ((H.degreeOver_coe_mul_beta_le (f i) i).trans (WithBot.coe_le_coe.mpr (hγ i hi))) + have hsum : ∑ i ∈ f.support, (f i : R) * β i ∈ (ν.degreeOver P).filtrationLE d := + ((ν.degreeOver P).filtrationLE d).sum_mem hmem + have ht' : (⟨t, ht⟩ : (ν.degreeOver P).filtrationLE d) = ⟨_, hsum⟩ := by + apply Subtype.ext + change t = ∑ i ∈ f.support, (f i : R) * β i + rw [← H.sum_repr_mul_beta t, Finsupp.sum] + rw [ht', (ν.degreeOver P).homogeneousMk_finsetSum f.support _ hmem hsum, Finset.sum_filter] + rw [← Finset.sum_attach f.support fun i ↦ if γ i = d then + degreeOverSubalgebraHom ν P (f i) * H.layerClass i else 0] + refine Finset.sum_congr rfl fun i _ ↦ ?_ + by_cases h : γ i = d + · rw [ite_eq_left h] + subst h + rw [H.degreeOverSubalgebraHom_mul_layerClass] + · rw [ite_eq_right h] + refine (ν.degreeOver P).homogeneousMk_eq_zero_of_degree_lt (hmem i i.2) ?_ + exact lt_of_le_of_lt (H.degreeOver_coe_mul_beta_le (f i) i) + (WithBot.coe_lt_coe.mpr (lt_of_le_of_ne (hγ i i.2) h)) + +/-- The classes `[β] i` generate `gr_{ν_P} R` over `P`: every element is a finite sum of products +`p [β]ᵢ` with `p ∈ P`. -/ +theorem closure_degreeOverSubalgebraHom_mul_layerClass_eq_top : + AddSubmonoid.closure + (Set.range fun x : P × ι ↦ degreeOverSubalgebraHom ν P x.1 * H.layerClass x.2) = ⊤ := by + rw [eq_top_iff] + rintro z - + induction z using DirectSum.induction_on with + | zero => exact zero_mem _ + | of d g => + induction g using componentInductionOn with + | H x => + obtain ⟨t, ht⟩ := x + rw [← (ν.degreeOver P).homogeneousMk_apply, H.homogeneousMk_eq_sum] + exact sum_mem fun i _ ↦ AddSubmonoid.subset_closure ⟨(_, i), rfl⟩ + | add u v hu hv => exact add_mem hu hv + +/-- The classes `[β] i` are independent over `P`: a vanishing finite combination `∑ pₖ [β]ₖ` has +every coefficient zero. -/ +theorem eq_zero_of_sum_degreeOverSubalgebraHom_mul_layerClass_eq_zero (s : Finset ι) (f : ι → P) + (h : ∑ k ∈ s, degreeOverSubalgebraHom ν P (f k) * H.layerClass k = 0) : + ∀ k ∈ s, f k = 0 := by + classical + have hmem : ∀ k, (f k : R) * β k ∈ (ν.degreeOver P).filtrationLE (γ k) := fun k ↦ + ((ν.degreeOver P).mem_filtrationLE_iff _ _).mpr (H.degreeOver_coe_mul_beta_le (f k) k) + have himage : ∑ k ∈ s, degreeOverSubalgebraHom ν P (f k) * H.layerClass k = + ∑ k ∈ s, (ν.degreeOver P).homogeneousMk (γ k) ⟨(f k : R) * β k, hmem k⟩ := + Finset.sum_congr rfl fun k _ ↦ H.degreeOverSubalgebraHom_mul_layerClass (f k) k + intro k₀ hk₀ + have hcomp : (∑ k ∈ s, degreeOverSubalgebraHom ν P (f k) * H.layerClass k) (γ k₀) = + (0 : (ν.degreeOver P).AssociatedGraded) (γ k₀) := congrArg (fun z ↦ z (γ k₀)) h + rw [himage, (ν.degreeOver P).homogeneousMk_finsetSum_apply s γ + (fun k ↦ (f k : R) * β k) hmem (γ k₀), DirectSum.zero_apply, + (ν.degreeOver P).componentMk_eq_zero_iff] at hcomp + set t := ∑ k ∈ s.filter (fun k ↦ γ k = γ k₀), (f k : R) * β k with ht + have hrepr : H.basis.repr t k₀ = f k₀ := by + have : t = ∑ k ∈ s.filter (fun k ↦ γ k = γ k₀), (f k) • H.basis k := by + refine Finset.sum_congr rfl fun k _ ↦ ?_ + rw [Algebra.smul_def, H.basis_apply] + rfl + rw [this, map_sum, Finsupp.finsetSum_apply, Finset.sum_eq_single k₀] + · rw [map_smul, Module.Basis.repr_self, Finsupp.smul_apply, Finsupp.single_eq_same, + smul_eq_mul, mul_one] + · intro k _ hk + rw [map_smul, Module.Basis.repr_self, Finsupp.smul_apply, Finsupp.single_eq_of_ne hk.symm, + smul_zero] + · intro h + exact absurd (Finset.mem_filter.mpr ⟨hk₀, rfl⟩ : k₀ ∈ s.filter (fun k ↦ γ k = γ k₀)) h + by_contra hne + have hsupp : k₀ ∈ (H.basis.repr t).support := by + rw [Finsupp.mem_support_iff, hrepr] + exact hne + exact lt_irrefl _ (H.gamma_lt_of_degreeOver_lt hcomp k₀ hsupp) + +section Bijective + +variable {L' : Type*} [CommRing L'] [Algebra L' P] {C : Type*} [CommRing C] [Algebra L' C] + (c : Module.Basis ι L' C) + {F : Type*} [FunLike F (C ⊗[L'] P) (ν.degreeOver P).AssociatedGraded] + [AddMonoidHomClass F (C ⊗[L'] P) (ν.degreeOver P).AssociatedGraded] + (Θ : F) + (hΘ : ∀ (i : ι) (p : P), Θ (c i ⊗ₜ[L'] p) = degreeOverSubalgebraHom ν P p * H.layerClass i) +include hΘ + +/-- A map `C ⊗ P → gr_{ν_P} R` sending `c i ⊗ p` to `p [β] i` is surjective. -/ +theorem surjective_of_tmul : Function.Surjective Θ := by + intro z + have hz : z ∈ AddSubmonoid.closure + (Set.range fun x : P × ι ↦ degreeOverSubalgebraHom ν P x.1 * H.layerClass x.2) := by + rw [H.closure_degreeOverSubalgebraHom_mul_layerClass_eq_top] + exact AddSubmonoid.mem_top z + refine AddSubmonoid.closure_induction (fun y hy ↦ ?_) ⟨0, _root_.map_zero Θ⟩ + (fun _ _ _ _ ⟨a, ha⟩ ⟨b, hb⟩ ↦ ⟨a + b, by rw [map_add, ha, hb]⟩) hz + obtain ⟨⟨p, i⟩, rfl⟩ := hy + exact ⟨c i ⊗ₜ[L'] p, hΘ i p⟩ + +/-- A map `C ⊗ P → gr_{ν_P} R` sending `c i ⊗ p` to `p [β] i` is injective. -/ +theorem injective_of_tmul : Function.Injective Θ := by + classical + rw [injective_iff_map_eq_zero] + intro x hx + set B := Algebra.TensorProduct.basis P c with hB + set x' := Algebra.TensorProduct.comm L' C P x with hx' + set f := B.repr x' with hf + -- expand `x` in the basis of `P ⊗[L'] C` + have hexp : x = ∑ k ∈ f.support, c k ⊗ₜ[L'] f k := by + have h1 : x' = ∑ k ∈ f.support, (f k : P) ⊗ₜ[L'] c k := by + conv_lhs => rw [← B.linearCombination_repr x', Finsupp.linearCombination_apply, Finsupp.sum] + refine Finset.sum_congr rfl fun k _ ↦ ?_ + rw [hB, Algebra.TensorProduct.basis_apply, TensorProduct.smul_tmul', smul_eq_mul, mul_one] + have h2 := congrArg (Algebra.TensorProduct.comm L' C P).symm h1 + rw [hx', AlgEquiv.symm_apply_apply, map_sum] at h2 + rw [h2] + exact Finset.sum_congr rfl fun k _ ↦ by rw [Algebra.TensorProduct.comm_symm_tmul] + have hcoord : ∀ k ∈ f.support, f k = 0 := by + refine H.eq_zero_of_sum_degreeOverSubalgebraHom_mul_layerClass_eq_zero f.support f ?_ + rw [← hx, hexp, map_sum] + exact Finset.sum_congr rfl fun k _ ↦ (hΘ k (f k)).symm + rw [hexp] + exact Finset.sum_eq_zero fun k hk ↦ by rw [hcoord k hk, TensorProduct.tmul_zero] + +/-- A map `C ⊗ P → gr_{ν_P} R` sending `c i ⊗ p` to `p [β] i` is bijective: `gr_{ν_P} R` is free +over `P` on the classes `[β] i`, and `C ⊗ P` is free over `P` on `c i ⊗ 1`. -/ +theorem bijective_of_tmul : Function.Bijective Θ := + ⟨H.injective_of_tmul c Θ hΘ, H.surjective_of_tmul c Θ hΘ⟩ + +end Bijective + +end IsBasisOver + +end Freeness + +/-! ### The prime criterion -/ + +section Prime + +variable [CommRing L] [Algebra L R] [WellFoundedLT M] +variable (ν : MaxAddDegree R M) (P : Subalgebra L R) +variable {L' : Type*} [CommRing L'] [Algebra L' P] {C : Type*} [CommRing C] [Algebra L' C] + +/-- The prime criterion: if `C ⊗[L'] P ≃ gr_{ν_P} R` as rings, with `1 ⊗ a ↦ in_{ν_P}(a)` (the +initial form of `a` for `ν_P`), then a non-zero `a ∈ P` is prime in `R` whenever `C ⊗[L'] P` and +`C ⊗[L'] (P ⧸ (a))` are domains. For the paper, `Θ : (P̂/I) ⊗_K S ≅ gr_{deg_S} K((ℝ^{≤0}))`. -/ +theorem prime_coe_of_degreeOverGradedRingEquiv + (Θ : C ⊗[L'] P ≃+* (ν.degreeOver P).AssociatedGraded) + (hΘ : ∀ a : P, Θ (1 ⊗ₜ[L'] a) = (ν.degreeOver P).initialForm a) + {a : P} (ha : a ≠ 0) [IsDomain (C ⊗[L'] P)] [IsDomain (C ⊗[L'] (P ⧸ Ideal.span {a}))] : + Prime (a : R) := by + classical + have hψsep : (ν.degreeOver P).IsSeparated := ν.degreeOver_isSeparated P + have : IsDomain (ν.degreeOver P).AssociatedGraded := Θ.symm.toMulEquiv.isDomain _ + -- the quotient by the initial form is a domain + have hmap : Ideal.span {(ν.degreeOver P).initialForm (a : R)} = + (Ideal.span ({1 ⊗ₜ[L'] a} : Set (C ⊗[L'] P))).map + (Θ : C ⊗[L'] P →+* (ν.degreeOver P).AssociatedGraded) := by + rw [Ideal.map_span, Set.image_singleton, ← hΘ] + rfl + have hmap' : (Ideal.span ({a} : Set P)).map + (Algebra.TensorProduct.includeRight : P →ₐ[L'] C ⊗[L'] P) = + Ideal.span ({1 ⊗ₜ[L'] a} : Set (C ⊗[L'] P)) := by + rw [Ideal.map_span, Set.image_singleton] + rfl + have : IsDomain ((C ⊗[L'] P) ⧸ Ideal.span ({1 ⊗ₜ[L'] a} : Set (C ⊗[L'] P))) := by + have e := Algebra.TensorProduct.tensorQuotientEquiv (R := L') L' P C (Ideal.span {a}) + rw [hmap'] at e + exact e.symm.toMulEquiv.isDomain _ + have : IsDomain ((ν.degreeOver P).AssociatedGraded ⧸ + Ideal.span {(ν.degreeOver P).initialForm (a : R)}) := + (Ideal.quotientEquiv _ _ Θ hmap).symm.toMulEquiv.isDomain _ + exact (ν.degreeOver P).prime_of_quotient_span_initialForm_isDomain hψsep + fun h ↦ ha (Subtype.ext h) + +/-- The prime criterion transported along an algebra isomorphism `P₀ ≃ P`: the domain +hypotheses may be verified on any model `P₀` of the subalgebra. -/ +theorem prime_coe_of_degreeOverGradedRingEquiv_of_algEquiv + (Θ : C ⊗[L'] P ≃+* (ν.degreeOver P).AssociatedGraded) + (hΘ : ∀ a : P, Θ (1 ⊗ₜ[L'] a) = (ν.degreeOver P).initialForm a) + {P₀ : Type*} [CommRing P₀] [Algebra L' P₀] (e : P₀ ≃ₐ[L'] P) + {a₀ : P₀} (ha₀ : a₀ ≠ 0) [IsDomain (C ⊗[L'] P₀)] + [IsDomain (C ⊗[L'] (P₀ ⧸ Ideal.span {a₀}))] : Prime ((e a₀ : P) : R) := by + have ha : e a₀ ≠ 0 := (map_ne_zero_iff e e.injective).mpr ha₀ + have : IsDomain (C ⊗[L'] P) := + (Algebra.TensorProduct.congr (AlgEquiv.refl (R := L') (A₁ := C)) e).symm.toMulEquiv.isDomain _ + have hmap : Ideal.span {e a₀} = (Ideal.span {a₀}).map (e : P₀ →+* P) := by + rw [Ideal.map_span, Set.image_singleton] + rfl + let eQ := Ideal.quotientEquivAlg (Ideal.span {a₀}) (Ideal.span {e a₀}) e hmap + have : IsDomain (C ⊗[L'] (P ⧸ Ideal.span {e a₀})) := + (Algebra.TensorProduct.congr (AlgEquiv.refl (R := L') (A₁ := C)) eQ).symm.toMulEquiv.isDomain _ + exact ν.prime_coe_of_degreeOverGradedRingEquiv P Θ hΘ ha + +end Prime + +end MaxAddDegree diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/DegreeAssociatedGraded.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/DegreeAssociatedGraded.lean new file mode 100644 index 0000000000..2b4283a035 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/DegreeAssociatedGraded.lean @@ -0,0 +1,498 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.MaxAddDegree +public import Mathlib.Algebra.DirectSum.Ring +public import Mathlib.GroupTheory.QuotientGroup.Defs + +/-! +# Associated graded ring of a max-additive degree + +For a max-additive degree `ν` and a grade `m`, the homogeneous component is the additive +quotient + +`ν.filtrationLE m / ν.filtrationLT m`. + +The strict filtration is represented inside the weak filtration by `lowerFiltration`. The mixed +strict product estimates derived from submultiplicativity make representative multiplication well +defined on these quotients. Their direct sum is `MaxAddDegree.AssociatedGraded ν` and inherits a +commutative ring structure. Exact multiplicativity is not needed for the construction; it enters +only where the graded ring is shown to be a domain. + +This quotient-first construction follows the quotient description given after LM24, Proposition +4.2.6. In particular, zero in every homogeneous component is the entire strict filtration, not +only the literal zero representative. The printed representative-dependent branch in LM24, +Definition 4.2.4 is not used; +`ConwayRefinement.Algebra.Valuation.Tests.AssociatedGraded` gives a compiled counterexample to +its commutativity. +-/ + +universe u v + +public noncomputable section + +namespace MaxAddDegree + +variable {R : Type u} {M : Type v} [CommRing R] [AddCommMonoid M] + [LinearOrder M] [IsOrderedCancelAddMonoid M] + +/-- The additive subgroup of elements of degree at most `m`. -/ +def filtrationLE (ν : MaxAddDegree R M) (m : M) : AddSubgroup R where + carrier := {x | ν x ≤ m} + zero_mem' := by simp + add_mem' {x y} hx hy := (ν.map_add_le_max x y).trans (max_le hx hy) + neg_mem' {x} hx := by simpa using hx + +/-- The additive subgroup of elements of degree strictly below `m`. -/ +def filtrationLT (ν : MaxAddDegree R M) (m : M) : AddSubgroup R where + carrier := {x | ν x < m} + zero_mem' := by simp + add_mem' {x y} hx hy := (ν.map_add_le_max x y).trans_lt (max_lt hx hy) + neg_mem' {x} hx := by simpa using hx + +omit [IsOrderedCancelAddMonoid M] in +@[simp] +theorem mem_filtrationLE_iff (ν : MaxAddDegree R M) (m : M) (x : R) : + x ∈ ν.filtrationLE m ↔ ν x ≤ m := + Iff.rfl + +omit [IsOrderedCancelAddMonoid M] in +@[simp] +theorem mem_filtrationLT_iff (ν : MaxAddDegree R M) (m : M) (x : R) : + x ∈ ν.filtrationLT m ↔ ν x < m := + Iff.rfl + +omit [IsOrderedCancelAddMonoid M] in +theorem filtrationLT_le_filtrationLE (ν : MaxAddDegree R M) (m : M) : + ν.filtrationLT m ≤ ν.filtrationLE m := + fun x hx ↦ show ν x ≤ m from hx.le + +theorem degree_mul_le_add {ν : MaxAddDegree R M} {m n : M} {x y : R} + (hx : ν x ≤ m) (hy : ν y ≤ n) : + ν (x * y) ≤ m + n := + (ν.map_mul_le_add x y).trans (add_le_add hx hy) + +theorem degree_mul_lt_add_of_lt_of_le {ν : MaxAddDegree R M} {m n : M} {x y : R} + (hx : ν x < m) (hy : ν y ≤ n) : + ν (x * y) < m + n := by + apply (ν.map_mul_le_add x y).trans_lt + by_cases hybot : ν y = ⊥ + · simp [hybot] + · exact WithBot.add_lt_add_of_lt_of_le hybot hx hy + +theorem degree_mul_lt_add_of_le_of_lt {ν : MaxAddDegree R M} {m n : M} {x y : R} + (hx : ν x ≤ m) (hy : ν y < n) : + ν (x * y) < m + n := by + apply (ν.map_mul_le_add x y).trans_lt + by_cases hxbot : ν x = ⊥ + · simp [hxbot] + · exact WithBot.add_lt_add_of_le_of_lt hxbot hx hy + +/-- Multiplication by a fixed weakly filtered representative. -/ +def mulFiltrationLE (ν : MaxAddDegree R M) {m n : M} + (x : ν.filtrationLE m) : ν.filtrationLE n →+ ν.filtrationLE (m + n) where + toFun y := ⟨(x : R) * (y : R), degree_mul_le_add x.2 y.2⟩ + map_zero' := by ext; exact mul_zero (x : R) + map_add' y z := by ext; exact mul_add (x : R) (y : R) (z : R) + +@[simp] +theorem coe_mulFiltrationLE (ν : MaxAddDegree R M) {m n : M} + (x : ν.filtrationLE m) (y : ν.filtrationLE n) : + (ν.mulFiltrationLE x y : R) = (x : R) * (y : R) := + (rfl) + +/-- The strict filtration, regarded as a subgroup of the weak filtration at the same grade. -/ +def lowerFiltration (ν : MaxAddDegree R M) (m : M) : + AddSubgroup (ν.filtrationLE m) := + (ν.filtrationLT m).comap (ν.filtrationLE m).subtype + +omit [IsOrderedCancelAddMonoid M] in +@[simp] +theorem mem_lowerFiltration_iff (ν : MaxAddDegree R M) (m : M) + (x : ν.filtrationLE m) : + x ∈ ν.lowerFiltration m ↔ ν x < m := by + rw [lowerFiltration] + exact mem_filtrationLT_iff ν m x + +/-- The homogeneous associated-graded component at `m`. + +A `def` rather than an `abbrev`, with instances supplied below: every graded object here is built +from components, and a reducible head sends each instance search down through `filtrationLE` into +the subring of `R`. -/ +@[expose] def Component (ν : MaxAddDegree R M) (m : M) : Type u := + ν.filtrationLE m ⧸ ν.lowerFiltration m + +instance (ν : MaxAddDegree R M) (m : M) : AddCommGroup (ν.Component m) := + inferInstanceAs (AddCommGroup (ν.filtrationLE m ⧸ ν.lowerFiltration m)) + +/-- The quotient map from the weak filtration to its homogeneous component. -/ +def componentMk (ν : MaxAddDegree R M) (m : M) : + ν.filtrationLE m →+ ν.Component m := + QuotientAddGroup.mk' (ν.lowerFiltration m) + +/-- The class of a representative. -/ +instance (ν : MaxAddDegree R M) (m : M) : CoeTC (ν.filtrationLE m) (ν.Component m) := + ⟨QuotientAddGroup.mk⟩ + +omit [IsOrderedCancelAddMonoid M] in +/-- Every element of a homogeneous component is the class of a representative, with the motive +on the component rather than on the underlying quotient. -/ +@[elab_as_elim] +theorem componentInductionOn {ν : MaxAddDegree R M} {m : M} + {motive : ν.Component m → Prop} (x : ν.Component m) + (H : ∀ b : ν.filtrationLE m, motive (ν.componentMk m b)) : + motive x := + QuotientAddGroup.induction_on x H + +omit [IsOrderedCancelAddMonoid M] in +@[simp] +theorem coe_component_eq_componentMk (ν : MaxAddDegree R M) (m : M) + (x : ν.filtrationLE m) : + (x : ν.Component m) = ν.componentMk m x := + (rfl) + +omit [IsOrderedCancelAddMonoid M] in +@[simp] +theorem componentMk_eq_zero_iff (ν : MaxAddDegree R M) (m : M) + (x : ν.filtrationLE m) : + ν.componentMk m x = 0 ↔ ν x < m := by + change (QuotientAddGroup.mk x : + (ν.filtrationLE m) ⧸ ν.lowerFiltration m) = 0 ↔ _ + rw [QuotientAddGroup.eq_zero_iff] + exact mem_lowerFiltration_iff ν m x + +omit [IsOrderedCancelAddMonoid M] in +/-- Homogeneous quotient constructors with equal grades and equal representatives are +heterogeneously equal. -/ +theorem componentMk_heq_of_grade_eq_of_coe_eq (ν : MaxAddDegree R M) {m n : M} + (h : m = n) (x : ν.filtrationLE m) (y : ν.filtrationLE n) + (hxy : (x : R) = (y : R)) : + HEq (ν.componentMk m x) (ν.componentMk n y) := by + subst n + apply heq_of_eq + apply congrArg (ν.componentMk m) + exact Subtype.ext hxy + +omit [IsOrderedCancelAddMonoid M] in +/-- Two representatives have the same homogeneous class exactly when their difference lies in +the strict filtration. -/ +theorem componentMk_eq_componentMk_iff (ν : MaxAddDegree R M) (m : M) + (x y : ν.filtrationLE m) : + ν.componentMk m x = ν.componentMk m y ↔ ν ((x : R) - (y : R)) < m := by + rw [← sub_eq_zero, ← map_sub, ν.componentMk_eq_zero_iff] + rfl + +omit [IsOrderedCancelAddMonoid M] in +/-- Homogeneous classes at equal grades whose representatives differ by an element of the +strict filtration are heterogeneously equal. -/ +theorem componentMk_heq_of_grade_eq_of_sub_lt (ν : MaxAddDegree R M) {m n : M} + (hmn : m = n) (x : ν.filtrationLE m) (y : ν.filtrationLE n) + (hxy : ν ((x : R) - (y : R)) < m) : + HEq (ν.componentMk m x) (ν.componentMk n y) := by + subst n + apply heq_of_eq + rw [ν.componentMk_eq_componentMk_iff] + exact hxy + +omit [IsOrderedCancelAddMonoid M] in +/-- Heterogeneously equal homogeneous classes at equal grades have representatives differing by +an element of the strict filtration. -/ +theorem sub_lt_of_componentMk_heq (ν : MaxAddDegree R M) {m n : M} + (hmn : m = n) (x : ν.filtrationLE m) (y : ν.filtrationLE n) + (hxy : HEq (ν.componentMk m x) (ν.componentMk n y)) : + ν ((x : R) - (y : R)) < m := by + subst n + rw [← ν.componentMk_eq_componentMk_iff] + exact eq_of_heq hxy + +/-- Multiplication followed by projection to a homogeneous component. -/ +private def mulRepresentative (ν : MaxAddDegree R M) {m n : M} + (x : ν.filtrationLE m) : ν.filtrationLE n →+ ν.Component (m + n) := + (ν.componentMk (m + n)).comp (ν.mulFiltrationLE x) + +private theorem lowerFiltration_le_mulRepresentative_ker + (ν : MaxAddDegree R M) {m n : M} + (x : ν.filtrationLE m) : + ν.lowerFiltration n ≤ (ν.mulRepresentative x).ker := by + intro y hy + rw [AddMonoidHom.mem_ker, mulRepresentative, AddMonoidHom.comp_apply, + componentMk_eq_zero_iff] + simpa only [coe_mulFiltrationLE, WithBot.coe_add] using + degree_mul_lt_add_of_le_of_lt + ((mem_filtrationLE_iff ν m x).mp x.2) + ((mem_lowerFiltration_iff ν n y).mp hy) + +/-- Multiplication by a representative, descended in the right argument. -/ +private def mulRight (ν : MaxAddDegree R M) {m n : M} (x : ν.filtrationLE m) : + ν.Component n →+ ν.Component (m + n) := + QuotientAddGroup.lift (ν.lowerFiltration n) (ν.mulRepresentative x) + (ν.lowerFiltration_le_mulRepresentative_ker x) + +@[simp] +private theorem mulRight_componentMk (ν : MaxAddDegree R M) {m n : M} + (x : ν.filtrationLE m) (y : ν.filtrationLE n) : + ν.mulRight x (ν.componentMk n y) = + ν.componentMk (m + n) (ν.mulFiltrationLE x y) := by + rfl + +/-- The additive dependence of descended multiplication on its left representative. -/ +private def mulLeftRepresentative (ν : MaxAddDegree R M) {m n : M} : + ν.filtrationLE m →+ (ν.Component n →+ ν.Component (m + n)) where + toFun := ν.mulRight + map_zero' := by + apply AddMonoidHom.ext + intro y + induction y using QuotientAddGroup.induction_on with + | H y => + change ν.mulRight (0 : ν.filtrationLE m) (ν.componentMk n y) = 0 + rw [mulRight_componentMk] + rw [componentMk_eq_zero_iff] + simp + map_add' x y := by + apply AddMonoidHom.ext + intro z + induction z using QuotientAddGroup.induction_on with + | H z => + change ν.mulRight (x + y) (ν.componentMk n z) = + ν.mulRight x (ν.componentMk n z) + ν.mulRight y (ν.componentMk n z) + rw [mulRight_componentMk, mulRight_componentMk, mulRight_componentMk] + rw [← map_add] + apply congrArg (ν.componentMk (m + n)) + apply Subtype.ext + simp only [coe_mulFiltrationLE, AddSubgroup.coe_add, add_mul] + +private theorem lowerFiltration_le_mulLeftRepresentative_ker + (ν : MaxAddDegree R M) {m n : M} : + ν.lowerFiltration m ≤ (ν.mulLeftRepresentative (m := m) (n := n)).ker := by + intro x hx + rw [AddMonoidHom.mem_ker] + apply AddMonoidHom.ext + intro y + induction y using QuotientAddGroup.induction_on with + | H y => + change ν.mulRight x (ν.componentMk n y) = 0 + rw [mulRight_componentMk] + apply (componentMk_eq_zero_iff ν (m + n) _).mpr + simpa only [coe_mulFiltrationLE, WithBot.coe_add] using + degree_mul_lt_add_of_lt_of_le + ((mem_lowerFiltration_iff ν m x).mp hx) + ((mem_filtrationLE_iff ν n y).mp y.2) + +/-- Homogeneous multiplication on associated-graded components. -/ +private def componentMulHom (ν : MaxAddDegree R M) {m n : M} : + ν.Component m →+ (ν.Component n →+ ν.Component (m + n)) := + QuotientAddGroup.lift (ν.lowerFiltration m) + (ν.mulLeftRepresentative (m := m) (n := n)) + (ν.lowerFiltration_le_mulLeftRepresentative_ker (m := m) (n := n)) + +/-- Multiplication of two homogeneous associated-graded elements. -/ +def componentMul (ν : MaxAddDegree R M) {m n : M} + (x : ν.Component m) (y : ν.Component n) : ν.Component (m + n) := + ν.componentMulHom x y + +private theorem componentMul_eq (ν : MaxAddDegree R M) {m n : M} + (x : ν.Component m) (y : ν.Component n) : + ν.componentMul x y = ν.componentMulHom x y := + (rfl) + +@[simp] +theorem zero_componentMul (ν : MaxAddDegree R M) {m n : M} + (y : ν.Component n) : + ν.componentMul (0 : ν.Component m) y = 0 := by + rw [componentMul_eq] + exact DFunLike.congr_fun (ν.componentMulHom (m := m) (n := n)).map_zero y + +@[simp] +theorem componentMul_zero (ν : MaxAddDegree R M) {m n : M} + (x : ν.Component m) : + ν.componentMul x (0 : ν.Component n) = 0 := by + rw [componentMul_eq] + exact (ν.componentMulHom x).map_zero + +@[simp] +theorem componentMul_componentMk (ν : MaxAddDegree R M) {m n : M} + (x : ν.filtrationLE m) (y : ν.filtrationLE n) : + ν.componentMul (ν.componentMk m x) (ν.componentMk n y) = + ν.componentMk (m + n) (ν.mulFiltrationLE x y) := by + rfl + +/-- The multiplicative identity in the grade-zero component. -/ +def componentOne (ν : MaxAddDegree R M) : ν.Component 0 := + ν.componentMk 0 ⟨1, (ν.mem_filtrationLE_iff 0 1).mpr ν.map_one_le_zero⟩ + +omit [IsOrderedCancelAddMonoid M] in +@[simp] +theorem componentOne_eq_componentMk (ν : MaxAddDegree R M) : + ν.componentOne = + ν.componentMk 0 ⟨1, (ν.mem_filtrationLE_iff 0 1).mpr ν.map_one_le_zero⟩ := + (rfl) + +/-- The multiplicative identity in the degree-zero component. -/ +scoped instance (ν : MaxAddDegree R M) : GradedMonoid.GOne ν.Component where + one := ν.componentOne + +/-- Multiplication of homogeneous components, with their degrees added. -/ +scoped instance (ν : MaxAddDegree R M) : GradedMonoid.GMul ν.Component where + mul := ν.componentMul + +open scoped MaxAddDegree + +/-- The graded commutative ring structure on the components. + +This instance is global so the ring structure on `AssociatedGraded` can be synthesized without +opening a scope. `GCommRing` also supplies `GMul` and `GOne` by projection; their standalone +instances remain scoped to avoid broad instance search on metavariable indices. -/ +instance (ν : MaxAddDegree R M) : DirectSum.GCommRing ν.Component where + mul := ν.componentMul + one := ν.componentOne + mul_zero := by + intro i j x + rw [componentMul_eq] + exact (ν.componentMulHom x).map_zero + zero_mul := by + intro i j y + rw [componentMul_eq] + exact DFunLike.congr_fun (ν.componentMulHom (m := i) (n := j)).map_zero y + mul_add := by + intro i j x y z + rw [componentMul_eq, componentMul_eq, componentMul_eq] + exact (ν.componentMulHom x).map_add y z + add_mul := by + intro i j x y z + rw [componentMul_eq, componentMul_eq, componentMul_eq] + exact DFunLike.congr_fun + ((ν.componentMulHom (m := i) (n := j)).map_add x y) z + one_mul := by + rintro ⟨m, x⟩ + induction x using QuotientAddGroup.induction_on with + | H x => + change GradedMonoid.mk (0 + m) + (ν.componentMul ν.componentOne (ν.componentMk m x)) = + GradedMonoid.mk m (ν.componentMk m x) + rw [componentOne_eq_componentMk, componentMul_componentMk] + apply Sigma.ext (zero_add m) + apply componentMk_heq_of_grade_eq_of_coe_eq ν (zero_add m) + simp + mul_one := by + rintro ⟨m, x⟩ + induction x using QuotientAddGroup.induction_on with + | H x => + change GradedMonoid.mk (m + 0) + (ν.componentMul (ν.componentMk m x) ν.componentOne) = + GradedMonoid.mk m (ν.componentMk m x) + rw [componentOne_eq_componentMk, componentMul_componentMk] + apply Sigma.ext (add_zero m) + apply componentMk_heq_of_grade_eq_of_coe_eq ν (add_zero m) + simp + mul_assoc := by + rintro ⟨i, x⟩ ⟨j, y⟩ ⟨k, z⟩ + induction x using QuotientAddGroup.induction_on with + | H x => + induction y using QuotientAddGroup.induction_on with + | H y => + induction z using QuotientAddGroup.induction_on with + | H z => + change GradedMonoid.mk ((i + j) + k) + (ν.componentMul + (ν.componentMul (ν.componentMk i x) (ν.componentMk j y)) + (ν.componentMk k z)) = + GradedMonoid.mk (i + (j + k)) + (ν.componentMul (ν.componentMk i x) + (ν.componentMul (ν.componentMk j y) (ν.componentMk k z))) + simp only [componentMul_componentMk] + apply Sigma.ext (add_assoc i j k) + apply componentMk_heq_of_grade_eq_of_coe_eq ν (add_assoc i j k) + simp only [coe_mulFiltrationLE, mul_assoc] + natCast := fun n ↦ n • ν.componentOne + natCast_zero := by simp + natCast_succ := by intros; simp [add_nsmul] + intCast := fun z ↦ z • ν.componentOne + intCast_ofNat := by intros; simp + intCast_negSucc_ofNat := by intros; simp + mul_comm := by + rintro ⟨i, x⟩ ⟨j, y⟩ + induction x using QuotientAddGroup.induction_on with + | H x => + induction y using QuotientAddGroup.induction_on with + | H y => + change GradedMonoid.mk (i + j) + (ν.componentMul (ν.componentMk i x) (ν.componentMk j y)) = + GradedMonoid.mk (j + i) + (ν.componentMul (ν.componentMk j y) (ν.componentMk i x)) + simp only [componentMul_componentMk] + apply Sigma.ext (add_comm i j) + apply componentMk_heq_of_grade_eq_of_coe_eq ν (add_comm i j) + simp only [coe_mulFiltrationLE, mul_comm] + +/-- `GAlgebra` and the direct sum's ring and algebra instances all take a `GSemiring` argument, +and reaching it through `GCommRing` rebuilds the componentwise multiplication each time. -/ +instance (ν : MaxAddDegree R M) : DirectSum.GSemiring ν.Component := + inferInstance + +instance (ν : MaxAddDegree R M) : DirectSum.GCommSemiring ν.Component := + inferInstance + +/-- The associated graded ring of a max-additive degree. -/ +abbrev AssociatedGraded (ν : MaxAddDegree R M) := + DirectSum M ν.Component + +/-- +The homogeneous map obtained by quotient projection to grade `m`, followed by the direct-sum +inclusion of that component. +-/ +def homogeneousMk (ν : MaxAddDegree R M) (m : M) : + ν.filtrationLE m →+ ν.AssociatedGraded := + (DirectSum.of ν.Component m).comp (ν.componentMk m) + +theorem homogeneousMk_apply (ν : MaxAddDegree R M) (m : M) + (x : ν.filtrationLE m) : + ν.homogeneousMk m x = DirectSum.of ν.Component m (ν.componentMk m x) := + (rfl) + +@[simp] +theorem homogeneousMk_eq_zero_iff (ν : MaxAddDegree R M) (m : M) + (x : ν.filtrationLE m) : + ν.homogeneousMk m x = 0 ↔ ν x < m := by + rw [ν.homogeneousMk_apply] + constructor + · intro hzero + apply (ν.componentMk_eq_zero_iff m x).mp + exact DirectSum.of_injective m (by simpa using hzero) + · intro hlt + rw [(ν.componentMk_eq_zero_iff m x).mpr hlt] + exact (DirectSum.of ν.Component m).map_zero + +@[simp] +theorem homogeneousMk_mul (ν : MaxAddDegree R M) {m n : M} + (x : ν.filtrationLE m) (y : ν.filtrationLE n) : + ν.homogeneousMk m x * ν.homogeneousMk n y = + ν.homogeneousMk (m + n) (ν.mulFiltrationLE x y) := by + rw [homogeneousMk, homogeneousMk, homogeneousMk, AddMonoidHom.comp_apply, + AddMonoidHom.comp_apply, AddMonoidHom.comp_apply, DirectSum.of_mul_of, + show GradedMonoid.GMul.mul _ _ = ν.componentMul _ _ from rfl, + componentMul_componentMk] + +/-- Homogeneous classes multiply as expected whenever the target index is the sum of the source +indices and the supplied target representative is their product. -/ +theorem homogeneousMk_mul_of_coe_eq (ν : MaxAddDegree R M) {m n p : M} (hp : p = m + n) + (x : ν.filtrationLE m) (y : ν.filtrationLE n) (z : ν.filtrationLE p) + (hz : (z : R) = (x : R) * (y : R)) : + ν.homogeneousMk p z = ν.homogeneousMk m x * ν.homogeneousMk n y := by + subst hp + rw [homogeneousMk_mul] + congr 1 + exact Subtype.ext (by rw [hz, coe_mulFiltrationLE]) + +/-- The grade-zero class of the multiplicative identity is the identity of the associated graded +ring. -/ +@[simp] +theorem homogeneousMk_one (ν : MaxAddDegree R M) : + ν.homogeneousMk 0 ⟨1, (ν.mem_filtrationLE_iff 0 1).mpr ν.map_one_le_zero⟩ = 1 := by + rw [homogeneousMk_apply, ← componentOne_eq_componentMk] + rfl + +end MaxAddDegree diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/DegreeAssociatedGradedDomain.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/DegreeAssociatedGradedDomain.lean new file mode 100644 index 0000000000..fd3b8f4982 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/DegreeAssociatedGradedDomain.lean @@ -0,0 +1,200 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.DegreeInitialForm +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.QuotientDegree +import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.DirectSum.LeadingGrade + +/-! +# Domain criterion for the associated graded ring of a degree function + +For a separated submultiplicative degree, every nonzero element has a nonzero homogeneous class +in its exact degree. If products of nonzero homogeneous components are nonzero, the +submultiplicative product inequality is therefore an equality. In particular, a domain associated +graded ring forces the original degree to be multiplicative. + +Applied to the least-representative degree on a quotient ring `R ⧸ I`, this shows that `R ⧸ I` +is a domain whenever the associated graded ring of that degree is one. The canonical isomorphism +of that associated graded ring with a quotient of `gr_ν R` is constructed separately. +-/ + +universe u v + +public noncomputable section + +namespace MaxAddDegree + +open scoped MaxAddDegree + +variable {R : Type u} {M : Type v} [CommRing R] [AddCommMonoid M] + [LinearOrder M] [IsOrderedCancelAddMonoid M] + +/-- No two nonzero homogeneous classes have zero product. -/ +def HomogeneousNoZeroDivisors (ν : MaxAddDegree R M) : Prop := + ∀ {m n : M} (x : ν.Component m) (y : ν.Component n), + x ≠ 0 → y ≠ 0 → ν.componentMul x y ≠ 0 + +theorem homogeneousNoZeroDivisors_iff (ν : MaxAddDegree R M) : + ν.HomogeneousNoZeroDivisors ↔ + ∀ {m n : M} (x : ν.Component m) (y : ν.Component n), + x ≠ 0 → y ≠ 0 → ν.componentMul x y ≠ 0 := + Iff.rfl + +/-- A domain associated graded ring has no homogeneous zero divisors. -/ +theorem homogeneousNoZeroDivisors_of_isDomain (ν : MaxAddDegree R M) + [IsDomain ν.AssociatedGraded] : + ν.HomogeneousNoZeroDivisors := by + rw [ν.homogeneousNoZeroDivisors_iff] + intro m n x y hx hy hxy + have hx' : DirectSum.of ν.Component m x ≠ 0 := + fun hzero ↦ hx (DirectSum.of_injective m (by simpa using hzero)) + have hy' : DirectSum.of ν.Component n y ≠ 0 := + fun hzero ↦ hy (DirectSum.of_injective n (by simpa using hzero)) + apply mul_ne_zero hx' hy' + rw [DirectSum.of_mul_of, + show GradedMonoid.GMul.mul x y = ν.componentMul x y from rfl, hxy] + exact (DirectSum.of ν.Component (m + n)).map_zero + +/-- A multiplicative degree has no nonzero homogeneous zero divisors. -/ +theorem homogeneousNoZeroDivisors_of_isMultiplicative + (ν : MaxAddDegree R M) [ν.IsMultiplicative] : + ν.HomogeneousNoZeroDivisors := by + rw [ν.homogeneousNoZeroDivisors_iff] + intro m n x y hx hy + induction x using QuotientAddGroup.induction_on with + | H x => + induction y using QuotientAddGroup.induction_on with + | H y => + rw [ν.coe_component_eq_componentMk] at hx + rw [ν.coe_component_eq_componentMk] at hy + have hxnotlt : ¬ν x < m := + fun hlt ↦ hx ((ν.componentMk_eq_zero_iff m x).mpr hlt) + have hynotlt : ¬ν y < n := + fun hlt ↦ hy ((ν.componentMk_eq_zero_iff n y).mpr hlt) + have hxdegree : ν x = (m : WithBot M) := + le_antisymm ((ν.mem_filtrationLE_iff m x).mp x.2) (le_of_not_gt hxnotlt) + have hydegree : ν y = (n : WithBot M) := + le_antisymm ((ν.mem_filtrationLE_iff n y).mp y.2) (le_of_not_gt hynotlt) + intro hzero + rw [ν.coe_component_eq_componentMk, ν.coe_component_eq_componentMk] at hzero + rw [ν.componentMul_componentMk, ν.componentMk_eq_zero_iff] at hzero + simp only [ν.coe_mulFiltrationLE] at hzero + rw [ν.map_mul, hxdegree, hydegree, WithBot.coe_add] at hzero + exact lt_irrefl _ hzero + +/-- Nonzero homogeneous classes of a multiplicative degree have nonzero product. -/ +theorem componentMul_ne_zero (ν : MaxAddDegree R M) [ν.IsMultiplicative] {m n : M} + (x : ν.Component m) (y : ν.Component n) (hx : x ≠ 0) (hy : y ≠ 0) : + ν.componentMul x y ≠ 0 := + ν.homogeneousNoZeroDivisors_iff.mp ν.homogeneousNoZeroDivisors_of_isMultiplicative x y hx hy + +/-- Multiplicativity of the degree prevents zero divisors in its associated graded ring. -/ +instance associatedGradedNoZeroDivisors + (ν : MaxAddDegree R M) [ν.IsMultiplicative] : + NoZeroDivisors ν.AssociatedGraded := + ⟨by + intro x y hxy + by_contra hnonzero + rw [not_or] at hnonzero + have hleading := DirectSum.leadingGrade_mul ν.Component + (fun a b ha hb ↦ ν.componentMul_ne_zero a b ha hb) x y + have hx : DirectSum.leadingGrade ν.Component x ≠ ⊥ := by + intro hxbot + exact hnonzero.1 ((DirectSum.leadingGrade_eq_bot_iff ν.Component x).mp hxbot) + have hy : DirectSum.leadingGrade ν.Component y ≠ ⊥ := by + intro hybot + exact hnonzero.2 ((DirectSum.leadingGrade_eq_bot_iff ν.Component y).mp hybot) + rw [hxy, DirectSum.leadingGrade_zero] at hleading + exact (WithBot.add_ne_bot.mpr ⟨hx, hy⟩) hleading.symm⟩ + +/-- Homogeneous non-zero-divisors force equality in the product-degree inequality. -/ +theorem degree_mul_eq_add_of_homogeneousNoZeroDivisors + (ν : MaxAddDegree R M) (hν : ν.IsSeparated) + (hgr : ν.HomogeneousNoZeroDivisors) {x y : R} + (hx : x ≠ 0) (hy : y ≠ 0) : + ν (x * y) = ν x + ν y := by + have hx' : ν x ≠ ⊥ := ν.map_ne_bot_of_ne_zero hν hx + have hy' : ν y ≠ ⊥ := ν.map_ne_bot_of_ne_zero hν hy + have hproduct : ν.componentMul + (ν.componentMk _ (ν.initialRepresentative x hx')) + (ν.componentMk _ (ν.initialRepresentative y hy')) ≠ 0 := + hgr _ _ (ν.componentMk_initialRepresentative_ne_zero x hx') + (ν.componentMk_initialRepresentative_ne_zero y hy') + apply le_antisymm + · exact ν.map_mul_le_add x y + · apply le_of_not_gt + intro hlt + apply hproduct + rw [ν.componentMul_componentMk, ν.componentMk_eq_zero_iff, ν.coe_mulFiltrationLE, + ν.coe_initialRepresentative, ν.coe_initialRepresentative, WithBot.coe_add, + WithBot.coe_unbot, WithBot.coe_unbot] + exact hlt + +/-- A separated degree whose associated graded ring has no homogeneous zero divisors is +multiplicative. -/ +theorem isMultiplicative_of_homogeneousNoZeroDivisors + (ν : MaxAddDegree R M) (hν : ν.IsSeparated) + (hgr : ν.HomogeneousNoZeroDivisors) : + ν.IsMultiplicative := by + rw [ν.isMultiplicative_iff] + intro x y + by_cases hx : x = 0 + · simp [hx] + by_cases hy : y = 0 + · simp [hy] + exact ν.degree_mul_eq_add_of_homogeneousNoZeroDivisors hν hgr hx hy + +/-- For a separated degree, multiplicativity is equivalent to absence of nonzero homogeneous +zero divisors. -/ +theorem isMultiplicative_iff_homogeneousNoZeroDivisors + (ν : MaxAddDegree R M) (hν : ν.IsSeparated) : + ν.IsMultiplicative ↔ ν.HomogeneousNoZeroDivisors := + ⟨fun _ ↦ ν.homogeneousNoZeroDivisors_of_isMultiplicative, + ν.isMultiplicative_of_homogeneousNoZeroDivisors hν⟩ + +/-- A separated degree is multiplicative when its associated graded ring is a domain. -/ +theorem isMultiplicative_of_associatedGraded_isDomain + (ν : MaxAddDegree R M) (hν : ν.IsSeparated) + [IsDomain ν.AssociatedGraded] : + ν.IsMultiplicative := + ν.isMultiplicative_of_homogeneousNoZeroDivisors hν + ν.homogeneousNoZeroDivisors_of_isDomain + +/-- A degree with a domain associated graded ring has a nontrivial source ring. -/ +theorem nontrivial_of_associatedGraded_isDomain + (ν : MaxAddDegree R M) [IsDomain ν.AssociatedGraded] : + Nontrivial R := by + apply not_subsingleton_iff_nontrivial.mp + intro hsub + let : Subsingleton R := hsub + have hcomponent (m : M) (x y : ν.Component m) : x = y := by + induction x using QuotientAddGroup.induction_on with + | H x => + induction y using QuotientAddGroup.induction_on with + | H y => + exact congrArg (fun z : ν.filtrationLE m ↦ (z : ν.Component m)) + (Subtype.ext (Subsingleton.elim (x : R) (y : R))) + have hgraded : (1 : ν.AssociatedGraded) = 0 := + DFinsupp.ext (fun m ↦ hcomponent m _ _) + exact one_ne_zero hgraded + +variable [WellFoundedLT M] + +/-- If the associated graded ring of the least-representative quotient degree is a domain, then +the quotient ring is a domain. -/ +theorem quotient_isDomain_of_associatedGraded_isDomain + (ν : MaxAddDegree R M) (I : Ideal R) (hν : ν.IsSeparated) + [IsDomain (ν.quotient I hν).AssociatedGraded] : + IsDomain (R ⧸ I) := by + let : Nontrivial (R ⧸ I) := + (ν.quotient I hν).nontrivial_of_associatedGraded_isDomain + have : (ν.quotient I hν).IsMultiplicative := + (ν.quotient I hν).isMultiplicative_of_associatedGraded_isDomain + (ν.quotient_isSeparated I hν) + exact ν.quotient_isDomain I hν + +end MaxAddDegree diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/DegreeAssociatedGradedMap.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/DegreeAssociatedGradedMap.lean new file mode 100644 index 0000000000..d2764efc81 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/DegreeAssociatedGradedMap.lean @@ -0,0 +1,291 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.DegreeInitialForm + +/-! +# Maps of associated graded rings + +A ring homomorphism that does not increase a max-additive degree sends each weak filtration and +each strict filtration into the corresponding target filtration. It therefore induces additive +maps on the homogeneous quotients and a graded ring homomorphism on their direct sums. Two cases +are used: a degree-preserving ring homomorphism between two filtered rings, and the identity of +one ring carrying a finer degree to a coarser one, `ν₂ ≤ ν₁` pointwise, which gives the canonical +map `gr_{ν₁} → gr_{ν₂}` between the two associated graded rings of the same ring. + +Exact preservation of degree makes every homogeneous component map injective, even if injectivity +of the original ring homomorphism has not been assumed separately. The resulting global graded +map is consequently injective. This functorial interface is used to compare a filtered ring with +its degree-zero localizations. +-/ + +open scoped MaxAddDegree + +universe u v w + +public noncomputable section + +namespace MaxAddDegree + +variable {R : Type u} {A : Type v} {M : Type w} +variable [CommRing R] [CommRing A] [AddCommMonoid M] +variable [LinearOrder M] [IsOrderedCancelAddMonoid M] + +/-- A degree-nonincreasing ring homomorphism restricted to a weak filtration. -/ +def mapFiltrationLE (νR : MaxAddDegree R M) (νA : MaxAddDegree A M) + (f : R →+* A) (hdegree : ∀ x, νA (f x) ≤ νR x) (m : M) : + νR.filtrationLE m →+ νA.filtrationLE m where + toFun x := ⟨f x, by + rw [νA.mem_filtrationLE_iff] + exact (hdegree x).trans ((νR.mem_filtrationLE_iff m x).mp x.2)⟩ + map_zero' := by ext; exact f.map_zero + map_add' x y := by ext; exact f.map_add x y + +omit [IsOrderedCancelAddMonoid M] in +@[simp] +theorem coe_mapFiltrationLE (νR : MaxAddDegree R M) (νA : MaxAddDegree A M) + (f : R →+* A) (hdegree : ∀ x, νA (f x) ≤ νR x) (m : M) + (x : νR.filtrationLE m) : + (νR.mapFiltrationLE νA f hdegree m x : A) = f x := + (rfl) + +omit [IsOrderedCancelAddMonoid M] in +private theorem lowerFiltration_le_componentRepresentative_ker + (νR : MaxAddDegree R M) (νA : MaxAddDegree A M) + (f : R →+* A) (hdegree : ∀ x, νA (f x) ≤ νR x) (m : M) : + νR.lowerFiltration m ≤ + ((νA.componentMk m).comp (νR.mapFiltrationLE νA f hdegree m)).ker := by + intro x hx + rw [AddMonoidHom.mem_ker, AddMonoidHom.comp_apply, + νA.componentMk_eq_zero_iff, coe_mapFiltrationLE] + exact (hdegree x).trans_lt ((νR.mem_lowerFiltration_iff m x).mp hx) + +/-- The map on a homogeneous quotient induced by a degree-nonincreasing ring homomorphism. -/ +def componentMap (νR : MaxAddDegree R M) (νA : MaxAddDegree A M) + (f : R →+* A) (hdegree : ∀ x, νA (f x) ≤ νR x) (m : M) : + νR.Component m →+ νA.Component m := + QuotientAddGroup.lift (νR.lowerFiltration m) + ((νA.componentMk m).comp (νR.mapFiltrationLE νA f hdegree m)) + (νR.lowerFiltration_le_componentRepresentative_ker νA f hdegree m) + +omit [IsOrderedCancelAddMonoid M] in +/-- The component map sends a representative class to the class of its image. -/ +@[simp] +theorem componentMap_componentMk + (νR : MaxAddDegree R M) (νA : MaxAddDegree A M) + (f : R →+* A) (hdegree : ∀ x, νA (f x) ≤ νR x) (m : M) + (x : νR.filtrationLE m) : + νR.componentMap νA f hdegree m (νR.componentMk m x) = + νA.componentMk m (νR.mapFiltrationLE νA f hdegree m x) := by + rw [← νR.coe_component_eq_componentMk] + rfl + +omit [IsOrderedCancelAddMonoid M] in +/-- Exact degree preservation makes the component map detect zero classes. -/ +theorem componentMap_eq_zero_iff + (νR : MaxAddDegree R M) (νA : MaxAddDegree A M) + (f : R →+* A) (hdegree : ∀ x, νA (f x) = νR x) (m : M) + (x : νR.Component m) : + νR.componentMap νA f (fun x ↦ (hdegree x).le) m x = 0 ↔ x = 0 := by + induction x using QuotientAddGroup.induction_on with + | H x => + rw [νR.coe_component_eq_componentMk, νR.componentMap_componentMk, + νA.componentMk_eq_zero_iff, coe_mapFiltrationLE, hdegree, + νR.componentMk_eq_zero_iff] + +omit [IsOrderedCancelAddMonoid M] in +/-- Every exactly degree-preserving component map is injective. -/ +theorem componentMap_injective + (νR : MaxAddDegree R M) (νA : MaxAddDegree A M) + (f : R →+* A) (hdegree : ∀ x, νA (f x) = νR x) (m : M) : + Function.Injective (νR.componentMap νA f (fun x ↦ (hdegree x).le) m) := by + intro x y hxy + apply sub_eq_zero.mp + apply (νR.componentMap_eq_zero_iff νA f hdegree m (x - y)).mp + rw [map_sub, hxy, sub_self] + +omit [IsOrderedCancelAddMonoid M] in +/-- The component maps preserve the homogeneous identity. -/ +theorem componentMap_componentOne + (νR : MaxAddDegree R M) (νA : MaxAddDegree A M) + (f : R →+* A) (hdegree : ∀ x, νA (f x) ≤ νR x) : + νR.componentMap νA f hdegree 0 νR.componentOne = νA.componentOne := by + rw [νR.componentOne_eq_componentMk, νR.componentMap_componentMk, + νA.componentOne_eq_componentMk] + apply congrArg (νA.componentMk 0) + apply Subtype.ext + exact f.map_one + +/-- The component maps commute with homogeneous multiplication. -/ +theorem componentMap_componentMul + (νR : MaxAddDegree R M) (νA : MaxAddDegree A M) + (f : R →+* A) (hdegree : ∀ x, νA (f x) ≤ νR x) + {m n : M} (x : νR.Component m) (y : νR.Component n) : + νR.componentMap νA f hdegree (m + n) (νR.componentMul x y) = + νA.componentMul + (νR.componentMap νA f hdegree m x) + (νR.componentMap νA f hdegree n y) := by + induction x using QuotientAddGroup.induction_on with + | H x => + induction y using QuotientAddGroup.induction_on with + | H y => + rw [νR.coe_component_eq_componentMk, νR.coe_component_eq_componentMk] + rw [νR.componentMul_componentMk, νR.componentMap_componentMk, + νR.componentMap_componentMk, νR.componentMap_componentMk, + νA.componentMul_componentMk] + apply congrArg (νA.componentMk (m + n)) + apply Subtype.ext + simp only [νR.coe_mulFiltrationLE, coe_mapFiltrationLE, + νA.coe_mulFiltrationLE] + exact f.map_mul (x : R) (y : R) + +/-- The graded ring homomorphism induced by a degree-nonincreasing ring homomorphism. -/ +def associatedGradedMap + (νR : MaxAddDegree R M) (νA : MaxAddDegree A M) + (f : R →+* A) (hdegree : ∀ x, νA (f x) ≤ νR x) : + νR.AssociatedGraded →+* νA.AssociatedGraded := + DirectSum.toSemiring + (fun m ↦ (DirectSum.of νA.Component m).comp + (νR.componentMap νA f hdegree m)) + (by + simp only [AddMonoidHom.comp_apply] + rw [show GradedMonoid.GOne.one = νR.componentOne from rfl, + νR.componentMap_componentOne νA f hdegree] + exact DirectSum.of_zero_one νA.Component) + (by + intro m n x y + simp only [AddMonoidHom.comp_apply] + rw [show GradedMonoid.GMul.mul x y = νR.componentMul x y from rfl, + νR.componentMap_componentMul, DirectSum.of_mul_of] + rfl) + +/-- The associated-graded map sends a homogeneous element to the image of its component. -/ +@[simp] +theorem associatedGradedMap_of + (νR : MaxAddDegree R M) (νA : MaxAddDegree A M) + (f : R →+* A) (hdegree : ∀ x, νA (f x) ≤ νR x) + (m : M) (x : νR.Component m) : + νR.associatedGradedMap νA f hdegree (DirectSum.of νR.Component m x) = + DirectSum.of νA.Component m (νR.componentMap νA f hdegree m x) := + DirectSum.toSemiring_of _ _ _ m x + +/-- The associated-graded map is computed componentwise. -/ +theorem associatedGradedMap_apply + (νR : MaxAddDegree R M) (νA : MaxAddDegree A M) + (f : R →+* A) (hdegree : ∀ x, νA (f x) ≤ νR x) + (z : νR.AssociatedGraded) (m : M) : + νR.associatedGradedMap νA f hdegree z m = + νR.componentMap νA f hdegree m (z m) := by + induction z using DirectSum.induction_on with + | zero => simp + | of n z => + by_cases hnm : n = m + · subst m + simp [νR.associatedGradedMap_of] + · simp [νR.associatedGradedMap_of, DirectSum.of_apply, hnm] + | add x y hx hy => simp [map_add, hx, hy] + +/-- An exactly degree-preserving ring homomorphism induces an injective associated-graded +map. -/ +theorem associatedGradedMap_injective + (νR : MaxAddDegree R M) (νA : MaxAddDegree A M) + (f : R →+* A) (hdegree : ∀ x, νA (f x) = νR x) : + Function.Injective (νR.associatedGradedMap νA f (fun x ↦ (hdegree x).le)) := by + intro x y hxy + apply DirectSum.ext + intro m + apply νR.componentMap_injective νA f hdegree m + rw [← νR.associatedGradedMap_apply νA f (fun x ↦ (hdegree x).le), + ← νR.associatedGradedMap_apply νA f (fun x ↦ (hdegree x).le), hxy] + +/-- The associated-graded map induced by an exactly degree-preserving ring homomorphism sends +each initial form to the initial form of its image. -/ +theorem associatedGradedMap_initialForm + (νR : MaxAddDegree R M) (νA : MaxAddDegree A M) + (f : R →+* A) (hdegree : ∀ x, νA (f x) = νR x) (x : R) : + νR.associatedGradedMap νA f (fun x ↦ (hdegree x).le) (νR.initialForm x) = + νA.initialForm (f x) := by + by_cases hx : νR x = ⊥ + · have hfx : νA (f x) = ⊥ := (hdegree x).trans hx + rw [νR.initialForm_eq_zero_of_eq_bot hx, νA.initialForm_eq_zero_of_eq_bot hfx, _root_.map_zero] + · have hfx : νA (f x) ≠ ⊥ := (hdegree x).symm ▸ hx + rw [νR.initialForm_eq_homogeneousMk_of_ne_bot hx, + νA.initialForm_eq_homogeneousMk_of_ne_bot hfx, + νR.homogeneousMk_apply, νA.homogeneousMk_apply, + νR.associatedGradedMap_of, + νR.componentMap_componentMk] + have hm : (νA (f x)).unbot hfx = (νR x).unbot hx := by + apply WithBot.coe_injective + rw [WithBot.coe_unbot, WithBot.coe_unbot, hdegree] + apply DirectSum.of_eq_of_gradedMonoid_eq + apply Sigma.ext hm.symm + apply νA.componentMk_heq_of_grade_eq_of_coe_eq hm.symm + rw [νR.coe_mapFiltrationLE, νR.coe_initialRepresentative, + νA.coe_initialRepresentative] + +/-- The associated-graded map of a degree-nonincreasing ring homomorphism sends the initial form +of an element `x` of degree `d` to the class of `f x` in grade `d`. -/ +theorem associatedGradedMap_initialForm_eq_homogeneousMk + (νR : MaxAddDegree R M) (νA : MaxAddDegree A M) + (f : R →+* A) (hdegree : ∀ x, νA (f x) ≤ νR x) {x : R} {d : M} (hx : νR x = d) : + νR.associatedGradedMap νA f hdegree (νR.initialForm x) = + νA.homogeneousMk d ⟨f x, (νA.mem_filtrationLE_iff d _).mpr ((hdegree x).trans hx.le)⟩ := by + have hmem : x ∈ νR.filtrationLE d := (νR.mem_filtrationLE_iff d x).mpr hx.le + have hne : νR.componentMk d ⟨x, hmem⟩ ≠ 0 := by + rw [Ne, νR.componentMk_eq_zero_iff] + change ¬ νR x < (d : WithBot M) + rw [hx] + exact lt_irrefl _ + rw [νR.initialForm_eq_homogeneousMk_of_componentMk_ne_zero d ⟨x, hmem⟩ hne, + νR.homogeneousMk_apply, νR.associatedGradedMap_of, νR.componentMap_componentMk, + νA.homogeneousMk_apply] + rfl + +/-- Equal max-additive degrees have canonically ring-equivalent associated graded rings. -/ +def associatedGradedCongr {R : Type u} {M : Type w} + [CommRing R] [AddCommMonoid M] [LinearOrder M] + [IsOrderedCancelAddMonoid M] {ν δ : MaxAddDegree R M} + (h : ν = δ) : ν.AssociatedGraded ≃+* δ.AssociatedGraded := by + subst δ + exact RingEquiv.refl _ + +/-- Equal max-additive degrees have canonically equivalent homogeneous components. -/ +def componentCongr {R : Type u} {M : Type w} + [CommRing R] [AddCommMonoid M] [LinearOrder M] + {ν δ : MaxAddDegree R M} (h : ν = δ) (m : M) : ν.Component m ≃+ δ.Component m := by + subst δ + exact AddEquiv.refl _ + +/-- Transport between equal degrees commutes with homogeneous inclusion. -/ +theorem associatedGradedCongr_of {R : Type u} {M : Type w} + [CommRing R] [AddCommMonoid M] [LinearOrder M] + [IsOrderedCancelAddMonoid M] {ν δ : MaxAddDegree R M} + (h : ν = δ) (m : M) (x : ν.Component m) : + ν.associatedGradedCongr h (DirectSum.of ν.Component m x) = + DirectSum.of δ.Component m (ν.componentCongr h m x) := by + subst δ + rfl + +/-- The associated-graded equivalence induced by reflexivity is the identity. -/ +@[simp] +theorem associatedGradedCongr_rfl {R : Type u} {M : Type w} + [CommRing R] [AddCommMonoid M] [LinearOrder M] + [IsOrderedCancelAddMonoid M] (ν : MaxAddDegree R M) + (x : ν.AssociatedGraded) : ν.associatedGradedCongr rfl x = x := + (rfl) + +/-- Transport along equality of max-additive degrees carries an initial form to the corresponding +initial form for the equal degree. -/ +theorem associatedGradedCongr_initialForm {R : Type u} {M : Type w} + [CommRing R] [AddCommMonoid M] [LinearOrder M] + [IsOrderedCancelAddMonoid M] {ν δ : MaxAddDegree R M} + (h : ν = δ) (x : R) : + ν.associatedGradedCongr h (ν.initialForm x) = δ.initialForm x := by + subst δ + exact ν.associatedGradedCongr_rfl (ν.initialForm x) + +end MaxAddDegree diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/DegreeAssociatedGradedQuotient.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/DegreeAssociatedGradedQuotient.lean new file mode 100644 index 0000000000..04150222a2 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/DegreeAssociatedGradedQuotient.lean @@ -0,0 +1,348 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.DegreeAssociatedGraded +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.QuotientDegree +public import Mathlib.RingTheory.Ideal.Maps + +import Mathlib.RingTheory.Ideal.Quotient.Operations + +/-! +# Associated graded rings of least-representative quotients + +Let a separated max-additive degree on `R` be indexed by a well-ordered additive monoid. Passage +to `R ⧸ I` induces a surjective map on every homogeneous component and hence a surjective graded +ring homomorphism. Its kernel is the homogeneous initial ideal of `I`: the ideal generated by the +classes of ideal elements in every weak filtration. + +Consequently, the associated graded ring of the least-representative quotient degree is canonically +isomorphic to the quotient of the source associated graded ring by the initial ideal: the +filtered-quotient isomorphism `gr_ν R ⧸ in_ν(I) ≅ gr_ν_quot (R ⧸ I)`. +-/ + +open scoped MaxAddDegree + +universe u v + +public noncomputable section + +namespace MaxAddDegree + +variable {R : Type u} {M : Type v} [CommRing R] [AddCommMonoid M] + [LinearOrder M] [IsOrderedCancelAddMonoid M] [WellFoundedLT M] + +/-- The quotient map restricted to the weak filtration at a fixed grade. -/ +def quotientFiltrationMap (ν : MaxAddDegree R M) (I : Ideal R) + (hν : ν.IsSeparated) (m : M) : + ν.filtrationLE m →+ (ν.quotient I hν).filtrationLE m where + toFun x := ⟨Ideal.Quotient.mk I x, by + rw [(ν.quotient I hν).mem_filtrationLE_iff] + rw [ν.quotient_apply I hν] + exact (ν.quotientValue_mk_le I hν x).trans + ((ν.mem_filtrationLE_iff m x).mp x.2)⟩ + map_zero' := by ext; exact (Ideal.Quotient.mk I).map_zero + map_add' x y := by ext; exact (Ideal.Quotient.mk I).map_add x y + +omit [IsOrderedCancelAddMonoid M] in +@[simp] +theorem coe_quotientFiltrationMap (ν : MaxAddDegree R M) (I : Ideal R) + (hν : ν.IsSeparated) (m : M) (x : ν.filtrationLE m) : + ((ν.quotientFiltrationMap I hν m x : + (ν.quotient I hν).filtrationLE m) : R ⧸ I) = + Ideal.Quotient.mk I x := + (rfl) + +omit [IsOrderedCancelAddMonoid M] in +private theorem lowerFiltration_le_quotientComponentRepresentative_ker + (ν : MaxAddDegree R M) (I : Ideal R) (hν : ν.IsSeparated) (m : M) : + ν.lowerFiltration m ≤ + (((ν.quotient I hν).componentMk m).comp + (ν.quotientFiltrationMap I hν m)).ker := by + intro x hx + rw [AddMonoidHom.mem_ker, AddMonoidHom.comp_apply, + (ν.quotient I hν).componentMk_eq_zero_iff] + rw [ν.quotient_apply I hν, coe_quotientFiltrationMap] + exact (ν.quotientValue_mk_le I hν x).trans_lt + ((ν.mem_lowerFiltration_iff m x).mp hx) + +/-- The map on a homogeneous component induced by passage to a quotient ring. -/ +def quotientComponentMap (ν : MaxAddDegree R M) (I : Ideal R) + (hν : ν.IsSeparated) (m : M) : + ν.Component m →+ (ν.quotient I hν).Component m := + QuotientAddGroup.lift (ν.lowerFiltration m) + (((ν.quotient I hν).componentMk m).comp + (ν.quotientFiltrationMap I hν m)) + (ν.lowerFiltration_le_quotientComponentRepresentative_ker I hν m) + +omit [IsOrderedCancelAddMonoid M] in +@[simp] +theorem quotientComponentMap_componentMk (ν : MaxAddDegree R M) (I : Ideal R) + (hν : ν.IsSeparated) (m : M) (x : ν.filtrationLE m) : + ν.quotientComponentMap I hν m (ν.componentMk m x) = + (ν.quotient I hν).componentMk m + (ν.quotientFiltrationMap I hν m x) := + by + rw [← ν.coe_component_eq_componentMk] + rfl + +omit [IsOrderedCancelAddMonoid M] in +/-- Every homogeneous class for the least-representative quotient degree lifts to the +corresponding source component. -/ +theorem quotientComponentMap_surjective (ν : MaxAddDegree R M) (I : Ideal R) + (hν : ν.IsSeparated) (m : M) : + Function.Surjective (ν.quotientComponentMap I hν m) := by + intro z + induction z using QuotientAddGroup.induction_on with + | H z => + by_cases hz : (ν.quotient I hν).componentMk m z = 0 + · refine ⟨0, ?_⟩ + simpa using hz.symm + · have hznotlt : ¬(ν.quotient I hν) z < m := + fun hlt ↦ hz (((ν.quotient I hν).componentMk_eq_zero_iff m z).mpr hlt) + have hzdegree : (ν.quotient I hν) z = (m : WithBot M) := + le_antisymm + (((ν.quotient I hν).mem_filtrationLE_iff m z).mp z.2) + (le_of_not_gt hznotlt) + have hznonzero : (z : R ⧸ I) ≠ 0 := by + intro hzero + apply hz + apply ((ν.quotient I hν).componentMk_eq_zero_iff m z).mpr + simp [hzero] + obtain ⟨x, hxz, hxdegree⟩ := + ν.exists_representative_quotientValue_eq I hν hznonzero + have hxle : ν x ≤ (m : WithBot M) := by + rw [hxdegree] + rw [← ν.quotient_apply I hν] + rw [hzdegree] + refine ⟨ν.componentMk m + ⟨x, (ν.mem_filtrationLE_iff m x).mpr hxle⟩, ?_⟩ + rw [ν.quotientComponentMap_componentMk] + rw [(ν.quotient I hν).coe_component_eq_componentMk] + apply congrArg ((ν.quotient I hν).componentMk m) + apply Subtype.ext + rw [coe_quotientFiltrationMap] + exact hxz + +omit [IsOrderedCancelAddMonoid M] in +/-- A source component lies in the kernel exactly when it can be represented at that grade by +an element of the quotient ideal. -/ +theorem quotientComponentMap_eq_zero_iff (ν : MaxAddDegree R M) (I : Ideal R) + (hν : ν.IsSeparated) (m : M) (x : ν.Component m) : + ν.quotientComponentMap I hν m x = 0 ↔ + ∃ i : ν.filtrationLE m, (i : R) ∈ I ∧ ν.componentMk m i = x := by + induction x using QuotientAddGroup.induction_on with + | H x => + constructor + · intro hx + rw [ν.coe_component_eq_componentMk, ν.quotientComponentMap_componentMk, + (ν.quotient I hν).componentMk_eq_zero_iff] at hx + by_cases hqx : Ideal.Quotient.mk I (x : R) = 0 + · exact ⟨x, Ideal.Quotient.eq_zero_iff_mem.mp hqx, + (ν.coe_component_eq_componentMk m x).symm⟩ + · obtain ⟨y, hyx, hydegree⟩ := + ν.exists_representative_quotientValue_eq I hν hqx + have hylt : ν y < (m : WithBot M) := by + rw [hydegree] + rw [← ν.quotient_apply I hν] + rw [coe_quotientFiltrationMap] at hx + exact hx + let y' : ν.filtrationLE m := + ⟨y, (ν.mem_filtrationLE_iff m y).mpr hylt.le⟩ + have hi : (x : R) - y ∈ I := + (Ideal.Quotient.mk_eq_mk_iff_sub_mem (I := I) (x : R) y).mp hyx.symm + have hile : ν ((x : R) - y) ≤ (m : WithBot M) := + (ν.map_sub_le_max (x : R) y).trans + (max_le ((ν.mem_filtrationLE_iff m x).mp x.2) hylt.le) + let i : ν.filtrationLE m := + ⟨(x : R) - y, (ν.mem_filtrationLE_iff m _).mpr hile⟩ + refine ⟨i, hi, ?_⟩ + rw [ν.coe_component_eq_componentMk] + have hiSub : i = x - y' := Subtype.ext rfl + rw [hiSub, map_sub, + (ν.componentMk_eq_zero_iff m y').mpr hylt, sub_zero] + · rintro ⟨i, hi, hix⟩ + rw [← hix] + rw [ν.quotientComponentMap_componentMk, + (ν.quotient I hν).componentMk_eq_zero_iff] + simp only [coe_quotientFiltrationMap] + rw [Ideal.Quotient.eq_zero_iff_mem.mpr hi] + simp + +omit [IsOrderedCancelAddMonoid M] in +/-- The gradewise quotient map preserves the homogeneous unit. -/ +theorem quotientComponentMap_componentOne (ν : MaxAddDegree R M) (I : Ideal R) + (hν : ν.IsSeparated) : + ν.quotientComponentMap I hν 0 ν.componentOne = + (ν.quotient I hν).componentOne := by + rw [ν.componentOne_eq_componentMk, ν.quotientComponentMap_componentMk, + (ν.quotient I hν).componentOne_eq_componentMk] + apply congrArg ((ν.quotient I hν).componentMk 0) + apply Subtype.ext + exact map_one (Ideal.Quotient.mk I) + +/-- The gradewise quotient maps preserve homogeneous multiplication. -/ +theorem quotientComponentMap_componentMul (ν : MaxAddDegree R M) (I : Ideal R) + (hν : ν.IsSeparated) {m n : M} (x : ν.Component m) (y : ν.Component n) : + ν.quotientComponentMap I hν (m + n) (ν.componentMul x y) = + (ν.quotient I hν).componentMul + (ν.quotientComponentMap I hν m x) + (ν.quotientComponentMap I hν n y) := by + induction x using QuotientAddGroup.induction_on with + | H x => + induction y using QuotientAddGroup.induction_on with + | H y => + rw [ν.coe_component_eq_componentMk, ν.coe_component_eq_componentMk] + rw [ν.componentMul_componentMk, ν.quotientComponentMap_componentMk, + ν.quotientComponentMap_componentMk, ν.quotientComponentMap_componentMk, + (ν.quotient I hν).componentMul_componentMk] + apply congrArg ((ν.quotient I hν).componentMk (m + n)) + apply Subtype.ext + simp only [ν.coe_mulFiltrationLE, coe_quotientFiltrationMap, + (ν.quotient I hν).coe_mulFiltrationLE] + exact (Ideal.Quotient.mk I).map_mul (x : R) (y : R) + +/-- The canonical graded ring map induced by passage to the quotient `R ⧸ I`. -/ +def associatedGradedQuotientMap (ν : MaxAddDegree R M) (I : Ideal R) + (hν : ν.IsSeparated) : + ν.AssociatedGraded →+* (ν.quotient I hν).AssociatedGraded := + DirectSum.toSemiring + (fun m ↦ (DirectSum.of (ν.quotient I hν).Component m).comp + (ν.quotientComponentMap I hν m)) + (by + simp only [AddMonoidHom.comp_apply] + rw [show GradedMonoid.GOne.one = ν.componentOne from rfl, + ν.quotientComponentMap_componentOne] + exact DirectSum.of_zero_one (ν.quotient I hν).Component) + (by + intro m n x y + simp only [AddMonoidHom.comp_apply] + rw [show GradedMonoid.GMul.mul x y = ν.componentMul x y from rfl, + ν.quotientComponentMap_componentMul, DirectSum.of_mul_of] + rfl) + +@[simp] +theorem associatedGradedQuotientMap_of (ν : MaxAddDegree R M) (I : Ideal R) + (hν : ν.IsSeparated) (m : M) (x : ν.Component m) : + ν.associatedGradedQuotientMap I hν (DirectSum.of ν.Component m x) = + DirectSum.of (ν.quotient I hν).Component m + (ν.quotientComponentMap I hν m x) := + DirectSum.toSemiring_of _ _ _ m x + +/-- The canonical graded quotient map is computed componentwise. -/ +theorem associatedGradedQuotientMap_apply (ν : MaxAddDegree R M) (I : Ideal R) + (hν : ν.IsSeparated) (z : ν.AssociatedGraded) (m : M) : + ν.associatedGradedQuotientMap I hν z m = + ν.quotientComponentMap I hν m (z m) := by + induction z using DirectSum.induction_on with + | zero => simp + | of n z => + by_cases hnm : n = m + · subst m + simp [ν.associatedGradedQuotientMap_of] + · simp [ν.associatedGradedQuotientMap_of, DirectSum.of_apply, hnm] + | add x y hx hy => simp [map_add, hx, hy] + +/-- The canonical map onto the associated graded ring of the quotient is surjective. -/ +theorem associatedGradedQuotientMap_surjective (ν : MaxAddDegree R M) (I : Ideal R) + (hν : ν.IsSeparated) : + Function.Surjective (ν.associatedGradedQuotientMap I hν) := by + intro z + induction z using DirectSum.induction_on with + | zero => exact ⟨0, (ν.associatedGradedQuotientMap I hν).map_zero⟩ + | of m z => + obtain ⟨x, hx⟩ := ν.quotientComponentMap_surjective I hν m z + refine ⟨DirectSum.of ν.Component m x, ?_⟩ + rw [ν.associatedGradedQuotientMap_of, hx] + | add x y hx hy => + obtain ⟨a, ha⟩ := hx + obtain ⟨b, hb⟩ := hy + refine ⟨a + b, ?_⟩ + rw [map_add, ha, hb] + +/-- The homogeneous initial ideal generated by the classes of ideal elements in every weak +filtration. Classes placed strictly above their degree are zero, so this is the usual ideal +generated by nonzero initial forms. -/ +def initialIdeal (ν : MaxAddDegree R M) (I : Ideal R) : Ideal ν.AssociatedGraded := + Ideal.span {z | ∃ (m : M) (i : ν.filtrationLE m), + (i : R) ∈ I ∧ z = ν.homogeneousMk m i} + +omit [WellFoundedLT M] in +/-- Every homogeneous class of an ideal element belongs to the initial ideal. -/ +theorem homogeneousMk_mem_initialIdeal (ν : MaxAddDegree R M) (I : Ideal R) + (m : M) (i : ν.filtrationLE m) (hi : (i : R) ∈ I) : + ν.homogeneousMk m i ∈ ν.initialIdeal I := + Ideal.subset_span ⟨m, i, hi, rfl⟩ + +omit [WellFoundedLT M] in +/-- To contain the initial ideal, it suffices and is necessary to contain every homogeneous class +of an element of the original ideal. -/ +theorem initialIdeal_le_iff (ν : MaxAddDegree R M) (I : Ideal R) + (J : Ideal ν.AssociatedGraded) : + ν.initialIdeal I ≤ J ↔ + ∀ (m : M) (i : ν.filtrationLE m), + (i : R) ∈ I → ν.homogeneousMk m i ∈ J := by + rw [initialIdeal, Ideal.span_le] + constructor + · intro h m i hi + exact h ⟨m, i, hi, rfl⟩ + · rintro h z ⟨m, i, hi, rfl⟩ + exact h m i hi + +/-- The initial ideal is exactly the kernel of the canonical graded quotient map. -/ +theorem initialIdeal_eq_ker_associatedGradedQuotientMap + (ν : MaxAddDegree R M) (I : Ideal R) (hν : ν.IsSeparated) : + ν.initialIdeal I = RingHom.ker (ν.associatedGradedQuotientMap I hν) := by + apply le_antisymm + · rw [initialIdeal, Ideal.span_le] + rintro z ⟨m, i, hi, rfl⟩ + change ν.associatedGradedQuotientMap I hν (ν.homogeneousMk m i) = 0 + rw [ν.homogeneousMk_apply, + ν.associatedGradedQuotientMap_of, ν.quotientComponentMap_componentMk] + have hcomponent : + (ν.quotient I hν).componentMk m + (ν.quotientFiltrationMap I hν m i) = 0 := by + rw [(ν.quotient I hν).componentMk_eq_zero_iff] + simp only [coe_quotientFiltrationMap] + rw [Ideal.Quotient.eq_zero_iff_mem.mpr hi] + simp + rw [hcomponent, (DirectSum.of (ν.quotient I hν).Component m).map_zero] + · intro z hz + rw [RingHom.mem_ker] at hz + classical + rw [← DirectSum.sum_support_of z] + apply Submodule.sum_mem + intro m hm + have hmzero : ν.quotientComponentMap I hν m (z m) = 0 := by + rw [← ν.associatedGradedQuotientMap_apply I hν z m, hz] + rfl + obtain ⟨i, hi, hix⟩ := + (ν.quotientComponentMap_eq_zero_iff I hν m (z m)).mp hmzero + rw [← hix] + rw [← ν.homogeneousMk_apply] + exact ν.homogeneousMk_mem_initialIdeal I m i hi + +/-- The associated graded ring of the least-representative quotient is the quotient by the +initial ideal. -/ +def associatedGradedQuotientEquiv (ν : MaxAddDegree R M) (I : Ideal R) + (hν : ν.IsSeparated) : + ν.AssociatedGraded ⧸ ν.initialIdeal I ≃+* + (ν.quotient I hν).AssociatedGraded := + (Ideal.quotEquivOfEq + (ν.initialIdeal_eq_ker_associatedGradedQuotientMap I hν)).trans + (RingHom.quotientKerEquivOfSurjective + (ν.associatedGradedQuotientMap_surjective I hν)) + +@[simp] +theorem associatedGradedQuotientEquiv_mk (ν : MaxAddDegree R M) (I : Ideal R) + (hν : ν.IsSeparated) (z : ν.AssociatedGraded) : + ν.associatedGradedQuotientEquiv I hν + (Ideal.Quotient.mk (ν.initialIdeal I) z) = + ν.associatedGradedQuotientMap I hν z := by + rw [associatedGradedQuotientEquiv, RingEquiv.trans_apply, + Ideal.quotEquivOfEq_mk, RingHom.quotientKerEquivOfSurjective_apply_mk] + +end MaxAddDegree diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/DegreeInitialForm.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/DegreeInitialForm.lean new file mode 100644 index 0000000000..6a915633d2 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/DegreeInitialForm.lean @@ -0,0 +1,199 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.DegreeAssociatedGraded + +/-! +# Initial forms in the associated graded ring + +An element of nonbottom degree is placed in the homogeneous component indexed by its exact +degree; an element of bottom degree has initial form zero. Thus the whole kernel of the degree, +not only the literal zero, is sent to zero, as for the semi-valuations of LM24, Section 4. For a +separated degree the kernel is `{0}`, and only zero has initial form zero. + +The definition needs no hypothesis on the degree. For a multiplicative degree the initial form +preserves products, and `ConwayRefinement.Algebra.Valuation.RV` shows that it descends +to the RV monoid. The unit is always sent to the unit, since every degree sends `1` to zero or is +bottom +everywhere. +-/ + +universe u v + +public noncomputable section + +namespace MaxAddDegree + +variable {R : Type u} {M : Type v} [CommRing R] [AddCommMonoid M] + [LinearOrder M] [IsOrderedCancelAddMonoid M] + +/-- An element of nonbottom degree, placed in the weak filtration at its exact degree. -/ +def initialRepresentative (ν : MaxAddDegree R M) (x : R) (hx : ν x ≠ ⊥) : + ν.filtrationLE ((ν x).unbot hx) := + ⟨x, (ν.mem_filtrationLE_iff _ x).mpr (by rw [WithBot.coe_unbot])⟩ + +omit [IsOrderedCancelAddMonoid M] in +@[simp] +theorem coe_initialRepresentative (ν : MaxAddDegree R M) (x : R) (hx : ν x ≠ ⊥) : + (ν.initialRepresentative x hx : R) = x := (rfl) + +/-- The initial form of an element in the associated graded ring: its class in the component of +its exact degree, or zero if the degree is bottom. -/ +def initialForm (ν : MaxAddDegree R M) (x : R) : ν.AssociatedGraded := + if hx : ν x = ⊥ then + 0 + else + ν.homogeneousMk ((ν x).unbot hx) (ν.initialRepresentative x hx) + +theorem initialForm_eq_zero_of_eq_bot (ν : MaxAddDegree R M) {x : R} + (hx : ν x = ⊥) : ν.initialForm x = 0 := by + rw [initialForm, dite_eq_left hx] + +theorem initialForm_eq_homogeneousMk_of_ne_bot (ν : MaxAddDegree R M) {x : R} + (hx : ν x ≠ ⊥) : + ν.initialForm x = ν.homogeneousMk ((ν x).unbot hx) (ν.initialRepresentative x hx) := by + rw [initialForm, dite_eq_right hx] + +omit [IsOrderedCancelAddMonoid M] in +/-- The homogeneous class of an element of nonbottom degree in its exact degree is nonzero. -/ +theorem componentMk_initialRepresentative_ne_zero (ν : MaxAddDegree R M) (x : R) + (hx : ν x ≠ ⊥) : + ν.componentMk _ (ν.initialRepresentative x hx) ≠ 0 := by + rw [ne_eq, ν.componentMk_eq_zero_iff, ν.coe_initialRepresentative, WithBot.coe_unbot] + exact lt_irrefl _ + +theorem initialForm_ne_zero_of_ne_bot (ν : MaxAddDegree R M) {x : R} + (hx : ν x ≠ ⊥) : ν.initialForm x ≠ 0 := by + rw [initialForm, dite_eq_right hx, ne_eq, ν.homogeneousMk_eq_zero_iff, + ν.coe_initialRepresentative, WithBot.coe_unbot] + exact lt_irrefl _ + +/-- The initial form vanishes exactly on the kernel of the degree. -/ +theorem initialForm_eq_zero_iff (ν : MaxAddDegree R M) (x : R) : + ν.initialForm x = 0 ↔ ν x = ⊥ := by + constructor + · contrapose! + exact ν.initialForm_ne_zero_of_ne_bot + · exact ν.initialForm_eq_zero_of_eq_bot + +/-- A nonzero class represented at grade `m` is the initial form of its representative. -/ +theorem initialForm_eq_homogeneousMk_of_componentMk_ne_zero + (ν : MaxAddDegree R M) (m : M) (x : ν.filtrationLE m) + (hx : ν.componentMk m x ≠ 0) : + ν.initialForm x = ν.homogeneousMk m x := by + have hnotlt : ¬ν x < m := + fun hlt ↦ hx ((ν.componentMk_eq_zero_iff m x).mpr hlt) + have hdegree : ν x = (m : WithBot M) := + le_antisymm ((ν.mem_filtrationLE_iff m x).mp x.2) (le_of_not_gt hnotlt) + have hxbot : ν x ≠ ⊥ := by simp [hdegree] + have hm : (ν x).unbot hxbot = m := + (WithBot.unbot_eq_iff hxbot).mpr hdegree + rw [initialForm, dite_eq_right hxbot, ν.homogeneousMk_apply, ν.homogeneousMk_apply] + apply DirectSum.of_eq_of_gradedMonoid_eq + apply Sigma.ext hm + apply ν.componentMk_heq_of_grade_eq_of_coe_eq hm + rfl + +/-- At its own degree, the homogeneous class of an element is its initial form. -/ +theorem homogeneousMk_eq_initialForm_of_degree_eq (ν : MaxAddDegree R M) {d : M} {x : R} + (hle : x ∈ ν.filtrationLE d) (hx : ν x = (d : WithBot M)) : + ν.homogeneousMk d ⟨x, hle⟩ = ν.initialForm x := by + refine (ν.initialForm_eq_homogeneousMk_of_componentMk_ne_zero d ⟨x, hle⟩ ?_).symm + rw [Ne, ν.componentMk_eq_zero_iff] + change ¬ ν x < (d : WithBot M) + rw [hx] + exact lt_irrefl _ + +@[simp] +theorem initialForm_zero (ν : MaxAddDegree R M) : ν.initialForm 0 = 0 := + ν.initialForm_eq_zero_of_eq_bot ν.map_zero + +/-- Elements whose difference has smaller degree than one of them have the same initial form. -/ +theorem initialForm_eq_of_sub_lt (ν : MaxAddDegree R M) {x y : R} + (hxy : ν (x - y) < ν x) : ν.initialForm x = ν.initialForm y := by + have hdegree : ν x = ν y := ν.map_eq_of_map_sub_lt hxy + have hx : ν x ≠ ⊥ := ne_bot_of_gt hxy + have hy : ν y ≠ ⊥ := hdegree ▸ hx + have hm : (ν x).unbot hx = (ν y).unbot hy := + (WithBot.unbot_inj hx hy).mpr hdegree + rw [initialForm, dite_eq_right hx, initialForm, dite_eq_right hy, + ν.homogeneousMk_apply, ν.homogeneousMk_apply] + apply DirectSum.of_eq_of_gradedMonoid_eq + apply Sigma.ext hm + apply ν.componentMk_heq_of_grade_eq_of_sub_lt hm + simpa only [initialRepresentative, WithBot.coe_unbot] using hxy + +variable (ν : MaxAddDegree R M) in +/-- The initial form of the unit is the unit: the unit has degree zero, or bottom degree when the +degree is bottom everywhere and the graded ring is trivial. -/ +@[simp] +theorem initialForm_one : ν.initialForm 1 = 1 := by + rcases ν.map_one_eq_bot_or_eq_zero with hone | hone + · rw [ν.initialForm_eq_zero_of_eq_bot hone, DirectSum.one_def] + change (0 : ν.AssociatedGraded) = DirectSum.of ν.Component 0 ν.componentOne + have hcomponentOne : ν.componentOne = 0 := by + rw [ν.componentOne_eq_componentMk, ν.componentMk_eq_zero_iff, hone] + exact WithBot.bot_lt_coe 0 + rw [hcomponentOne, (DirectSum.of ν.Component 0).map_zero] + · have hne : ν 1 ≠ ⊥ := by simp [hone] + have hm : (ν 1).unbot hne = 0 := (WithBot.unbot_eq_iff hne).mpr hone + rw [initialForm, dite_eq_right hne, ν.homogeneousMk_apply, DirectSum.one_def] + change DirectSum.of ν.Component _ _ = DirectSum.of ν.Component 0 ν.componentOne + rw [ν.componentOne_eq_componentMk] + apply DirectSum.of_eq_of_gradedMonoid_eq + apply Sigma.ext hm + apply ν.componentMk_heq_of_grade_eq_of_coe_eq hm + rfl + +section Multiplicative + +variable (ν : MaxAddDegree R M) [ν.IsMultiplicative] + +/-- Initial forms of a multiplicative degree preserve multiplication. -/ +@[simp] +theorem initialForm_mul (x y : R) : + ν.initialForm (x * y) = ν.initialForm x * ν.initialForm y := by + by_cases hx : ν x = ⊥ + · have hxy : ν (x * y) = ⊥ := by simp [hx] + rw [ν.initialForm_eq_zero_of_eq_bot hxy, ν.initialForm_eq_zero_of_eq_bot hx, zero_mul] + by_cases hy : ν y = ⊥ + · have hxy : ν (x * y) = ⊥ := by simp [hy] + rw [ν.initialForm_eq_zero_of_eq_bot hxy, ν.initialForm_eq_zero_of_eq_bot hy, mul_zero] + · have hxy : ν (x * y) ≠ ⊥ := by + rw [ν.map_mul, WithBot.add_ne_bot] + exact ⟨hx, hy⟩ + have hm : (ν (x * y)).unbot hxy = (ν x).unbot hx + (ν y).unbot hy := by + apply WithBot.coe_injective + rw [WithBot.coe_unbot, WithBot.coe_add, ν.map_mul, WithBot.coe_unbot, WithBot.coe_unbot] + rw [initialForm, dite_eq_right hxy, initialForm, dite_eq_right hx, initialForm, + dite_eq_right hy, + ν.homogeneousMk_mul, ν.homogeneousMk_apply, ν.homogeneousMk_apply] + apply DirectSum.of_eq_of_gradedMonoid_eq + apply Sigma.ext hm + apply ν.componentMk_heq_of_grade_eq_of_coe_eq hm + simp only [coe_initialRepresentative, coe_mulFiltrationLE] + +end Multiplicative + +section Separated + +variable (ν : MaxAddDegree R M) + +/-- For a separated degree, every nonzero element has nonzero initial form. -/ +theorem initialForm_ne_zero_of_ne_zero (hν : ν.IsSeparated) {x : R} (hx : x ≠ 0) : + ν.initialForm x ≠ 0 := + ν.initialForm_ne_zero_of_ne_bot (ν.map_ne_bot_of_ne_zero hν hx) + +/-- For a separated degree, only zero has initial form zero. -/ +theorem initialForm_eq_zero_iff_of_isSeparated (hν : ν.IsSeparated) (x : R) : + ν.initialForm x = 0 ↔ x = 0 := by + rw [ν.initialForm_eq_zero_iff] + exact (ν.isSeparated_iff).mp hν x + +end Separated + +end MaxAddDegree diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/DegreeOver.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/DegreeOver.lean new file mode 100644 index 0000000000..c698bc87c7 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/DegreeOver.lean @@ -0,0 +1,251 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.DegreeInitialForm +public import Mathlib.Algebra.Algebra.Subalgebra.Basic +public import Mathlib.Algebra.Algebra.Operations + + +/-! +# The degree over a subalgebra + +Let `ν` be a max-additive degree on a commutative ring `R` and let `P` be a subalgebra of `R`. +The level `γ` of the degree over `P` is the `P`-submodule generated by the elements of degree at +most `γ`, + +`P · R_{ν ≤ γ}`. + +The degree over `P`, `ν_P(t)`, is the least `γ` with `t ∈ P · R_{ν ≤ γ}`; for `ν = deg` on +`K((ℝ^{≤0}))` and `P = S`, the series of finite degree, this is the paper's degree over `S`, +`deg_S`. It is again a max-additive degree, it is bounded by `ν`, it is separated, and every +non-zero element of `P` has degree zero over `P`. +-/ + +universe u v w + +public noncomputable section + +namespace MaxAddDegree + +variable {R : Type u} {M : Type v} {L : Type w} +variable [CommRing R] [AddCommMonoid M] [LinearOrder M] [IsOrderedCancelAddMonoid M] +variable [CommRing L] [Algebra L R] + +/-- The level `P · R_{ν ≤ γ}` of the degree over `P`: the `P`-submodule generated by the elements +of degree at most `γ`. -/ +def degreeOverStage (ν : MaxAddDegree R M) (P : Subalgebra L R) (γ : M) : Submodule P R := + Submodule.span P (ν.filtrationLE γ : Set R) + +variable (ν : MaxAddDegree R M) (P : Subalgebra L R) + +omit [IsOrderedCancelAddMonoid M] in +theorem degreeOverStage_le_iff (N : Submodule P R) (γ : M) : + ν.degreeOverStage P γ ≤ N ↔ (ν.filtrationLE γ : Set R) ⊆ N := + Submodule.span_le + +omit [IsOrderedCancelAddMonoid M] in +theorem mem_degreeOverStage_of_degree_le {t : R} {γ : M} (ht : ν t ≤ γ) : + t ∈ ν.degreeOverStage P γ := + Submodule.subset_span ((ν.mem_filtrationLE_iff γ t).mpr ht) + +omit [IsOrderedCancelAddMonoid M] in +theorem degreeOverStage_mono {γ γ' : M} (h : γ ≤ γ') : + ν.degreeOverStage P γ ≤ ν.degreeOverStage P γ' := + Submodule.span_mono fun t ht ↦ (ν.mem_filtrationLE_iff γ' t).mpr + (le_trans ((ν.mem_filtrationLE_iff γ t).mp ht) (WithBot.coe_le_coe.mpr h)) + +theorem degreeOverStage_mul_le (γ γ' : M) : + ν.degreeOverStage P γ * ν.degreeOverStage P γ' ≤ ν.degreeOverStage P (γ + γ') := by + rw [degreeOverStage, degreeOverStage, Submodule.span_mul_span] + refine Submodule.span_le.mpr ?_ + rintro _ ⟨x, hx, y, hy, rfl⟩ + exact Submodule.subset_span ((ν.mem_filtrationLE_iff _ _).mpr + (degree_mul_le_add ((ν.mem_filtrationLE_iff _ _).mp hx) ((ν.mem_filtrationLE_iff _ _).mp hy))) + +theorem mul_mem_degreeOverStage {γ γ' : M} {x y : R} (hx : x ∈ ν.degreeOverStage P γ) + (hy : y ∈ ν.degreeOverStage P γ') : x * y ∈ ν.degreeOverStage P (γ + γ') := + ν.degreeOverStage_mul_le P γ γ' (Submodule.mul_mem_mul hx hy) + +omit [IsOrderedCancelAddMonoid M] in +theorem one_mem_degreeOverStage_zero : (1 : R) ∈ ν.degreeOverStage P 0 := + ν.mem_degreeOverStage_of_degree_le P (by simpa using ν.map_one_le_zero) + +omit [IsOrderedCancelAddMonoid M] in +theorem coe_mem_degreeOverStage_zero (p : P) : (p : R) ∈ ν.degreeOverStage P 0 := by + have := (ν.degreeOverStage P 0).smul_mem p (ν.one_mem_degreeOverStage_zero P) + rwa [Algebra.smul_def, mul_one] at this + +omit [IsOrderedCancelAddMonoid M] in +theorem exists_mem_degreeOverStage (t : R) : ∃ γ : M, t ∈ ν.degreeOverStage P γ := by + cases h : ν t with + | bot => exact ⟨0, ν.mem_degreeOverStage_of_degree_le P (by rw [h]; exact bot_le)⟩ + | coe m => exact ⟨m, ν.mem_degreeOverStage_of_degree_le P h.le⟩ + +variable [WellFoundedLT M] + +omit [IsOrderedCancelAddMonoid M] in +/-- The least `γ` with `t ∈ P · R_{ν ≤ γ}`. -/ +private def fibreMin (t : R) : M := + WellFounded.min wellFounded_lt {γ : M | t ∈ ν.degreeOverStage P γ} + (ν.exists_mem_degreeOverStage P t) + +omit [IsOrderedCancelAddMonoid M] in +private theorem mem_degreeOverStage_fibreMin (t : R) : t ∈ ν.degreeOverStage P (fibreMin ν P t) := + WellFounded.min_mem wellFounded_lt {γ : M | t ∈ ν.degreeOverStage P γ} + (ν.exists_mem_degreeOverStage P t) + +omit [IsOrderedCancelAddMonoid M] in +private theorem fibreMin_le {t : R} {γ : M} (h : t ∈ ν.degreeOverStage P γ) : + fibreMin ν P t ≤ γ := + not_lt.mp fun hlt ↦ WellFounded.not_lt_min wellFounded_lt {γ : M | t ∈ ν.degreeOverStage P γ} + (show γ ∈ {γ : M | t ∈ ν.degreeOverStage P γ} from h) hlt + +omit [IsOrderedCancelAddMonoid M] in +private theorem fibreMin_le_iff (t : R) (γ : M) : + fibreMin ν P t ≤ γ ↔ t ∈ ν.degreeOverStage P γ := + ⟨fun h ↦ ν.degreeOverStage_mono P h (mem_degreeOverStage_fibreMin ν P t), fibreMin_le ν P⟩ + +open Classical in +/-- The value of the degree over `P`, before bundling. -/ +private def degreeOverFun (t : R) : WithBot M := + if t = 0 then ⊥ else ((fibreMin ν P t : M) : WithBot M) + +omit [IsOrderedCancelAddMonoid M] in +private theorem degreeOverFun_le_iff (t : R) (γ : M) : + degreeOverFun ν P t ≤ γ ↔ t ∈ ν.degreeOverStage P γ := by + rw [degreeOverFun] + split_ifs with ht + · subst ht + exact ⟨fun _ ↦ Submodule.zero_mem _, fun _ ↦ bot_le⟩ + · rw [WithBot.coe_le_coe] + exact fibreMin_le_iff ν P t γ + +omit [IsOrderedCancelAddMonoid M] in +private theorem degreeOverFun_eq_bot_iff (t : R) : degreeOverFun ν P t = ⊥ ↔ t = 0 := by + rw [degreeOverFun] + split_ifs with ht + · exact ⟨fun _ ↦ ht, fun _ ↦ rfl⟩ + · exact ⟨fun h ↦ absurd h WithBot.coe_ne_bot, fun h ↦ absurd h ht⟩ + +omit [AddCommMonoid M] [IsOrderedCancelAddMonoid M] [WellFoundedLT M] in +private theorem withBot_eq_of_forall_le_iff {a b : WithBot M} (hbot : a = ⊥ ↔ b = ⊥) + (h : ∀ γ : M, a ≤ γ ↔ b ≤ γ) : a = b := by + cases a with + | bot => exact (hbot.mp rfl).symm + | coe m => + cases b with + | bot => exact absurd (hbot.mpr rfl) WithBot.coe_ne_bot + | coe n => + exact le_antisymm ((h n).mpr le_rfl) ((h m).mp le_rfl) + +/-- The degree over `P`, `ν_P`: the least `γ` with `t ∈ P · R_{ν ≤ γ}`, and `-∞` at `0`. For +`ν = deg` and `P = S` this is the paper's `deg_S`. -/ +def degreeOver : MaxAddDegree R M where + toFun := degreeOverFun ν P + map_zero' := by rw [degreeOverFun, ite_eq_left rfl] + map_one_le_zero' := by + rw [WithBot.coe_zero.symm, degreeOverFun_le_iff] + exact ν.one_mem_degreeOverStage_zero P + map_neg' t := by + refine withBot_eq_of_forall_le_iff ?_ fun γ ↦ ?_ + · rw [degreeOverFun_eq_bot_iff, degreeOverFun_eq_bot_iff, neg_eq_zero] + · rw [degreeOverFun_le_iff, degreeOverFun_le_iff] + exact ⟨fun h ↦ by simpa using Submodule.neg_mem (ν.degreeOverStage P γ) h, + fun h ↦ Submodule.neg_mem (ν.degreeOverStage P γ) h⟩ + map_add_le_max' t t' := by + cases hmax : max (degreeOverFun ν P t) (degreeOverFun ν P t') with + | bot => + have ht : degreeOverFun ν P t = ⊥ := le_bot_iff.mp (hmax ▸ le_max_left _ _) + have ht' : degreeOverFun ν P t' = ⊥ := le_bot_iff.mp (hmax ▸ le_max_right _ _) + rw [(degreeOverFun_eq_bot_iff ν P t).mp ht, (degreeOverFun_eq_bot_iff ν P t').mp ht', + add_zero, (degreeOverFun_eq_bot_iff ν P 0).mpr rfl] + | coe γ => + rw [degreeOverFun_le_iff] + have ht : degreeOverFun ν P t ≤ γ := hmax ▸ le_max_left _ _ + have ht' : degreeOverFun ν P t' ≤ γ := hmax ▸ le_max_right _ _ + exact (ν.degreeOverStage P γ).add_mem ((degreeOverFun_le_iff ν P t γ).mp ht) + ((degreeOverFun_le_iff ν P t' γ).mp ht') + map_mul_le_add' t t' := by + cases ht : degreeOverFun ν P t with + | bot => + rw [(degreeOverFun_eq_bot_iff ν P t).mp ht, zero_mul, + (degreeOverFun_eq_bot_iff ν P 0).mpr rfl] + exact bot_le + | coe γ => + cases ht' : degreeOverFun ν P t' with + | bot => + rw [(degreeOverFun_eq_bot_iff ν P t').mp ht', mul_zero, + (degreeOverFun_eq_bot_iff ν P 0).mpr rfl] + exact bot_le + | coe γ' => + rw [← WithBot.coe_add, degreeOverFun_le_iff] + exact ν.mul_mem_degreeOverStage P ((degreeOverFun_le_iff ν P t γ).mp ht.le) + ((degreeOverFun_le_iff ν P t' γ').mp ht'.le) + +theorem degreeOver_le_iff (t : R) (γ : M) : + ν.degreeOver P t ≤ γ ↔ t ∈ ν.degreeOverStage P γ := + degreeOverFun_le_iff ν P t γ + +theorem degreeOver_eq_bot_iff (t : R) : ν.degreeOver P t = ⊥ ↔ t = 0 := + degreeOverFun_eq_bot_iff ν P t + +theorem degreeOver_isSeparated : (ν.degreeOver P).IsSeparated := + (isSeparated_iff _).mpr fun t ↦ ν.degreeOver_eq_bot_iff P t + +theorem degreeOver_le_of_degree_le {t : R} {γ : M} (ht : ν t ≤ γ) : + ν.degreeOver P t ≤ γ := + (ν.degreeOver_le_iff P t γ).mpr (ν.mem_degreeOverStage_of_degree_le P ht) + +theorem degreeOver_le (hν : ν.IsSeparated) (t : R) : ν.degreeOver P t ≤ ν t := by + cases h : ν t with + | bot => + rw [((isSeparated_iff ν).mp hν t).mp h, (ν.degreeOver_eq_bot_iff P 0).mpr rfl] + | coe γ => exact ν.degreeOver_le_of_degree_le P h.le + +theorem degreeOver_coe_le_zero (p : P) : ν.degreeOver P (p : R) ≤ 0 := by + rw [WithBot.coe_zero.symm, degreeOver_le_iff] + exact ν.coe_mem_degreeOverStage_zero P p + +/-- Multiplying an element of degree at most `γ` by an element of `P` keeps the degree over `P` +at most `γ`. -/ +theorem degreeOver_coe_mul_le_of_degree_le (p : P) {t : R} {γ : M} (ht : ν t ≤ γ) : + ν.degreeOver P ((p : R) * t) ≤ γ := + ((ν.degreeOver P).map_mul_le_add _ _).trans <| by + calc ν.degreeOver P (p : R) + ν.degreeOver P t ≤ 0 + (γ : WithBot M) := + add_le_add (ν.degreeOver_coe_le_zero P p) (ν.degreeOver_le_of_degree_le P ht) + _ = γ := zero_add _ + +theorem coe_mul_mem_degreeOver_filtrationLE_of_degree_le (p : P) {t : R} {γ : M} (ht : ν t ≤ γ) : + (p : R) * t ∈ (ν.degreeOver P).filtrationLE γ := + ((ν.degreeOver P).mem_filtrationLE_iff _ _).mpr (ν.degreeOver_coe_mul_le_of_degree_le P p ht) + +/-- When `0` is the least value, every non-zero element of `P` has degree exactly zero over `P`. -/ +theorem degreeOver_coe_eq_zero (h0 : ∀ m : M, 0 ≤ m) {p : P} (hp : (p : R) ≠ 0) : + ν.degreeOver P (p : R) = 0 := by + refine le_antisymm (ν.degreeOver_coe_le_zero P p) ?_ + cases h : ν.degreeOver P (p : R) with + | bot => exact absurd ((ν.degreeOver_eq_bot_iff P _).mp h) hp + | coe m => exact WithBot.coe_le_coe.mpr (h0 m) + +theorem degreeOver_algebraMap_eq_zero (h0 : ∀ m : M, 0 ≤ m) {l : L} + (hl : algebraMap L R l ≠ 0) : ν.degreeOver P (algebraMap L R l) = 0 := + ν.degreeOver_coe_eq_zero P h0 (p := ⟨algebraMap L R l, P.algebraMap_mem l⟩) hl + +/-- Degree over `P` below `γ` means membership in a strictly lower level, for non-zero elements. -/ +theorem exists_mem_degreeOverStage_of_degreeOver_lt {t : R} {γ : M} (ht : t ≠ 0) + (h : ν.degreeOver P t < γ) : ∃ γ' < γ, t ∈ ν.degreeOverStage P γ' := by + cases hψ : ν.degreeOver P t with + | bot => exact absurd ((ν.degreeOver_eq_bot_iff P t).mp hψ) ht + | coe m => + rw [hψ] at h + exact ⟨m, WithBot.coe_lt_coe.mp h, (ν.degreeOver_le_iff P t m).mp hψ.le⟩ + +theorem degreeOver_lt_of_mem_degreeOverStage_of_lt {t : R} {γ' γ : M} + (h : t ∈ ν.degreeOverStage P γ') (hlt : γ' < γ) : ν.degreeOver P t < γ := + lt_of_le_of_lt ((ν.degreeOver_le_iff P t γ').mpr h) (WithBot.coe_lt_coe.mpr hlt) + +end MaxAddDegree diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/DegreePrincipalInitialIdeal.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/DegreePrincipalInitialIdeal.lean new file mode 100644 index 0000000000..b69dec9f14 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/DegreePrincipalInitialIdeal.lean @@ -0,0 +1,201 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.DegreeAssociatedGradedQuotient +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.DegreeInitialForm +import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.DegreeAssociatedGradedDomain +import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.DirectSum.HomogeneousDivisibility +import Mathlib.RingTheory.Ideal.Quotient.Basic + +/-! +# Initial ideals of principal ideals + +For a multiplicative max-additive degree, the initial ideal of `(q)` is generated by the initial +form of `q`. For a separated degree, a domain associated graded ring supplies multiplicativity, so +the associated graded ring of `R / (q)` is the quotient by that single initial form. + +If this graded quotient is a domain, then `R / (q)` is a domain. The same conclusion, that a +nonzero `a` whose initial form generates a prime ideal of the associated graded ring is prime, has +a direct proof for a separated multiplicative degree over a well-ordered value monoid: for +`b ∉ (a)` of least degree in its coset, `in(b) ∈ (in a)` would give `in(b) = in(a) g` with `g` +homogeneous, and a lift `g_lift` of `g` would produce `b - a g_lift` of smaller degree in the same +coset. +-/ + +open scoped MaxAddDegree + +universe u v + +public noncomputable section + +namespace MaxAddDegree + +variable {R : Type u} {M : Type v} [CommRing R] [AddCommMonoid M] + [LinearOrder M] [IsOrderedCancelAddMonoid M] + +/-- The initial ideal of a principal ideal is generated by the initial form of its generator when +the degree is multiplicative. -/ +theorem initialIdeal_span_singleton_eq_span_initialForm + (ν : MaxAddDegree R M) [ν.IsMultiplicative] (q : R) : + ν.initialIdeal (Ideal.span {q}) = Ideal.span {ν.initialForm q} := by + apply le_antisymm + · rw [ν.initialIdeal_le_iff] + intro m i hi + by_cases hic : ν.componentMk m i = 0 + · rw [ν.homogeneousMk_apply, hic, + (DirectSum.of ν.Component m).map_zero] + exact (Ideal.span {ν.initialForm q}).zero_mem + · obtain ⟨b, hb⟩ := Ideal.mem_span_singleton.mp hi + rw [← ν.initialForm_eq_homogeneousMk_of_componentMk_ne_zero m i hic, + hb, ν.initialForm_mul] + exact Ideal.mem_span_singleton.mpr ⟨ν.initialForm b, rfl⟩ + · rw [Ideal.span_le] + intro z hz + rw [Set.mem_singleton_iff.mp hz] + by_cases hq : ν q = ⊥ + · rw [ν.initialForm_eq_zero_of_eq_bot hq] + exact (ν.initialIdeal (Ideal.span {q})).zero_mem + · rw [ν.initialForm_eq_homogeneousMk_of_ne_bot hq] + apply ν.homogeneousMk_mem_initialIdeal + simpa only [ν.coe_initialRepresentative] using + Ideal.mem_span_singleton_self q + +/-- A domain source associated graded ring gives the principal-initial-ideal equality. -/ +theorem initialIdeal_span_singleton_eq_span_initialForm_of_isDomain + (ν : MaxAddDegree R M) (hν : ν.IsSeparated) [IsDomain ν.AssociatedGraded] + (q : R) : + ν.initialIdeal (Ideal.span {q}) = Ideal.span {ν.initialForm q} := + haveI := ν.isMultiplicative_of_associatedGraded_isDomain hν + ν.initialIdeal_span_singleton_eq_span_initialForm q + +variable [WellFoundedLT M] + +/-- The associated graded ring of a principal quotient is the quotient by the generator's initial +form when the source associated graded ring is a domain. -/ +def associatedGradedPrincipalQuotientEquiv + (ν : MaxAddDegree R M) (hν : ν.IsSeparated) [IsDomain ν.AssociatedGraded] + (q : R) : + ν.AssociatedGraded ⧸ Ideal.span {ν.initialForm q} ≃+* + (ν.quotient (Ideal.span {q}) hν).AssociatedGraded := + (Ideal.quotEquivOfEq + (ν.initialIdeal_span_singleton_eq_span_initialForm_of_isDomain hν q).symm).trans + (ν.associatedGradedQuotientEquiv (Ideal.span {q}) hν) + +@[simp] +theorem associatedGradedPrincipalQuotientEquiv_mk + (ν : MaxAddDegree R M) (hν : ν.IsSeparated) [IsDomain ν.AssociatedGraded] + (q : R) (z : ν.AssociatedGraded) : + ν.associatedGradedPrincipalQuotientEquiv hν q + (Ideal.Quotient.mk (Ideal.span {ν.initialForm q}) z) = + ν.associatedGradedQuotientMap (Ideal.span {q}) hν z := by + rw [associatedGradedPrincipalQuotientEquiv, RingEquiv.trans_apply, + Ideal.quotEquivOfEq_mk, ν.associatedGradedQuotientEquiv_mk] + +/-! ### The direct prime criterion -/ + +omit [IsOrderedCancelAddMonoid M] in +/-- A coset of an ideal not containing zero has a representative of least degree. -/ +theorem exists_sub_mem_and_forall_le (ν : MaxAddDegree R M) (hν : ν.IsSeparated) (I : Ideal R) + {b : R} (hb : b ∉ I) : + ∃ b₀, b₀ - b ∈ I ∧ ∀ b', b' - b ∈ I → ν b₀ ≤ ν b' := by + have hq : Ideal.Quotient.mk I b ≠ 0 := fun h ↦ hb (Ideal.Quotient.eq_zero_iff_mem.mp h) + obtain ⟨b₀, hb₀, hνb₀⟩ := ν.exists_representative_quotientValue_eq I hν hq + refine ⟨b₀, Ideal.Quotient.eq.mp hb₀, fun b' hb' ↦ ?_⟩ + rw [hνb₀, ← Ideal.Quotient.eq.mpr hb'] + exact ν.quotientValue_mk_le I hν b' + +omit [WellFoundedLT M] in +/-- For a separated multiplicative degree, an element `b ∉ (a)` of least degree in its coset +modulo `(a)` has initial form outside `(in_ν a)`: otherwise `in_ν b = in_ν a · g` with `g` +homogeneous, and a lift `g_lift` of `g` gives `ν (b - a g_lift) < ν b` in the same coset. -/ +theorem initialForm_notMem_span_initialForm (ν : MaxAddDegree R M) + (hν : ν.IsSeparated) {a b : R} (ha : a ≠ 0) (hb : b ∉ Ideal.span {a}) + (hmin : ∀ b', b' - b ∈ Ideal.span {a} → ν b ≤ ν b') : + ν.initialForm b ∉ Ideal.span {ν.initialForm a} := by + classical + intro hmem + obtain ⟨g, hg⟩ := Ideal.mem_span_singleton'.mp hmem + have hb0 : b ≠ 0 := fun h ↦ hb (h ▸ (Ideal.span {a}).zero_mem) + obtain ⟨e, he⟩ := WithBot.ne_bot_iff_exists.mp (ν.map_ne_bot_of_ne_zero hν ha) + obtain ⟨d, hd⟩ := WithBot.ne_bot_iff_exists.mp (ν.map_ne_bot_of_ne_zero hν hb0) + have hale : a ∈ ν.filtrationLE e := (ν.mem_filtrationLE_iff e a).mpr he.ge + have hble : b ∈ ν.filtrationLE d := (ν.mem_filtrationLE_iff d b).mpr hd.ge + rw [← ν.homogeneousMk_eq_initialForm_of_degree_eq hale he.symm, + ← ν.homogeneousMk_eq_initialForm_of_degree_eq hble hd.symm, mul_comm, + ν.homogeneousMk_apply, ν.homogeneousMk_apply] at hg + -- compare the components in grade `d = ν b` + have hd' := congrArg (fun z : ν.AssociatedGraded ↦ z d) hg + simp only [DirectSum.of_eq_same] at hd' + by_cases hj : ∃ j, e + j = d + · obtain ⟨j, rfl⟩ := hj + rw [DirectSum.of_mul_apply_add] at hd' + obtain ⟨gt, hgt⟩ : ∃ gt, ν.componentMk j gt = g j := + componentInductionOn (g j) fun gt ↦ ⟨gt, rfl⟩ + rw [← hgt, show GradedMonoid.GMul.mul _ _ = ν.componentMul _ _ from rfl, + ν.componentMul_componentMk, ν.componentMk_eq_componentMk_iff] at hd' + simp only [ν.coe_mulFiltrationLE] at hd' + have hlt : ν (b - a * gt) < (e + j : WithBot M) := by + rw [← ν.map_neg, neg_sub] + exact hd' + have hcoset : b - a * gt - b ∈ Ideal.span {a} := by + rw [sub_sub_cancel_left, neg_mem_iff] + exact Ideal.mem_span_singleton'.mpr ⟨gt, mul_comm _ _⟩ + exact absurd (hmin _ hcoset) (not_le.mpr (hd ▸ hlt)) + · rw [DirectSum.of_mul_apply_eq_zero_of_not_exists _ _ _ hj, eq_comm, + ν.componentMk_eq_zero_iff] at hd' + exact absurd hd' (not_lt.mpr hd.le) + +/-- For a separated multiplicative degree over a well-ordered value monoid, a nonzero `a` whose +initial form generates a prime ideal of the associated graded ring generates a prime ideal. -/ +theorem span_singleton_isPrime_of_span_initialForm_isPrime (ν : MaxAddDegree R M) + [ν.IsMultiplicative] (hν : ν.IsSeparated) {a : R} (ha : a ≠ 0) + (hprime : (Ideal.span {ν.initialForm a}).IsPrime) : (Ideal.span {a}).IsPrime := by + refine ⟨fun htop ↦ ?_, fun {b c} hbc ↦ ?_⟩ + · -- `in_ν a` is not a unit, so `a` is not a unit + obtain ⟨a', ha'⟩ := (Ideal.span_singleton_eq_top.mp htop).exists_right_inv + apply hprime.ne_top + rw [Ideal.span_singleton_eq_top] + exact IsUnit.of_mul_eq_one (ν.initialForm a') + (by rw [← ν.initialForm_mul, ha', ν.initialForm_one]) + · by_contra hnot + rw [not_or] at hnot + -- replace `b` and `c` by representatives of least degree in their cosets + obtain ⟨b₀, hb₀, hbmin⟩ := ν.exists_sub_mem_and_forall_le hν _ hnot.1 + obtain ⟨c₀, hc₀, hcmin⟩ := ν.exists_sub_mem_and_forall_le hν _ hnot.2 + have hb₀' : b₀ ∉ Ideal.span {a} := fun h ↦ + hnot.1 (by simpa using (Ideal.span {a}).sub_mem h hb₀) + have hc₀' : c₀ ∉ Ideal.span {a} := fun h ↦ + hnot.2 (by simpa using (Ideal.span {a}).sub_mem h hc₀) + have hmin_b : ∀ b', b' - b₀ ∈ Ideal.span {a} → ν b₀ ≤ ν b' := fun b' h ↦ + hbmin b' (by simpa using (Ideal.span {a}).add_mem h hb₀) + have hmin_c : ∀ c', c' - c₀ ∈ Ideal.span {a} → ν c₀ ≤ ν c' := fun c' h ↦ + hcmin c' (by simpa using (Ideal.span {a}).add_mem h hc₀) + have hbc₀ : b₀ * c₀ ∈ Ideal.span {a} := by + have hmem : b₀ * c₀ - b * c ∈ Ideal.span {a} := by + rw [show b₀ * c₀ - b * c = (b₀ - b) * c₀ + b * (c₀ - c) by ring] + exact (Ideal.span {a}).add_mem ((Ideal.span {a}).mul_mem_right _ hb₀) + ((Ideal.span {a}).mul_mem_left _ hc₀) + simpa using (Ideal.span {a}).add_mem hmem hbc + obtain ⟨q, hq⟩ := Ideal.mem_span_singleton'.mp hbc₀ + have hin : ν.initialForm b₀ * ν.initialForm c₀ ∈ Ideal.span {ν.initialForm a} := by + rw [← ν.initialForm_mul, ← hq, ν.initialForm_mul] + exact Ideal.mem_span_singleton'.mpr ⟨_, rfl⟩ + rcases hprime.mem_or_mem hin with h | h + · exact ν.initialForm_notMem_span_initialForm hν ha hb₀' hmin_b h + · exact ν.initialForm_notMem_span_initialForm hν ha hc₀' hmin_c h + +/-- For a separated degree with a domain associated graded ring, a nonzero `a` with +`gr_ν R / (in_ν a)` a domain is prime. -/ +theorem prime_of_quotient_span_initialForm_isDomain (ν : MaxAddDegree R M) (hν : ν.IsSeparated) + [IsDomain ν.AssociatedGraded] {a : R} (ha : a ≠ 0) + [IsDomain (ν.AssociatedGraded ⧸ Ideal.span {ν.initialForm a})] : Prime a := + haveI := ν.isMultiplicative_of_associatedGraded_isDomain hν + (Ideal.span_singleton_prime ha).mp + (ν.span_singleton_isPrime_of_span_initialForm_isPrime hν ha + ((Ideal.Quotient.isDomain_iff_prime _).mp inferInstance)) + +end MaxAddDegree diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/DegreeRepresentatives.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/DegreeRepresentatives.lean new file mode 100644 index 0000000000..a1e286db84 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/DegreeRepresentatives.lean @@ -0,0 +1,251 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.DegreeAssociatedGradedMap +public import Mathlib.Algebra.MvPolynomial.Eval +public import Mathlib.RingTheory.MvPolynomial.WeightedHomogeneous +import Mathlib.Algebra.MvPolynomial.CommRing + +/-! +# Representatives of homogeneous classes + +An element represents a homogeneous class in degree `m` when it lies in the filtration at `m` +and maps to that class in the associated graded ring. This relation respects the ring operations. +-/ + +public noncomputable section + +open MvPolynomial + +universe u v w z + +namespace MaxAddDegree + +variable {R : Type u} {M : Type v} [CommRing R] [AddCommMonoid M] + [LinearOrder M] [IsOrderedCancelAddMonoid M] + +/-- An element of a filtered ring representing a homogeneous class in a specified degree. -/ +structure Represents (ν : MaxAddDegree R M) (x : R) (m : M) + (e : ν.AssociatedGraded) : Prop where + /-- The representative lies in the specified filtration. -/ + degree_le : ν x ≤ m + /-- Its image in the associated graded ring is the specified class. -/ + class_eq : + ν.homogeneousMk m ⟨x, (ν.mem_filtrationLE_iff m x).mpr degree_le⟩ = e + +theorem represents_iff {ν : MaxAddDegree R M} {x : R} {m : M} {e : ν.AssociatedGraded} : + ν.Represents x m e ↔ ∃ h : ν x ≤ m, + ν.homogeneousMk m ⟨x, (ν.mem_filtrationLE_iff m x).mpr h⟩ = e := by + constructor + · exact fun h ↦ ⟨h.degree_le, h.class_eq⟩ + · rintro ⟨hdegree, hclass⟩ + exact ⟨hdegree, hclass⟩ + +/-- A representative remains a representative after identifying equal degree functions. -/ +theorem Represents.congr {ν δ : MaxAddDegree R M} (h : ν = δ) + {x : R} {m : M} {e : ν.AssociatedGraded} (he : ν.Represents x m e) : + δ.Represents x m (ν.associatedGradedCongr h e) := by + subst δ + simpa using he + +/-- Zero represents zero in every degree. -/ +theorem represents_zero (ν : MaxAddDegree R M) (m : M) : ν.Represents 0 m 0 := by + refine ⟨by simp, (ν.homogeneousMk_eq_zero_iff m _).mpr ?_⟩ + simp + +/-- One represents one in degree zero. -/ +theorem represents_one (ν : MaxAddDegree R M) : ν.Represents 1 0 1 := + ⟨ν.map_one_le_zero, ν.homogeneousMk_one⟩ + +/-- Representatives in a common degree add. -/ +theorem Represents.add {ν : MaxAddDegree R M} {x y : R} {m : M} + {e f : ν.AssociatedGraded} (hx : ν.Represents x m e) (hy : ν.Represents y m f) : + ν.Represents (x + y) m (e + f) := by + obtain ⟨hdx, hex⟩ := hx + obtain ⟨hdy, hey⟩ := hy + have hd : ν (x + y) ≤ m := (ν.map_add_le_max x y).trans (max_le hdx hdy) + refine ⟨hd, ?_⟩ + rw [show (⟨x + y, (ν.mem_filtrationLE_iff m _).mpr hd⟩ : ν.filtrationLE m) = + ⟨x, (ν.mem_filtrationLE_iff m _).mpr hdx⟩ + + ⟨y, (ν.mem_filtrationLE_iff m _).mpr hdy⟩ from Subtype.ext rfl, + map_add, hex, hey] + +/-- Representatives multiply in the sum of their degrees. -/ +theorem Represents.mul {ν : MaxAddDegree R M} {x y : R} {m n p : M} + {e f : ν.AssociatedGraded} (hp : p = m + n) + (hx : ν.Represents x m e) (hy : ν.Represents y n f) : + ν.Represents (x * y) p (e * f) := by + obtain ⟨hdx, hex⟩ := hx + obtain ⟨hdy, hey⟩ := hy + have hd : ν (x * y) ≤ p := by + rw [hp] + exact (ν.map_mul_le_add x y).trans (by simpa using add_le_add hdx hdy) + refine ⟨hd, ?_⟩ + rw [← hex, ← hey, ν.homogeneousMk_mul_of_coe_eq hp + ⟨x, (ν.mem_filtrationLE_iff m _).mpr hdx⟩ + ⟨y, (ν.mem_filtrationLE_iff n _).mpr hdy⟩ + ⟨x * y, (ν.mem_filtrationLE_iff p _).mpr hd⟩ rfl] + +/-- Powers of a representative represent the corresponding powers. -/ +theorem Represents.pow {ν : MaxAddDegree R M} {x : R} {m : M} {e : ν.AssociatedGraded} + (hx : ν.Represents x m e) (n : ℕ) : ν.Represents (x ^ n) (n • m) (e ^ n) := by + induction n with + | zero => simpa using ν.represents_one + | succ n ih => simpa [pow_succ, succ_nsmul] using ih.mul rfl hx + +/-- A finite product of representatives represents the product. -/ +theorem represents_prod {ν : MaxAddDegree R M} {ι : Type w} {s : Finset ι} + {x : ι → R} {m : ι → M} {e : ι → ν.AssociatedGraded} + (h : ∀ i ∈ s, ν.Represents (x i) (m i) (e i)) : + ν.Represents (∏ i ∈ s, x i) (∑ i ∈ s, m i) (∏ i ∈ s, e i) := by + classical + induction s using Finset.cons_induction with + | empty => simpa using ν.represents_one + | cons i s hi ih => + rw [Finset.prod_cons, Finset.prod_cons] + exact (h i (Finset.mem_cons_self i s)).mul (Finset.sum_cons hi) + (ih fun j hj ↦ h j (Finset.mem_cons_of_mem hj)) + +/-- A finite sum of representatives in one degree represents the sum. -/ +theorem represents_sum {ν : MaxAddDegree R M} {ι : Type w} {s : Finset ι} + {x : ι → R} {m : M} {e : ι → ν.AssociatedGraded} + (h : ∀ i ∈ s, ν.Represents (x i) m (e i)) : + ν.Represents (∑ i ∈ s, x i) m (∑ i ∈ s, e i) := by + classical + induction s using Finset.cons_induction with + | empty => simpa using ν.represents_zero m + | cons i s hi ih => + rw [Finset.sum_cons, Finset.sum_cons] + exact (h i (Finset.mem_cons_self i s)).add + (ih fun j hj ↦ h j (Finset.mem_cons_of_mem hj)) + +/-- Representatives of the same class differ by an element of smaller degree. -/ +theorem Represents.degree_sub_lt {ν : MaxAddDegree R M} {x y : R} {m : M} + {e : ν.AssociatedGraded} (hx : ν.Represents x m e) (hy : ν.Represents y m e) : + ν (x - y) < m := by + obtain ⟨hdx, hex⟩ := hx + obtain ⟨hdy, hey⟩ := hy + have hd : ν (x - y) ≤ m := (ν.map_sub_le_max x y).trans (max_le hdx hdy) + apply (ν.homogeneousMk_eq_zero_iff m + ⟨x - y, (ν.mem_filtrationLE_iff m _).mpr hd⟩).mp + rw [show (⟨x - y, (ν.mem_filtrationLE_iff m _).mpr hd⟩ : ν.filtrationLE m) = + ⟨x, (ν.mem_filtrationLE_iff m _).mpr hdx⟩ - + ⟨y, (ν.mem_filtrationLE_iff m _).mpr hdy⟩ from Subtype.ext rfl, + map_sub, hex, hey, sub_self] + +/-- An element of smaller degree represents zero. -/ +theorem represents_zero_of_degree_lt {ν : MaxAddDegree R M} {x : R} {m : M} + (h : ν x < (m : WithBot M)) : ν.Represents x m 0 := + ⟨h.le, (ν.homogeneousMk_eq_zero_iff m _).mpr h⟩ + +/-- An element represents at most one class in a fixed degree. -/ +theorem Represents.unique {ν : MaxAddDegree R M} {x : R} {m : M} + {e f : ν.AssociatedGraded} (he : ν.Represents x m e) (hf : ν.Represents x m f) : e = f := by + obtain ⟨hde, heq⟩ := he + obtain ⟨hdf, hfq⟩ := hf + rw [← heq, ← hfq] + +/-- A representative of a nonzero class has exactly the specified degree. -/ +theorem Represents.degree_eq {ν : MaxAddDegree R M} {x : R} {m : M} + {e : ν.AssociatedGraded} (h : ν.Represents x m e) (he : e ≠ 0) : + ν x = (m : WithBot M) := by + rcases h.degree_le.lt_or_eq with hlt | heq + · exact absurd ((ν.represents_zero_of_degree_lt hlt).unique h) (by simpa [eq_comm] using he) + · exact heq + +/-- A representative of zero has degree below the specified degree. -/ +theorem Represents.degree_lt_of_eq_zero {ν : MaxAddDegree R M} {x : R} {m : M} + (h : ν.Represents x m 0) : ν x < (m : WithBot M) := by + obtain ⟨hd, he⟩ := h + exact (ν.homogeneousMk_eq_zero_iff m + ⟨x, (ν.mem_filtrationLE_iff m _).mpr hd⟩).mp he + +/-- A choice of representative for each member of a graded family. -/ +structure LiftFamily (ν : MaxAddDegree R M) {ι : Type w} (wt : ι → M) + (e : ι → ν.AssociatedGraded) where + /-- The chosen representative. -/ + lift : ι → R + /-- Each chosen element represents the corresponding homogeneous class. -/ + represents : ∀ i, ν.Represents (lift i) (wt i) (e i) + +variable {k : Type z} [CommRing k] [Algebra k R] + +/-- Weighted homogeneous evaluation preserves representation. -/ +theorem represents_aeval {ν : MaxAddDegree R M} {ι : Type w} {wt : ι → M} + {x : ι → R} {e : ι → ν.AssociatedGraded} [Algebra k ν.AssociatedGraded] + (hscalar : ∀ c : k, + ν.Represents (algebraMap k R c) 0 (algebraMap k ν.AssociatedGraded c)) + (hx : ∀ i, ν.Represents (x i) (wt i) (e i)) + {F : MvPolynomial ι k} {m : M} (hF : IsWeightedHomogeneous wt F m) : + ν.Represents (aeval x F) m (aeval e F) := by + classical + induction hF using IsWeightedHomogeneous.induction_on with + | zero => simpa using ν.represents_zero m + | add p q hp hq ihp ihq => simpa using ihp.add ihq + | monomial d c hc => + rw [← hc, aeval_monomial, aeval_monomial, Finsupp.weight_apply, Finsupp.sum, + Finsupp.prod, Finsupp.prod] + exact (hscalar c).mul (zero_add _).symm + (ν.represents_prod fun i _ ↦ (hx i).pow (d i)) + +/-- Evaluating a polynomial whose monomials all have weight below `m` has degree below `m`. -/ +theorem degree_aeval_lt_of_forall_weight_lt {ν : MaxAddDegree R M} {ι : Type w} + {wt : ι → M} {x : ι → R} {e : ι → ν.AssociatedGraded} + [Algebra k ν.AssociatedGraded] + (hscalar : ∀ c : k, + ν.Represents (algebraMap k R c) 0 (algebraMap k ν.AssociatedGraded c)) + (hx : ∀ i, ν.Represents (x i) (wt i) (e i)) + {F : MvPolynomial ι k} {m : M} + (hF : ∀ d ∈ F.support, Finsupp.weight wt d < m) : + ν (aeval x F) < (m : WithBot M) := by + classical + rw [show aeval x F = + ∑ d ∈ F.support, aeval x (monomial d (AddMonoidAlgebra.coeff F d)) by + conv_lhs => rw [F.as_sum] + rw [map_sum]] + apply ν.map_sum_lt_of_forall_lt _ _ (WithBot.bot_lt_coe m) + intro d hd + have hhom : IsWeightedHomogeneous wt (monomial d (AddMonoidAlgebra.coeff F d)) + (Finsupp.weight wt d) := + isWeightedHomogeneous_monomial wt d (AddMonoidAlgebra.coeff F d) rfl + exact (ν.represents_aeval hscalar hx hhom).degree_le.trans_lt + (WithBot.coe_lt_coe.mpr (hF d hd)) + +/-- Polynomial evaluation represents the evaluation of its top weighted homogeneous part. -/ +theorem represents_aeval_weightedHomogeneousComponent {ν : MaxAddDegree R M} {ι : Type w} + {wt : ι → M} {x : ι → R} {e : ι → ν.AssociatedGraded} + [Algebra k ν.AssociatedGraded] + (hscalar : ∀ c : k, + ν.Represents (algebraMap k R c) 0 (algebraMap k ν.AssociatedGraded c)) + (hx : ∀ i, ν.Represents (x i) (wt i) (e i)) + {F : MvPolynomial ι k} {m : M} + (hF : ∀ d ∈ F.support, Finsupp.weight wt d ≤ m) : + ν.Represents (aeval x F) m (aeval e (weightedHomogeneousComponent wt m F)) := by + classical + have hhom : IsWeightedHomogeneous wt (weightedHomogeneousComponent wt m F) m := + weightedHomogeneousComponent_isWeightedHomogeneous (w := wt) (n := m) (φ := F) + have hrest : ∀ d ∈ (F - weightedHomogeneousComponent wt m F).support, + Finsupp.weight wt d < m := by + intro d hd + have hne := MvPolynomial.mem_support_iff.mp hd + rw [MvPolynomial.coeff_sub, coeff_weightedHomogeneousComponent] at hne + by_cases hdw : Finsupp.weight wt d = m + · rw [ite_eq_left hdw, sub_self] at hne + exact absurd rfl hne + · rw [ite_eq_right hdw, sub_zero] at hne + exact lt_of_le_of_ne (hF d (MvPolynomial.mem_support_iff.mpr hne)) hdw + have htop := ν.represents_aeval hscalar hx hhom + have hlow : + ν.Represents (aeval x (F - weightedHomogeneousComponent wt m F)) m 0 := + ν.represents_zero_of_degree_lt + (ν.degree_aeval_lt_of_forall_weight_lt hscalar hx hrest) + have := htop.add hlow + rwa [← map_add, add_sub_cancel, add_zero] at this + +end MaxAddDegree + +end diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/DegreeScalar.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/DegreeScalar.lean new file mode 100644 index 0000000000..ab8e0cce09 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/DegreeScalar.lean @@ -0,0 +1,102 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.DegreeInitialForm + +/-! +# Degree-zero scalar maps + +A scalar map whose nonzero values all have degree zero induces a ring homomorphism from the +scalar ring to the associated graded ring, sending each scalar to its initial form. Its image is +represented in grade zero. This is how the scalars of a subalgebra act on a fibre associated +graded ring. +-/ + +open scoped MaxAddDegree + +universe u v w + +public noncomputable section + +namespace MaxAddDegree + +variable {R : Type u} {M : Type v} {k : Type w} [CommRing R] [AddCommMonoid M] + [LinearOrder M] [IsOrderedCancelAddMonoid M] + +private def degreeZeroScalarFiltration [CommRing k] + (ν : MaxAddDegree R M) (ι : k →+* R) + (hdegree : ∀ c : k, c ≠ 0 → ν (ι c) = 0) (c : k) : + ν.filtrationLE 0 := + ⟨ι c, (ν.mem_filtrationLE_iff 0 _).mpr <| by + by_cases hc : c = 0 + · subst c + simp + · rw [hdegree c hc, WithBot.coe_zero]⟩ + +/-- The ring homomorphism from degree-zero scalars to their grade-zero initial classes. -/ +def degreeZeroScalarHom [CommRing k] + (ν : MaxAddDegree R M) (ι : k →+* R) + (hdegree : ∀ c : k, c ≠ 0 → ν (ι c) = 0) : + k →+* ν.AssociatedGraded where + toFun c := ν.homogeneousMk 0 (degreeZeroScalarFiltration ν ι hdegree c) + map_zero' := by + change ν.homogeneousMk 0 (degreeZeroScalarFiltration ν ι hdegree 0) = 0 + have hzero : degreeZeroScalarFiltration ν ι hdegree 0 = 0 := by + apply Subtype.ext + exact ι.map_zero + rw [hzero] + exact (ν.homogeneousMk 0).map_zero + map_one' := by + rw [ν.homogeneousMk_apply] + change DirectSum.of ν.Component 0 + (ν.componentMk 0 (degreeZeroScalarFiltration ν ι hdegree 1)) = + DirectSum.of ν.Component 0 ν.componentOne + apply congrArg (DirectSum.of ν.Component 0) + rw [ν.componentOne_eq_componentMk] + apply congrArg (ν.componentMk 0) + apply Subtype.ext + exact ι.map_one + map_add' c d := by + change ν.homogeneousMk 0 (degreeZeroScalarFiltration ν ι hdegree (c + d)) = + ν.homogeneousMk 0 (degreeZeroScalarFiltration ν ι hdegree c) + + ν.homogeneousMk 0 (degreeZeroScalarFiltration ν ι hdegree d) + rw [← (ν.homogeneousMk 0).map_add] + apply congrArg (ν.homogeneousMk 0) + apply Subtype.ext + exact ι.map_add c d + map_mul' c d := by + rw [ν.homogeneousMk_mul, ν.homogeneousMk_apply, ν.homogeneousMk_apply] + apply DirectSum.of_eq_of_gradedMonoid_eq + apply Sigma.ext (zero_add 0).symm + apply ν.componentMk_heq_of_grade_eq_of_coe_eq (zero_add 0).symm + rw [ν.coe_mulFiltrationLE] + exact ι.map_mul c d + +/-- Evaluation of the degree-zero scalar homomorphism on any grade-zero filtration +representative of the scalar's image. -/ +theorem degreeZeroScalarHom_apply [CommRing k] + (ν : MaxAddDegree R M) (ι : k →+* R) + (hdegree : ∀ c : k, c ≠ 0 → ν (ι c) = 0) (c : k) + (x : ν.filtrationLE 0) (hx : (x : R) = ι c) : + degreeZeroScalarHom ν ι hdegree c = ν.homogeneousMk 0 x := by + change ν.homogeneousMk 0 (degreeZeroScalarFiltration ν ι hdegree c) = _ + refine congrArg (ν.homogeneousMk 0) (Subtype.ext ?_) + exact hx.symm + +/-- The degree-zero scalar homomorphism sends each scalar to its initial form. -/ +theorem degreeZeroScalarHom_apply_eq_initialForm [CommRing k] + (ν : MaxAddDegree R M) (ι : k →+* R) + (hdegree : ∀ c : k, c ≠ 0 → ν (ι c) = 0) (c : k) : + degreeZeroScalarHom ν ι hdegree c = ν.initialForm (ι c) := by + by_cases hc : c = 0 + · subst c + rw [(degreeZeroScalarHom ν ι hdegree).map_zero, ι.map_zero, ν.initialForm_zero] + · rw [degreeZeroScalarHom_apply ν ι hdegree c ⟨ι c, (ν.mem_filtrationLE_iff 0 _).mpr + (hdegree c hc).le⟩ rfl] + exact ν.homogeneousMk_eq_initialForm_of_degree_eq _ (hdegree c hc) + +end MaxAddDegree diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/DegreeSum.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/DegreeSum.lean new file mode 100644 index 0000000000..a41337b31f --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/DegreeSum.lean @@ -0,0 +1,159 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.DegreeInitialForm + +import Mathlib.Tactic.Ring + +/-! +# Degrees and homogeneous classes of finite sums + +For a max-additive degree `ν`, a summand of strictly dominant degree determines the degree of a +sum, a finite sum of elements of degree below `d` has degree below `d`, and the homogeneous class +at level `d` of a finite sum of elements of the weak filtration is the sum of the classes. The +grade-`d` component of a finite sum of homogeneous classes `homogeneousMk (m i) (y i)` is the class +of the sum of the terms with `m i = d`, and the grade-`d` component of an initial form is the class +of the element when its degree is `d` and zero otherwise. Finally, for a well-founded value +monoid, an additive subgroup whose elements of degree at most `d` exhaust the classes at level `d`, +for every `d`, is the whole ring. +-/ + +universe u v x + +public noncomputable section + +namespace MaxAddDegree + +variable {R : Type u} {M : Type v} +variable [CommRing R] [AddCommMonoid M] [LinearOrder M] [IsOrderedCancelAddMonoid M] + +variable (ν : MaxAddDegree R M) + +theorem homogeneousMk_eq_zero_of_degree_lt {d : M} {x : R} (hle : x ∈ ν.filtrationLE d) + (hx : ν x < (d : WithBot M)) : ν.homogeneousMk d ⟨x, hle⟩ = 0 := + (ν.homogeneousMk_eq_zero_iff d ⟨x, hle⟩).mpr hx + +/-- The homogeneous class of a finite sum at a common level is the sum of the classes. -/ +theorem homogeneousMk_finsetSum {ι : Type x} (s : Finset ι) (x : ι → R) {d : M} + (hx : ∀ i ∈ s, x i ∈ ν.filtrationLE d) (hsum : ∑ i ∈ s, x i ∈ ν.filtrationLE d) : + ν.homogeneousMk d ⟨∑ i ∈ s, x i, hsum⟩ = + ∑ i ∈ s.attach, ν.homogeneousMk d ⟨x i, hx i i.2⟩ := by + rw [← map_sum] + congr 1 + apply Subtype.ext + rw [AddSubmonoidClass.coe_finsetSum] + simp only + rw [Finset.sum_attach s x] + +omit [IsOrderedCancelAddMonoid M] in +/-- A strictly dominant summand determines the degree of a sum. -/ +theorem degree_add_eq_of_lt {x y : R} (h : ν y < ν x) : ν (x + y) = ν x := by + refine le_antisymm ((ν.map_add_le_max x y).trans (max_le le_rfl h.le)) ?_ + by_contra hcon + rw [not_le] at hcon + have hx : x = (x + y) + (-y) := by ring + have hbound := ν.map_add_le_max (x + y) (-y) + rw [← hx, ν.map_neg] at hbound + exact absurd (lt_of_le_of_lt hbound (max_lt hcon h)) (lt_irrefl _) + +omit [IsOrderedCancelAddMonoid M] in +theorem degree_finsetSum_lt {ι : Type x} (s : Finset ι) (x : ι → R) {d : M} + (hx : ∀ i ∈ s, ν (x i) < (d : WithBot M)) : ν (∑ i ∈ s, x i) < (d : WithBot M) := by + classical + refine lt_of_le_of_lt (ν.map_sum_le_of_forall_le s x (s.sup fun i ↦ ν (x i)) + fun i hi ↦ Finset.le_sup (f := fun i ↦ ν (x i)) hi) ?_ + exact (Finset.sup_lt_iff (WithBot.bot_lt_coe d)).mpr hx + +theorem homogeneousMk_apply_of_eq {m d : M} {y : R} (hy : y ∈ ν.filtrationLE m) (h : m = d) : + (ν.homogeneousMk m ⟨y, hy⟩) d = ν.componentMk d ⟨y, h ▸ hy⟩ := by + subst h + rw [ν.homogeneousMk_apply, DirectSum.of_eq_same] + +theorem homogeneousMk_apply_of_ne {m d : M} {y : R} (hy : y ∈ ν.filtrationLE m) (h : m ≠ d) : + (ν.homogeneousMk m ⟨y, hy⟩) d = 0 := by + rw [ν.homogeneousMk_apply, DirectSum.of_eq_of_ne _ _ _ (Ne.symm h)] + +/-- The grade-`d` component of a finite sum of homogeneous classes is the class of the sum of +the terms of grade `d`. -/ +theorem homogeneousMk_finsetSum_apply {ι : Type x} (s : Finset ι) (m : ι → M) (y : ι → R) + (hy : ∀ i, y i ∈ ν.filtrationLE (m i)) (d : M) : + (∑ i ∈ s, ν.homogeneousMk (m i) ⟨y i, hy i⟩) d = + ν.componentMk d ⟨∑ i ∈ s.filter (fun i ↦ m i = d), y i, + (ν.filtrationLE d).sum_mem fun i hi ↦ (Finset.mem_filter.mp hi).2 ▸ hy i⟩ := by + classical + rw [DirectSum.sum_apply] + have hterm : ∀ i ∈ s, (ν.homogeneousMk (m i) ⟨y i, hy i⟩) d = + if h : m i = d then ν.componentMk d ⟨y i, h ▸ hy i⟩ else 0 := fun i _ ↦ by + by_cases h : m i = d + · rw [dite_eq_left h, ν.homogeneousMk_apply_of_eq (hy i) h] + · rw [dite_eq_right h, ν.homogeneousMk_apply_of_ne (hy i) h] + rw [Finset.sum_congr rfl hterm, Finset.sum_dite, Finset.sum_const_zero, add_zero, ← map_sum] + congr 1 + apply Subtype.ext + rw [AddSubmonoidClass.coe_finsetSum] + simp only + exact Finset.sum_attach (s.filter fun i ↦ m i = d) y + +/-- The grade-`d` component of an initial form. -/ +theorem initialForm_apply (y : R) (d : M) : + (ν.initialForm y) d = + if h : ν y = (d : WithBot M) then + ν.componentMk d ⟨y, (ν.mem_filtrationLE_iff d y).mpr h.le⟩ else 0 := by + by_cases hy : ν y = ⊥ + · rw [ν.initialForm_eq_zero_of_eq_bot hy, DirectSum.zero_apply] + split_ifs with h + · rw [hy] at h + exact absurd h WithBot.bot_ne_coe + · rfl + · obtain ⟨m, hm⟩ := WithBot.ne_bot_iff_exists.mp hy + have hmem : y ∈ ν.filtrationLE m := (ν.mem_filtrationLE_iff m y).mpr hm.symm.le + rw [← ν.homogeneousMk_eq_initialForm_of_degree_eq hmem hm.symm] + by_cases h : m = d + · rw [ν.homogeneousMk_apply_of_eq hmem h, dite_eq_left (by rw [← hm, h])] + · rw [ν.homogeneousMk_apply_of_ne hmem h, dite_eq_right] + intro h' + rw [← hm, WithBot.coe_inj] at h' + exact h h' + +omit [IsOrderedCancelAddMonoid M] in +theorem zero_le_degree (hν : ν.IsSeparated) (h0 : ∀ m : M, 0 ≤ m) {x : R} (hx : x ≠ 0) : + (0 : WithBot M) ≤ ν x := by + cases h : ν x with + | bot => exact absurd (((isSeparated_iff ν).mp hν x).mp h) hx + | coe m => exact WithBot.coe_le_coe.mpr (h0 m) + +omit [IsOrderedCancelAddMonoid M] in +/-- An additive subgroup `P` containing, for every degree `d` and every class `g` at level `d`, +an element of degree at most `d` whose class at level `d` is `g`, is the whole ring: by +well-founded induction on the degree, subtracting such an element lowers the degree. -/ +theorem mem_of_forall_exists_componentMk_eq [WellFoundedLT M] (hν : ν.IsSeparated) + (P : AddSubgroup R) + (h : ∀ (d : M) (g : ν.Component d), ∃ p ∈ P, ∃ hp : p ∈ ν.filtrationLE d, + ν.componentMk d ⟨p, hp⟩ = g) + (t : R) : t ∈ P := by + induction hdeg : ν t using WellFoundedLT.induction generalizing t with + | _ δ ih => + cases hδ : δ with + | bot => + rw [hδ] at hdeg + rw [((ν.isSeparated_iff).mp hν t).mp hdeg] + exact zero_mem P + | coe d => + rw [hδ] at hdeg ih + have hle : t ∈ ν.filtrationLE d := (ν.mem_filtrationLE_iff d t).mpr hdeg.le + obtain ⟨p, hpP, hple, hp⟩ := h d (ν.componentMk d ⟨t, hle⟩) + have hsub : ν.componentMk d ⟨t - p, (ν.filtrationLE d).sub_mem hle hple⟩ = 0 := by + have : (⟨t - p, (ν.filtrationLE d).sub_mem hle hple⟩ : ν.filtrationLE d) = + ⟨t, hle⟩ - ⟨p, hple⟩ := rfl + rw [this, map_sub, hp, sub_self] + rw [ν.componentMk_eq_zero_iff] at hsub + have hmem := ih _ (hdeg ▸ hsub) (t - p) rfl + have : t = (t - p) + p := by ring + rw [this] + exact P.add_mem hmem hpP + +end MaxAddDegree diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/DegreeWeightedPolynomial.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/DegreeWeightedPolynomial.lean new file mode 100644 index 0000000000..10f3287dfc --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/DegreeWeightedPolynomial.lean @@ -0,0 +1,239 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.DegreeSum +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MvPolynomial.WeightedTotalDegree +public import Mathlib.Algebra.MvPolynomial.Eval + +import Mathlib.Algebra.BigOperators.Ring.Finset +import Mathlib.Algebra.BigOperators.Finsupp.Basic + +/-! +# The degree of a polynomial in elements with independent initial forms + +Let `ν` be a multiplicative degree on a commutative ring `R` with values in `M`, let `L → R` be a +ring of scalars whose nonzero elements have degree zero, and let `x i ∈ R` be elements of degrees +`w i ∈ M`. Suppose the initial forms of the `x i` are algebraically independent over the initial +forms of `L`: an injective ring homomorphism `Φ : L[X] → gr_ν R` sends `C c` to `in(c)` and `X i` +to `in(x i)`. Then for every nonzero polynomial `F`, the degree of `F(x)` is the weighted total +degree of `F` for the weights `w`, and the initial form of `F(x)` is `Φ` of the top +weighted-homogeneous component of `F`: the monomials of top weight have independent initial +forms, so their sum has exactly that degree, and the remaining terms have smaller degree. +Consequently evaluation at `x` is injective. + +The weights take values in the value monoid `M` itself; weights in `ℕ`, read in `M` through +`Nat.cast`, are the case treated by the cast lemmas of +`ConwayRefinement.Algebra.MvPolynomial.WeightedTotalDegree`. +-/ + +universe u v w x + +public noncomputable section + +open MvPolynomial + +namespace MaxAddDegree + +variable {R : Type u} {M : Type v} {L : Type w} {σ : Type x} + +variable [CommRing R] [AddCommMonoid M] [LinearOrder M] [IsOrderedCancelAddMonoid M] + +section Multiplicative + +variable (ν : MaxAddDegree R M) [ν.IsMultiplicative] + +/-- The initial form of a power is the power of the initial form. -/ +theorem initialForm_pow (y : R) (n : ℕ) : ν.initialForm (y ^ n) = ν.initialForm y ^ n := by + induction n with + | zero => rw [pow_zero, pow_zero, ν.initialForm_one] + | succ n ih => rw [pow_succ, pow_succ, ν.initialForm_mul, ih] + +/-- The initial form of a finite product is the product of the initial forms. -/ +theorem initialForm_finset_prod {ι : Type*} (s : Finset ι) (f : ι → R) : + ν.initialForm (∏ i ∈ s, f i) = ∏ i ∈ s, ν.initialForm (f i) := by + classical + induction s using Finset.induction_on with + | empty => rw [Finset.prod_empty, Finset.prod_empty, ν.initialForm_one] + | insert a s ha ih => rw [Finset.prod_insert ha, Finset.prod_insert ha, ν.initialForm_mul, ih] + +end Multiplicative + +variable [CommRing L] [Nontrivial L] [Algebra L R] + +/-- Elements `x i` of degrees `w i` whose initial forms are algebraically independent over the +initial forms of the degree-zero scalars `L`, witnessed by an injective ring homomorphism +`Φ : L[X] → gr_ν R` with `Φ (C c) = in(c)` and `Φ (X i) = in(x i)`. -/ +structure IsInitialFormCoordinates (ν : MaxAddDegree R M) (w : σ → M) (x : σ → R) + (Φ : MvPolynomial σ L →+* ν.AssociatedGraded) : Prop where + degree_algebraMap : ∀ c : L, c ≠ 0 → ν (algebraMap L R c) = 0 + degree_x : ∀ i, ν (x i) = (w i : WithBot M) + injective : Function.Injective Φ + map_C : ∀ c : L, Φ (C c) = ν.initialForm (algebraMap L R c) + map_X : ∀ i, Φ (X i) = ν.initialForm (x i) + +namespace IsInitialFormCoordinates + +variable {ν : MaxAddDegree R M} {w : σ → M} {x : σ → R} + {Φ : MvPolynomial σ L →+* ν.AssociatedGraded} +variable [ν.IsMultiplicative] (H : IsInitialFormCoordinates ν w x Φ) +include H + +omit [ν.IsMultiplicative] in +theorem degree_one : ν 1 = 0 := by + simpa using H.degree_algebraMap 1 one_ne_zero + +theorem degree_pow {y : R} {m : M} (hy : ν y = m) (n : ℕ) : + ν (y ^ n) = ((n • m : M) : WithBot M) := by + induction n with + | zero => rw [pow_zero, zero_smul, WithBot.coe_zero]; exact H.degree_one + | succ n ih => rw [pow_succ, ν.map_mul, ih, hy, succ_nsmul, WithBot.coe_add] + +theorem degree_finset_prod {ι : Type*} (s : Finset ι) (f : ι → R) (m : ι → M) + (h : ∀ i ∈ s, ν (f i) = m i) : + ν (∏ i ∈ s, f i) = ((∑ i ∈ s, m i : M) : WithBot M) := by + classical + induction s using Finset.induction_on with + | empty => simpa using H.degree_one + | insert a s ha ih => + rw [Finset.prod_insert ha, Finset.sum_insert ha, ν.map_mul, h a (Finset.mem_insert_self a s), + ih fun i hi ↦ h i (Finset.mem_insert_of_mem hi), WithBot.coe_add] + +/-- The degree of the value of a monomial with nonzero coefficient is its weight. -/ +theorem degree_aeval_monomial (e : σ →₀ ℕ) {c : L} (hc : c ≠ 0) : + ν (aeval x (monomial e c)) = (Finsupp.weight w e : WithBot M) := by + classical + rw [aeval_monomial, ν.map_mul, H.degree_algebraMap c hc, zero_add, Finsupp.prod, + H.degree_finset_prod e.support (fun i ↦ x i ^ e i) (fun i ↦ e i • w i) + fun i _ ↦ H.degree_pow (H.degree_x i) (e i), + Finsupp.weight_apply, Finsupp.sum] + +omit [Nontrivial L] in +/-- On a monomial, the initial form of the value is `Φ` of the monomial. -/ +theorem initialForm_aeval_monomial (e : σ →₀ ℕ) (c : L) : + ν.initialForm (aeval x (monomial e c)) = Φ (monomial e c) := by + classical + rw [aeval_monomial, ν.initialForm_mul, Finsupp.prod, ν.initialForm_finset_prod, monomial_eq, + _root_.map_mul, H.map_C, Finsupp.prod, _root_.map_prod] + congr 1 + exact Finset.prod_congr rfl fun i _ ↦ by rw [ν.initialForm_pow, _root_.map_pow, H.map_X] + +/-- For a weighted-homogeneous polynomial `G` of weight `d`, the class of `G(x)` at level `d` is +`Φ G`: every monomial of `G` has degree exactly `d`, where the class map is additive. -/ +theorem homogeneousMk_aeval_of_isWeightedHomogeneous {G : MvPolynomial σ L} {d : M} + (hG : IsWeightedHomogeneous w G d) (hle : aeval x G ∈ ν.filtrationLE d) : + ν.homogeneousMk d ⟨aeval x G, hle⟩ = Φ G := by + classical + have hdeg : ∀ e ∈ G.support, + ν (aeval x (monomial e (G.coeff e))) = (d : WithBot M) := fun e he ↦ by + rw [H.degree_aeval_monomial e (mem_support_iff.mp he), hG (mem_support_iff.mp he)] + have hmem : ∀ e ∈ G.support, aeval x (monomial e (G.coeff e)) ∈ ν.filtrationLE d := + fun e he ↦ (ν.mem_filtrationLE_iff _ _).mpr (hdeg e he).le + have hsplit : (⟨aeval x G, hle⟩ : ν.filtrationLE d) = + ⟨∑ e ∈ G.support, aeval x (monomial e (G.coeff e)), (ν.filtrationLE _).sum_mem hmem⟩ := by + apply Subtype.ext + change aeval x G = _ + conv_lhs => rw [as_sum G] + rw [_root_.map_sum] + rw [hsplit, ν.homogeneousMk_finsetSum _ _ hmem] + conv_rhs => rw [as_sum G] + rw [_root_.map_sum, ← Finset.sum_attach G.support fun e ↦ Φ (monomial e (G.coeff e))] + refine Finset.sum_congr rfl fun e _ ↦ ?_ + rw [ν.homogeneousMk_eq_initialForm_of_degree_eq _ (hdeg e.1 e.2)] + exact H.initialForm_aeval_monomial e.1 (G.coeff e.1) + +variable [OrderBot M] + +/-- A polynomial of weighted total degree at most `d` evaluates to an element of degree at most +`d`. -/ +theorem degree_aeval_le_of_weightedTotalDegree_le {F : MvPolynomial σ L} {d : M} + (hF : weightedTotalDegree w F ≤ d) : + ν (aeval x F) ≤ (d : WithBot M) := by + classical + conv_lhs => rw [as_sum F] + rw [_root_.map_sum] + refine ν.map_sum_le_of_forall_le _ _ _ fun e he ↦ ?_ + rw [H.degree_aeval_monomial e (mem_support_iff.mp he)] + exact WithBot.coe_le_coe.mpr ((le_weightedTotalDegree w he).trans hF) + +/-- A polynomial value has degree at most the weighted total degree of the polynomial. -/ +theorem degree_aeval_le (F : MvPolynomial σ L) : + ν (aeval x F) ≤ ((weightedTotalDegree w F : M) : WithBot M) := + H.degree_aeval_le_of_weightedTotalDegree_le le_rfl + +/-- A nonzero weighted-homogeneous polynomial of weight `d` evaluates to an element of degree +exactly `d`. -/ +theorem degree_aeval_eq_of_isWeightedHomogeneous {G : MvPolynomial σ L} {d : M} + (hG : IsWeightedHomogeneous w G d) (hne : G ≠ 0) : + ν (aeval x G) = (d : WithBot M) := by + have hle : ν (aeval x G) ≤ (d : WithBot M) := + H.degree_aeval_le_of_weightedTotalDegree_le + (Finset.sup_le fun e he ↦ (hG (mem_support_iff.mp he)).le) + have hmem := (ν.mem_filtrationLE_iff _ _).mpr hle + refine le_antisymm hle (not_lt.mp fun hlt ↦ H.injective.ne hne ?_) + rw [_root_.map_zero, ← H.homogeneousMk_aeval_of_isWeightedHomogeneous hG hmem] + exact ν.homogeneousMk_eq_zero_of_degree_lt hmem hlt + +/-- The initial form of the value of a weighted-homogeneous polynomial `G` is `Φ G`. -/ +theorem initialForm_aeval_of_isWeightedHomogeneous {G : MvPolynomial σ L} {d : M} + (hG : IsWeightedHomogeneous w G d) : + ν.initialForm (aeval x G) = Φ G := by + by_cases hzero : G = 0 + · subst hzero + rw [_root_.map_zero, _root_.map_zero, ν.initialForm_zero] + have hdeg := H.degree_aeval_eq_of_isWeightedHomogeneous hG hzero + have hmem := (ν.mem_filtrationLE_iff _ _).mpr hdeg.le + rw [← ν.homogeneousMk_eq_initialForm_of_degree_eq hmem hdeg] + exact H.homogeneousMk_aeval_of_isWeightedHomogeneous hG hmem + +/-- The degree of the value of a nonzero polynomial is its weighted total degree, and the initial +form of the value is `Φ` of the top weighted-homogeneous component. -/ +theorem degree_aeval_eq_and_initialForm {F : MvPolynomial σ L} (hF : F ≠ 0) : + ν (aeval x F) = ((weightedTotalDegree w F : M) : WithBot M) ∧ + ν.initialForm (aeval x F) = + Φ (weightedHomogeneousComponent w (weightedTotalDegree w F) F) := by + classical + set d := weightedTotalDegree w F with hd + set G := weightedHomogeneousComponent w d F with hG + have hGne : G ≠ 0 := weightedHomogeneousComponent_weightedTotalDegree_ne_zero w hF + have hGhom : IsWeightedHomogeneous w G d := + weightedHomogeneousComponent_isWeightedHomogeneous d F + have hGdeg := H.degree_aeval_eq_of_isWeightedHomogeneous hGhom hGne + have hrest : ν (aeval x (F - G)) < (d : WithBot M) := by + rcases weightedTotalDegree_sub_weightedHomogeneousComponent_lt w F with h0 | hlt + · rw [h0, _root_.map_zero, ν.map_zero] + exact WithBot.bot_lt_coe _ + · exact lt_of_le_of_lt (H.degree_aeval_le (F - G)) (WithBot.coe_lt_coe.mpr hlt) + have hsplit : aeval x F = aeval x G + aeval x (F - G) := by + rw [← _root_.map_add, add_sub_cancel] + have hdegF : ν (aeval x F) = (d : WithBot M) := by + rw [hsplit, ν.degree_add_eq_of_lt (by rw [hGdeg]; exact hrest), hGdeg] + refine ⟨hdegF, ?_⟩ + have hmemF := (ν.mem_filtrationLE_iff _ _).mpr hdegF.le + have hmemG := (ν.mem_filtrationLE_iff _ _).mpr hGdeg.le + have hmemR := (ν.mem_filtrationLE_iff _ _).mpr hrest.le + rw [← ν.homogeneousMk_eq_initialForm_of_degree_eq hmemF hdegF] + have hsum : (⟨aeval x F, hmemF⟩ : ν.filtrationLE d) = + ⟨aeval x G, hmemG⟩ + ⟨aeval x (F - G), hmemR⟩ := Subtype.ext hsplit + rw [hsum, _root_.map_add, H.homogeneousMk_aeval_of_isWeightedHomogeneous hGhom hmemG, + ν.homogeneousMk_eq_zero_of_degree_lt hmemR hrest, add_zero] + +/-- The degree of the value of a nonzero polynomial is its weighted total degree. -/ +theorem degree_aeval_eq {F : MvPolynomial σ L} (hF : F ≠ 0) : + ν (aeval x F) = ((weightedTotalDegree w F : M) : WithBot M) := + (H.degree_aeval_eq_and_initialForm hF).1 + +/-- Evaluation at `x` is injective: the `x i` are algebraically independent over `L`. -/ +theorem aeval_injective : Function.Injective (aeval (R := L) x) := by + refine (injective_iff_map_eq_zero _).mpr fun F hF ↦ ?_ + by_contra hne + have h := H.degree_aeval_eq hne + rw [hF, ν.map_zero] at h + exact WithBot.bot_ne_coe h + +end IsInitialFormCoordinates + +end MaxAddDegree diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/FiltrationDegree.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/FiltrationDegree.lean new file mode 100644 index 0000000000..916d649fc5 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/FiltrationDegree.lean @@ -0,0 +1,255 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.MaxAddDegree +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.DegreeAssociatedGraded +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.DegreeAssociatedGradedDomain +public import Mathlib.RingTheory.Ideal.Operations + +/-! +# A max-additive degree from a separated multiplicative filtration + +A decreasing, multiplicative filtration by ideals which is separated — every nonzero element +eventually leaves it — determines a max-additive degree, valued in `OrderDual ℕ` because the +filtration decreases. The generic construction can be reused for scalar extensions and quotient +filtrations. + +The file also proves that a ring with a separated multiplicative filtration and domain associated +graded ring is itself a domain. The proof avoids +`MaxAddDegree.quotient_isDomain_of_associatedGraded_isDomain`, whose `[WellFoundedLT M]` +hypothesis fails for `M = ℕᵒᵈ` — precisely the value monoid of a decreasing `ℕ`-indexed +filtration. The elementary route needs no well-foundedness. +-/ + +open scoped MaxAddDegree + +universe u + +public noncomputable section + +variable {R : Type u} [CommRing R] + +/-- A decreasing multiplicative filtration by ideals, separated in the sense that every nonzero +element eventually leaves it. -/ +structure IsSeparatedFiltration (F : ℕ → Ideal R) : Prop where + /-- The filtration is decreasing. -/ + antitone : Antitone F + /-- The zeroth stage is everything. -/ + top : F 0 = ⊤ + /-- The filtration is multiplicative: `F a · F b ⊆ F (a + b)`. -/ + mul_le : ∀ a b, F a * F b ≤ F (a + b) + /-- Every nonzero element eventually leaves the filtration. -/ + exists_not_mem : ∀ {x : R}, x ≠ 0 → ∃ j, x ∉ F j + +namespace IsSeparatedFiltration + +variable {F : ℕ → Ideal R} (hF : IsSeparatedFiltration F) + +/-- The first stage a nonzero element is absent from. -/ +def firstExcluded {x : R} (hx : x ≠ 0) : ℕ := by + classical + exact Nat.find (hF.exists_not_mem hx) + +theorem not_mem_firstExcluded {x : R} (hx : x ≠ 0) : + x ∉ F (hF.firstExcluded hx) := by + classical + exact Nat.find_spec (hF.exists_not_mem hx) + +theorem firstExcluded_le {x : R} (hx : x ≠ 0) {j : ℕ} (hj : x ∉ F j) : + hF.firstExcluded hx ≤ j := by + classical + exact Nat.find_le hj + +theorem firstExcluded_pos {x : R} (hx : x ≠ 0) : 0 < hF.firstExcluded hx := by + rcases Nat.eq_zero_or_pos (hF.firstExcluded hx) with h | h + · exfalso + apply hF.not_mem_firstExcluded hx + rw [h, hF.top] + trivial + · exact h + +theorem mem_iff_lt_firstExcluded {x : R} (hx : x ≠ 0) (j : ℕ) : + x ∈ F j ↔ j < hF.firstExcluded hx := by + constructor + · intro hmem + by_contra hnot + exact hF.not_mem_firstExcluded hx (hF.antitone (Nat.not_lt.mp hnot) hmem) + · intro hj + by_contra hnot + exact absurd (hF.firstExcluded_le hx hnot) (Nat.not_le.mpr hj) + +/-- The largest stage containing a nonzero element. -/ +def index {x : R} (hx : x ≠ 0) : ℕ := hF.firstExcluded hx - 1 + +theorem mem_iff_le_index {x : R} (hx : x ≠ 0) (j : ℕ) : + x ∈ F j ↔ j ≤ hF.index hx := by + rw [hF.mem_iff_lt_firstExcluded hx] + unfold index + have hpos := hF.firstExcluded_pos hx + omega + +/-- The filtration index as a max-additive degree value, order-reversed. -/ +def value (x : R) : WithBot (OrderDual ℕ) := by + classical + exact if hx : x = 0 then ⊥ else + ((OrderDual.toDual (hF.index hx) : OrderDual ℕ) : WithBot (OrderDual ℕ)) + +@[simp] +theorem value_zero : hF.value 0 = ⊥ := by + rw [value, dite_eq_left rfl] + +theorem value_of_ne_zero {x : R} (hx : x ≠ 0) : + hF.value x = ((OrderDual.toDual (hF.index hx) : OrderDual ℕ) : + WithBot (OrderDual ℕ)) := by + rw [value, dite_eq_right hx] + +theorem value_eq_bot_iff (x : R) : hF.value x = ⊥ ↔ x = 0 := by + constructor + · intro h + by_contra hx + rw [hF.value_of_ne_zero hx] at h + exact absurd h (WithBot.coe_ne_bot) + · rintro rfl + exact hF.value_zero + +theorem value_le_toDual_iff (x : R) (j : ℕ) : + hF.value x ≤ ((OrderDual.toDual j : OrderDual ℕ) : WithBot (OrderDual ℕ)) ↔ + x ∈ F j := by + by_cases hx : x = 0 + · subst hx + simp only [hF.value_zero, bot_le, true_iff] + exact Submodule.zero_mem _ + · rw [hF.value_of_ne_zero hx, WithBot.coe_le_coe, hF.mem_iff_le_index hx] + exact OrderDual.toDual_le_toDual + +private theorem firstExcluded_congr {x y : R} (hx : x ≠ 0) (hy : y ≠ 0) + (h : ∀ j, x ∈ F j ↔ y ∈ F j) : hF.firstExcluded hx = hF.firstExcluded hy := by + refine le_antisymm ?_ ?_ + · exact hF.firstExcluded_le hx fun hmem ↦ + hF.not_mem_firstExcluded hy ((h _).mp hmem) + · exact hF.firstExcluded_le hy fun hmem ↦ + hF.not_mem_firstExcluded hx ((h _).mpr hmem) + +theorem value_neg (x : R) : hF.value (-x) = hF.value x := by + by_cases hx : x = 0 + · subst hx + rw [neg_zero] + · have hnx : -x ≠ 0 := neg_ne_zero.mpr hx + rw [hF.value_of_ne_zero hnx, hF.value_of_ne_zero hx] + have hfirst : hF.firstExcluded hnx = hF.firstExcluded hx := + hF.firstExcluded_congr hnx hx fun j ↦ + ⟨fun hmem ↦ by simpa using (F j).neg_mem hmem, fun hmem ↦ (F j).neg_mem hmem⟩ + rw [index, index, hfirst] + +/-- The ultrametric inequality, from additivity of each stage. -/ +theorem value_add_le_max (x y : R) : + hF.value (x + y) ≤ max (hF.value x) (hF.value y) := by + by_cases hx : x = 0 + · subst hx + rw [zero_add, hF.value_zero] + exact le_max_right _ _ + by_cases hy : y = 0 + · subst hy + rw [add_zero, hF.value_zero] + exact le_max_left _ _ + rcases le_total (hF.index hx) (hF.index hy) with hab | hab + · have hmax : max (hF.value x) (hF.value y) = + ((OrderDual.toDual (hF.index hx) : OrderDual ℕ) : WithBot (OrderDual ℕ)) := by + rw [hF.value_of_ne_zero hx, hF.value_of_ne_zero hy] + exact max_eq_left (by simpa using hab) + rw [hmax, hF.value_le_toDual_iff] + exact Submodule.add_mem _ ((hF.mem_iff_le_index hx _).mpr le_rfl) + ((hF.mem_iff_le_index hy _).mpr hab) + · have hmax : max (hF.value x) (hF.value y) = + ((OrderDual.toDual (hF.index hy) : OrderDual ℕ) : WithBot (OrderDual ℕ)) := by + rw [hF.value_of_ne_zero hx, hF.value_of_ne_zero hy] + exact max_eq_right (by simpa using hab) + rw [hmax, hF.value_le_toDual_iff] + exact Submodule.add_mem _ ((hF.mem_iff_le_index hx _).mpr hab) + ((hF.mem_iff_le_index hy _).mpr le_rfl) + +/-- Subadditivity under multiplication, from the multiplicativity hypothesis. -/ +theorem value_mul_le_add (x y : R) : + hF.value (x * y) ≤ hF.value x + hF.value y := by + by_cases hx : x = 0 + · subst hx + rw [zero_mul, hF.value_zero] + exact bot_le + by_cases hy : y = 0 + · subst hy + rw [mul_zero, hF.value_zero] + exact bot_le + have hrhs : hF.value x + hF.value y = + ((OrderDual.toDual (hF.index hx + hF.index hy) : OrderDual ℕ) : + WithBot (OrderDual ℕ)) := by + rw [hF.value_of_ne_zero hx, hF.value_of_ne_zero hy, ← WithBot.coe_add] + rfl + rw [hrhs, hF.value_le_toDual_iff] + exact hF.mul_le _ _ (Ideal.mul_mem_mul ((hF.mem_iff_le_index hx _).mpr le_rfl) + ((hF.mem_iff_le_index hy _).mpr le_rfl)) + +theorem value_lt_toDual_iff (x : R) (j : ℕ) : + hF.value x < ((OrderDual.toDual j : OrderDual ℕ) : WithBot (OrderDual ℕ)) ↔ + x ∈ F (j + 1) := by + by_cases hx : x = 0 + · subst hx + simp only [hF.value_zero, bot_lt_iff_ne_bot, ne_eq, WithBot.coe_ne_bot, + not_false_eq_true, true_iff] + exact Submodule.zero_mem _ + · rw [hF.value_of_ne_zero hx, WithBot.coe_lt_coe, hF.mem_iff_le_index hx] + constructor + · intro hlt + exact Nat.succ_le_of_lt (OrderDual.toDual_lt_toDual.mp hlt) + · intro hle + exact OrderDual.toDual_lt_toDual.mpr (Nat.lt_of_succ_le hle) + +/-- The max-additive degree attached to a separated multiplicative filtration. -/ +def degree : MaxAddDegree R (OrderDual ℕ) where + toFun := hF.value + map_zero' := hF.value_zero + map_one_le_zero' := by + change hF.value 1 ≤ ((OrderDual.toDual 0 : OrderDual ℕ) : WithBot (OrderDual ℕ)) + rw [hF.value_le_toDual_iff, hF.top] + trivial + map_neg' := hF.value_neg + map_add_le_max' := hF.value_add_le_max + map_mul_le_add' := hF.value_mul_le_add + +@[simp] +theorem degree_apply (x : R) : hF.degree x = hF.value x := (rfl) + +/-- The attached degree is separated. -/ +theorem degree_isSeparated : (hF.degree).IsSeparated := + (MaxAddDegree.isSeparated_iff hF.degree).mpr fun x ↦ hF.value_eq_bot_iff x + +/-- A ring with a separated multiplicative filtration and domain associated graded ring is a +domain. + +The proof does not use `MaxAddDegree.quotient_isDomain_of_associatedGraded_isDomain`, whose +`[WellFoundedLT M]` hypothesis fails for `M = ℕᵒᵈ`. Instead it obtains multiplicativity of the +attached degree directly from the domain associated graded ring. -/ +theorem isDomain_of_associatedGraded_isDomain + [IsDomain (hF.degree).AssociatedGraded] : IsDomain R := by + have : Nontrivial R := (hF.degree).nontrivial_of_associatedGraded_isDomain + have : (hF.degree).IsMultiplicative := + (hF.degree).isMultiplicative_of_associatedGraded_isDomain hF.degree_isSeparated + exact (hF.degree).isDomain hF.degree_isSeparated + +/-- The degree's weak filtration at dual index `j` is the stage `F j`. -/ +theorem mem_degree_filtrationLE_iff (j : ℕ) (x : R) : + x ∈ (hF.degree).filtrationLE (OrderDual.toDual j) ↔ x ∈ F j := by + rw [MaxAddDegree.mem_filtrationLE_iff] + exact hF.value_le_toDual_iff x j + +/-- The degree's strict filtration at dual index `j` is the stage `F (j+1)`. -/ +theorem mem_degree_lowerFiltration_iff (j : ℕ) + (x : (hF.degree).filtrationLE (OrderDual.toDual j)) : + x ∈ (hF.degree).lowerFiltration (OrderDual.toDual j) ↔ (x : R) ∈ F (j + 1) := by + rw [MaxAddDegree.mem_lowerFiltration_iff] + exact hF.value_lt_toDual_iff (x : R) j + +end IsSeparatedFiltration diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/MaxAddDegree.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/MaxAddDegree.lean new file mode 100644 index 0000000000..50f50425f1 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/MaxAddDegree.lean @@ -0,0 +1,210 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import Mathlib.Algebra.Order.Monoid.Unbundled.WithTop +public import Mathlib.Algebra.Order.Monoid.Defs +public import Mathlib.Algebra.BigOperators.Group.Finset.Basic +public import Mathlib.Algebra.Ring.Basic + +/-! +# Max-additive degree functions + +A `MaxAddDegree` records the properties of a unital ring filtration written in LM24's additive +convention: bottom at zero, degree at most zero for one, invariance under negation, the +ultrametric inequality with `max` for addition, and subadditivity under multiplication. + +Multiplication need not preserve the degree exactly. This is necessary for quotient filtrations: +the degree of a nonzero quotient class is the least degree of a representative, and +multiplication of least-degree representatives gives only an inequality until an +associated-graded argument proves equality. The exact case is the class `IsMultiplicative`; a +multiplicative degree is a multiplicative semi-valuation in the sense of LM24, Section 4, and a +separated one is a multiplicative valuation. LM24's bespoke convention `-∞ < -∞` is not used; +the bottom value is treated by the standard order on `WithBot`. +-/ + +universe u v + +public noncomputable section + +open scoped BigOperators + +/-- A ring degree function with bottom at zero, `max` for addition, and subadditivity under +multiplication. -/ +structure MaxAddDegree (R : Type u) (M : Type v) [CommRing R] [AddCommMonoid M] + [LinearOrder M] where + /-- The underlying degree function, with bottom as the value of zero. -/ + toFun : R → WithBot M + map_zero' : toFun 0 = ⊥ + map_one_le_zero' : toFun 1 ≤ 0 + map_neg' : ∀ x, toFun (-x) = toFun x + map_add_le_max' : ∀ x y, toFun (x + y) ≤ max (toFun x) (toFun y) + map_mul_le_add' : ∀ x y, toFun (x * y) ≤ toFun x + toFun y + +namespace MaxAddDegree + +variable {R : Type u} {M : Type v} [CommRing R] [AddCommMonoid M] [LinearOrder M] + +instance : CoeFun (MaxAddDegree R M) (fun _ ↦ R → WithBot M) := + ⟨MaxAddDegree.toFun⟩ + +/-- Max-additive degrees are equal when their underlying functions are equal. -/ +@[ext] +theorem ext {ν δ : MaxAddDegree R M} (h : ∀ x, ν x = δ x) : ν = δ := by + have hf : ν.toFun = δ.toFun := funext h + cases ν with + | mk f hz ho hn ha hm => + cases δ with + | mk g gz go gn ga gm => + dsimp only [MaxAddDegree.toFun] at hf + subst g + rfl + +@[simp] +theorem map_zero (ν : MaxAddDegree R M) : ν 0 = ⊥ := + ν.map_zero' + +/-- The unit lies in filtration degree zero. -/ +theorem map_one_le_zero (ν : MaxAddDegree R M) : ν 1 ≤ 0 := + ν.map_one_le_zero' + +@[simp] +theorem map_neg (ν : MaxAddDegree R M) (x : R) : ν (-x) = ν x := + ν.map_neg' x + +theorem map_add_le_max (ν : MaxAddDegree R M) (x y : R) : + ν (x + y) ≤ max (ν x) (ν y) := + ν.map_add_le_max' x y + +/-- Subtraction satisfies the same ultrametric inequality as addition. -/ +theorem map_sub_le_max (ν : MaxAddDegree R M) (x y : R) : + ν (x - y) ≤ max (ν x) (ν y) := by + simpa [sub_eq_add_neg] using ν.map_add_le_max x (-y) + +theorem map_mul_le_add (ν : MaxAddDegree R M) (x y : R) : + ν (x * y) ≤ ν x + ν y := + ν.map_mul_le_add' x y + +/-- Two elements whose difference has degree strictly below the degree of one of them have the +same degree. -/ +theorem map_eq_of_map_sub_lt (ν : MaxAddDegree R M) {x y : R} (hxy : ν (x - y) < ν x) : + ν x = ν y := by + apply le_antisymm + · by_contra hyx + have hyx' : ν y < ν x := lt_of_not_ge hyx + have hle : ν x ≤ max (ν y) (ν (x - y)) := by + simpa only [add_sub_cancel] using ν.map_add_le_max y (x - y) + exact (not_lt_of_ge hle) (max_lt hyx' hxy) + · have hle : ν y ≤ max (ν x) (ν (x - y)) := by + simpa only [sub_sub_cancel] using ν.map_sub_le_max x (x - y) + simpa only [max_eq_left hxy.le] using hle + +/-- A finite sum has degree at most a common bound for the degrees of its summands. -/ +theorem map_sum_le_of_forall_le (ν : MaxAddDegree R M) {ι : Type*} + (s : Finset ι) (f : ι → R) (m : WithBot M) + (h : ∀ i ∈ s, ν (f i) ≤ m) : + ν (∑ i ∈ s, f i) ≤ m := by + classical + induction s using Finset.induction_on with + | empty => simp + | @insert i s hi ih => + rw [Finset.sum_insert hi] + exact (ν.map_add_le_max (f i) (∑ j ∈ s, f j)).trans + (max_le (h i (Finset.mem_insert_self i s)) + (ih fun j hj ↦ h j (Finset.mem_insert_of_mem hj))) + +/-- A finite sum has degree strictly below any bound above bottom that strictly bounds every +summand. -/ +theorem map_sum_lt_of_forall_lt (ν : MaxAddDegree R M) {ι : Type*} + (s : Finset ι) (f : ι → R) {m : WithBot M} (hm : ⊥ < m) + (h : ∀ i ∈ s, ν (f i) < m) : + ν (∑ i ∈ s, f i) < m := by + classical + induction s using Finset.induction_on with + | empty => simpa only [Finset.sum_empty, ν.map_zero] using hm + | @insert i s hi ih => + rw [Finset.sum_insert hi] + exact (ν.map_add_le_max (f i) (∑ j ∈ s, f j)).trans_lt + (max_lt (h i (Finset.mem_insert_self i s)) + (ih fun j hj ↦ h j (Finset.mem_insert_of_mem hj))) + +/-- A max-additive degree function is separated when only zero has bottom degree. -/ +def IsSeparated (ν : MaxAddDegree R M) : Prop := + ∀ x, ν x = ⊥ ↔ x = 0 + +/-- The defining condition for a separated max-additive degree function. -/ +theorem isSeparated_iff (ν : MaxAddDegree R M) : + ν.IsSeparated ↔ ∀ x, ν x = ⊥ ↔ x = 0 := + Iff.rfl + +/-- A separated degree sends every nonzero element to a nonbottom degree. -/ +theorem map_ne_bot_of_ne_zero (ν : MaxAddDegree R M) (hν : ν.IsSeparated) {x : R} + (hx : x ≠ 0) : ν x ≠ ⊥ := + fun h ↦ hx (((isSeparated_iff ν).mp hν x).mp h) + +/-- A max-additive degree function is multiplicative when its product inequality is always an +equality. This is the multiplicativity clause of LM24's multiplicative semi-valuations. -/ +class IsMultiplicative (ν : MaxAddDegree R M) : Prop where + map_mul : ∀ x y, ν (x * y) = ν x + ν y + +/-- The defining condition for a multiplicative max-additive degree function. -/ +theorem isMultiplicative_iff (ν : MaxAddDegree R M) : + ν.IsMultiplicative ↔ ∀ x y, ν (x * y) = ν x + ν y := + ⟨fun h ↦ h.map_mul, fun h ↦ ⟨h⟩⟩ + +/-- Multiplicativity with the degree explicit, as `Valuation.map_mul`. Inside `namespace +MaxAddDegree` this shadows the root `map_mul` for homomorphisms, which is then `_root_.map_mul`. -/ +@[simp] +theorem map_mul (ν : MaxAddDegree R M) [ν.IsMultiplicative] (x y : R) : + ν (x * y) = ν x + ν y := + IsMultiplicative.map_mul x y + +/-- Every degree sends the unit to bottom or to zero: `ν 1 ≤ ν 1 + ν 1` by submultiplicativity +and `ν 1 ≤ 0`. The bottom case is the degenerate degree that is bottom everywhere. -/ +theorem map_one_eq_bot_or_eq_zero (ν : MaxAddDegree R M) [IsOrderedCancelAddMonoid M] : + ν 1 = ⊥ ∨ ν 1 = 0 := by + by_cases hbot : ν 1 = ⊥ + · exact Or.inl hbot + obtain ⟨m, hm⟩ := WithBot.ne_bot_iff_exists.mp hbot + have hone := ν.map_mul_le_add 1 1 + rw [one_mul, ← hm, ← WithBot.coe_add, WithBot.coe_le_coe] at hone + have hle : m ≤ 0 := WithBot.coe_le_coe.mp (hm ▸ ν.map_one_le_zero) + have hge : 0 ≤ m := le_of_add_le_add_left (a := m) (by simpa using hone) + exact Or.inr (by rw [← hm, le_antisymm hle hge]; rfl) + +/-- A separated degree on a nontrivial ring sends the unit to degree zero. -/ +theorem map_one_eq_zero_of_isSeparated (ν : MaxAddDegree R M) + [IsOrderedCancelAddMonoid M] [Nontrivial R] (hν : ν.IsSeparated) : + ν 1 = 0 := by + rcases ν.map_one_eq_bot_or_eq_zero with hbot | hzero + · exact absurd (((ν.isSeparated_iff).mp hν 1).mp hbot) one_ne_zero + · exact hzero + +/-- If a degree sends the unit to bottom, it is bottom everywhere: `ν x ≤ ν x + ν 1`. -/ +theorem map_eq_bot_of_map_one_eq_bot (ν : MaxAddDegree R M) (hone : ν 1 = ⊥) (x : R) : + ν x = ⊥ := + le_bot_iff.mp (by simpa [hone] using ν.map_mul_le_add x 1) + +/-- A separated multiplicative degree function detects zero products. -/ +theorem eq_zero_or_eq_zero_of_mul_eq_zero (ν : MaxAddDegree R M) [ν.IsMultiplicative] + (hν : ν.IsSeparated) {x y : R} (hxy : x * y = 0) : + x = 0 ∨ y = 0 := by + have hbot : ν x + ν y = ⊥ := by + rw [← ν.map_mul x y, hxy, ν.map_zero] + rcases WithBot.add_eq_bot.mp hbot with hx | hy + · exact Or.inl (((isSeparated_iff ν).mp hν x).mp hx) + · exact Or.inr (((isSeparated_iff ν).mp hν y).mp hy) + +/-- A nontrivial commutative ring carrying a separated multiplicative degree function is a +domain. -/ +theorem isDomain (ν : MaxAddDegree R M) [Nontrivial R] [ν.IsMultiplicative] + (hν : ν.IsSeparated) : + IsDomain R := by + let : NoZeroDivisors R := + ⟨fun hxy ↦ ν.eq_zero_or_eq_zero_of_mul_eq_zero hν hxy⟩ + exact NoZeroDivisors.to_isDomain R + +end MaxAddDegree diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/OfValuation.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/OfValuation.lean new file mode 100644 index 0000000000..a9ccc7f859 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/OfValuation.lean @@ -0,0 +1,67 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.MaxAddDegree +public import Mathlib.Algebra.Order.Monoid.ToMulBot +public import Mathlib.RingTheory.Valuation.Basic + +/-! +# Mathlib valuations as max-additive degrees + +A Mathlib `Valuation` with values in `WithZero (Multiplicative M)` is a multiplicative max-additive +degree once its values are read additively, with bottom in place of the absorbing zero. This +reading turns Mathlib's multiplicative convention into LM24's additive one, and makes Mathlib's +stock of valuations available as examples and as a comparison point. Separation of the degree is +triviality of the valuation's support ideal; a nonzero support is allowed, exactly as LM24 allows +a nonzero kernel for its semi-valuations. +-/ + +universe u v + +public noncomputable section + +namespace MaxAddDegree + +variable {R : Type u} {M : Type v} [CommRing R] [AddCommMonoid M] + [LinearOrder M] [IsOrderedCancelAddMonoid M] + +/-- The max-additive degree of a Mathlib valuation: its value, written additively with bottom +at the support. -/ +def ofValuation (w : Valuation R (WithZero (Multiplicative M))) : MaxAddDegree R M where + toFun x := Multiplicative.toAdd (WithZero.toMulBot (w x)) + map_zero' := by simp + map_one_le_zero' := by simp + map_neg' x := by simp [w.map_neg] + map_add_le_max' x y := w.map_add x y + map_mul_le_add' x y := by simp [w.map_mul] + +theorem ofValuation_apply (w : Valuation R (WithZero (Multiplicative M))) (x : R) : + ofValuation w x = Multiplicative.toAdd (WithZero.toMulBot (w x)) := + (rfl) + +instance (w : Valuation R (WithZero (Multiplicative M))) : (ofValuation w).IsMultiplicative := + ⟨fun x y ↦ by simp [ofValuation_apply, w.map_mul]⟩ + +@[simp] +theorem ofValuation_one (w : Valuation R (WithZero (Multiplicative M))) : + ofValuation w 1 = 0 := by + simp [ofValuation_apply] + +@[simp] +theorem ofValuation_eq_bot_iff_mem_supp (w : Valuation R (WithZero (Multiplicative M))) + (x : R) : + ofValuation w x = ⊥ ↔ x ∈ w.supp := by + rw [Valuation.mem_supp_iff] + rfl + +/-- The degree of a Mathlib valuation is separated exactly when the support ideal is zero. -/ +theorem isSeparated_ofValuation_iff (w : Valuation R (WithZero (Multiplicative M))) : + (ofValuation w).IsSeparated ↔ w.supp = ⊥ := by + rw [isSeparated_iff, Ideal.ext_iff] + simp only [ofValuation_eq_bot_iff_mem_supp, Ideal.mem_bot] + +end MaxAddDegree diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/QuotientDegree.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/QuotientDegree.lean new file mode 100644 index 0000000000..a31b6cf899 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/QuotientDegree.lean @@ -0,0 +1,213 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.MaxAddDegree +public import Mathlib.RingTheory.Ideal.Quotient.Defs + +import Mathlib.Order.Minimal + +/-! +# Least-representative degree on a quotient ring + +Let a commutative ring carry a separated max-additive degree whose value index is well ordered. +The degree of a nonzero class modulo an ideal is defined to be the least degree among all its +representatives, while the zero class has bottom degree. This realizes the quotient-degree +construction for filtered quotient rings. + +The resulting quotient degree is separated and satisfies the ultrametric addition inequality and +the submultiplicative product inequality. Equality for products is a later associated-graded +consequence and is deliberately not asserted here. +-/ + +universe u v + +public noncomputable section + +namespace MaxAddDegree + +variable {R : Type u} {M : Type v} [CommRing R] [AddCommMonoid M] [LinearOrder M] + +/-- The grades attained by representatives of a quotient class. -/ +def representativeGrades (ν : MaxAddDegree R M) (I : Ideal R) (q : R ⧸ I) : Set M := + {m | ∃ x : R, Ideal.Quotient.mk I x = q ∧ ν x = m} + +/-- Membership in the set of grades attained by representatives of a quotient class. -/ +theorem mem_representativeGrades_iff (ν : MaxAddDegree R M) (I : Ideal R) + (q : R ⧸ I) (m : M) : + m ∈ ν.representativeGrades I q ↔ + ∃ x : R, Ideal.Quotient.mk I x = q ∧ ν x = m := + Iff.rfl + +theorem representativeGrades_nonempty (ν : MaxAddDegree R M) (I : Ideal R) + (hν : ν.IsSeparated) {q : R ⧸ I} (hq : q ≠ 0) : + (ν.representativeGrades I q).Nonempty := by + obtain ⟨x, rfl⟩ := Ideal.Quotient.mk_surjective q + have hx : x ≠ 0 := by + intro hx + apply hq + simp [hx] + have hνx : ν x ≠ ⊥ := ν.map_ne_bot_of_ne_zero hν hx + refine ⟨(ν x).unbot hνx, x, rfl, ?_⟩ + exact (WithBot.coe_unbot (ν x) hνx).symm + +variable [WellFoundedLT M] + +/-- The least degree of a representative of a quotient class, with bottom assigned to zero. -/ +def quotientValue (ν : MaxAddDegree R M) (I : Ideal R) (hν : ν.IsSeparated) + (q : R ⧸ I) : WithBot M := by + classical + exact if hq : q = 0 then ⊥ + else (wellFounded_lt.min (ν.representativeGrades I q) + (ν.representativeGrades_nonempty I hν hq) : M) + +@[simp] +theorem quotientValue_zero (ν : MaxAddDegree R M) (I : Ideal R) (hν : ν.IsSeparated) : + ν.quotientValue I hν 0 = ⊥ := by + simp [quotientValue] + +theorem quotientValue_eq_coe_min (ν : MaxAddDegree R M) (I : Ideal R) + (hν : ν.IsSeparated) {q : R ⧸ I} (hq : q ≠ 0) : + ν.quotientValue I hν q = + (wellFounded_lt.min (ν.representativeGrades I q) + (ν.representativeGrades_nonempty I hν hq) : M) := by + simp [quotientValue, hq] + +@[simp] +theorem quotientValue_eq_bot_iff (ν : MaxAddDegree R M) (I : Ideal R) + (hν : ν.IsSeparated) (q : R ⧸ I) : + ν.quotientValue I hν q = ⊥ ↔ q = 0 := by + by_cases hq : q = 0 + · simp [hq] + · rw [ν.quotientValue_eq_coe_min I hν hq] + simp [hq] + +/-- Every nonzero quotient class has a representative whose degree is its quotient degree. -/ +theorem exists_representative_quotientValue_eq (ν : MaxAddDegree R M) (I : Ideal R) + (hν : ν.IsSeparated) {q : R ⧸ I} (hq : q ≠ 0) : + ∃ x : R, Ideal.Quotient.mk I x = q ∧ ν x = ν.quotientValue I hν q := by + have hmem := wellFounded_lt.min_mem (ν.representativeGrades I q) + (ν.representativeGrades_nonempty I hν hq) + obtain ⟨x, hxq, hxν⟩ := hmem + refine ⟨x, hxq, ?_⟩ + rw [ν.quotientValue_eq_coe_min I hν hq] + exact hxν + +/-- The quotient degree is at most the degree of every representative. -/ +theorem quotientValue_mk_le (ν : MaxAddDegree R M) (I : Ideal R) + (hν : ν.IsSeparated) (x : R) : + ν.quotientValue I hν (Ideal.Quotient.mk I x) ≤ ν x := by + by_cases hq : Ideal.Quotient.mk I x = 0 + · rw [hq, ν.quotientValue_zero] + exact bot_le + · have hx : x ≠ 0 := by + intro hx + apply hq + simp [hx] + have hνx : ν x ≠ ⊥ := by + intro hbot + exact hx (((isSeparated_iff ν).mp hν x).mp hbot) + have hmem : (ν x).unbot hνx ∈ + ν.representativeGrades I (Ideal.Quotient.mk I x) := by + refine ⟨x, rfl, ?_⟩ + exact (WithBot.coe_unbot (ν x) hνx).symm + rw [ν.quotientValue_eq_coe_min I hν hq, ← WithBot.coe_unbot (ν x) hνx, + WithBot.coe_le_coe] + exact WellFoundedLT.min_le hmem + +/-- The unit of the quotient has degree at most zero. -/ +theorem quotientValue_one_le_zero (ν : MaxAddDegree R M) (I : Ideal R) + (hν : ν.IsSeparated) : + ν.quotientValue I hν 1 ≤ 0 := by + calc + ν.quotientValue I hν 1 = + ν.quotientValue I hν (Ideal.Quotient.mk I 1) := by rw [map_one] + _ ≤ ν 1 := ν.quotientValue_mk_le I hν 1 + _ ≤ 0 := ν.map_one_le_zero + +@[simp] +theorem quotientValue_neg (ν : MaxAddDegree R M) (I : Ideal R) + (hν : ν.IsSeparated) (q : R ⧸ I) : + ν.quotientValue I hν (-q) = ν.quotientValue I hν q := by + by_cases hq : q = 0 + · simp [hq] + · obtain ⟨x, hxq, hxν⟩ := ν.exists_representative_quotientValue_eq I hν hq + have hle : ν.quotientValue I hν (-q) ≤ ν.quotientValue I hν q := by + rw [← hxν, ← map_neg, ← hxq] + exact ν.quotientValue_mk_le I hν (-x) + have hnq : -q ≠ 0 := neg_ne_zero.mpr hq + obtain ⟨y, hyq, hyν⟩ := ν.exists_representative_quotientValue_eq I hν hnq + have hge : ν.quotientValue I hν q ≤ ν.quotientValue I hν (-q) := by + rw [← hyν, ← map_neg, ← neg_neg q, ← hyq] + exact ν.quotientValue_mk_le I hν (-y) + exact le_antisymm hle hge + +theorem quotientValue_add_le_max (ν : MaxAddDegree R M) (I : Ideal R) + (hν : ν.IsSeparated) (q r : R ⧸ I) : + ν.quotientValue I hν (q + r) ≤ + max (ν.quotientValue I hν q) (ν.quotientValue I hν r) := by + by_cases hq : q = 0 + · simp [hq] + by_cases hr : r = 0 + · simp [hr] + obtain ⟨x, hxq, hxν⟩ := ν.exists_representative_quotientValue_eq I hν hq + obtain ⟨y, hyr, hyν⟩ := ν.exists_representative_quotientValue_eq I hν hr + calc + ν.quotientValue I hν (q + r) = + ν.quotientValue I hν (Ideal.Quotient.mk I (x + y)) := by rw [map_add, hxq, hyr] + _ ≤ ν (x + y) := ν.quotientValue_mk_le I hν (x + y) + _ ≤ max (ν x) (ν y) := ν.map_add_le_max x y + _ = max (ν.quotientValue I hν q) (ν.quotientValue I hν r) := by rw [hxν, hyν] + +theorem quotientValue_mul_le_add (ν : MaxAddDegree R M) (I : Ideal R) + (hν : ν.IsSeparated) (q r : R ⧸ I) : + ν.quotientValue I hν (q * r) ≤ + ν.quotientValue I hν q + ν.quotientValue I hν r := by + by_cases hq : q = 0 + · simp [hq] + by_cases hr : r = 0 + · simp [hr] + obtain ⟨x, hxq, hxν⟩ := ν.exists_representative_quotientValue_eq I hν hq + obtain ⟨y, hyr, hyν⟩ := ν.exists_representative_quotientValue_eq I hν hr + calc + ν.quotientValue I hν (q * r) = + ν.quotientValue I hν (Ideal.Quotient.mk I (x * y)) := by rw [_root_.map_mul, hxq, hyr] + _ ≤ ν (x * y) := ν.quotientValue_mk_le I hν (x * y) + _ ≤ ν x + ν y := ν.map_mul_le_add x y + _ = ν.quotientValue I hν q + ν.quotientValue I hν r := by rw [hxν, hyν] + +/-- The quotient degree obtained by minimizing the degree among all representatives. -/ +def quotient (ν : MaxAddDegree R M) (I : Ideal R) (hν : ν.IsSeparated) : + MaxAddDegree (R ⧸ I) M where + toFun := ν.quotientValue I hν + map_zero' := ν.quotientValue_zero I hν + map_one_le_zero' := ν.quotientValue_one_le_zero I hν + map_neg' := ν.quotientValue_neg I hν + map_add_le_max' := ν.quotientValue_add_le_max I hν + map_mul_le_add' := ν.quotientValue_mul_le_add I hν + +@[simp] +theorem quotient_apply (ν : MaxAddDegree R M) (I : Ideal R) + (hν : ν.IsSeparated) (q : R ⧸ I) : + ν.quotient I hν q = ν.quotientValue I hν q := (rfl) + +/-- The least-representative degree on a quotient ring is separated. -/ +theorem quotient_isSeparated (ν : MaxAddDegree R M) (I : Ideal R) + (hν : ν.IsSeparated) : + (ν.quotient I hν).IsSeparated := by + rw [isSeparated_iff] + intro q + rw [ν.quotient_apply I hν] + exact ν.quotientValue_eq_bot_iff I hν q + +/-- If the least-representative quotient degree is multiplicative, then the quotient is a +domain. -/ +theorem quotient_isDomain (ν : MaxAddDegree R M) (I : Ideal R) + (hν : ν.IsSeparated) [Nontrivial (R ⧸ I)] [(ν.quotient I hν).IsMultiplicative] : + IsDomain (R ⧸ I) := + (ν.quotient I hν).isDomain (ν.quotient_isSeparated I hν) + +end MaxAddDegree diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/RV.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/RV.lean new file mode 100644 index 0000000000..cde11fb4fd --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/RV.lean @@ -0,0 +1,400 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.DegreeInitialForm +public import Mathlib.GroupTheory.Congruence.Hom + +/-! +# RV classes and initial forms + +For a max-additive degree `ν`, two representatives are RV-equivalent when both have bottom +degree, or when their difference has degree strictly below their common nonbottom degree; the +multiplicative structure of RV needs `ν` multiplicative. +Thus the entire kernel of the degree, rather than only the literal zero element, forms the zero +RV class. + +The resulting quotient is a commutative monoid with zero. Its degree is well defined, and the +initial-form map embeds it into the associated graded ring as zero together with the homogeneous +classes. The grade-zero component carries Mathlib's canonical direct-sum grade-zero ring structure +and is exposed as the residue ring. + +LM24 uses the bespoke convention `-∞ < -∞`. Lean's strict order on `WithBot` does not, so the +explicit bottom branch is the standard-order encoding of LM24, Definition 4.1.1. It collapses the +kernel to one class and makes the relation reflexive on its nonzero elements. The degree axioms +also supply `w(0) = -∞`, which is not implied by the two generic semi-valuation equations +displayed in LM24. +-/ +universe u v + +public noncomputable section + +namespace MaxAddDegree + +open scoped DirectSum + +variable {R : Type u} {M : Type v} [CommRing R] [AddCommMonoid M] [LinearOrder M] + +/-- Two representatives define the same RV class. -/ +def RVRel (ν : MaxAddDegree R M) (x y : R) : Prop := + (ν x = ⊥ ∧ ν y = ⊥) ∨ + (ν x ≠ ⊥ ∧ ν (x - y) < ν x) + +@[simp] +theorem rvRel_iff (ν : MaxAddDegree R M) (x y : R) : + ν.RVRel x y ↔ + (ν x = ⊥ ∧ ν y = ⊥) ∨ + (ν x ≠ ⊥ ∧ ν (x - y) < ν x) := + Iff.rfl + +theorem rvRel_degree_eq {ν : MaxAddDegree R M} {x y : R} (h : ν.RVRel x y) : + ν x = ν y := by + rcases h with hbot | ⟨-, hxy⟩ + · exact hbot.1.trans hbot.2.symm + · exact ν.map_eq_of_map_sub_lt hxy + +theorem rvRel_refl (ν : MaxAddDegree R M) (x : R) : ν.RVRel x x := by + by_cases hx : ν x = ⊥ + · exact Or.inl ⟨hx, hx⟩ + · exact Or.inr ⟨hx, by simpa using WithBot.bot_lt_iff_ne_bot.mpr hx⟩ + +theorem rvRel_symm {ν : MaxAddDegree R M} {x y : R} (h : ν.RVRel x y) : + ν.RVRel y x := by + rcases h with hbot | ⟨hx, hxy⟩ + · exact Or.inl hbot.symm + · refine Or.inr ⟨?_, ?_⟩ + · simpa only [← rvRel_degree_eq (Or.inr ⟨hx, hxy⟩)] using hx + · rw [← rvRel_degree_eq (Or.inr ⟨hx, hxy⟩)] + rw [← neg_sub] + simpa only [ν.map_neg] using hxy + +theorem rvRel_trans {ν : MaxAddDegree R M} {x y z : R} + (hxy : ν.RVRel x y) (hyz : ν.RVRel y z) : ν.RVRel x z := by + have hxyDegree := rvRel_degree_eq hxy + have hyzDegree := rvRel_degree_eq hyz + by_cases hx : ν x = ⊥ + · refine Or.inl ⟨hx, ?_⟩ + exact hyzDegree.symm.trans (hxyDegree.symm.trans hx) + · refine Or.inr ⟨hx, ?_⟩ + have hxyLt : ν (x - y) < ν x := by + rcases hxy with hbot | h + · exact (hx hbot.1).elim + · exact h.2 + have hyzLt : ν (y - z) < ν x := by + rcases hyz with hbot | h + · exact (hx (hxyDegree.trans hbot.1)).elim + · simpa only [hxyDegree] using h.2 + have hle := ν.map_add_le_max (x - y) (y - z) + rw [sub_add_sub_cancel] at hle + exact hle.trans_lt (max_lt hxyLt hyzLt) + +variable [IsOrderedCancelAddMonoid M] + +section Graded + +variable (ν : MaxAddDegree R M) + +/-- The multiplicative submonoid consisting of zero and all homogeneous graded classes. -/ +def homogeneousClasses : Submonoid ν.AssociatedGraded where + carrier := {a | a = 0 ∨ ∃ m, ∃ c : ν.Component m, a = DirectSum.of ν.Component m c} + one_mem' := Or.inr ⟨0, ν.componentOne, (DirectSum.one_def ν.Component).symm⟩ + mul_mem' {a b} ha hb := by + rcases ha with rfl | ⟨m, c, rfl⟩ + · exact Or.inl (zero_mul _) + rcases hb with rfl | ⟨n, d, rfl⟩ + · exact Or.inl (mul_zero _) + · refine Or.inr ⟨m + n, ν.componentMul c d, ?_⟩ + exact DirectSum.of_mul_of c d + +theorem mem_homogeneousClasses_iff (a : ν.AssociatedGraded) : + a ∈ ν.homogeneousClasses ↔ + a = 0 ∨ ∃ m, ∃ c : ν.Component m, a = DirectSum.of ν.Component m c := + Iff.rfl + +/-- Zero and the homogeneous classes, as a commutative monoid with zero. -/ +abbrev HomogeneousClasses := + ν.homogeneousClasses + +instance : Zero ν.HomogeneousClasses := + ⟨⟨0, (ν.mem_homogeneousClasses_iff 0).mpr (Or.inl rfl)⟩⟩ + +instance : CommMonoidWithZero ν.HomogeneousClasses where + zero_mul q := Subtype.ext (zero_mul (q : ν.AssociatedGraded)) + mul_zero q := Subtype.ext (mul_zero (q : ν.AssociatedGraded)) + +theorem initialForm_mem_homogeneousClasses (x : R) : + ν.initialForm x ∈ ν.homogeneousClasses := by + rw [ν.mem_homogeneousClasses_iff] + by_cases hx : ν x = ⊥ + · exact Or.inl (ν.initialForm_eq_zero_of_eq_bot hx) + · refine Or.inr ⟨(ν x).unbot hx, + ν.componentMk _ (ν.initialRepresentative x hx), ?_⟩ + rw [ν.initialForm_eq_homogeneousMk_of_ne_bot hx, ν.homogeneousMk_apply] + +/-- The residue ring, namely the grade-zero homogeneous quotient. -/ +abbrev ResidueRing := + ν.Component 0 + +/-- The canonical embedding of the residue ring into the associated graded ring. -/ +def residueRingHom : ν.ResidueRing →+* ν.AssociatedGraded := + DirectSum.ofZeroRingHom ν.Component + +@[simp] +theorem residueRingHom_apply (c : ν.ResidueRing) : + ν.residueRingHom c = DirectSum.of ν.Component 0 c := (rfl) + +theorem residueRingHom_injective : + Function.Injective ν.residueRingHom := + DirectSum.of_injective 0 + +/-- RV-equivalent representatives have the same initial form. -/ +theorem initialForm_eq_of_rvRel {x y : R} (h : ν.RVRel x y) : + ν.initialForm x = ν.initialForm y := by + rcases h with hbot | ⟨-, hxy⟩ + · rw [ν.initialForm_eq_zero_of_eq_bot hbot.1, ν.initialForm_eq_zero_of_eq_bot hbot.2] + · exact ν.initialForm_eq_of_sub_lt hxy + +end Graded + +/-- The RV relation is compatible with multiplication for a multiplicative degree. -/ +theorem rvRel_mul_left {ν : MaxAddDegree R M} [ν.IsMultiplicative] {x y : R} (z : R) + (h : ν.RVRel x y) : ν.RVRel (z * x) (z * y) := by + by_cases hz : ν z = ⊥ + · exact Or.inl ⟨by simp [hz], by simp [hz]⟩ + rcases h with hbot | ⟨hx, hxy⟩ + · exact Or.inl ⟨by simp [hbot.1], by simp [hbot.2]⟩ + · refine Or.inr ⟨?_, ?_⟩ + · rw [ν.map_mul, WithBot.add_ne_bot] + exact ⟨hz, hx⟩ + · rw [← mul_sub, ν.map_mul, ν.map_mul] + exact WithBot.add_lt_add_of_le_of_lt hz le_rfl hxy + +variable (ν : MaxAddDegree R M) [ν.IsMultiplicative] + +/-- The multiplicative congruence whose quotient is the RV monoid. -/ +def rvCon : Con R where + r := ν.RVRel + iseqv := ⟨ν.rvRel_refl, rvRel_symm, rvRel_trans⟩ + mul' {x y z t} hxy hzt := by + have hxy' : ν.RVRel (x * z) (y * z) := by + simpa only [mul_comm] using ν.rvRel_mul_left z hxy + exact rvRel_trans hxy' (ν.rvRel_mul_left y hzt) + +/-- The RV quotient attached to a multiplicative max-additive degree. -/ +abbrev RV := ν.rvCon.Quotient + +/-- The quotient map to RV classes. -/ +def rv : R →* ν.RV := + ν.rvCon.mk' + +/-- Every RV class has a representative in the original ring. -/ +theorem rv_surjective : Function.Surjective ν.rv := by + exact ν.rvCon.mk'_surjective + +@[simp] +theorem rv_eq_iff {x y : R} : + ν.rv x = ν.rv y ↔ ν.RVRel x y := by + exact ν.rvCon.eq + +/-- For a representative of nonbottom degree, RV equality is exactly strict decrease of the +degree of the difference. -/ +theorem rv_eq_iff_of_value_ne_bot {x y : R} (hx : ν x ≠ ⊥) : + ν.rv x = ν.rv y ↔ ν (x - y) < ν x := by + rw [ν.rv_eq_iff, ν.rvRel_iff] + constructor + · rintro (⟨hxBot, -⟩ | ⟨-, hxy⟩) + · exact (hx hxBot).elim + · exact hxy + · exact fun hxy ↦ Or.inr ⟨hx, hxy⟩ + +/-- The common RV class of the kernel of the degree. -/ +instance : Zero ν.RV := + ⟨ν.rv 0⟩ + +@[simp] +theorem rv_zero : ν.rv 0 = 0 := + rfl + +@[simp] +theorem rv_eq_zero_iff {x : R} : + ν.rv x = 0 ↔ ν x = ⊥ := by + rw [← ν.rv_zero, ν.rv_eq_iff] + constructor + · rintro (⟨hx, -⟩ | ⟨-, hlt⟩) + · exact hx + · have : ν x < ν x := by simpa only [sub_zero] using hlt + exact (lt_irrefl _ this).elim + · intro hx + exact Or.inl ⟨hx, ν.map_zero⟩ + +instance : CommMonoidWithZero ν.RV where + zero_mul q := by + induction q using Con.induction_on with + | _ x => + change ν.rv 0 * ν.rv x = ν.rv 0 + rw [← _root_.map_mul, zero_mul] + mul_zero q := by + induction q using Con.induction_on with + | _ x => + change ν.rv x * ν.rv 0 = ν.rv 0 + rw [← _root_.map_mul, mul_zero] + +/-- The degree of an RV class. -/ +def rvValue (q : ν.RV) : WithBot M := + Con.liftOn q ν fun _ _ h ↦ rvRel_degree_eq h + +@[simp] +theorem rvValue_rv (x : R) : + ν.rvValue (ν.rv x) = ν x := (rfl) + +@[simp] +theorem rvValue_zero : ν.rvValue 0 = ⊥ := by + rw [← ν.rv_zero, ν.rvValue_rv, ν.map_zero] + +/-- The degree of the RV class of one is the degree of one: zero, unless the degree is the +degenerate one that is bottom everywhere. -/ +@[simp] +theorem rvValue_one : ν.rvValue 1 = ν 1 := by + change ν.rvValue (ν.rv 1) = ν 1 + rw [ν.rvValue_rv] + +@[simp] +theorem rvValue_mul (q r : ν.RV) : + ν.rvValue (q * r) = ν.rvValue q + ν.rvValue r := by + induction q, r using Con.induction_on₂ with + | _ x y => + change ν (x * y) = ν x + ν y + exact ν.map_mul x y + +/-- The initial form, viewed as a function of the RV class. -/ +def rvInitialForm (q : ν.RV) : ν.AssociatedGraded := + Con.liftOn q ν.initialForm fun _ _ h ↦ ν.initialForm_eq_of_rvRel h + +@[simp] +theorem rvInitialForm_rv (x : R) : + ν.rvInitialForm (ν.rv x) = ν.initialForm x := (rfl) + +/-- The multiplicative map from RV classes to the associated graded ring, sending the class of +`x` to the initial form of `x`. -/ +def rvInitialFormHom : ν.RV →*₀ ν.AssociatedGraded where + toFun := ν.rvInitialForm + map_one' := by + change ν.initialForm 1 = 1 + exact ν.initialForm_one + map_mul' q r := by + induction q, r using Con.induction_on₂ with + | _ x y => + change ν.initialForm (x * y) = ν.initialForm x * ν.initialForm y + exact ν.initialForm_mul x y + map_zero' := by + change ν.initialForm 0 = 0 + exact ν.initialForm_zero + +@[simp] +theorem rvInitialFormHom_rv (x : R) : + ν.rvInitialFormHom (ν.rv x) = ν.initialForm x := (rfl) + +theorem rvInitialFormHom_injective : + Function.Injective ν.rvInitialFormHom := by + intro q r hqr + induction q, r using Con.induction_on₂ with + | _ x y => + change ν.rv x = ν.rv y + rw [ν.rv_eq_iff] + change ν.initialForm x = ν.initialForm y at hqr + by_cases hx : ν x = ⊥ + · have hy : ν y = ⊥ := by + by_contra hy + have hix := ν.initialForm_eq_zero_of_eq_bot hx + have hiy := ν.initialForm_ne_zero_of_ne_bot hy + exact hiy (hqr.symm.trans hix) + exact Or.inl ⟨hx, hy⟩ + · have hy : ν y ≠ ⊥ := by + intro hy + have hix := ν.initialForm_ne_zero_of_ne_bot hx + have hiy := ν.initialForm_eq_zero_of_eq_bot hy + exact hix (hqr.trans hiy) + rw [ν.initialForm_eq_homogeneousMk_of_ne_bot hx, + ν.initialForm_eq_homogeneousMk_of_ne_bot hy, + ν.homogeneousMk_apply, ν.homogeneousMk_apply] at hqr + rcases (DFinsupp.single_eq_single_iff _ _ _ _).mp hqr with hnonzero | hzero + · refine Or.inr ⟨hx, ?_⟩ + have hlt := ν.sub_lt_of_componentMk_heq hnonzero.1 + (ν.initialRepresentative x hx) (ν.initialRepresentative y hy) hnonzero.2 + simpa only [coe_initialRepresentative, WithBot.coe_unbot] using hlt + · have hlt := (ν.componentMk_eq_zero_iff _ _).mp hzero.1 + have : ν x < ν x := by + simpa only [coe_initialRepresentative, WithBot.coe_unbot] using hlt + exact (lt_irrefl _ this).elim + +/-- The RV class represented as zero or a nonzero homogeneous graded class. -/ +def rvHomogeneous : ν.RV →*₀ ν.HomogeneousClasses where + toFun q := ⟨ν.rvInitialFormHom q, by + induction q using Con.induction_on with + | _ x => exact ν.initialForm_mem_homogeneousClasses x⟩ + map_one' := Subtype.ext ν.rvInitialFormHom.map_one + map_mul' q r := Subtype.ext (ν.rvInitialFormHom.map_mul q r) + map_zero' := Subtype.ext ν.rvInitialFormHom.map_zero + +@[simp] +theorem coe_rvHomogeneous (q : ν.RV) : + (ν.rvHomogeneous q : ν.AssociatedGraded) = ν.rvInitialFormHom q := (rfl) + +theorem rvHomogeneous_injective : + Function.Injective ν.rvHomogeneous := by + intro q r h + apply ν.rvInitialFormHom_injective + exact congrArg Subtype.val h + +theorem rvHomogeneous_surjective : + Function.Surjective ν.rvHomogeneous := by + rintro ⟨a, ha⟩ + rw [ν.mem_homogeneousClasses_iff] at ha + rcases ha with rfl | ⟨m, c, rfl⟩ + · refine ⟨ν.rv 0, Subtype.ext ?_⟩ + change ν.initialForm 0 = 0 + exact ν.initialForm_zero + induction c using QuotientAddGroup.induction_on with + | H x => + by_cases hx : ν.componentMk m x = 0 + · refine ⟨ν.rv 0, Subtype.ext ?_⟩ + change ν.initialForm 0 = DirectSum.of ν.Component m (x : ν.Component m) + have hxc : (x : ν.Component m) = 0 := by + rw [ν.coe_component_eq_componentMk] + exact hx + rw [ν.initialForm_zero, hxc] + exact ((DirectSum.of ν.Component m).map_zero).symm + · refine ⟨ν.rv x, Subtype.ext ?_⟩ + rw [ν.coe_rvHomogeneous, ν.rvInitialFormHom_rv] + change ν.initialForm x = DirectSum.of ν.Component m (x : ν.Component m) + calc + ν.initialForm x = ν.homogeneousMk m x := + ν.initialForm_eq_homogeneousMk_of_componentMk_ne_zero m x hx + _ = DirectSum.of ν.Component m (ν.componentMk m x) := + ν.homogeneousMk_apply m x + _ = DirectSum.of ν.Component m (x : ν.Component m) := + congrArg (DirectSum.of ν.Component m) (ν.coe_component_eq_componentMk m x).symm + +/-- RV is multiplicatively equivalent to zero together with the nonzero homogeneous classes. -/ +def rvEquivHomogeneous : ν.RV ≃* ν.HomogeneousClasses := + MulEquiv.ofBijective ν.rvHomogeneous.toMonoidHom + ⟨ν.rvHomogeneous_injective, ν.rvHomogeneous_surjective⟩ + +@[simp] +theorem rvEquivHomogeneous_apply (q : ν.RV) : + ν.rvEquivHomogeneous q = ν.rvHomogeneous q := (rfl) + +theorem rvEquivHomogeneous_zero : + ν.rvEquivHomogeneous 0 = 0 := by + rw [ν.rvEquivHomogeneous_apply, ν.rvHomogeneous.map_zero] + +@[simp] +theorem rvEquivHomogeneous_symm_zero : + ν.rvEquivHomogeneous.symm 0 = 0 := by + apply ν.rvEquivHomogeneous.injective + rw [ν.rvEquivHomogeneous.apply_symm_apply, ν.rvEquivHomogeneous_zero] + +end MaxAddDegree diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/Residue.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/Residue.lean new file mode 100644 index 0000000000..ba0cc1b128 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/Residue.lean @@ -0,0 +1,180 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.RV +public import Mathlib.RingTheory.Ideal.Quotient.Basic +public import Mathlib.RingTheory.Ideal.Maps + +import Mathlib.RingTheory.Ideal.Quotient.Operations + +/-! +# The residue map + +For a max-additive degree, the elements of nonpositive degree form a subring. Those of strictly +negative degree form an ideal in that subring, and projection to the grade-zero component is a +surjective ring homomorphism with this ideal as its kernel. Consequently, the grade-zero component +is canonically isomorphic to the quotient by the strictly negative ideal. Submultiplicativity +suffices for all of this; multiplicativity enters only in the comparison with the RV class. + +This is the quotient presentation in LM24, Proposition 4.2.10. It also realizes the ring in +Corollary 4.2.8 as `MaxAddDegree.ResidueRing`. The module structure of Corollary 4.2.9 is the +grade-zero action `Module ν.ResidueRing (ν.Component m)` supplied by Mathlib's graded direct sums. +The quotient construction remains additive when two degree-zero representatives cancel to strictly +lower degree; `ConwayRefinement.Algebra.Valuation.Tests.Residue` includes a certificate for that +case. +-/ + +universe u v + +public noncomputable section + +open scoped DirectSum + +namespace MaxAddDegree + +variable {R : Type u} {M : Type v} [CommRing R] [AddCommMonoid M] + [LinearOrder M] [IsOrderedCancelAddMonoid M] + +/-- The subring of elements whose degree is at most zero. -/ +def nonpositiveSubring (ν : MaxAddDegree R M) : Subring R where + carrier := {x | ν x ≤ 0} + zero_mem' := by simp + one_mem' := ν.map_one_le_zero + add_mem' {x y} hx hy := (ν.map_add_le_max x y).trans (max_le hx hy) + mul_mem' {x y} hx hy := by + change ν (x * y) ≤ 0 + change ν x ≤ 0 at hx + change ν y ≤ 0 at hy + simpa using degree_mul_le_add hx hy + neg_mem' {x} hx := by simpa using hx + +@[simp] +theorem mem_nonpositiveSubring_iff (ν : MaxAddDegree R M) (x : R) : + x ∈ ν.nonpositiveSubring ↔ ν x ≤ 0 := + Iff.rfl + +/-- The additive identification of the nonpositive subring with the weak filtration at zero. -/ +def nonpositiveEquivFiltrationLEZero (ν : MaxAddDegree R M) : + ν.nonpositiveSubring ≃+ ν.filtrationLE 0 where + toFun x := ⟨x, (ν.mem_filtrationLE_iff 0 x).mpr + ((ν.mem_nonpositiveSubring_iff x).mp x.2)⟩ + invFun x := ⟨x, (ν.mem_nonpositiveSubring_iff x).mpr + ((ν.mem_filtrationLE_iff 0 x).mp x.2)⟩ + left_inv _ := Subtype.ext rfl + right_inv _ := Subtype.ext rfl + map_add' _ _ := rfl + +@[simp] +theorem coe_nonpositiveEquivFiltrationLEZero (ν : MaxAddDegree R M) + (x : ν.nonpositiveSubring) : + (ν.nonpositiveEquivFiltrationLEZero x : R) = x := + by simp [nonpositiveEquivFiltrationLEZero] + +/-- The projection from the nonpositive subring to the grade-zero homogeneous quotient. -/ +def residueMap (ν : MaxAddDegree R M) : + ν.nonpositiveSubring →+* ν.ResidueRing where + toFun x := ν.componentMk 0 (ν.nonpositiveEquivFiltrationLEZero x) + map_zero' := by simp + map_add' x y := by + change ν.componentMk 0 + (ν.nonpositiveEquivFiltrationLEZero (x + y)) = _ + rw [map_add, map_add] + map_one' := by + change ν.componentMk 0 + (ν.nonpositiveEquivFiltrationLEZero 1) = ν.componentOne + rw [ν.componentOne_eq_componentMk] + congr + map_mul' x y := by + apply ν.residueRingHom_injective + simp only [ν.residueRingHom_apply] + rw [DirectSum.of_zero_mul] + simp only [← ν.homogeneousMk_apply] + rw [ν.homogeneousMk_mul] + simp only [ν.homogeneousMk_apply] + apply DirectSum.of_eq_of_gradedMonoid_eq + apply Sigma.ext (zero_add 0).symm + apply ν.componentMk_heq_of_grade_eq_of_coe_eq (zero_add 0).symm + simp only [ν.coe_nonpositiveEquivFiltrationLEZero, ν.coe_mulFiltrationLE] + exact _root_.map_mul ν.nonpositiveSubring.subtype x y + +@[simp] +theorem residueMap_apply (ν : MaxAddDegree R M) (x : ν.nonpositiveSubring) : + ν.residueMap x = + ν.componentMk 0 (ν.nonpositiveEquivFiltrationLEZero x) := + by simp [residueMap] + +/-- Every grade-zero class has a representative of nonpositive degree. -/ +theorem residueMap_surjective (ν : MaxAddDegree R M) : + Function.Surjective ν.residueMap := by + intro c + induction c using QuotientAddGroup.induction_on with + | H x => exact ⟨ν.nonpositiveEquivFiltrationLEZero.symm x, by simp⟩ + +theorem residueMap_eq_zero_iff (ν : MaxAddDegree R M) + (x : ν.nonpositiveSubring) : + ν.residueMap x = 0 ↔ ν (x : R) < 0 := by + rw [ν.residueMap_apply, ν.componentMk_eq_zero_iff] + rfl + +/-- At degree zero or bottom, the RV class and residue class have the same homogeneous image. -/ +theorem coe_rvEquivHomogeneous_rv_eq_residueRingHom_residueMap + (ν : MaxAddDegree R M) [ν.IsMultiplicative] (x : ν.nonpositiveSubring) + (hx : ν (x : R) = 0 ∨ ν (x : R) = ⊥) : + (ν.rvEquivHomogeneous (ν.rv (x : R)) : ν.AssociatedGraded) = + ν.residueRingHom (ν.residueMap x) := by + rw [ν.rvEquivHomogeneous_apply, ν.coe_rvHomogeneous, + ν.rvInitialFormHom_rv] + rcases hx with hx | hx + · have hxnonbot : ν (x : R) ≠ ⊥ := by simp [hx] + rw [ν.initialForm_eq_homogeneousMk_of_ne_bot hxnonbot] + rw [ν.residueRingHom_apply, ν.residueMap_apply, ν.homogeneousMk_apply] + apply DirectSum.of_eq_of_gradedMonoid_eq + have hgrade : (ν (x : R)).unbot hxnonbot = 0 := + (WithBot.unbot_eq_iff hxnonbot).mpr hx + apply Sigma.ext hgrade + apply ν.componentMk_heq_of_grade_eq_of_coe_eq hgrade + rw [ν.coe_initialRepresentative, ν.coe_nonpositiveEquivFiltrationLEZero] + · rw [ν.initialForm_eq_zero_of_eq_bot hx] + have hresidue : ν.residueMap x = 0 := by + rw [ν.residueMap_eq_zero_iff, hx] + simp + rw [hresidue, ν.residueRingHom.map_zero] + +/-- The ideal of strictly negative elements in the nonpositive subring. -/ +def negativeIdeal (ν : MaxAddDegree R M) : Ideal ν.nonpositiveSubring where + carrier := {x | ν (x : R) < 0} + zero_mem' := by simp + add_mem' {x y} hx hy := (ν.map_add_le_max x y).trans_lt (max_lt hx hy) + smul_mem' x y hy := by + change ν ((x : R) * (y : R)) < 0 + simpa using degree_mul_lt_add_of_le_of_lt x.2 hy + +@[simp] +theorem mem_negativeIdeal_iff (ν : MaxAddDegree R M) + (x : ν.nonpositiveSubring) : + x ∈ ν.negativeIdeal ↔ ν (x : R) < 0 := + Iff.rfl + +/-- The kernel statement in LM24, Proposition 4.2.10. -/ +theorem residueMap_ker (ν : MaxAddDegree R M) : + RingHom.ker ν.residueMap = ν.negativeIdeal := by + ext x + rw [RingHom.mem_ker, ν.residueMap_eq_zero_iff, ν.mem_negativeIdeal_iff] + +/-- The first-isomorphism presentation of the residue ring. -/ +def residueQuotientEquiv (ν : MaxAddDegree R M) : + ν.nonpositiveSubring ⧸ ν.negativeIdeal ≃+* ν.ResidueRing := + (Ideal.quotEquivOfEq ν.residueMap_ker.symm).trans + (RingHom.quotientKerEquivOfSurjective ν.residueMap_surjective) + +@[simp] +theorem residueQuotientEquiv_mk (ν : MaxAddDegree R M) + (x : ν.nonpositiveSubring) : + ν.residueQuotientEquiv (Ideal.Quotient.mk ν.negativeIdeal x) = ν.residueMap x := by + simp [residueQuotientEquiv] + +end MaxAddDegree diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/ResidueMathlib.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/ResidueMathlib.lean new file mode 100644 index 0000000000..51e0142264 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/ResidueMathlib.lean @@ -0,0 +1,74 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.OfValuation +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.Residue +public import Mathlib.RingTheory.Valuation.Integers + +/-! +# Comparison with Mathlib's valuation integers + +For a group-valued Mathlib valuation, read as a max-additive degree by `MaxAddDegree.ofValuation`, +the nonpositive subring is Mathlib's `Valuation.integer`, and the strictly negative ideal is the +pullback of `Valuation.ltIdeal w 1`. These bridges make Mathlib's valuation-ring API available +without imposing a group structure on the monoid-valued construction used in LM24, Section 4. +-/ + +universe u v + +public noncomputable section + +namespace MaxAddDegree + +variable {R : Type u} {M : Type v} [CommRing R] [AddCommGroup M] + [LinearOrder M] [IsOrderedAddMonoid M] + +/-- In the group-valued case, the nonpositive subring is Mathlib's valuation integer subring. -/ +theorem nonpositiveSubring_ofValuation_eq_integer (w : Valuation R (WithZero (Multiplicative M))) : + (ofValuation w).nonpositiveSubring = w.integer := by + ext x + rw [mem_nonpositiveSubring_iff, Valuation.mem_integer_iff, ofValuation_apply] + change Multiplicative.toAdd (WithZero.toMulBot (w x)) ≤ 0 ↔ w x ≤ 1 + rfl + +/-- The canonical equivalence from the LM24 nonpositive subring to Mathlib's valuation integers. -/ +def nonpositiveEquivInteger (w : Valuation R (WithZero (Multiplicative M))) : + (ofValuation w).nonpositiveSubring ≃+* w.integer where + toFun x := ⟨x, by + rw [← nonpositiveSubring_ofValuation_eq_integer] + exact x.2⟩ + invFun x := ⟨x, by + rw [nonpositiveSubring_ofValuation_eq_integer] + exact x.2⟩ + left_inv _ := Subtype.ext rfl + right_inv _ := Subtype.ext rfl + map_add' _ _ := rfl + map_mul' _ _ := rfl + +@[simp] +theorem coe_nonpositiveEquivInteger (w : Valuation R (WithZero (Multiplicative M))) + (x : (ofValuation w).nonpositiveSubring) : + (nonpositiveEquivInteger w x : R) = x := + by simp [nonpositiveEquivInteger] + +/-- The LM24 negative ideal is the pullback of Mathlib's strict ideal below `1`. -/ +theorem negativeIdeal_ofValuation_eq_comap_ltIdeal + (w : Valuation R (WithZero (Multiplicative M))) : + (ofValuation w).negativeIdeal = + (w.ltIdeal 1).comap (nonpositiveEquivInteger w).toRingHom := by + ext x + rw [mem_negativeIdeal_iff, Ideal.mem_comap] + rw [Valuation.mem_ltIdeal_iff] + have hcoe : + (((nonpositiveEquivInteger w).toRingHom x : w.integer) : R) = x := + coe_nonpositiveEquivInteger w x + rw [hcoe, ofValuation_apply] + change Multiplicative.toAdd (WithZero.toMulBot (w (x : R))) < 0 ↔ + w (x : R) < 1 + rfl + +end MaxAddDegree diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/Tests.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/Tests.lean new file mode 100644 index 0000000000..a9ae5200d8 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/Tests.lean @@ -0,0 +1,19 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.Tests.AssociatedGraded +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.Tests.AssociatedGradedValuation +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.Tests.DegreeAssociatedGraded +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.Tests.DegreeAssociatedGradedQuotient +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.Tests.FiltrationDegree +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.Tests.Fixtures +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.Tests.QuotientDegree +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.Tests.RV +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.Tests.Residue + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/Tests/AssociatedGraded.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/Tests/AssociatedGraded.lean new file mode 100644 index 0000000000..efa58de63e --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/Tests/AssociatedGraded.lean @@ -0,0 +1,201 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.DegreeAssociatedGraded +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.OfValuation +public import Mathlib.Algebra.Order.Ring.Rat + +import Mathlib.Algebra.Ring.Prod + +/-! +# API checks for max-additive degrees and associated graded rings + +The raw constant-value fixture satisfies the two multiplicative semi-valuation axioms printed at +the start of LM24, Section 4, but the relation in Definition 4.1.1 is not reflexive. This verifies +that the additional zero-to-bottom condition used by the formalization is not a consequence of the +printed axioms. + +The remaining fixtures are Mathlib valuations read as multiplicative max-additive degrees through +`MaxAddDegree.ofValuation`. The first is a nonseparated counterexample to representative-sensitive +quotient rules. It pulls the trivial valuation on `ℚ` back along the first projection +`ℚ × ℚ → ℚ`. Thus `(0, 1)` is a nonzero element of the kernel. The certificates verify that its +homogeneous class is zero and that `(1, 1)` and `(1, 0)` have the same nonzero class. These +statements would fail for a construction that collapsed only the literal zero representative. + +The second fixture uses the separated trivial valuation on `ℚ`. It proves that the asymmetric +zero-plus-one test printed in LM24, Definition 4.2.4 selects the zero branch even though the class +of one is nonzero. Its grade-zero multiplication certificate also computes the product of the +homogeneous classes of two and three as the class of six. Together the fixtures exercise support, +separation, the strict quotient, and multiplication. +-/ + +public noncomputable section + +namespace Tests + +/-- The constant finite value map used to test the two semi-valuation axioms printed in LM24. +Ignoring its argument is the point of the fixture, hence the `nolint`. -/ +def printedConstantValue (_ : ℚ) : WithBot ℕ := + 0 + +theorem printedConstantValue_add_le_max (x y : ℚ) : + printedConstantValue (x + y) ≤ max (printedConstantValue x) (printedConstantValue y) := by + simp [printedConstantValue] + +theorem printedConstantValue_mul (x y : ℚ) : + printedConstantValue (x * y) = printedConstantValue x + printedConstantValue y := by + simp [printedConstantValue] + +/-- The two semi-valuation axioms printed in LM24 do not make Definition 4.1.1 reflexive. -/ +theorem printedSemivaluationRelation_not_reflexive : + ¬ Std.Refl (fun x y : ℚ ↦ printedConstantValue (x - y) < printedConstantValue x) := by + intro h + simpa [printedConstantValue] using h.refl 0 + +/-- The trivial valuation on the first coordinate of `ℚ × ℚ`. -/ +def firstProjectionValuation : MaxAddDegree (ℚ × ℚ) ℕ := + MaxAddDegree.ofValuation + ((1 : Valuation ℚ (WithZero (Multiplicative ℕ))).comap (RingHom.fst ℚ ℚ)) + +instance : firstProjectionValuation.IsMultiplicative := + inferInstanceAs (MaxAddDegree.ofValuation _).IsMultiplicative + +theorem firstProjectionValuation_value_zero_one : + firstProjectionValuation (0, 1) = ⊥ := by + simp [MaxAddDegree.ofValuation_apply, firstProjectionValuation, Valuation.one_apply_def] + +theorem firstProjectionValuation_value_one_one : + firstProjectionValuation (1, 1) = 0 := by + simp [MaxAddDegree.ofValuation_apply, firstProjectionValuation, Valuation.one_apply_def] + +/-- The first-projection valuation is genuinely nonseparated. -/ +theorem firstProjectionValuation_not_isSeparated : + ¬ firstProjectionValuation.IsSeparated := by + rw [MaxAddDegree.isSeparated_iff] + push Not + exact ⟨(0, 1), by simp [MaxAddDegree.ofValuation_apply, firstProjectionValuation, + Valuation.one_apply_def]⟩ + +/-- The element `(0, 1)` in filtration degree zero, used to test the support kernel. -/ +def supportRepresentative : firstProjectionValuation.filtrationLE 0 := + ⟨(0, 1), by simp [MaxAddDegree.ofValuation_apply, firstProjectionValuation, + Valuation.one_apply_def]⟩ + +/-- The element `(1, 1)` in filtration degree zero, whose homogeneous class is nonzero. -/ +def nonzeroRepresentative : firstProjectionValuation.filtrationLE 0 := + ⟨(1, 1), by simp [MaxAddDegree.ofValuation_apply, firstProjectionValuation, + Valuation.one_apply_def]⟩ + +/-- The element `(1, 0)` in filtration degree zero, with the same leading class as `(1, 1)`. -/ +def sameLeadingRepresentative : firstProjectionValuation.filtrationLE 0 := + ⟨(1, 0), by simp [MaxAddDegree.ofValuation_apply, firstProjectionValuation, + Valuation.one_apply_def]⟩ + +/-- A nonzero element of the support ideal represents homogeneous zero. -/ +theorem supportRepresentative_componentMk_eq_zero : + firstProjectionValuation.componentMk 0 supportRepresentative = 0 := by + rw [MaxAddDegree.componentMk_eq_zero_iff] + simp [MaxAddDegree.ofValuation_apply, supportRepresentative, firstProjectionValuation, + Valuation.one_apply_def] + +/-- The class represented by `(1, 1)` is nonzero. -/ +theorem nonzeroRepresentative_componentMk_ne_zero : + firstProjectionValuation.componentMk 0 nonzeroRepresentative ≠ 0 := by + rw [ne_eq, MaxAddDegree.componentMk_eq_zero_iff] + simp [MaxAddDegree.ofValuation_apply, nonzeroRepresentative, firstProjectionValuation, + Valuation.one_apply_def] + +/-- Representatives differing by the nonzero support element `(0, 1)` have the same class. -/ +theorem firstProjectionValuation_same_leading_class : + firstProjectionValuation.componentMk 0 nonzeroRepresentative = + firstProjectionValuation.componentMk 0 sameLeadingRepresentative := by + rw [← sub_eq_zero, ← map_sub, MaxAddDegree.componentMk_eq_zero_iff] + change firstProjectionValuation ((1, 1) - (1, 0)) < (0 : ℕ) + simp [MaxAddDegree.ofValuation_apply, firstProjectionValuation, Valuation.one_apply_def] + +/-- Adding a nonzero support representative does not change a homogeneous class. -/ +theorem firstProjectionValuation_add_support_class : + firstProjectionValuation.componentMk 0 nonzeroRepresentative + + firstProjectionValuation.componentMk 0 supportRepresentative = + firstProjectionValuation.componentMk 0 nonzeroRepresentative := by + rw [supportRepresentative_componentMk_eq_zero, add_zero] + +/-- The separated trivial valuation on `ℚ`. -/ +def trivialValuation : MaxAddDegree ℚ ℕ := + MaxAddDegree.ofValuation 1 + +instance : trivialValuation.IsMultiplicative := + inferInstanceAs (MaxAddDegree.ofValuation _).IsMultiplicative + +/-- The rational unit in filtration degree zero for the trivial valuation. -/ +def oneRepresentative : trivialValuation.filtrationLE 0 := + ⟨1, by simp [MaxAddDegree.ofValuation_apply, trivialValuation, Valuation.one_apply_def]⟩ + +theorem oneRepresentative_componentMk_ne_zero : + trivialValuation.componentMk 0 oneRepresentative ≠ 0 := by + rw [ne_eq, MaxAddDegree.componentMk_eq_zero_iff] + simp [MaxAddDegree.ofValuation_apply, oneRepresentative, trivialValuation, + Valuation.one_apply_def] + +/-- The representative-level addition formula printed in LM24, Definition 4.2.4 at grade zero. -/ +def printedRepresentativeAdd + (x y : trivialValuation.filtrationLE 0) : trivialValuation.Component 0 := + if trivialValuation ((x : ℚ) + (y : ℚ)) = trivialValuation x then + trivialValuation.componentMk 0 (x + y) + else + 0 + +/-- The addition formula printed in LM24, Definition 4.2.4 is not commutative. -/ +theorem printedRepresentativeAdd_not_commutative : + printedRepresentativeAdd 0 oneRepresentative ≠ + printedRepresentativeAdd oneRepresentative 0 := by + have hzeroOne : + trivialValuation + (((0 : trivialValuation.filtrationLE 0) : ℚ) + (oneRepresentative : ℚ)) ≠ + trivialValuation ((0 : trivialValuation.filtrationLE 0) : ℚ) := by + simp [MaxAddDegree.ofValuation_apply, oneRepresentative, trivialValuation, + Valuation.one_apply_def] + have honeZero : + trivialValuation + ((oneRepresentative : ℚ) + ((0 : trivialValuation.filtrationLE 0) : ℚ)) = + trivialValuation oneRepresentative := by + simp + rw [printedRepresentativeAdd, ite_eq_right hzeroOne, printedRepresentativeAdd, ite_eq_left + honeZero] + simp only [add_zero] + exact oneRepresentative_componentMk_ne_zero.symm + +theorem trivialValuation_isSeparated : trivialValuation.IsSeparated := by + rw [MaxAddDegree.isSeparated_iff] + intro x + by_cases hx : x = 0 + · simp [MaxAddDegree.ofValuation_apply, trivialValuation, Valuation.one_apply_def, hx] + · simp [MaxAddDegree.ofValuation_apply, trivialValuation, Valuation.one_apply_def, hx] + +/-- The rational number two in filtration degree zero for the trivial valuation. -/ +def twoRepresentative : trivialValuation.filtrationLE 0 := + ⟨2, by simp [MaxAddDegree.ofValuation_apply, trivialValuation, Valuation.one_apply_def]⟩ + +/-- The rational number three in filtration degree zero for the trivial valuation. -/ +def threeRepresentative : trivialValuation.filtrationLE 0 := + ⟨3, by simp [MaxAddDegree.ofValuation_apply, trivialValuation, Valuation.one_apply_def]⟩ + +/-- The rational number six in filtration degree zero for the trivial valuation. -/ +def sixRepresentative : trivialValuation.filtrationLE 0 := + ⟨6, by simp [MaxAddDegree.ofValuation_apply, trivialValuation, Valuation.one_apply_def]⟩ + +/-- Homogeneous multiplication computes `2 * 3 = 6` in the grade-zero component. -/ +theorem trivialValuation_two_mul_three : + trivialValuation.homogeneousMk 0 twoRepresentative * + trivialValuation.homogeneousMk 0 threeRepresentative = + trivialValuation.homogeneousMk 0 sixRepresentative := by + rw [MaxAddDegree.homogeneousMk_mul] + apply congrArg (trivialValuation.homogeneousMk 0) + apply Subtype.ext + norm_num [twoRepresentative, threeRepresentative, sixRepresentative] + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/Tests/AssociatedGradedValuation.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/Tests/AssociatedGradedValuation.lean new file mode 100644 index 0000000000..fabbf0d7cf --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/Tests/AssociatedGradedValuation.lean @@ -0,0 +1,119 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.AssociatedGradedValuation +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.OfValuation +public import Mathlib.Algebra.Order.Ring.Rat + +import Mathlib.Algebra.Ring.Prod + +/-! +# API checks for leading-grade valuations + +A two-grade direct sum over `ℤ` verifies that leading grade uses the largest nonzero grade and +that ordinary addition of grades governs products. The asymmetric grades ensure that the client +is not merely checking the grade-zero ring inherited from the coefficient ring. + +The first-projection valuation on `ℚ × ℚ`, read as a multiplicative max-additive degree, is +nonseparated, while its associated-graded valuation is separated. Its nonzero kernel element has +zero initial form, and a representative outside the kernel retains its degree under the +initial-form map. These certificates exercise the distinction between the original kernel and the +zero element of the associated graded ring. +-/ + +public noncomputable section + +open MaxAddDegree +open scoped DirectSum + +namespace Tests + +/-- The direct sum of integer components indexed by natural-number degrees, used to test leading +grades. -/ +abbrev LeadingGradeFixture := DirectSum ℕ (fun _ ↦ ℤ) + +/-- The homogeneous element with coefficient two in degree one. -/ +def leadingGradeLow : LeadingGradeFixture := + DirectSum.of (fun _ : ℕ ↦ ℤ) 1 2 + +/-- The homogeneous element with coefficient five in degree three. -/ +def leadingGradeHigh : LeadingGradeFixture := + DirectSum.of (fun _ : ℕ ↦ ℤ) 3 5 + +/-- The sum of components in grades one and three has leading grade three. -/ +theorem leadingGrade_sum_fixture : + DirectSum.leadingGrade (fun _ : ℕ ↦ ℤ) (leadingGradeLow + leadingGradeHigh) = 3 := by + have hlow : DirectSum.leadingGrade (fun _ : ℕ ↦ ℤ) leadingGradeLow = 1 := by + rw [leadingGradeLow] + exact DirectSum.leadingGrade_of _ (by norm_num) + have hhigh : DirectSum.leadingGrade (fun _ : ℕ ↦ ℤ) leadingGradeHigh = 3 := by + rw [leadingGradeHigh] + exact DirectSum.leadingGrade_of _ (by norm_num) + apply le_antisymm + · calc + DirectSum.leadingGrade (fun _ : ℕ ↦ ℤ) (leadingGradeLow + leadingGradeHigh) ≤ + max (DirectSum.leadingGrade (fun _ : ℕ ↦ ℤ) leadingGradeLow) + (DirectSum.leadingGrade (fun _ : ℕ ↦ ℤ) leadingGradeHigh) := + DirectSum.leadingGrade_add_le_max _ _ _ + _ = 3 := by + rw [hlow, hhigh] + norm_num + · apply DirectSum.grade_le_leadingGrade + norm_num [leadingGradeLow, leadingGradeHigh, DirectSum.of_apply] + +/-- The product of the grade-one and grade-three components has leading grade four. -/ +theorem leadingGrade_mul_fixture : + DirectSum.leadingGrade (fun _ : ℕ ↦ ℤ) (leadingGradeLow * leadingGradeHigh) = 4 := by + have hlow : DirectSum.leadingGrade (fun _ : ℕ ↦ ℤ) leadingGradeLow = 1 := by + rw [leadingGradeLow] + exact DirectSum.leadingGrade_of _ (by norm_num) + have hhigh : DirectSum.leadingGrade (fun _ : ℕ ↦ ℤ) leadingGradeHigh = 3 := by + rw [leadingGradeHigh] + exact DirectSum.leadingGrade_of _ (by norm_num) + rw [DirectSum.leadingGrade_mul (fun _ : ℕ ↦ ℤ) + (fun a b ha hb ↦ mul_ne_zero ha hb)] + rw [hlow, hhigh] + norm_num + +/-- The trivial valuation pulled back along the first projection, used to test separation of the +associated graded ring. -/ +def associatedFirstProjectionValuation : MaxAddDegree (ℚ × ℚ) ℕ := + MaxAddDegree.ofValuation + ((1 : Valuation ℚ (WithZero (Multiplicative ℕ))).comap (RingHom.fst ℚ ℚ)) + +instance : associatedFirstProjectionValuation.IsMultiplicative := + inferInstanceAs (MaxAddDegree.ofValuation _).IsMultiplicative + +theorem associatedFirstProjectionValuation_not_isSeparated : + ¬associatedFirstProjectionValuation.IsSeparated := by + rw [MaxAddDegree.isSeparated_iff] + push Not + exact ⟨(0, 1), by simp [MaxAddDegree.ofValuation_apply, + associatedFirstProjectionValuation, Valuation.one_apply_def]⟩ + +/-- The associated-graded valuation is separated even when the original valuation is not. -/ +theorem associatedFirstProjectionValuation_associated_isSeparated : + associatedFirstProjectionValuation.associatedGradedValuation.IsSeparated := + associatedFirstProjectionValuation.associatedGradedValuation_isSeparated + +/-- A nonzero element of the original kernel has bottom-valued initial form. -/ +theorem associatedFirstProjectionValuation_support_initialForm : + associatedFirstProjectionValuation.associatedGradedValuation + (associatedFirstProjectionValuation.initialForm (0, 1)) = ⊥ := by + rw [MaxAddDegree.associatedGradedValuation_initialForm] + simp [MaxAddDegree.ofValuation_apply, associatedFirstProjectionValuation, + Valuation.one_apply_def] + +/-- A representative outside the kernel retains its finite degree under the initial-form map. -/ +theorem associatedFirstProjectionValuation_nonzero_initialForm : + associatedFirstProjectionValuation.associatedGradedValuation + (associatedFirstProjectionValuation.initialForm (1, 1)) = 0 := by + rw [MaxAddDegree.associatedGradedValuation_initialForm] + simp [MaxAddDegree.ofValuation_apply, associatedFirstProjectionValuation, + Valuation.one_apply_def] + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/Tests/DegreeAssociatedGraded.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/Tests/DegreeAssociatedGraded.lean new file mode 100644 index 0000000000..1321e7f9e6 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/Tests/DegreeAssociatedGraded.lean @@ -0,0 +1,63 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.DegreeAssociatedGradedDomain +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.Tests.Fixtures.PolynomialAssociatedGraded + +import Mathlib.Algebra.Polynomial.Degree.Operations + +/-! +# API checks for the associated graded ring of a degree function + +The class of `X` in grade one is nonzero, and its homogeneous square is represented by `X ^ 2` +in grade two. The square is nonzero because its polynomial degree is exactly two. This checks +multiplication on a genuinely nonconstant representative and distinguishes the intended strict +lower filtration from a quotient that kills all positive-degree elements. + +The zero polynomial still maps to zero in a positive component, checking the bottom-degree branch. +-/ + +public noncomputable section + +namespace Tests + +open Polynomial +open scoped MaxAddDegree + +/-- Exact multiplication of polynomial degree gives the generic homogeneous +non-zero-divisor condition. -/ +theorem polynomialDegree_homogeneousNoZeroDivisors : + polynomialDegree.HomogeneousNoZeroDivisors := + polynomialDegree.homogeneousNoZeroDivisors_of_isMultiplicative + +/-- Homogeneous squaring is represented by polynomial squaring. -/ +theorem polynomialInitial_sq : + polynomialDegree.componentMul polynomialXInitial polynomialXInitial = + polynomialDegree.componentMk 2 + ⟨X ^ 2, (polynomialDegree.mem_filtrationLE_iff 2 (X ^ 2)).mpr (by + rw [polynomialDegree_apply, Polynomial.degree_X_pow] + simp)⟩ := by + rw [polynomialXInitial_eq_componentMk, polynomialDegree.componentMul_componentMk] + apply congrArg (polynomialDegree.componentMk 2) + apply Subtype.ext + rw [polynomialDegree.coe_mulFiltrationLE] + exact (pow_two (X : ℚ[X])).symm + +/-- The square of the nonzero degree-one test class is nonzero. -/ +theorem polynomialInitial_sq_ne_zero : + polynomialDegree.componentMul polynomialXInitial polynomialXInitial ≠ 0 := by + rw [polynomialInitial_sq, ne_eq, polynomialDegree.componentMk_eq_zero_iff, + polynomialDegree_apply, Polynomial.degree_X_pow] + exact lt_irrefl _ + +/-- Bottom degree maps the zero polynomial to zero in a positive component. -/ +theorem polynomialZeroInitial_eq_zero : + polynomialDegree.componentMk 1 ⟨(0 : ℚ[X]), by simp⟩ = 0 := by + rw [polynomialDegree.componentMk_eq_zero_iff, polynomialDegree_apply] + simp + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/Tests/DegreeAssociatedGradedQuotient.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/Tests/DegreeAssociatedGradedQuotient.lean new file mode 100644 index 0000000000..7a92667f73 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/Tests/DegreeAssociatedGradedQuotient.lean @@ -0,0 +1,156 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.DegreeAssociatedGradedQuotient +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.Tests.Fixtures.PolynomialAssociatedGraded +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.Tests.Fixtures.PolynomialQuotientDegree + +import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.DegreePrincipalInitialIdeal +import Mathlib.Algebra.Polynomial.Degree.Operations + +/-! +# API checks for the associated graded ring of a quotient + +For `ℚ[X] / (X - 1)`, the degree-one initial class of `X - 1` equals the initial class of `X`. +The canonical graded quotient map therefore kills that nonzero degree-one class, and the class lies +in the initial ideal. The degree-zero unit survives. Together these facts separate the canonical +map from both the identity map and the zero map, while checking that lower-degree terms disappear +from an initial form. +-/ + +open scoped MaxAddDegree + +public noncomputable section + +namespace Tests + +open Polynomial + +private def relationFiltrationOne : polynomialDegree.filtrationLE 1 := + ⟨X - C 1, (polynomialDegree.mem_filtrationLE_iff 1 _).mpr (by + rw [polynomialDegree_apply] + exact Polynomial.degree_X_sub_C_le 1)⟩ + +private theorem relation_mem_evaluationAtOneIdeal : + (relationFiltrationOne : ℚ[X]) ∈ evaluationAtOneIdeal := by + rw [relationFiltrationOne] + exact Ideal.Quotient.eq_zero_iff_mem.mp quotientMk_X_sub_one_eq_zero + +private theorem relation_component_eq_xInitial : + polynomialDegree.componentMk 1 relationFiltrationOne = polynomialXInitial := by + let x : polynomialDegree.filtrationLE 1 := + ⟨X, (polynomialDegree.mem_filtrationLE_iff 1 X).mpr (by + rw [polynomialDegree_apply, Polynomial.degree_X] + simp)⟩ + let c : polynomialDegree.filtrationLE 1 := + ⟨C 1, (polynomialDegree.mem_filtrationLE_iff 1 _).mpr (by + rw [polynomialDegree_apply, Polynomial.degree_C one_ne_zero] + simp)⟩ + have hc : polynomialDegree.componentMk 1 c = 0 := by + rw [polynomialDegree.componentMk_eq_zero_iff, polynomialDegree_apply, + Polynomial.degree_C one_ne_zero] + simp + have hrelation : relationFiltrationOne = x - c := Subtype.ext rfl + rw [hrelation, map_sub, hc, sub_zero, polynomialXInitial_eq_componentMk] + +/-- The degree-one initial class of `X` maps to zero modulo `X - 1`. -/ +theorem polynomialGradedQuotientMap_X_eq_zero : + polynomialDegree.associatedGradedQuotientMap evaluationAtOneIdeal + polynomialDegree_isSeparated + (DirectSum.of polynomialDegree.Component 1 polynomialXInitial) = 0 := by + rw [polynomialDegree.associatedGradedQuotientMap_of] + have hcomponent : + polynomialDegree.quotientComponentMap evaluationAtOneIdeal + polynomialDegree_isSeparated 1 polynomialXInitial = 0 := + (polynomialDegree.quotientComponentMap_eq_zero_iff evaluationAtOneIdeal + polynomialDegree_isSeparated 1 polynomialXInitial).mpr + ⟨relationFiltrationOne, relation_mem_evaluationAtOneIdeal, + relation_component_eq_xInitial⟩ + rw [hcomponent, + (DirectSum.of + (polynomialDegree.quotient evaluationAtOneIdeal + polynomialDegree_isSeparated).Component 1).map_zero] + +/-- The degree-one initial class of `X` belongs to the initial ideal of `(X - 1)`. -/ +theorem polynomialXInitial_mem_initialIdeal : + DirectSum.of polynomialDegree.Component 1 polynomialXInitial ∈ + polynomialDegree.initialIdeal evaluationAtOneIdeal := by + have hmem := polynomialDegree.homogeneousMk_mem_initialIdeal evaluationAtOneIdeal + 1 relationFiltrationOne relation_mem_evaluationAtOneIdeal + rw [polynomialDegree.homogeneousMk_apply, relation_component_eq_xInitial] at hmem + exact hmem + +/-- The quotient-ring equivalence sends the class of the degree-one initial form to zero. -/ +theorem polynomialAssociatedGradedQuotientEquiv_X_eq_zero : + polynomialDegree.associatedGradedQuotientEquiv evaluationAtOneIdeal + polynomialDegree_isSeparated + (Ideal.Quotient.mk (polynomialDegree.initialIdeal evaluationAtOneIdeal) + (DirectSum.of polynomialDegree.Component 1 polynomialXInitial)) = 0 := by + rw [polynomialDegree.associatedGradedQuotientEquiv_mk, + polynomialGradedQuotientMap_X_eq_zero] + +/-- The initial ideal of `(X - 1)` is generated by the degree-one initial class of `X`. -/ +theorem polynomialInitialIdeal_eq_span_XInitial : + polynomialDegree.initialIdeal evaluationAtOneIdeal = + Ideal.span {DirectSum.of polynomialDegree.Component 1 polynomialXInitial} := by + rw [evaluationAtOneIdeal_eq_span, + polynomialDegree.initialIdeal_span_singleton_eq_span_initialForm] + have hcomponent : + polynomialDegree.componentMk 1 relationFiltrationOne ≠ 0 := by + rw [relation_component_eq_xInitial] + exact polynomialXInitial_ne_zero + have hinitial := + polynomialDegree.initialForm_eq_homogeneousMk_of_componentMk_ne_zero + 1 relationFiltrationOne hcomponent + change polynomialDegree.initialForm (X - C 1) = + polynomialDegree.homogeneousMk 1 relationFiltrationOne at hinitial + rw [hinitial, + polynomialDegree.homogeneousMk_apply, relation_component_eq_xInitial] + +private theorem evaluationAtOneQuotient_one_ne_zero : + (1 : ℚ[X] ⧸ evaluationAtOneIdeal) ≠ 0 := by + simpa using quotientMk_one_ne_zero + +private theorem evaluationAtOneQuotientDegree_one_eq_zero : + (polynomialDegree.quotient evaluationAtOneIdeal polynomialDegree_isSeparated) 1 = + (0 : ℕ) := by + let νq := polynomialDegree.quotient evaluationAtOneIdeal polynomialDegree_isSeparated + have hsep : νq.IsSeparated := + polynomialDegree.quotient_isSeparated evaluationAtOneIdeal + polynomialDegree_isSeparated + have hnebot : νq 1 ≠ ⊥ := by + intro hbot + exact evaluationAtOneQuotient_one_ne_zero + (((νq.isSeparated_iff).mp hsep 1).mp hbot) + have hle : νq 1 ≤ (0 : WithBot ℕ) := νq.map_one_le_zero + obtain ⟨n, hn⟩ := WithBot.ne_bot_iff_exists.mp hnebot + rw [← hn] at hle ⊢ + have hnzero : n = 0 := Nat.eq_zero_of_le_zero (WithBot.coe_le_coe.mp hle) + simp [hnzero] + +/-- The degree-zero unit survives the canonical graded quotient map. -/ +theorem polynomialGradedQuotientMap_one_ne_zero : + polynomialDegree.associatedGradedQuotientMap evaluationAtOneIdeal + polynomialDegree_isSeparated 1 ≠ 0 := by + let νq := polynomialDegree.quotient evaluationAtOneIdeal polynomialDegree_isSeparated + have hcomponentOne : νq.componentOne ≠ 0 := by + rw [νq.componentOne_eq_componentMk, ne_eq, νq.componentMk_eq_zero_iff] + rw [evaluationAtOneQuotientDegree_one_eq_zero] + exact lt_irrefl _ + have hgradedOne : (1 : νq.AssociatedGraded) ≠ 0 := by + rw [DirectSum.one_def] + intro hzero + have hzero' : DirectSum.of νq.Component 0 νq.componentOne = 0 := by + simpa only [show GradedMonoid.GOne.one = νq.componentOne from rfl] using hzero + apply hcomponentOne + apply DirectSum.of_injective 0 + simpa using hzero' + rw [(polynomialDegree.associatedGradedQuotientMap evaluationAtOneIdeal + polynomialDegree_isSeparated).map_one] + exact hgradedOne + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/Tests/FiltrationDegree.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/Tests/FiltrationDegree.lean new file mode 100644 index 0000000000..30c05b6633 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/Tests/FiltrationDegree.lean @@ -0,0 +1,78 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.FiltrationDegree + +/-! +# API checks for the degree attached to a separated filtration + +For a nonzero element, `index` is the largest filtration stage containing it. Thus the element +lies in the stage indexed by its index and not in the next stage. + +The value lies in `WithBot (OrderDual ℕ)`: deeper filtration stages give smaller values, as +required for a max-additive degree. Membership in stage `F j` is therefore equivalent to the +corresponding upper bound on the value. The final checks record zero detection, separatedness, +and the weak and strict filtrations recovered from this degree. +-/ + +public noncomputable section + +namespace Tests + +universe u + +variable {R : Type u} [CommRing R] {F : ℕ → Ideal R} + +/-- A nonzero element lies in the filtration stage indexed by its index. -/ +theorem mem_filtration_index (hF : IsSeparatedFiltration F) {x : R} (hx : x ≠ 0) : + x ∈ F (hF.index hx) := + (hF.mem_iff_le_index hx _).mpr le_rfl + +/-- A nonzero element does not lie in the stage immediately above its index. -/ +theorem not_mem_filtration_index_succ (hF : IsSeparatedFiltration F) {x : R} + (hx : x ≠ 0) : + x ∉ F (hF.index hx + 1) := by + rw [hF.mem_iff_le_index hx] + omega + +/-- The value is antitone in the index: deeper filtration means smaller value. -/ +theorem value_antitone_of_index_le (hF : IsSeparatedFiltration F) {x y : R} + (hx : x ≠ 0) (hy : y ≠ 0) (h : hF.index hx ≤ hF.index hy) : + hF.value y ≤ hF.value x := by + rw [hF.value_of_ne_zero hx, hF.value_of_ne_zero hy, WithBot.coe_le_coe] + exact OrderDual.toDual_le_toDual.mpr h + +/-- Membership in a filtration stage is equivalent to the corresponding upper bound on the +value. -/ +theorem mem_iff_value_le (hF : IsSeparatedFiltration F) (x : R) (j : ℕ) : + x ∈ F j ↔ hF.value x ≤ ((OrderDual.toDual j : OrderDual ℕ) : WithBot (OrderDual ℕ)) := + (hF.value_le_toDual_iff x j).symm + +/-- The degree attached to the filtration evaluates to its value function. -/ +theorem degree_eq_value (hF : IsSeparatedFiltration F) (x : R) : + hF.degree x = hF.value x := + hF.degree_apply x + +/-- An element has value `⊥` exactly when it is zero. -/ +theorem value_eq_bot_iff_eq_zero (hF : IsSeparatedFiltration F) (x : R) : + hF.value x = ⊥ ↔ x = 0 := + hF.value_eq_bot_iff x + +/-- The degree attached to a separated filtration is separated. -/ +theorem degree_isSeparated' (hF : IsSeparatedFiltration F) : + (hF.degree).IsSeparated := + hF.degree_isSeparated + +/-- At dual index `j`, the weak filtration of the degree is `F j` and its strict filtration is +`F (j+1)`. -/ +theorem mem_degree_filtration_iff (hF : IsSeparatedFiltration F) (j : ℕ) (x : R) : + (x ∈ (hF.degree).filtrationLE (OrderDual.toDual j) ↔ x ∈ F j) ∧ + ∀ y : (hF.degree).filtrationLE (OrderDual.toDual j), + (y ∈ (hF.degree).lowerFiltration (OrderDual.toDual j) ↔ (y : R) ∈ F (j + 1)) := + ⟨hF.mem_degree_filtrationLE_iff j x, fun y ↦ hF.mem_degree_lowerFiltration_iff j y⟩ + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/Tests/Fixtures.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/Tests/Fixtures.lean new file mode 100644 index 0000000000..8ff1dd42ab --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/Tests/Fixtures.lean @@ -0,0 +1,13 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.Tests.Fixtures.PolynomialAssociatedGraded +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.Tests.Fixtures.PolynomialDegree +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.Tests.Fixtures.PolynomialQuotientDegree + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/Tests/Fixtures/PolynomialAssociatedGraded.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/Tests/Fixtures/PolynomialAssociatedGraded.lean new file mode 100644 index 0000000000..616502504a --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/Tests/Fixtures/PolynomialAssociatedGraded.lean @@ -0,0 +1,45 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.DegreeAssociatedGraded +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.Tests.Fixtures.PolynomialDegree + +/-! +# Polynomial associated-graded fixture + +This module supplies the degree-one initial class of `X` shared by associated-graded API clients. +-/ + +public noncomputable section + +namespace Tests + +open Polynomial + +/-- The class of `X` in the degree-one homogeneous component. -/ +def polynomialXInitial : polynomialDegree.Component 1 := + polynomialDegree.componentMk 1 + ⟨X, (polynomialDegree.mem_filtrationLE_iff 1 X).mpr (by + rw [polynomialDegree_apply, Polynomial.degree_X] + simp)⟩ + +/-- Evaluation of the polynomial initial-class fixture. -/ +theorem polynomialXInitial_eq_componentMk : + polynomialXInitial = polynomialDegree.componentMk 1 + ⟨X, (polynomialDegree.mem_filtrationLE_iff 1 X).mpr (by + rw [polynomialDegree_apply, Polynomial.degree_X] + simp)⟩ := + (rfl) + +/-- The degree-one initial class of `X` is nonzero. -/ +theorem polynomialXInitial_ne_zero : polynomialXInitial ≠ 0 := by + rw [polynomialXInitial_eq_componentMk, ne_eq, + polynomialDegree.componentMk_eq_zero_iff, + polynomialDegree_apply, Polynomial.degree_X] + exact lt_irrefl _ + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/Tests/Fixtures/PolynomialDegree.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/Tests/Fixtures/PolynomialDegree.lean new file mode 100644 index 0000000000..abd4565e68 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/Tests/Fixtures/PolynomialDegree.lean @@ -0,0 +1,48 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.MaxAddDegree +public import Mathlib.Algebra.Polynomial.Degree.Defs +import Mathlib.Algebra.Polynomial.Degree.Operations + +/-! +# Polynomial-degree fixture + +This module packages ordinary degree on `ℚ[X]` as a separated `MaxAddDegree`. It is shared by +the quotient-degree and associated-graded API clients. +-/ + +public noncomputable section + +namespace Tests + +open Polynomial + +/-- The ordinary degree on `ℚ[X]` as a submultiplicative max-additive degree. -/ +def polynomialDegree : MaxAddDegree ℚ[X] ℕ where + toFun := Polynomial.degree + map_zero' := Polynomial.degree_zero + map_one_le_zero' := Polynomial.degree_one_le + map_neg' := Polynomial.degree_neg + map_add_le_max' := Polynomial.degree_add_le + map_mul_le_add' := Polynomial.degree_mul_le + +@[simp] +theorem polynomialDegree_apply (p : ℚ[X]) : + polynomialDegree p = p.degree := (rfl) + +/-- Ordinary polynomial degree is separated. -/ +theorem polynomialDegree_isSeparated : polynomialDegree.IsSeparated := by + rw [MaxAddDegree.isSeparated_iff] + intro p + rw [polynomialDegree_apply, Polynomial.degree_eq_bot] + +/-- Ordinary polynomial degree is exactly multiplicative over `ℚ`. -/ +instance polynomialDegree_isMultiplicative : polynomialDegree.IsMultiplicative := + ⟨fun _ _ ↦ Polynomial.degree_mul⟩ + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/Tests/Fixtures/PolynomialQuotientDegree.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/Tests/Fixtures/PolynomialQuotientDegree.lean new file mode 100644 index 0000000000..5dbf496001 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/Tests/Fixtures/PolynomialQuotientDegree.lean @@ -0,0 +1,74 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.QuotientDegree +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.Tests.Fixtures.PolynomialDegree +public import Mathlib.Algebra.Polynomial.Eval.Defs +public import Mathlib.RingTheory.Ideal.Maps + +/-! +# Polynomial quotient-degree fixture + +This module packages the least-representative degree on `ℚ[X] / (X - 1)`. It is shared by the +quotient-degree and associated-graded-quotient API clients. +-/ + +public noncomputable section + +namespace Tests + +open Polynomial + +/-- The ideal imposing the relation `X = 1`. -/ +def evaluationAtOneIdeal : Ideal ℚ[X] := + Ideal.span {X - C 1} + +/-- Evaluation of the ideal imposing `X = 1`. -/ +theorem evaluationAtOneIdeal_eq_span : + evaluationAtOneIdeal = Ideal.span {X - C 1} := + (rfl) + +theorem evaluationAtOneIdeal_le_ker_evalAtOne : + evaluationAtOneIdeal ≤ RingHom.ker (Polynomial.evalRingHom (1 : ℚ)) := by + rw [evaluationAtOneIdeal, Ideal.span_le] + intro p hp + rw [Set.mem_singleton_iff.mp hp] + change Polynomial.evalRingHom (1 : ℚ) (X - C 1) = 0 + simp + +/-- The quotient degree on `ℚ[X] / (X - 1)`. -/ +def evaluationAtOneQuotientDegree : MaxAddDegree (ℚ[X] ⧸ evaluationAtOneIdeal) ℕ := + polynomialDegree.quotient evaluationAtOneIdeal polynomialDegree_isSeparated + +@[simp] +theorem evaluationAtOneQuotientDegree_apply (q : ℚ[X] ⧸ evaluationAtOneIdeal) : + evaluationAtOneQuotientDegree q = + polynomialDegree.quotientValue evaluationAtOneIdeal + polynomialDegree_isSeparated q := by + rw [evaluationAtOneQuotientDegree, polynomialDegree.quotient_apply] + +theorem quotientMk_X_eq_quotientMk_one : + Ideal.Quotient.mk evaluationAtOneIdeal X = + Ideal.Quotient.mk evaluationAtOneIdeal (C 1) := by + rw [Ideal.Quotient.eq, evaluationAtOneIdeal] + exact Ideal.subset_span (Set.mem_singleton _) + +theorem quotientMk_one_ne_zero : + Ideal.Quotient.mk evaluationAtOneIdeal (C 1) ≠ 0 := by + intro hzero + have hmem : C (1 : ℚ) ∈ evaluationAtOneIdeal := + Ideal.Quotient.eq_zero_iff_mem.mp hzero + have hker := evaluationAtOneIdeal_le_ker_evalAtOne hmem + rw [RingHom.mem_ker] at hker + simp at hker + +theorem quotientMk_X_sub_one_eq_zero : + Ideal.Quotient.mk evaluationAtOneIdeal (X - C 1) = 0 := by + rw [Ideal.Quotient.eq_zero_iff_mem, evaluationAtOneIdeal] + exact Ideal.subset_span (Set.mem_singleton _) + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/Tests/QuotientDegree.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/Tests/QuotientDegree.lean new file mode 100644 index 0000000000..d5469d32ca --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/Tests/QuotientDegree.lean @@ -0,0 +1,58 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.Tests.Fixtures.PolynomialQuotientDegree + +/-! +# API checks for least-representative quotient degree + +The ordinary degree on `ℚ[X]` gives a separated max-additive degree. We quotient by `(X - 1)`. +The nonzero class of `X` also has the constant representative `1`, so its quotient degree is zero +rather than the degree one of `X`. Conversely, the zero class has the nonzero representative +`X - 1` of degree one but receives bottom degree. These two checks distinguish minimization over +all representatives and the explicit zero-class branch from the nearby wrong construction that +uses one arbitrarily chosen representative. +-/ + +public noncomputable section + +namespace Tests + +open Polynomial + +/-- The class of `X` has quotient degree zero because the same class has constant representative +`1`; a construction using the displayed representative `X` would assign degree one. -/ +theorem evaluationAtOneQuotientDegree_X_eq_zero : + evaluationAtOneQuotientDegree + (Ideal.Quotient.mk evaluationAtOneIdeal X) = 0 := by + rw [quotientMk_X_eq_quotientMk_one, evaluationAtOneQuotientDegree_apply] + have hle := polynomialDegree.quotientValue_mk_le evaluationAtOneIdeal + polynomialDegree_isSeparated (C (1 : ℚ)) + rw [polynomialDegree_apply, Polynomial.degree_C one_ne_zero] at hle + have hne : polynomialDegree.quotientValue evaluationAtOneIdeal + polynomialDegree_isSeparated (Ideal.Quotient.mk evaluationAtOneIdeal (C 1)) ≠ ⊥ := by + rw [ne_eq, polynomialDegree.quotientValue_eq_bot_iff] + exact quotientMk_one_ne_zero + obtain ⟨n, hn⟩ := WithBot.ne_bot_iff_exists.mp hne + rw [← hn] at hle ⊢ + have hn0 : n = 0 := Nat.eq_zero_of_le_zero (WithBot.coe_le_coe.mp hle) + simp [hn0] + +/-- The zero quotient class has bottom degree even when displayed by the degree-one representative +`X - 1`; a construction minimizing only nonzero classes without a zero branch would fail here. -/ +theorem evaluationAtOneQuotientDegree_X_sub_one_eq_bot : + evaluationAtOneQuotientDegree + (Ideal.Quotient.mk evaluationAtOneIdeal (X - C 1)) = ⊥ ∧ + (X - C (1 : ℚ)).degree = 1 := by + constructor + · rw [quotientMk_X_sub_one_eq_zero] + exact MaxAddDegree.map_zero evaluationAtOneQuotientDegree + · apply le_antisymm (Polynomial.degree_X_sub_C_le 1) + apply Polynomial.le_degree_of_ne_zero + norm_num [Polynomial.coeff_X, Polynomial.coeff_one] + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/Tests/RV.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/Tests/RV.lean new file mode 100644 index 0000000000..ee0d3018af --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/Tests/RV.lean @@ -0,0 +1,125 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.RV +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.OfValuation +public import Mathlib.Algebra.Order.Ring.Rat + +import Mathlib.Algebra.Ring.Prod + +/-! +# API checks for RV classes, initial forms, and the residue ring + +The fixtures are Mathlib valuations read as multiplicative max-additive degrees through +`MaxAddDegree.ofValuation`. The first-projection valuation on `ℚ × ℚ` is nonseparated. Its +nonzero kernel element `(0, 1)` therefore separates LM24's RV quotient from a quotient that +collapses only literal zero. The representatives `(1, 1)` and `(1, 0)` further verify that adding +a kernel element preserves both the RV class and the leading homogeneous class. + +The separated trivial valuation on `ℚ` checks the grade-zero residue-ring multiplication on +nontrivial representatives. These tests use only the public RV and associated-graded interfaces. +-/ +public noncomputable section + +namespace Tests + +open scoped DirectSum + +/-- The trivial valuation pulled back along the first projection, used to test the RV quotient. -/ +def rvFirstProjectionValuation : MaxAddDegree (ℚ × ℚ) ℕ := + MaxAddDegree.ofValuation + ((1 : Valuation ℚ (WithZero (Multiplicative ℕ))).comap (RingHom.fst ℚ ℚ)) + +instance : rvFirstProjectionValuation.IsMultiplicative := + inferInstanceAs (MaxAddDegree.ofValuation _).IsMultiplicative + +/-- The nonzero element `(0, 1)` in the support of the first-projection valuation. -/ +def rvSupportElement : ℚ × ℚ := + (0, 1) + +theorem rvSupportElement_ne_zero : rvSupportElement ≠ 0 := by + norm_num [rvSupportElement] + +theorem rvFirstProjectionValuation_value_support : + rvFirstProjectionValuation rvSupportElement = ⊥ := by + simp [MaxAddDegree.ofValuation_apply, rvSupportElement, rvFirstProjectionValuation, + Valuation.one_apply_def] + +/-- The RV zero class contains the nonzero support element `(0, 1)`. -/ +theorem rvSupportElement_rv_eq_zero : + rvFirstProjectionValuation.rv rvSupportElement = 0 := by + rw [MaxAddDegree.rv_eq_zero_iff] + exact rvFirstProjectionValuation_value_support + +/-- The standard-order encoding of the RV relation is reflexive at a nonzero support element. -/ +theorem rvSupportElement_self_related : + rvFirstProjectionValuation.RVRel rvSupportElement rvSupportElement := + rvFirstProjectionValuation.rvRel_refl rvSupportElement + +/-- Representatives differing by a nonzero support element have the same RV class. -/ +theorem rvFirstProjectionValuation_same_rv : + rvFirstProjectionValuation.rv (1, 1) = rvFirstProjectionValuation.rv (1, 0) := by + rw [MaxAddDegree.rv_eq_iff] + rw [MaxAddDegree.rvRel_iff] + right + constructor + · simp [MaxAddDegree.ofValuation_apply, rvFirstProjectionValuation, + Valuation.one_apply_def] + · simp [MaxAddDegree.ofValuation_apply, rvFirstProjectionValuation, + Valuation.one_apply_def] + +/-- RV-equivalent representatives have the same initial form. -/ +theorem rvFirstProjectionValuation_same_initialForm : + rvFirstProjectionValuation.initialForm (1, 1) = + rvFirstProjectionValuation.initialForm (1, 0) := by + exact rvFirstProjectionValuation.initialForm_eq_of_rvRel + ((MaxAddDegree.rv_eq_iff rvFirstProjectionValuation).mp + rvFirstProjectionValuation_same_rv) + +/-- The RV-to-homogeneous map retains multiplication and the support zero. -/ +theorem rvHomogeneous_support_mul_one : + rvFirstProjectionValuation.rvHomogeneous + (rvFirstProjectionValuation.rv rvSupportElement * + rvFirstProjectionValuation.rv (1, 0)) = 0 := by + rw [rvSupportElement_rv_eq_zero, zero_mul, map_zero] + +/-- The trivial valuation on the rationals in max-additive notation for RV computations. -/ +def rvTrivialValuation : MaxAddDegree ℚ ℕ := + MaxAddDegree.ofValuation 1 + +instance : rvTrivialValuation.IsMultiplicative := + inferInstanceAs (MaxAddDegree.ofValuation _).IsMultiplicative + +/-- The rational number two in filtration degree zero for the RV multiplication fixture. -/ +def rvTwoRepresentative : rvTrivialValuation.filtrationLE 0 := + ⟨2, by simp [MaxAddDegree.ofValuation_apply, rvTrivialValuation, Valuation.one_apply_def]⟩ + +/-- The rational number three in filtration degree zero for the RV multiplication fixture. -/ +def rvThreeRepresentative : rvTrivialValuation.filtrationLE 0 := + ⟨3, by simp [MaxAddDegree.ofValuation_apply, rvTrivialValuation, Valuation.one_apply_def]⟩ + +/-- The rational number six in filtration degree zero for the RV multiplication fixture. -/ +def rvSixRepresentative : rvTrivialValuation.filtrationLE 0 := + ⟨6, by simp [MaxAddDegree.ofValuation_apply, rvTrivialValuation, Valuation.one_apply_def]⟩ + +/-- Multiplication in the residue ring computes the product of the classes of two and three. -/ +theorem residueRing_two_mul_three : + rvTrivialValuation.componentMk 0 rvTwoRepresentative * + rvTrivialValuation.componentMk 0 rvThreeRepresentative = + rvTrivialValuation.componentMk 0 rvSixRepresentative := by + apply rvTrivialValuation.residueRingHom_injective + rw [map_mul] + rw [MaxAddDegree.residueRingHom_apply, + MaxAddDegree.residueRingHom_apply, MaxAddDegree.residueRingHom_apply, + ← MaxAddDegree.homogeneousMk_apply, ← MaxAddDegree.homogeneousMk_apply, + ← MaxAddDegree.homogeneousMk_apply] + rw [MaxAddDegree.homogeneousMk_mul] + apply congrArg (rvTrivialValuation.homogeneousMk 0) + apply Subtype.ext + norm_num [rvTwoRepresentative, rvThreeRepresentative, rvSixRepresentative] + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/Tests/Residue.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/Tests/Residue.lean new file mode 100644 index 0000000000..7281ad5031 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Algebra/Valuation/Tests/Residue.lean @@ -0,0 +1,186 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.ResidueMathlib +public import Mathlib.Algebra.Order.Ring.Rat +public import Mathlib.NumberTheory.Padics.PadicNumbers + +import Mathlib.Algebra.Ring.Prod + +/-! +# API checks for the residue map + +The first-projection valuation on `ℚ × ℚ` has a nonzero support ideal. Its residue map kills a +nonzero support element but not an element of value zero, which distinguishes the strictly +negative kernel from the zero ideal. + +The first cancellation fixture uses two representatives of value zero whose sum has bottom value. +A second fixture uses the separated `2`-adic valuation: `2` has the nonbottom value `-1`, and two +copies of the value-zero representative `1` add to it. This distinguishes the strictly negative +ideal from the support ideal and checks additivity across a genuine finite value drop. The root +`LM24` module does not import this client. +-/ + +public noncomputable section + +open scoped DirectSum + +namespace Tests + +/-- The trivial valuation pulled back along the first projection, used to test the residue map. -/ +def residueFirstProjectionValuation : MaxAddDegree (ℚ × ℚ) ℕ := + MaxAddDegree.ofValuation + ((1 : Valuation ℚ (WithZero (Multiplicative ℕ))).comap (RingHom.fst ℚ ℚ)) + +instance : residueFirstProjectionValuation.IsMultiplicative := + inferInstanceAs (MaxAddDegree.ofValuation _).IsMultiplicative + +/-- The element `(0, 1)` of the nonpositive subring, lying in the valuation support. -/ +def residueSupportElement : residueFirstProjectionValuation.nonpositiveSubring := + ⟨(0, 1), by + rw [MaxAddDegree.mem_nonpositiveSubring_iff] + simp [MaxAddDegree.ofValuation_apply, residueFirstProjectionValuation, + Valuation.one_apply_def]⟩ + +/-- The element `(1, 1)` of the nonpositive subring, whose degree is zero. -/ +def residueValueZeroElement : residueFirstProjectionValuation.nonpositiveSubring := + ⟨(1, 1), by + rw [MaxAddDegree.mem_nonpositiveSubring_iff] + simp [MaxAddDegree.ofValuation_apply, residueFirstProjectionValuation, + Valuation.one_apply_def]⟩ + +/-- The element `(1, 0)` of the nonpositive subring, used with its negative to test residue +classes. -/ +def residuePositiveUnit : residueFirstProjectionValuation.nonpositiveSubring := + ⟨(1, 0), by + rw [MaxAddDegree.mem_nonpositiveSubring_iff] + simp [MaxAddDegree.ofValuation_apply, residueFirstProjectionValuation, + Valuation.one_apply_def]⟩ + +/-- The element `(-1, 0)` of the nonpositive subring, used with its negative to test residue +classes. -/ +def residueNegativeUnit : residueFirstProjectionValuation.nonpositiveSubring := + ⟨(-1, 0), by + rw [MaxAddDegree.mem_nonpositiveSubring_iff] + simp [MaxAddDegree.ofValuation_apply, residueFirstProjectionValuation, + Valuation.one_apply_def]⟩ + +/-- The residue kernel contains a nonzero element of the original ring. -/ +theorem residueMap_supportElement_eq_zero : + residueFirstProjectionValuation.residueMap residueSupportElement = 0 := by + rw [MaxAddDegree.residueMap_eq_zero_iff] + simp [MaxAddDegree.ofValuation_apply, residueFirstProjectionValuation, + residueSupportElement, Valuation.one_apply_def] + +/-- An element of value zero does not lie in the residue kernel. -/ +theorem residueMap_valueZeroElement_ne_zero : + residueFirstProjectionValuation.residueMap residueValueZeroElement ≠ 0 := by + rw [ne_eq, MaxAddDegree.residueMap_eq_zero_iff] + simp [MaxAddDegree.ofValuation_apply, residueFirstProjectionValuation, + residueValueZeroElement, Valuation.one_apply_def] + +/-- Two value-zero representatives can cancel to an element of strictly lower value. -/ +theorem residueMap_cancellation_fixture : + residueFirstProjectionValuation.residueMap residuePositiveUnit ≠ 0 ∧ + residueFirstProjectionValuation.residueMap residueNegativeUnit ≠ 0 ∧ + residueFirstProjectionValuation.residueMap + (residuePositiveUnit + residueNegativeUnit) = 0 := by + constructor + · rw [ne_eq, MaxAddDegree.residueMap_eq_zero_iff] + simp [MaxAddDegree.ofValuation_apply, residueFirstProjectionValuation, + residuePositiveUnit, Valuation.one_apply_def] + constructor + · rw [ne_eq, MaxAddDegree.residueMap_eq_zero_iff] + simp [MaxAddDegree.ofValuation_apply, residueFirstProjectionValuation, + residueNegativeUnit, Valuation.one_apply_def] + · have hsum : residuePositiveUnit + residueNegativeUnit = 0 := by + apply Subtype.ext + simp [residuePositiveUnit, residueNegativeUnit] + rw [hsum, map_zero] + +/-- The two nonzero residue classes in the cancellation fixture add to zero. -/ +theorem residueMap_cancellation_sum_eq_zero : + residueFirstProjectionValuation.residueMap residuePositiveUnit + + residueFirstProjectionValuation.residueMap residueNegativeUnit = 0 := by + rw [← map_add] + exact residueMap_cancellation_fixture.2.2 + +example (m : ℕ) : Module residueFirstProjectionValuation.ResidueRing + (residueFirstProjectionValuation.Component m) := + inferInstance + +/-- The grade-zero scalar action is the homogeneous product used by LM24. -/ +theorem residueModule_smul_embeds_as_mul (m : ℕ) + (a : residueFirstProjectionValuation.ResidueRing) + (b : residueFirstProjectionValuation.Component m) : + DirectSum.of residueFirstProjectionValuation.Component m (a • b) = + DirectSum.of residueFirstProjectionValuation.Component 0 a * + DirectSum.of residueFirstProjectionValuation.Component m b := + DirectSum.of_zero_smul _ a b + +section Padic + +local instance : Fact (Nat.Prime 2) := ⟨Nat.prime_two⟩ + +/-- The two-adic valuation on the rationals in max-additive notation. -/ +abbrev residueTwoAdicValuation : MaxAddDegree ℚ ℤ := + MaxAddDegree.ofValuation (Rat.padicValuation 2) + +/-- The rational unit in the nonpositive subring of the two-adic valuation. -/ +def residueTwoAdicOne : residueTwoAdicValuation.nonpositiveSubring := + ⟨1, by simp⟩ + +/-- The element `2` has the nonbottom max-additive value `-1`. -/ +theorem residueTwoAdic_value_two : + residueTwoAdicValuation 2 = ((-1 : ℤ) : WithBot ℤ) := by + rw [MaxAddDegree.ofValuation_apply] + have h := congrArg + (fun z : WithZero (Multiplicative ℤ) ↦ + Multiplicative.toAdd (WithZero.toMulBot z)) + (Rat.padicValuation_self 2) + exact h.trans (by rfl) + +/-- The rational number two in the nonpositive subring of the two-adic valuation. -/ +def residueTwoAdicTwo : residueTwoAdicValuation.nonpositiveSubring := + ⟨2, by + rw [MaxAddDegree.mem_nonpositiveSubring_iff, residueTwoAdic_value_two] + simp⟩ + +/-- The strictly negative residue kernel is larger than the support ideal. -/ +theorem residueTwoAdic_two_eq_zero : + residueTwoAdicValuation.residueMap residueTwoAdicTwo = 0 := by + rw [MaxAddDegree.residueMap_eq_zero_iff] + rw [show (residueTwoAdicTwo : ℚ) = 2 from rfl, residueTwoAdic_value_two] + simp + +theorem residueTwoAdic_one_ne_zero : + residueTwoAdicValuation.residueMap residueTwoAdicOne ≠ 0 := by + rw [ne_eq, MaxAddDegree.residueMap_eq_zero_iff] + simp [residueTwoAdicOne] + +/-- +Two value-zero representatives add in the valuation subring to `2`, whose value is strictly +negative and nonbottom; their residue classes therefore sum to zero. +-/ +theorem residueTwoAdic_one_add_one_eq_zero : + residueTwoAdicValuation.residueMap residueTwoAdicOne + + residueTwoAdicValuation.residueMap residueTwoAdicOne = 0 := by + rw [← map_add] + have hsum : residueTwoAdicOne + residueTwoAdicOne = residueTwoAdicTwo := by + apply Subtype.ext + norm_num [residueTwoAdicOne, residueTwoAdicTwo] + rw [hsum, residueTwoAdic_two_eq_zero] + +theorem residueTwoAdic_negativeIdeal_mathlib_bridge : + residueTwoAdicValuation.negativeIdeal = + ((Rat.padicValuation 2).ltIdeal 1).comap + (MaxAddDegree.nonpositiveEquivInteger (Rat.padicValuation 2)).toRingHom := + MaxAddDegree.negativeIdeal_ofValuation_eq_comap_ltIdeal (Rat.padicValuation 2) + +end Padic + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Blueprint.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Blueprint.lean new file mode 100644 index 0000000000..570bce4fa9 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Blueprint.lean @@ -0,0 +1,232 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import Lean +public meta import Batteries.Lean.NameMapAttribute + +/-! # Blueprint -/ + +public meta section + +open Lean Elab Command + +namespace ConwayRefinement.Blueprint + +/-- Mathematical phases used by the generated proof map. -/ +meta def phases : Array String := #[ + "Algebraic and ordinal preliminaries", + "Ordinal value and degree", + "Cantor–Bendixson ranks of supports", + "Algebraic independence in graded rings", + "Translated truncations", + "Limit ordinals in the degree induction", + "Principal RV-elements", + "Polynomial presentations", + "Primality and factorisation for real exponents", + "Finitely many Archimedean classes", + "Refinement over Archimedean classes", + "A cut criterion for Cauchy completeness", + "Bounded generalised-power-series integer parts", + "Surreal numbers and omnific integers", +] + +/-- The mathematical account attached to one selected Lean declaration. -/ +structure Node where + /-- The fully qualified name of the Lean declaration described by this node. -/ + name : Name + /-- The label identifying the declaration in the mathematical proof map. -/ + label : String + /-- The phase of the mathematical argument containing the declaration. -/ + phase : String + /-- The title displayed for this declaration in the proof map. -/ + title : String + /-- The informal mathematical statement attached to the declaration. -/ + statement : String + /-- The informal proof explanation attached to the declaration. -/ + proof : String + /-- Whether to highlight this declaration in the proof map. -/ + highlight : Bool := false +deriving Inhabited, ToExpr + +/-- Checked blueprint metadata, persisted with each compiled module. -/ +initialize nodeExt : NameMapExtension Node ← registerNameMapExtension Node + +/-- Syntax for specifying the phase of a blueprint declaration. -/ +syntax blueprintPhaseOption := "(" &"phase" " := " str ")" +/-- Syntax for specifying the title of a blueprint declaration. -/ +syntax blueprintTitleOption := "(" &"title" " := " str ")" +/-- Syntax for attaching an informal statement to a blueprint declaration. -/ +syntax blueprintStatementOption := "(" &"statement" " := " plainDocComment ")" +/-- The proof-map option containing an informal proof as a documentation comment. -/ +syntax blueprintProofOption := "(" &"proof" " := " plainDocComment ")" +/-- The optional marker highlighting a result in the mathematical proof map. -/ +syntax blueprintHighlightOption := "(" &"highlight" ")" +/-- The label, phase, title, statement, proof, and optional highlight of a proof-map entry. -/ +syntax blueprintOptions := + str ppSpace blueprintPhaseOption ppSpace blueprintTitleOption + ppSpace blueprintStatementOption ppSpace blueprintProofOption + (ppSpace blueprintHighlightOption)? + +/-- Internal attribute implementing proof-map metadata. -/ +syntax (name := conwayRefinementBlueprint) "conway_refinement_blueprint" ppSpace + blueprintOptions : attr + +/-- Select a declaration for the mathematical proof map. -/ +macro "blueprint" ppSpace options:blueprintOptions : attr => + `(attr| conway_refinement_blueprint $options:blueprintOptions) + +/-- Reject a proof-map label whose prefix does not identify a recognized mathematical result +kind. -/ +def resultKindForLabel (label : String) : CoreM Unit := do + unless #["def:", "thm:", "lem:", "prop:", "cor:", "fact:"].any + (fun resultPrefix => label.startsWith resultPrefix) do + throwError "blueprint label {label} has no recognized mathematical result kind" + +/-- Parse and validate the proof-map metadata attached to a declaration. -/ +def elaborateNode (name : Name) : Syntax → CoreM Node + | `(attr| conway_refinement_blueprint $label:str + (phase := $phase:str) + (title := $title:str) + (statement := $statement) + (proof := $proof) + $[$highlight:blueprintHighlightOption]?) => do + let label := label.getString + let phase := phase.getString + unless phases.contains phase do + throwError "unknown proof-map phase {phase}" + resultKindForLabel label + return { + name + label + phase + title := title.getString + statement := (← getDocStringText statement).trimAscii.copy + proof := (← getDocStringText proof).trimAscii.copy + highlight := highlight.isSome + } + | _ => throwUnsupportedSyntax + +initialize registerBuiltinAttribute { + name := `conwayRefinementBlueprint + descr := "selects a declaration for the mathematical proof map" + applicationTime := .afterCompilation + add := fun name stx kind => do + unless kind == AttributeKind.global do + throwError "invalid attribute 'blueprint', must be global" + nodeExt.add name (← elaborateNode name stx) +} + +private structure CollectContext where + environment : Environment + root : Name + +private structure CollectState where + visited : NameSet := {} + selected : NameSet := {} + +private abbrev CollectM := ReaderT CollectContext (StateM CollectState) + +private def collectSelected : Nat → Name → CollectM Unit + | 0, _ => pure () + | fuel + 1, name => do + let state ← get + unless state.visited.contains name do + modify fun state => { state with visited := state.visited.insert name } + let { environment, root } ← read + if name != root && (nodeExt.find? environment name).isSome then + modify fun state => { state with selected := state.selected.insert name } + else + let collectExpression (expression : Expr) : CollectM Unit := + expression.getUsedConstants.forM (collectSelected fuel) + match environment.find? name with + | some (.axiomInfo _) => pure () + | some (.defnInfo value) => collectExpression value.type *> collectExpression value.value + | some (.thmInfo value) => collectExpression value.type *> collectExpression value.value + | some (.opaqueInfo value) => collectExpression value.type *> collectExpression value.value + | some (.quotInfo _) => pure () + | some (.ctorInfo value) => collectExpression value.type + | some (.recInfo value) => collectExpression value.type + | some (.inductInfo value) => + collectExpression value.type *> value.ctors.forM (collectSelected fuel) + | none => pure () + +private def declarationType : ConstantInfo → Expr + | .axiomInfo value | .defnInfo value | .thmInfo value | .opaqueInfo value | + .ctorInfo value | .recInfo value | .inductInfo value => value.type + | .quotInfo value => value.type + +private def declarationValue? : ConstantInfo → Option Expr + | .defnInfo value => some value.value + | .thmInfo value => some value.value + | .opaqueInfo value => some value.value + | _ => none + +private def collectDependencies (environment : Environment) (root : Name) : + NameSet × NameSet := Id.run do + let some info := environment.find? root | return ({}, {}) + let mut statementState : CollectState := {} + for name in (declarationType info).getUsedConstants do + (_, statementState) := ((collectSelected (environment.constants.toList.length + 1) name).run { environment, root }).run statementState + let mut proofState := statementState + if let some value := declarationValue? info then + for name in value.getUsedConstants do + (_, proofState) := ((collectSelected (environment.constants.toList.length + 1) name).run { environment, root }).run proofState + return (statementState.selected, proofState.selected \ statementState.selected) + +private def namesJson (names : NameSet) : Json := + .arr <| names.toArray.qsort Name.lt |>.map fun name => .str name.toString + +private def positionJson (position : Position) : Json := Json.mkObj [ + ("line", position.line), + ("column", position.column) +] + +private def rangeJson (range : DeclarationRange) : Json := Json.mkObj [ + ("start", positionJson range.pos), + ("end", positionJson range.endPos) +] + +private def moduleOf (environment : Environment) (name : Name) : Name := + match environment.getModuleIdxFor? name with + | some index => environment.allImportedModuleNames[index.toNat]! + | none => environment.header.mainModule + +private def nodeJson (node : Node) : CoreM Json := do + let environment ← getEnv + let moduleName := moduleOf environment node.name + let range ← findDeclarationRanges? node.name + let (statementDependencies, proofDependencies) := + collectDependencies environment node.name + return Json.mkObj [ + ("name", node.name.toString), + ("label", node.label), + ("phase", node.phase), + ("title", node.title), + ("statement", node.statement), + ("proof", node.proof), + ("highlight", node.highlight), + ("module", moduleName.toString), + ("source", s!"{moduleName.toString.replace "." "/"}.lean"), + ("range", range.map (fun ranges => rangeJson ranges.range) |>.getD Json.null), + ("statementDependencies", namesJson statementDependencies), + ("proofDependencies", namesJson proofDependencies) + ] + +private def blueprintJson : CoreM Json := do + let environment ← getEnv + let entries := (nodeExt.getState environment).get.toList.toArray + let nodes := entries.map (·.2) |>.qsort fun left right => + left.name.toString < right.name.toString + return .arr (← nodes.mapM nodeJson) + +/-- Write checked blueprint metadata for the currently imported modules. -/ +elab "#write_blueprint_data" path:str : command => do + let json ← liftCoreM blueprintJson + IO.FS.writeFile path.getString json.pretty + +end ConwayRefinement.Blueprint diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Data.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Data.lean new file mode 100644 index 0000000000..2fa0daba1d --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Data.lean @@ -0,0 +1,11 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Data.Multiset + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Data/Multiset.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Data/Multiset.lean new file mode 100644 index 0000000000..b6cc145366 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Data/Multiset.lean @@ -0,0 +1,12 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Data.Multiset.SelectionComplexity +public import LeanPool.ConwayRefinement.ConwayRefinement.Data.Multiset.Tests + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Data/Multiset/SelectionComplexity.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Data/Multiset/SelectionComplexity.lean new file mode 100644 index 0000000000..a03bb5f5ac --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Data/Multiset/SelectionComplexity.lean @@ -0,0 +1,407 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import Mathlib.SetTheory.Cardinal.Order +public import Mathlib.SetTheory.Ordinal.Basic +public import Mathlib.Data.Multiset.DershowitzManna +import Mathlib.Data.Finset.Max +import Lean.Elab.Tactic.Omega + +/-! +# Selection and decreasing multiset complexity + +Selection minimizes an ordinal priority, then maximizes an ordinal weight, with a fixed +well-order resolving ties. Complexity records the weights of distinct members at least as +heavy as the selection, followed by the selected multiplicity. Thus duplicating other members +does not increase the first component. + +Removing one selected copy, doubling the other multiplicities, and adjoining lighter members +of no smaller priority strictly decreases this well-founded complexity. The argument abstracts +the finite-expression reduction in Berarducci, Definitions 9.1--9.3 and Lemma 9.5; it assumes +no series, ring, or valuation. The first component uses the Mathlib Dershowitz--Manna relation. +-/ + +public noncomputable section +universe u v +namespace Multiset + +/-- Ordinal priorities and weights for selection in a finite multiset. -/ +structure SelectionWeights (α : Type v) where + /-- The ordinal priority to minimize when selecting a multiset member. -/ + priority : α → Ordinal.{u} + /-- The ordinal weight to maximize among members of equal least priority. -/ + weight : α → Ordinal.{u} + +namespace SelectionWeights +variable {α : Type v} (s : SelectionWeights.{u, v} α) + +/-- A member of least priority, greatest weight among those, and least in a fixed well-order. -/ +structure IsSelected (w : Multiset α) (x : α) : Prop where + mem : x ∈ w + min_priority : ∀ y ∈ w, s.priority x ≤ s.priority y + max_weight : ∀ y ∈ w, s.priority y = s.priority x → + s.weight y ≤ s.weight x + least : ∀ y ∈ w, s.priority y = s.priority x → s.weight y = s.weight x → + ¬ WellOrderingRel y x + +/-- Every nonempty finite multiset has a unique selected member. -/ +theorem existsUnique_isSelected {w : Multiset α} (hw : w ≠ 0) : + ∃! x, s.IsSelected w x := by + classical + have hne : w.toFinset.Nonempty := by + rw [Finset.nonempty_iff_ne_empty] + intro h + exact hw (Multiset.toFinset_eq_empty.mp h) + obtain ⟨x₀, hx₀, hx₀min⟩ := + w.toFinset.exists_min_image (fun y ↦ s.priority y) hne + set A := w.toFinset.filter fun y ↦ s.priority y = s.priority x₀ with hAdef + have hAne : A.Nonempty := ⟨x₀, by simp [hAdef, hx₀]⟩ + obtain ⟨x₁, hx₁, hx₁max⟩ := A.exists_max_image (fun y ↦ s.weight y) hAne + set B := A.filter fun y ↦ s.weight y = s.weight x₁ with hBdef + have hBne : (↑B : Set α).Nonempty := + ⟨x₁, by simp [hBdef, hx₁]⟩ + have hwf : WellFounded (WellOrderingRel (α := α)) := + (WellOrderingRel.isWellOrder (α := α)).wf + set x := hwf.min _ hBne with hxdef + have hxB : x ∈ B := hwf.min_mem _ hBne + have hxA : x ∈ A := (Finset.mem_filter.mp hxB).1 + have hxw : x ∈ w := Multiset.mem_toFinset.mp (Finset.mem_filter.mp hxA).1 + have hxprin : s.priority x = s.priority x₀ := (Finset.mem_filter.mp hxA).2 + have hxord : s.weight x = s.weight x₁ := (Finset.mem_filter.mp hxB).2 + refine ⟨x, ⟨hxw, ?_, ?_, ?_⟩, ?_⟩ + · intro y hy + rw [hxprin] + exact hx₀min y (Multiset.mem_toFinset.mpr hy) + · intro y hy hyprin + rw [hxord] + refine hx₁max y ?_ + simp only [hAdef, Finset.mem_filter, Multiset.mem_toFinset] + exact ⟨hy, hyprin.trans hxprin⟩ + · intro y hy hyprin hyord + have hyB : y ∈ (↑B : Set α) := by + simp only [hBdef, hAdef, Finset.mem_coe, Finset.mem_filter, Multiset.mem_toFinset] + exact ⟨⟨hy, hyprin.trans hxprin⟩, hyord.trans hxord⟩ + exact hwf.not_lt_min _ hyB + · rintro y hy + have hsel : s.IsSelected w x := by + refine ⟨hxw, ?_, ?_, ?_⟩ + · intro z hz + rw [hxprin] + exact hx₀min z (Multiset.mem_toFinset.mpr hz) + · intro z hz hzprin + rw [hxord] + refine hx₁max z ?_ + simp only [hAdef, Finset.mem_filter, Multiset.mem_toFinset] + exact ⟨hz, hzprin.trans hxprin⟩ + · intro z hz hzprin hzord + have hzB : z ∈ (↑B : Set α) := by + simp only [hBdef, hAdef, Finset.mem_coe, Finset.mem_filter, Multiset.mem_toFinset] + exact ⟨⟨hz, hzprin.trans hxprin⟩, hzord.trans hxord⟩ + exact hwf.not_lt_min _ hzB + have hprin : s.priority y = s.priority x := + le_antisymm (hy.min_priority x hxw) (hsel.min_priority y hy.mem) + have hord : s.weight y = s.weight x := + le_antisymm (hsel.max_weight y hy.mem hprin) (hy.max_weight x hxw hprin.symm) + rcases trichotomous_of + (WellOrderingRel : α → _ → Prop) y x with h | h | h + · exact absurd h (hsel.least y hy.mem hprin hord) + · exact h + · exact absurd h (hy.least x hxw hprin.symm hord.symm) + +/-- The selected member of a nonempty multiset. -/ +noncomputable def selected (w : Multiset α) (hw : w ≠ 0) : + α := + (s.existsUnique_isSelected hw).choose + +theorem isSelected_selected (w : Multiset α) (hw : w ≠ 0) : + s.IsSelected w (s.selected w hw) := + (s.existsUnique_isSelected hw).choose_spec.1 + +theorem eq_selected_of_isSelected {w : Multiset α} (hw : w ≠ 0) + {x : α} (hx : s.IsSelected w x) : x = s.selected w hw := + (s.existsUnique_isSelected hw).choose_spec.2 x hx + +theorem selected_singleton (x : α) : + s.selected {x} (by simp) = x := by + refine (s.eq_selected_of_isSelected (by simp) ⟨by simp, ?_, ?_, ?_⟩).symm + · intro y hy + rw [Multiset.mem_singleton.mp hy] + · intro y hy _ + rw [Multiset.mem_singleton.mp hy] + · intro y hy _ _ + rw [Multiset.mem_singleton.mp hy] + exact irrefl_of (WellOrderingRel : α → _ → Prop) x + +open Classical in +/-- The multiplicity of the selected member. -/ +noncomputable def selectedExponent (w : Multiset α) (hw : w ≠ 0) : ℕ := + w.count (s.selected w hw) + +theorem selected_cons_of_mem {w : Multiset α} (hw : w ≠ 0) + {y : α} (hy : y ∈ w) : + s.selected (y ::ₘ w) Multiset.cons_ne_zero = s.selected w hw := by + have hmem : ∀ z ∈ y ::ₘ w, z ∈ w := + fun z hz ↦ (Multiset.mem_cons.mp hz).elim (fun h ↦ h ▸ hy) id + have hsel := s.isSelected_selected w hw + refine (s.eq_selected_of_isSelected Multiset.cons_ne_zero ⟨Multiset.mem_cons_of_mem hsel.mem, + fun z hz ↦ hsel.min_priority z (hmem z hz), + fun z hz ↦ hsel.max_weight z (hmem z hz), + fun z hz ↦ hsel.least z (hmem z hz)⟩).symm + +open Classical in +theorem selectedExponent_eq_count (w : Multiset α) (hw : w ≠ 0) : + s.selectedExponent w hw = w.count (s.selected w hw) := (rfl) + +open Classical in +/-- The weights of distinct members at least as heavy as the selected member. -/ +noncomputable def relevantValues (w : Multiset α) (hw : w ≠ 0) : Multiset Ordinal := + (w.toFinset.filter fun y ↦ s.weight (s.selected w hw) ≤ s.weight y).val.map + fun y ↦ s.weight y + +open Classical in +theorem relevantValues_eq_map (w : Multiset α) (hw : w ≠ 0) : + s.relevantValues w hw = (w.toFinset.filter fun y ↦ + s.weight (s.selected w hw) ≤ s.weight y).val.map fun y ↦ s.weight y := + (rfl) + +open Classical in +/-- Equal selections and equal relevant members give the same relevant-weight multiset. -/ +theorem relevantValues_congr {w w' : Multiset α} (hw : w ≠ 0) (hw' : w' ≠ 0) + (hsel : s.selected w hw = s.selected w' hw') + (hmem : ∀ y, s.weight (s.selected w hw) ≤ s.weight y → (y ∈ w ↔ y ∈ w')) : + s.relevantValues w hw = s.relevantValues w' hw' := by + have hfilter : (w.toFinset.filter fun y ↦ s.weight (s.selected w hw) ≤ s.weight y) + = w'.toFinset.filter fun y ↦ s.weight (s.selected w hw) ≤ s.weight y := by + ext y + simp only [Finset.mem_filter, Multiset.mem_toFinset] + exact and_congr_left fun h ↦ hmem y h + rw [relevantValues, relevantValues, ← hsel, hfilter] + +/-- The distinct relevant weights, followed by the selected multiplicity. -/ +noncomputable def complexity (w : Multiset α) (hw : w ≠ 0) : Multiset Ordinal × ℕ := + (s.relevantValues w hw, s.selectedExponent w hw) + +/-- Lexicographic decrease of relevant weights in the Dershowitz--Manna order, then multiplicity. -/ +def ComplexityLT : (Multiset Ordinal × ℕ) → (Multiset Ordinal × ℕ) → Prop := + Prod.Lex Multiset.IsDershowitzMannaLT (· < ·) + +/-- The complexity order is well-founded. -/ +theorem wellFounded_complexityLT : WellFounded (ComplexityLT) := + WellFounded.prod_lex Multiset.wellFounded_isDershowitzMannaLT wellFounded_lt + +theorem complexityLT_of_relevantValues {w w' : Multiset α} {hw : w ≠ 0} {hw' : w' ≠ 0} + {X Y Z : Multiset Ordinal} (hZ : Z ≠ 0) (hw'X : s.relevantValues w' hw' = X + Y) + (hwX : s.relevantValues w hw = X + Z) (hYZ : ∀ y ∈ Y, ∃ z ∈ Z, y < z) : + ComplexityLT (s.complexity w' hw') (s.complexity w hw) := + Prod.Lex.left _ _ ⟨X, Y, Z, hZ, hw'X, hwX, hYZ⟩ + +theorem complexityLT_of_selectedExponent {w w' : Multiset α} {hw : w ≠ 0} {hw' : w' ≠ 0} + (h₁ : s.relevantValues w' hw' = s.relevantValues w hw) + (h₂ : s.selectedExponent w' hw' < s.selectedExponent w hw) : + ComplexityLT (s.complexity w' hw') (s.complexity w hw) := by + rw [complexity, complexity, h₁] + exact Prod.Lex.right _ h₂ + +open Classical in +/-- The multiset remaining after removing every copy of the selected member. -/ +noncomputable def unselected (w : Multiset α) (hw : w ≠ 0) : Multiset α := + w.filter (· ≠ s.selected w hw) + +open Classical in +theorem unselected_eq (w : Multiset α) (hw : w ≠ 0) : + s.unselected w hw = w.filter (· ≠ s.selected w hw) := (rfl) + +open Classical in +theorem mem_unselected {w : Multiset α} {hw : w ≠ 0} + {y : α} : + y ∈ s.unselected w hw ↔ y ∈ w ∧ y ≠ s.selected w hw := by + rw [unselected] + exact Multiset.mem_filter + +open Classical in +/-- Remove one selected copy, double all other copies, and adjoin the replacement multiset. -/ +noncomputable def reduced (w : Multiset α) (hw : w ≠ 0) (t : Multiset α) : + Multiset α := + t + Multiset.replicate (s.selectedExponent w hw - 1) (s.selected w hw) + + (s.unselected w hw + s.unselected w hw) + +theorem reduced_eq (w : Multiset α) (hw : w ≠ 0) (t : Multiset α) : + s.reduced w hw t = t + Multiset.replicate (s.selectedExponent w hw - 1) (s.selected w hw) + + (s.unselected w hw + s.unselected w hw) := (rfl) + +theorem mem_reduced {w : Multiset α} {hw : w ≠ 0} {t : Multiset α} + {y : α} : + y ∈ s.reduced w hw t ↔ y ∈ t ∨ (s.selectedExponent w hw - 1 ≠ 0 ∧ y = s.selected w hw) ∨ + (y ∈ w ∧ y ≠ s.selected w hw) := by + rw [reduced] + simp only [Multiset.mem_add, Multiset.mem_replicate, s.mem_unselected, or_self, or_assoc] + +theorem one_le_selectedExponent (w : Multiset α) (hw : w ≠ 0) : + 1 ≤ s.selectedExponent w hw := by + classical + rw [s.selectedExponent_eq_count] + exact Multiset.count_pos.mpr (s.isSelected_selected w hw).mem + +open Classical in +/-- A replacement excluding the selected member reduces its multiplicity by one. -/ +theorem count_selected_reduced {w : Multiset α} {hw : w ≠ 0} {t : Multiset α} + (ht : s.selected w hw ∉ t) : + Multiset.count (s.selected w hw) (s.reduced w hw t) = s.selectedExponent w hw - 1 := by + rw [reduced] + simp only [Multiset.count_add, Multiset.count_replicate_self] + rw [Multiset.count_eq_zero.mpr ht, + Multiset.count_eq_zero.mpr fun h ↦ (s.mem_unselected.mp h).2 rfl] + omega + +open Classical in +/-- A member distinct from the selection and absent from the replacement is doubled. -/ +theorem count_reduced_of_ne {w : Multiset α} {hw : w ≠ 0} {t : Multiset α} + {y : α} (hy : y ≠ s.selected w hw) (hyt : y ∉ t) : + Multiset.count y (s.reduced w hw t) = 2 * Multiset.count y w := by + rw [reduced, unselected] + simp only [Multiset.count_add, Multiset.count_replicate, Multiset.count_filter, + ite_eq_right (Ne.symm hy), ite_eq_left hy, Multiset.count_eq_zero.mpr hyt] + omega + +theorem selected_mem_reduced {w : Multiset α} {hw : w ≠ 0} {t : Multiset α} + (hk : 1 < s.selectedExponent w hw) : s.selected w hw ∈ s.reduced w hw t := + s.mem_reduced.mpr (Or.inr (Or.inl ⟨by omega, rfl⟩)) + +theorem selectedExponent_lt_of_isSelected {w : Multiset α} {hw : w ≠ 0} + {t : Multiset α} (hw₂ : s.reduced w hw t ≠ 0) + (ht : s.selected w hw ∉ t) (hsel : s.selected (s.reduced w hw t) hw₂ = s.selected w hw) : + s.selectedExponent (s.reduced w hw t) hw₂ < s.selectedExponent w hw := by + rw [s.selectedExponent_eq_count, hsel, s.count_selected_reduced ht] + have := s.one_le_selectedExponent w hw + omega + +/-- If a selected copy remains, lighter replacements of no smaller priority preserve selection. -/ +theorem isSelected_reduced (w : Multiset α) (hw : w ≠ 0) (t : Multiset α) + (ht : ∀ u ∈ t, s.weight u < s.weight (s.selected w hw)) + (htp : ∀ u ∈ t, s.priority (s.selected w hw) ≤ s.priority u) + (hk : 1 < s.selectedExponent w hw) : + s.IsSelected (s.reduced w hw t) (s.selected w hw) := by + have hsel := s.isSelected_selected w hw + refine ⟨s.mem_reduced.mpr (Or.inr (Or.inl ⟨by omega, rfl⟩)), ?_, ?_, ?_⟩ + · intro y hy + rcases s.mem_reduced.mp hy with h | ⟨-, rfl⟩ | ⟨hyw, -⟩ + · exact htp y h + · exact le_rfl + · exact hsel.min_priority y hyw + · intro y hy hyp + rcases s.mem_reduced.mp hy with h | ⟨-, rfl⟩ | ⟨hyw, -⟩ + · exact (ht y h).le + · exact le_rfl + · exact hsel.max_weight y hyw hyp + · intro y hy hyp hyo + rcases s.mem_reduced.mp hy with h | ⟨-, rfl⟩ | ⟨hyw, -⟩ + · exact absurd hyo (ht y h).ne + · exact irrefl_of (WellOrderingRel : α → _ → Prop) _ + · exact hsel.least y hyw hyp hyo + +/-- Deleting the selection and introducing only lighter new members strictly lowers complexity. -/ +theorem complexityLT_of_forall_lt_or_mem {w w' : Multiset α} (hw : w ≠ 0) (hw' : w' ≠ 0) + (h : ∀ u ∈ w', s.weight u < s.weight (s.selected w hw) ∨ + (u ∈ w ∧ u ≠ s.selected w hw)) : + ComplexityLT (s.complexity w' hw') (s.complexity w hw) := by + classical + set f : α → Ordinal := fun y ↦ s.weight y with hf + set S : Finset α := w'.toFinset.filter + (fun y ↦ s.weight (s.selected w' hw') ≤ s.weight y) with hS + set T : Finset α := + w.toFinset.filter (fun y ↦ s.weight (s.selected w hw) ≤ s.weight y) with hT + have hxT : s.selected w hw ∈ T := + Finset.mem_filter.mpr ⟨Multiset.mem_toFinset.mpr (s.isSelected_selected w hw).mem, le_rfl⟩ + set R : Finset α := T.erase (s.selected w hw) with hR + have hkey : ∀ u ∈ S, u ∉ R → s.weight u < s.weight (s.selected w hw) := by + intro u hu huR + have humem : u ∈ w' := Multiset.mem_toFinset.mp (Finset.mem_filter.mp hu).1 + rcases h u humem with hlt | ⟨huw, hux⟩ + · exact hlt + · rw [hR, Finset.mem_erase] at huR + have hTu : u ∉ T := fun hmem ↦ huR ⟨hux, hmem⟩ + refine lt_of_not_ge fun hle ↦ hTu ?_ + rw [hT] + exact Finset.mem_filter.mpr ⟨Multiset.mem_toFinset.mpr huw, hle⟩ + have hsplit : ∀ A B : Finset α, + A.val = (A ∩ B).val + (A \ B).val := by + intro A B + rw [← Finset.filter_mem_eq_inter, Finset.sdiff_eq_filter, Finset.filter_val, + Finset.filter_val] + exact (Multiset.filter_add_not _ _).symm + refine s.complexityLT_of_relevantValues (X := (S ∩ R).val.map f) (Y := (S \ R).val.map f) + (Z := f (s.selected w hw) ::ₘ (R \ S).val.map f) (by simp) ?_ ?_ ?_ + · rw [relevantValues_eq_map, ← hS, hsplit S R, Multiset.map_add] + · rw [relevantValues_eq_map, ← hT, ← Multiset.cons_erase (s := T.val) hxT, + ← Finset.erase_val, ← hR, Multiset.map_cons, hsplit R S, Multiset.map_add, + Finset.inter_comm, Multiset.add_cons] + · intro y hy + obtain ⟨u, hu, rfl⟩ := Multiset.mem_map.mp hy + rw [Finset.mem_val, Finset.mem_sdiff] at hu + exact ⟨f (s.selected w hw), Multiset.mem_cons_self _ _, + hkey u hu.1 hu.2⟩ + +/-- Removing every selected copy strictly lowers complexity when the remainder is nonempty. -/ +theorem complexityLT_unselected {w : Multiset α} (hw : w ≠ 0) + (hr : s.unselected w hw ≠ 0) : + ComplexityLT (s.complexity (s.unselected w hw) hr) (s.complexity w hw) := + s.complexityLT_of_forall_lt_or_mem hw hr fun _ hu ↦ Or.inr (s.mem_unselected.mp hu) + +/-- Replacing one selected copy by lighter members of no smaller priority strictly lowers +complexity, even while doubling every other member. -/ +theorem complexityLT_reduced (w : Multiset α) (hw : w ≠ 0) (t : Multiset α) + (ht : ∀ u ∈ t, s.weight u < s.weight (s.selected w hw)) + (htp : ∀ u ∈ t, s.priority (s.selected w hw) ≤ s.priority u) + (hw₂ : s.reduced w hw t ≠ 0) : + ComplexityLT (s.complexity (s.reduced w hw t) hw₂) (s.complexity w hw) := by + classical + have htmem : s.selected w hw ∉ t := fun h ↦ absurd (ht _ h) (lt_irrefl _) + rcases lt_or_ge 1 (s.selectedExponent w hw) with hk | hk + · -- Case 1: the selected factor survives, so only its exponent moves. + have hsel : s.selected (s.reduced w hw t) hw₂ = s.selected w hw := + (s.eq_selected_of_isSelected hw₂ (s.isSelected_reduced w hw t ht htp hk)).symm + refine s.complexityLT_of_selectedExponent ?_ + (s.selectedExponent_lt_of_isSelected hw₂ htmem hsel) + refine s.relevantValues_congr hw₂ hw hsel fun y hy ↦ ?_ + rw [hsel] at hy + constructor + · intro hmem + rcases s.mem_reduced.mp hmem with hmem | ⟨-, rfl⟩ | ⟨hmem, -⟩ + · exact absurd hy (not_le.mpr (ht y hmem)) + · exact (s.isSelected_selected w hw).mem + · exact hmem + · intro hmem + by_cases hyx : y = s.selected w hw + · exact s.mem_reduced.mpr (Or.inr (Or.inl ⟨by omega, hyx⟩)) + · exact s.mem_reduced.mpr (Or.inr (Or.inr ⟨hmem, hyx⟩)) + · -- Case 2: the selected factor disappears, and its value is replaced by smaller ones. + have hk1 : s.selectedExponent w hw - 1 = 0 := by + have := s.one_le_selectedExponent w hw + omega + refine s.complexityLT_of_forall_lt_or_mem hw hw₂ fun u hu ↦ ?_ + rcases s.mem_reduced.mp hu with hmem | ⟨hne, -⟩ | hmem + · exact Or.inl (ht u hmem) + · exact absurd hk1 hne + · exact Or.inr hmem + +/-- The selected copies and the remaining factors partition the original multiset. -/ +theorem replicate_selectedExponent_add_unselected (w : Multiset α) (hw : w ≠ 0) : + Multiset.replicate (s.selectedExponent w hw) (s.selected w hw) + s.unselected w hw = w := by + classical + refine Multiset.ext.mpr fun y ↦ ?_ + rw [Multiset.count_add, s.unselected_eq, Multiset.count_replicate, Multiset.count_filter] + by_cases hy : y = s.selected w hw + · subst hy + rw [ite_eq_left rfl, ite_eq_right (fun h ↦ h rfl), add_zero, s.selectedExponent_eq_count] + · rw [ite_eq_right (Ne.symm hy), ite_eq_left hy, zero_add] + +/-- The complexity consists of the relevant distinct-factor weights and selected multiplicity. -/ +theorem complexity_eq (w : Multiset α) (hw : w ≠ 0) : + s.complexity w hw = (s.relevantValues w hw, s.selectedExponent w hw) := (rfl) + +end SelectionWeights +end Multiset diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Data/Multiset/Tests.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Data/Multiset/Tests.lean new file mode 100644 index 0000000000..0ac9e0fcb5 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Data/Multiset/Tests.lean @@ -0,0 +1,11 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Data.Multiset.Tests.SelectionComplexity + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Data/Multiset/Tests/SelectionComplexity.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Data/Multiset/Tests/SelectionComplexity.lean new file mode 100644 index 0000000000..602e0e4eab --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Data/Multiset/Tests/SelectionComplexity.lean @@ -0,0 +1,105 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module +public import LeanPool.ConwayRefinement.ConwayRefinement.Data.Multiset.SelectionComplexity +import Mathlib.Tactic.Tauto + +/-! +# Distinct-factor complexity checks + +The fixture separates the intended first component from the tempting wrong version that +counts every occurrence: the number of factors grows from three to four, but distinct +relevant weights remain unchanged and the selected multiplicity falls. A second check removes +the selected member entirely. Both use only the compiled public selection API. +-/ + +public noncomputable section +namespace Tests.Selection +open Multiset + +/-- Lower priority selects 1 over the heavier member 2. -/ +def weights : SelectionWeights.{0, 0} ℕ where + priority n := if n = 2 then 1 else 0 + weight n := n + 1 + +private theorem selected_pair : + weights.selected ((1 ::ₘ {2}) : Multiset ℕ) (by simp) = 1 := by + symm + apply weights.eq_selected_of_isSelected + constructor + · simp + · intro y hy + simp only [mem_cons, mem_singleton] at hy + rcases hy with rfl | rfl <;> simp [weights] + · intro y hy hp + simp only [mem_cons, mem_singleton] at hy + rcases hy with rfl | rfl <;> simp_all [weights] + · intro y hy hp _ + simp only [mem_cons, mem_singleton] at hy + rcases hy with rfl | rfl + · exact irrefl_of (WellOrderingRel : ℕ → ℕ → Prop) 1 + · simp [weights] at hp + +private theorem selected_triple : + weights.selected ((1 ::ₘ 1 ::ₘ {2}) : Multiset ℕ) (by simp) = 1 := by + rw [weights.selected_cons_of_mem (by simp) (by simp : 1 ∈ ((1 ::ₘ {2}) : Multiset ℕ))] + exact selected_pair + +/-- Duplicating the heavier, higher-priority member does not change distinct relevant weights. +The selected multiplicity decreases while the total number of factors increases. -/ +theorem multiplicity_drop : + weights.reduced ((1 ::ₘ 1 ::ₘ {2}) : Multiset ℕ) (by simp) {0} = (0 ::ₘ 1 ::ₘ 2 ::ₘ {2}) ∧ + weights.relevantValues ((1 ::ₘ 1 ::ₘ {2}) : Multiset ℕ) (by simp) = + weights.relevantValues ((0 ::ₘ 1 ::ₘ 2 ::ₘ {2}) : Multiset ℕ) (by simp) ∧ + SelectionWeights.ComplexityLT + (weights.complexity ((0 ::ₘ 1 ::ₘ 2 ::ₘ {2}) : Multiset ℕ) (by simp)) + (weights.complexity ((1 ::ₘ 1 ::ₘ {2}) : Multiset ℕ) (by simp)) := by + have hred : weights.reduced ((1 ::ₘ 1 ::ₘ {2}) : Multiset ℕ) (by simp) {0} = + (0 ::ₘ 1 ::ₘ 2 ::ₘ {2}) := by + rw [weights.reduced_eq, weights.selectedExponent_eq_count, weights.unselected_eq, + selected_triple] + simp [Multiset.filter_singleton, Multiset.cons_swap] + have ht : ∀ u ∈ ({0} : Multiset ℕ), weights.weight u < + weights.weight (weights.selected ((1 ::ₘ 1 ::ₘ {2}) : Multiset ℕ) (by simp)) := by + rw [selected_triple] + simp [weights] + have hp : ∀ u ∈ ({0} : Multiset ℕ), + weights.priority (weights.selected ((1 ::ₘ 1 ::ₘ {2}) : Multiset ℕ) (by simp)) ≤ + weights.priority u := by + rw [selected_triple] + simp [weights] + refine ⟨hred, ?_, ?_⟩ + · have hsel := weights.isSelected_reduced ((1 ::ₘ 1 ::ₘ {2}) : Multiset ℕ) (by simp) {0} + ht hp (by rw [weights.selectedExponent_eq_count, selected_triple]; simp) + rw [hred, selected_triple] at hsel + have hs := weights.eq_selected_of_isSelected (by simp) hsel + apply weights.relevantValues_congr (by simp) (by simp) (selected_triple.trans hs) + intro y hy + rw [selected_triple] at hy + simp only [weights] at hy + simp only [mem_cons, mem_singleton] + constructor + · tauto + · rintro (rfl | rfl | rfl | rfl) + · simp at hy + all_goals simp + · simpa only [hred] using weights.complexityLT_reduced ((1 ::ₘ 1 ::ₘ {2}) : Multiset ℕ) + (by simp) {0} ht hp (by rw [hred]; simp) + +/-- Once the selected copy disappears, the first complexity component decreases. -/ +theorem selection_disappears : + SelectionWeights.ComplexityLT + (weights.complexity ((0 ::ₘ 2 ::ₘ {2}) : Multiset ℕ) (by simp)) + (weights.complexity ((1 ::ₘ {2}) : Multiset ℕ) (by simp)) := by + have hred : weights.reduced ((1 ::ₘ {2}) : Multiset ℕ) (by simp) {0} = (0 ::ₘ 2 ::ₘ {2}) := by + rw [weights.reduced_eq, weights.selectedExponent_eq_count, weights.unselected_eq, + selected_pair] + simp [Multiset.filter_singleton, Multiset.cons_swap] + simpa only [hred] using weights.complexityLT_reduced ((1 ::ₘ {2}) : Multiset ℕ) + (by simp) {0} (by rw [selected_pair]; simp [weights]) (by rw [selected_pair]; simp [weights]) + (by rw [hred]; simp) + +end Tests.Selection diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Examples.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Examples.lean new file mode 100644 index 0000000000..c988e9d905 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Examples.lean @@ -0,0 +1,11 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Examples.OmnificInteger + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Examples/OmnificInteger.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Examples/OmnificInteger.lean new file mode 100644 index 0000000000..eb32ecf23c --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Examples/OmnificInteger.lean @@ -0,0 +1,15 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Examples.OmnificInteger.DegreeTwoNormalForm +public import LeanPool.ConwayRefinement.ConwayRefinement.Examples.OmnificInteger.DegreeTwoPrime +public import LeanPool.ConwayRefinement.ConwayRefinement.Examples.OmnificInteger.OneRowNormalForm +public import LeanPool.ConwayRefinement.ConwayRefinement.Examples.OmnificInteger.OneRowPrime +public import LeanPool.ConwayRefinement.ConwayRefinement.Examples.OmnificInteger.ZFCDegreeTwoPrime + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Examples/OmnificInteger/DegreeTwoNormalForm.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Examples/OmnificInteger/DegreeTwoNormalForm.lean new file mode 100644 index 0000000000..68489036f2 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Examples/OmnificInteger/DegreeTwoNormalForm.lean @@ -0,0 +1,175 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import Mathlib.Data.Prod.Lex +public import Mathlib.SetTheory.Ordinal.Arithmetic +public import LeanPool.ConwayRefinement.CombinatorialGames.Surreal.HahnSeries.Basic + +/-! +# The normal form of a degree-two omnific integer + +The nonconstant exponents of the explicit element are + +`1 / (m + 1) + 1 / ((m + 1) * (m + 2) * (n + 1))`, + +for `m n : ℕ`, and every displayed coefficient is one. For fixed `m` these exponents decrease to +`1 / (m + 1)`; the rows themselves decrease to zero. The final constant term is also one. + +The construction is universe-polymorphic: the normal form is written in the surreal numbers of +every universe `u`. Its support order type and primeness are stated in `DegreeTwoPrime`. +-/ + +universe u + +@[expose] public noncomputable section + +namespace Surreal.OmnificInteger.DegreeTwoExample + +open Set + +/-- The positive Conway exponent in row `m` and column `n`. -/ +def exponent (m n : ℕ) : ℝ := + 1 / (m + 1 : ℝ) + + 1 / ((m + 1 : ℝ) * (m + 2 : ℝ) * (n + 1 : ℝ)) + +@[simp] +theorem exponent_apply (m n : ℕ) : + exponent m n = + 1 / (m + 1 : ℝ) + + 1 / ((m + 1 : ℝ) * (m + 2 : ℝ) * (n + 1 : ℝ)) := by + rfl + +private def cutoff (m : ℕ) : ℝ := + 1 / (m + 1 : ℝ) + +private theorem exponent_strictAnti_second (m : ℕ) : + StrictAnti (exponent m) := by + apply strictAnti_nat_of_succ_lt + intro n + rw [exponent_apply, exponent_apply] + gcongr + omega + +private theorem cutoff_lt_exponent (m n : ℕ) : + cutoff m < exponent m n := by + rw [cutoff, exponent_apply] + have : 0 < + 1 / ((m + 1 : ℝ) * (m + 2 : ℝ) * (n + 1 : ℝ)) := by + positivity + linarith + +private theorem next_exponent_zero_lt_cutoff (m : ℕ) : + exponent (m + 1) 0 < cutoff m := by + rw [exponent_apply, cutoff] + field_simp + norm_num [Nat.cast_add, Nat.cast_one] + ring_nf + nlinarith + +private theorem exponent_gt_of_first_lt + {m m' n n' : ℕ} (hmm' : m < m') : + exponent m n > exponent m' n' := by + calc + exponent m' n' ≤ exponent (m + 1) 0 := by + by_cases hsucc : m + 1 = m' + · subst m' + exact (exponent_strictAnti_second (m + 1)).antitone (Nat.zero_le n') + · have hfirst : m + 1 < m' := lt_of_le_of_ne (Nat.succ_le_iff.mpr hmm') hsucc + exact (exponent_gt_of_first_lt hfirst).le + _ < cutoff m := next_exponent_zero_lt_cutoff m + _ < exponent m n := cutoff_lt_exponent m n +termination_by m' - m + +private theorem exponent_strictAnti_lex : + StrictAnti (fun p : Lex (ℕ × ℕ) ↦ exponent (ofLex p).1 (ofLex p).2) := by + intro p q hpq + rw [Prod.Lex.lt_iff] at hpq + rcases hpq with hfirst | ⟨hfirst, hsecond⟩ + · exact exponent_gt_of_first_lt hfirst + · change exponent (ofLex p).1 (ofLex p).2 > exponent (ofLex q).1 (ofLex q).2 + rw [hfirst] + exact exponent_strictAnti_second _ hsecond + +/-- The row-column index, followed by one final index for the constant term. -/ +abbrev Index := WithTop (Lex (ℕ × ℕ)) + +/-- The exponent sequence of the concrete Conway normal form. -/ +def exponentAtIndex : Index → Surreal.{u} + | ⊤ => 0 + | (p : Lex (ℕ × ℕ)) => (exponent (ofLex p).1 (ofLex p).2 : ℝ) + +private theorem exponent_pos (m n : ℕ) : 0 < exponent m n := by + rw [exponent_apply] + positivity + +private theorem exponentAtIndex_strictAnti : StrictAnti exponentAtIndex.{u} := by + intro p q hpq + induction p using WithTop.recTopCoe with + | top => exact (not_lt_of_ge le_top hpq).elim + | coe p => + induction q using WithTop.recTopCoe with + | top => + change (0 : Surreal) < (exponent (ofLex p).1 (ofLex p).2 : ℝ) + exact_mod_cast exponent_pos (ofLex p).1 (ofLex p).2 + | coe q => + change ((exponent (ofLex q).1 (ofLex q).2 : ℝ) : Surreal) < + (exponent (ofLex p).1 (ofLex p).2 : ℝ) + exact_mod_cast exponent_strictAnti_lex (WithTop.coe_lt_coe.mp hpq) + +/-- The coefficient function of the explicit normal form. -/ +def coefficient (i : Surreal.{u}) : ℝ := + by + classical + exact if i ∈ range exponentAtIndex then 1 else 0 + +private theorem support_coefficient : + Function.support coefficient.{u} = range exponentAtIndex := by + classical + ext i + simp [Function.support, coefficient] + +/-- The displayed coefficient support is small enough for `SurrealHahnSeries` in every +universe. -/ +theorem small_support_coefficient : + Small.{u} (Function.support coefficient.{u}) := by + rw [support_coefficient] + infer_instance + +/-- The displayed exponents are reverse well-ordered. -/ +theorem wellFoundedOn_support_coefficient : + (Function.support coefficient.{u}).WellFoundedOn (· > ·) := by + rw [support_coefficient, wellFoundedOn_range] + convert wellFounded_lt (α := Index) using 1 + ext p q + exact exponentAtIndex_strictAnti.lt_iff_gt + +/-- The explicit Conway normal form with all coefficients equal to one. -/ +def normalForm : SurrealHahnSeries.{u} := + SurrealHahnSeries.mk coefficient small_support_coefficient + wellFoundedOn_support_coefficient + +@[simp] +theorem normalForm_coeff (i : Surreal.{u}) : + normalForm.coeff i = coefficient i := by + rw [normalForm, SurrealHahnSeries.coeff_mk, coefficient] + +@[simp] +theorem normalForm_support : normalForm.{u}.support = range exponentAtIndex := by + rw [normalForm, SurrealHahnSeries.support_mk, support_coefficient] + +theorem normalForm_coeff_exponent (m n : ℕ) : + normalForm.{u}.coeff (exponent m n : ℝ) = 1 := by + classical + rw [normalForm_coeff, coefficient, ite_eq_left] + exact ⟨(↑(toLex (m, n)) : Index), rfl⟩ + +theorem normalForm_coeff_zero : normalForm.{u}.coeff 0 = 1 := by + classical + rw [normalForm_coeff, coefficient, ite_eq_left] + exact ⟨⊤, rfl⟩ + +end Surreal.OmnificInteger.DegreeTwoExample diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Examples/OmnificInteger/DegreeTwoPrime.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Examples/OmnificInteger/DegreeTwoPrime.lean new file mode 100644 index 0000000000..de46f7c5bc --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Examples/OmnificInteger/DegreeTwoPrime.lean @@ -0,0 +1,237 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.OmnificInteger.Primality.IrreducibleOmnificIntegers +public import LeanPool.ConwayRefinement.ConwayRefinement.Examples.OmnificInteger.DegreeTwoNormalForm + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.DegreeTwo.DegreeTwoExample +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.CharZero +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.NonpositiveCoefficientMap +import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.Degree +import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.ArchimedeanAssumptions +import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.HahnSeries.DegreeTransfer +import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.HahnSeries.IntegerPart +import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.HahnSeries.RealLeadingSplit + +/-! +# An explicit degree-two prime in the omnific integers + +The PS06 construction supplies a generalised power series of support order type `ω ^ 2 + 1` +whose three independent translated-truncation classes modulo `J + K` prevent a nontrivial +factorisation, +over every field of characteristic zero. The omnific integer `ofRealSeries` of its real form has +this series as its signed Conway normal form. Irreducibility over the infinitesimal Hahn field +transfers to the omnific integer by the residue-one case of LM24, Proposition 8.3.6(5). +Every irreducible series and every irreducible omnific integer is prime. Everything is proved in +the model of Conway's `Oz` inside the surreal numbers of an arbitrary universe `u`. + +## References + +* J. Pommersheim, S. Shahriari, *Unique factorization in generalized power series rings*, +Proc. Amer. Math. Soc. 134 (2006), 1277–1287, cited as [PS06]. +* S. L'Innocente, V. Mantova, *A factorisation theory for generalised power series and omnific + integers*, Adv. Math. 442 (2024) 109513, cited as [LM24]. +-/ + +open scoped HahnSeries + +universe u + +noncomputable section + +namespace Surreal.OmnificInteger.DegreeTwoExample + +open HahnSeries.Nonpositive PommersheimShahriari.DegreeTwoExample + +private theorem degreeTwoWithConstant_ne_zero : degreeTwoWithConstant (K := ℝ) ≠ 0 := by + intro hzero + have hcoeff := degreeTwoWithConstant_coeff_zero (K := ℝ) + rw [hzero] at hcoeff + norm_num at hcoeff + +private theorem degreeTwoWithConstant_constantCoeff_mem : + constantCoeff (degreeTwoWithConstant (K := ℝ)) ∈ Surreal.realIntegerSubring := by + rw [degreeTwoWithConstant_constantCoeff] + exact Surreal.realIntegerSubring.one_mem + +/-- The signed degree-two series has negative order: its exponent `q₀,₀` carries coefficient one +and is negative. -/ +private theorem signedDegreeTwo_order_neg : + (mapRealDomainToSurreal (degreeTwoWithConstant (K := ℝ)) : ℝ⟦Surreal.{u}⟧).order < 0 := by + have hcoeff : (mapRealDomainToSurreal (degreeTwoWithConstant (K := ℝ)) : + ℝ⟦Surreal.{u}⟧).coeff ((degreeTwoExponentPair (0, 0) : ℝ) : Surreal) ≠ 0 := by + have h := degreeTwoWithConstant_coeff_embedding (K := ℝ) 0 0 + rw [degreeTwoExponentEmbedding_apply] at h + rw [mapRealDomainToSurreal_coeff_real, h] + exact one_ne_zero + refine (HahnSeries.order_le_of_coeff_ne_zero hcoeff).trans_lt ?_ + norm_num [degreeTwoExponentPair_apply] + +private theorem signedDegreeTwo_order_ne_zero : + (mapRealDomainToSurreal (degreeTwoWithConstant (K := ℝ)) : ℝ⟦Surreal.{u}⟧).order ≠ 0 := + signedDegreeTwo_order_neg.ne + +private theorem degreeTwoExponentPair_eq_neg_exponent (m n : ℕ) : + degreeTwoExponentPair (m, n) = + -DegreeTwoExample.exponent m n := by + rw [degreeTwoExponentPair_apply, + DegreeTwoExample.exponent_apply] + ring + +public section + +/-- The explicit PS06 series is prime over every characteristic-zero coefficient field. -/ +@[blueprint "thm:degree-two-series-prime" + (phase := "Surreal numbers and omnific integers") + (title := "Primality of an explicit degree-two series") + (statement := /-- + Let $K$ be a field of characteristic $0$. The series + \[ + 1+\sum_{m,n\in\mathbb N} + t^{-\frac{1}{m+1}-\frac{1}{(m+1)(m+2)(n+1)}} + \] + is prime in $K((\mathbb R^{\le 0}))$. + -/) + (proof := /-- + The nonconstant support consists of $\omega$ successive blocks of order type + $\omega$ and accumulates at $0$; adjoining the constant term gives support + order type $\omega^2+1$. Three translated-truncation classes from distinct + blocks are linearly independent modulo $J+K$, so their span has dimension + greater than $2$. Hence \ref{fact:ps06-irreducibility} makes the displayed + series irreducible. It is prime by + \ref{cor:hahn-series-irreducible-is-prime}. + -/)] +theorem degreeTwoWithConstant_prime {K : Type*} [Field K] [CharZero K] : + Prime (degreeTwoWithConstant (K := K)) := + Berarducci.prime_of_irreducible degreeTwoWithConstant_irreducible + +/-- The explicit degree-two omnific integer obtained from the PS06 series with three independent +classes modulo `J`. -/ +def degreeTwoOz : Surreal.OmnificInteger.{u} := + ofRealSeries (degreeTwoWithConstant (K := ℝ)) degreeTwoWithConstant_constantCoeff_mem + +private theorem degreeTwoOz_signed : + degreeTwoOz.{u}.1.toSignedFullHahnSeries = + mapRealDomainToSurreal (degreeTwoWithConstant (K := ℝ)) := + toSignedFullHahnSeries_ofRealSeries _ _ + +/-- The explicit PS06 omnific integer is irreducible. -/ +theorem degreeTwoOz_irreducible : Irreducible degreeTwoOz.{u} := by + apply irreducible_ofRealSeries + apply irreducible_mapRealDomainToSurrealIntegerPart Surreal.archimedeanStrata + Surreal.realIntegerSubring (degreeTwoWithConstant (K := ℝ)) degreeTwoWithConstant_ne_zero + signedDegreeTwo_order_ne_zero degreeTwoWithConstant_constantCoeff + rw [nonpositiveCoefficientMap_degreeTwoWithConstant] + exact degreeTwoWithConstant_irreducible + (K := ℝ⟦FiniteArchimedeanClass.ball ℝ Surreal.realFiniteClass⟧) + +/-- The explicit construction has the prescribed Conway normal form. -/ +theorem degreeTwoOz_toHahnSeries : degreeTwoOz.{u}.1.toHahnSeries = + DegreeTwoExample.normalForm := by + apply Surreal.toHahnSeries_eq_of_toSignedFullHahnSeries_eq degreeTwoOz_signed + · intro r + by_cases hr : r ∈ Set.range degreeTwoExponentEmbedding + · obtain ⟨p, rfl⟩ := hr + rcases p with ⟨m, n⟩ + have hcoeff := degreeTwoWithConstant_coeff_embedding (K := ℝ) m n + rw [degreeTwoExponentEmbedding_apply] at hcoeff + change DegreeTwoExample.normalForm.coeff + (-((degreeTwoExponentEmbedding (toLex (m, n)) : ℝ) : Surreal)) = + ((degreeTwoWithConstant (K := ℝ) : Berarducci.Series ℝ) : ℝ⟦ℝ⟧).coeff + (degreeTwoExponentEmbedding (toLex (m, n))) + rw [degreeTwoExponentEmbedding_apply, hcoeff, degreeTwoExponentPair_eq_neg_exponent, + Real.toSurreal_neg, neg_neg, + DegreeTwoExample.normalForm_coeff_exponent] + · by_cases hr0 : r = 0 + · subst hr0 + rw [degreeTwoWithConstant_coeff_zero] + simpa using DegreeTwoExample.normalForm_coeff_zero + · rw [degreeTwoWithConstant_coeff_eq_zero hr hr0, ← not_ne_iff, + ← SurrealHahnSeries.mem_support_iff, + DegreeTwoExample.normalForm_support] + rintro ⟨p, hp⟩ + induction p using WithTop.recTopCoe with + | top => + apply hr0 + have h0 : (0 : Surreal) = -(r : Surreal) := hp + exact_mod_cast (neg_eq_zero.mp h0.symm) + | coe q => + rcases q with ⟨m, n⟩ + apply hr + refine ⟨toLex (m, n), ?_⟩ + have hmn : + ((DegreeTwoExample.exponent m n : ℝ) : Surreal) = + -(r : Surreal) := hp + rw [← Real.toSurreal_neg, Real.toSurreal_inj] at hmn + rw [degreeTwoExponentEmbedding_apply, degreeTwoExponentPair_eq_neg_exponent, hmn, + neg_neg] + · rw [DegreeTwoExample.normalForm_support] + rintro _ ⟨p, rfl⟩ + induction p using WithTop.recTopCoe with + | top => + refine ⟨0, ?_⟩ + change -((0 : ℝ) : Surreal) = (0 : Surreal) + simp + | coe q => + rcases q with ⟨m, n⟩ + refine ⟨-DegreeTwoExample.exponent m n, ?_⟩ + change -((-DegreeTwoExample.exponent m n : ℝ) : Surreal) = + ((DegreeTwoExample.exponent m n : ℝ) : Surreal) + rw [Real.toSurreal_neg, neg_neg] + +/-- The Conway support of the explicit omnific integer is the displayed two-dimensional exponent +sequence followed by exponent zero. -/ +theorem degreeTwoOz_support : degreeTwoOz.{u}.1.support = + Set.range DegreeTwoExample.exponentAtIndex := by + rw [← Surreal.support_toHahnSeries, degreeTwoOz_toHahnSeries, + DegreeTwoExample.normalForm_support] + +/-- The Conway normal form of the explicit omnific integer has exact support order type +`ω ^ 2 + 1`. -/ +theorem degreeTwoOz_length : degreeTwoOz.{u}.1.length = + Ordinal.omega0 ^ (2 : Ordinal) + 1 := by + have hlift := Ordinal.lift_omega0_opow_natCast.{u, 0} 2 + simp only [Nat.cast_ofNat] at hlift + rw [degreeTwoOz, length_ofRealSeries, degreeTwoWithConstant_supportOrderType, Ordinal.lift_add, + Ordinal.lift_one, hlift] + +/-- The explicit PS06 omnific integer is reduced: its Hahn exponents lie in one nonzero +Archimedean class. -/ +theorem degreeTwoOz_isReduced : degreeTwoOz.{u}.toSignedNonpositiveHahn.IsReduced := + isReduced_ofRealSeries _ _ signedDegreeTwo_order_ne_zero + degreeTwoWithConstant_constantCoeff + +/-- The omnific integer obtained from the explicit PS06 series is prime. -/ +@[blueprint "thm:explicit-omnific-prime" + (phase := "Surreal numbers and omnific integers") + (title := "Primality of an explicit degree-two omnific integer") + (statement := /-- + The omnific integer + \[ + 1+\sum_{m,n\in\mathbb N} + \omega^{\frac{1}{m+1}+\frac{1}{(m+1)(m+2)(n+1)}} + \] + is prime in $\mathbf{Oz}$. + -/) + (proof := /-- + In the signed orientation $t=\omega^{-1}$, the nonconstant part is the + real-exponent series above, now over the coefficient field of the leading + Archimedean class. By \ref{fact:ps06-irreducibility}, that series is + irreducible. Coefficient + transport and the residue-one irreducibility transfer then make the displayed + omnific integer irreducible. It is prime by + \ref{thm:omnific-factorisation}. + -/) + (highlight)] +theorem degreeTwoOz_prime : Prime degreeTwoOz.{u} := + Surreal.OmnificInteger.prime_of_irreducible _ degreeTwoOz_irreducible + +end + +end Surreal.OmnificInteger.DegreeTwoExample diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Examples/OmnificInteger/OneRowNormalForm.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Examples/OmnificInteger/OneRowNormalForm.lean new file mode 100644 index 0000000000..a7a4315272 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Examples/OmnificInteger/OneRowNormalForm.lean @@ -0,0 +1,121 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.CombinatorialGames.Surreal.HahnSeries.Basic +public import Mathlib.Basic.Real.Basic +public import Mathlib.Order.TypeTags + +/-! +# Conway's one-row omnific integer + +This module writes the normal form + +`1 + Σ n : ℕ, ω ^ (1 / (n + 1))`, + +with every displayed coefficient equal to one. Its positive exponents form one decreasing row +converging to zero, followed by the final constant term. The sibling statement `OneRowPrime` +records its arithmetic properties using only Mathlib and CombinatorialGames. +-/ + +@[expose] public noncomputable section + +namespace Surreal.OmnificInteger.OneRowExample + +open Set + +/-- The `n`-th positive exponent in Conway's one-row normal form. -/ +def exponent (n : ℕ) : ℝ := + 1 / (n + 1 : ℝ) + +@[simp] +theorem exponent_apply (n : ℕ) : exponent n = 1 / (n + 1 : ℝ) := by + rfl + +private theorem exponent_strictAnti : StrictAnti exponent := by + refine strictAnti_nat_of_succ_lt fun n ↦ ?_ + rw [exponent_apply, exponent_apply] + apply one_div_lt_one_div_of_lt + · positivity + · norm_num + +/-- The natural-number row followed by the final constant-term index. -/ +abbrev Index := WithTop ℕ + +/-- The exponent at an index of the displayed normal form. -/ +def exponentAtIndex : Index → Surreal + | ⊤ => 0 + | (n : ℕ) => (exponent n : ℝ) + +private theorem exponent_pos (n : ℕ) : 0 < exponent n := by + rw [exponent_apply] + positivity + +private theorem exponentAtIndex_strictAnti : StrictAnti exponentAtIndex := by + intro p q hpq + induction p using WithTop.recTopCoe with + | top => exact (not_lt_of_ge le_top hpq).elim + | coe p => + induction q using WithTop.recTopCoe with + | top => + change (0 : Surreal) < (exponent p : ℝ) + exact_mod_cast exponent_pos p + | coe q => + change ((exponent q : ℝ) : Surreal) < (exponent p : ℝ) + exact_mod_cast exponent_strictAnti (WithTop.coe_lt_coe.mp hpq) + +/-- The coefficient function supported on the displayed exponents. -/ +def coefficient (i : Surreal) : ℝ := + by + classical + exact if i ∈ range exponentAtIndex then 1 else 0 + +private theorem support_coefficient : + Function.support coefficient = range exponentAtIndex := by + classical + ext i + simp [Function.support, coefficient] + +/-- The displayed coefficient support is small enough for a surreal Hahn series. -/ +theorem small_support_coefficient : + Small.{0} (Function.support coefficient) := by + rw [support_coefficient] + infer_instance + +/-- The displayed exponents are reverse well-ordered. -/ +theorem wellFoundedOn_support_coefficient : + (Function.support coefficient).WellFoundedOn (· > ·) := by + rw [support_coefficient, wellFoundedOn_range] + convert wellFounded_lt (α := Index) using 1 + ext p q + exact exponentAtIndex_strictAnti.lt_iff_gt + +/-- Conway's coefficient-one normal form `1 + Σ n, ω ^ (1 / (n + 1))`. -/ +def normalForm : SurrealHahnSeries := + SurrealHahnSeries.mk coefficient small_support_coefficient + wellFoundedOn_support_coefficient + +@[simp] +theorem normalForm_coeff (i : Surreal) : + normalForm.coeff i = coefficient i := by + rw [normalForm, SurrealHahnSeries.coeff_mk, coefficient] + +@[simp] +theorem normalForm_support : normalForm.support = range exponentAtIndex := by + rw [normalForm, SurrealHahnSeries.support_mk, support_coefficient] + +theorem normalForm_coeff_exponent (n : ℕ) : + normalForm.coeff (exponent n : ℝ) = 1 := by + classical + rw [normalForm_coeff, coefficient, ite_eq_left] + exact ⟨(n : Index), rfl⟩ + +theorem normalForm_coeff_zero : normalForm.coeff 0 = 1 := by + classical + rw [normalForm_coeff, coefficient, ite_eq_left] + exact ⟨⊤, rfl⟩ + +end Surreal.OmnificInteger.OneRowExample diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Examples/OmnificInteger/OneRowPrime.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Examples/OmnificInteger/OneRowPrime.lean new file mode 100644 index 0000000000..a363c40a9f --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Examples/OmnificInteger/OneRowPrime.lean @@ -0,0 +1,169 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.OmnificInteger.Primality.IrreducibleOmnificIntegers +public import LeanPool.ConwayRefinement.ConwayRefinement.Examples.OmnificInteger.OneRowNormalForm + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.CharZero +import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.Degree +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OneRow +import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.ArchimedeanAssumptions +import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.HahnSeries.DegreeTransfer +import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.HahnSeries.IntegerPart +import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.HahnSeries.RealLeadingSplit + +/-! +# Conway's one-row prime + +Consider Conway's normal form + +`1 + Σ n : ℕ, ω ^ (1 / (n + 1))`. + +It is the omnific integer `ofRealSeries` of Berarducci's coefficient-one row with constant term. +The row remains irreducible after extending coefficients to the infinitesimal Hahn field, so the +residue-one case of LM24, Proposition 8.3.6(5) makes the omnific integer irreducible. It is +reduced, and its support has exact order type `ω + 1`, below `ω ^ ω`. The finite-degree primality +theorem then makes it prime. + +## References + +* A. Berarducci, *Factorization in generalized power series*, Trans. Amer. Math. Soc. 352 + (2000), 553–577, cited as [Ber00]. +* S. L'Innocente, V. Mantova, *A factorisation theory for generalised power series and omnific + integers*, Adv. Math. 442 (2024) 109513, cited as [LM24]. +-/ + +open scoped HahnSeries + +noncomputable section + +namespace Surreal.OmnificInteger.OneRowExample + +open Berarducci.OneRow HahnSeries.Nonpositive + +private theorem withConstant_ne_zero : withConstant (K := ℝ) ≠ 0 := by + intro hzero + have hcoeff := withConstant_coeff_zero (K := ℝ) + rw [hzero] at hcoeff + norm_num at hcoeff + +private theorem withConstant_constantCoeff_mem : + constantCoeff (withConstant (K := ℝ)) ∈ Surreal.realIntegerSubring := by + rw [withConstant_constantCoeff] + exact Surreal.realIntegerSubring.one_mem + +private theorem signedOneRow_order_neg : + (mapRealDomainToSurreal (withConstant (K := ℝ)) : ℝ⟦Surreal.{0}⟧).order < 0 := by + have hcoeff : (mapRealDomainToSurreal (withConstant (K := ℝ)) : ℝ⟦Surreal.{0}⟧).coeff + ((Berarducci.OneRow.exponent 0 : ℝ) : Surreal) ≠ 0 := by + rw [mapRealDomainToSurreal_coeff_real, withConstant_coeff_exponent] + exact one_ne_zero + refine (HahnSeries.order_le_of_coeff_ne_zero hcoeff).trans_lt ?_ + exact_mod_cast (show Berarducci.OneRow.exponent 0 < 0 by + rw [Berarducci.OneRow.exponent_apply] + norm_num) + +private theorem signedOneRow_order_ne_zero : + (mapRealDomainToSurreal (withConstant (K := ℝ)) : ℝ⟦Surreal.{0}⟧).order ≠ 0 := + signedOneRow_order_neg.ne + +private theorem signedExponent_eq_neg_normalExponent (n : ℕ) : + Berarducci.OneRow.exponent n = + -OneRowExample.exponent n := by + rw [Berarducci.OneRow.exponent_apply, + OneRowExample.exponent_apply] + +public section + +/-- Conway's one-row omnific integer in the cut presentation. -/ +def oneRowOz : Surreal.OmnificInteger.{0} := + ofRealSeries (withConstant (K := ℝ)) withConstant_constantCoeff_mem + +private theorem oneRowOz_signed : + oneRowOz.1.toSignedFullHahnSeries = mapRealDomainToSurreal (withConstant (K := ℝ)) := + toSignedFullHahnSeries_ofRealSeries _ _ + +/-- Conway's one-row omnific integer is irreducible. -/ +theorem oneRowOz_irreducible : Irreducible oneRowOz := by + apply irreducible_ofRealSeries + apply irreducible_mapRealDomainToSurrealIntegerPart Surreal.archimedeanStrata + Surreal.realIntegerSubring (withConstant (K := ℝ)) withConstant_ne_zero + signedOneRow_order_ne_zero withConstant_constantCoeff + rw [nonpositiveCoefficientMap_withConstant] + exact (irreducible_withoutConstant_and_withConstant + (K := ℝ⟦FiniteArchimedeanClass.ball ℝ Surreal.realFiniteClass⟧)).2 + +/-- The cut-defined omnific integer has the prescribed literal Conway normal form. -/ +theorem oneRowOz_toHahnSeries : oneRowOz.1.toHahnSeries = + OneRowExample.normalForm := by + apply Surreal.toHahnSeries_eq_of_toSignedFullHahnSeries_eq oneRowOz_signed + · intro r + by_cases hr : r ∈ Set.range exponentEmbedding + · obtain ⟨n, rfl⟩ := hr + rw [exponentEmbedding_apply, withConstant_coeff_exponent, + signedExponent_eq_neg_normalExponent, Real.toSurreal_neg, neg_neg, + OneRowExample.normalForm_coeff_exponent] + · by_cases hr0 : r = 0 + · subst hr0 + rw [withConstant_coeff_zero] + simpa using OneRowExample.normalForm_coeff_zero + · have hzero : (withConstant (K := ℝ) : ℝ⟦ℝ⟧).coeff r = 0 := by + rw [← not_ne_iff, ← HahnSeries.mem_support, withConstant_support] + rintro (hrange | hrzero) + · exact hr hrange + · exact hr0 (Set.mem_singleton_iff.mp hrzero) + rw [hzero, ← not_ne_iff, ← SurrealHahnSeries.mem_support_iff, + OneRowExample.normalForm_support] + rintro ⟨p, hp⟩ + induction p using WithTop.recTopCoe with + | top => + apply hr0 + have h0 : (0 : Surreal) = -(r : Surreal) := hp + exact_mod_cast (neg_eq_zero.mp h0.symm) + | coe n => + apply hr + refine ⟨n, ?_⟩ + have hn : ((OneRowExample.exponent n : ℝ) : Surreal) = + -(r : Surreal) := hp + rw [← Real.toSurreal_neg, Real.toSurreal_inj] at hn + rw [exponentEmbedding_apply, signedExponent_eq_neg_normalExponent, hn, neg_neg] + · rw [OneRowExample.normalForm_support] + rintro _ ⟨p, rfl⟩ + induction p using WithTop.recTopCoe with + | top => + refine ⟨0, ?_⟩ + change -((0 : ℝ) : Surreal) = (0 : Surreal) + simp + | coe n => + refine ⟨-OneRowExample.exponent n, ?_⟩ + change -((-OneRowExample.exponent n : ℝ) : Surreal) = + ((OneRowExample.exponent n : ℝ) : Surreal) + rw [Real.toSurreal_neg, neg_neg] + +/-- The Conway support is exactly the displayed positive row followed by zero. -/ +theorem oneRowOz_support : oneRowOz.1.support = + Set.range OneRowExample.exponentAtIndex := by + rw [← Surreal.support_toHahnSeries, oneRowOz_toHahnSeries, + OneRowExample.normalForm_support] + +/-- The one-row Conway normal form has exact support order type `ω + 1`. -/ +theorem oneRowOz_length : oneRowOz.1.length = Ordinal.omega0 + 1 := by + rw [oneRowOz, length_ofRealSeries, withConstant_supportOrderType, Ordinal.lift_id] + +/-- Conway's one-row omnific integer is reduced. -/ +theorem oneRowOz_isReduced : + HahnSeries.Nonpositive.IsReduced oneRowOz.toSignedNonpositiveHahn := + isReduced_ofRealSeries _ _ signedOneRow_order_ne_zero + withConstant_constantCoeff + +/-- Conway's one-row omnific integer is prime. -/ +theorem oneRowOz_prime : Prime oneRowOz := + Surreal.OmnificInteger.prime_of_irreducible _ oneRowOz_irreducible + +end + +end Surreal.OmnificInteger.OneRowExample diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Examples/OmnificInteger/ZFCDegreeTwoPrime.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Examples/OmnificInteger/ZFCDegreeTwoPrime.lean new file mode 100644 index 0000000000..20d4659093 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Examples/OmnificInteger/ZFCDegreeTwoPrime.lean @@ -0,0 +1,77 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.OmnificInteger.Primality.ZFC +public import LeanPool.ConwayRefinement.ConwayRefinement.Examples.OmnificInteger.DegreeTwoPrime + +/-! +# A degree-two prime in the class presentation of the omnific integers + +The explicit degree-two prime transfers through the equivalence between the library and +set-coded presentations of the omnific integers. +-/ + +universe u + +public noncomputable section + +namespace ZFSet.Surreal.OmnificInteger.DegreeTwoExample + +/-- The explicit degree-two prime, as a Conway-equivalence class of omnific ZFC codes. -/ +def degreeTwoOz : OmnificInteger.{u} := + ringEquiv.symm _root_.Surreal.OmnificInteger.DegreeTwoExample.degreeTwoOz + +@[simp] +theorem toOmnificInteger_degreeTwoOz : toOmnificInteger degreeTwoOz.{u} = + _root_.Surreal.OmnificInteger.DegreeTwoExample.degreeTwoOz := by + rw [← ringEquiv_apply] + exact ringEquiv.apply_symm_apply _ + +/-- The class-valued example has exactly the displayed Conway normal form. -/ +theorem degreeTwoOz_toHahnSeries : + ZFSet.Surreal.toHahnSeries (degreeTwoOz.{u} : ZFSet.Surreal.{u}) = + _root_.Surreal.OmnificInteger.DegreeTwoExample.normalForm := by + rw [ZFSet.Surreal.toHahnSeries_eq_toSurreal, ← coe_toOmnificInteger, + toOmnificInteger_degreeTwoOz] + exact _root_.Surreal.OmnificInteger.DegreeTwoExample.degreeTwoOz_toHahnSeries + +/-- The prescribed normal form identifies the class-valued example uniquely. -/ +theorem toHahnSeries_eq_normalForm_iff (x : OmnificInteger.{u}) : + ZFSet.Surreal.toHahnSeries (x : ZFSet.Surreal.{u}) = + _root_.Surreal.OmnificInteger.DegreeTwoExample.normalForm ↔ x = degreeTwoOz := by + rw [← degreeTwoOz_toHahnSeries] + constructor + · intro h + apply Subtype.ext + apply ZFSet.Surreal.toSurreal_injective + simpa only [ZFSet.Surreal.toHahnSeries_eq_toSurreal, + _root_.Surreal.toSurreal_toHahnSeries] using congrArg SurrealHahnSeries.toSurreal h + · rintro rfl + rfl + +/-- The normal form of the class-valued example has support order type `ω ^ 2 + 1`. -/ +theorem degreeTwoOz_length : + (ZFSet.Surreal.toHahnSeries (degreeTwoOz.{u} : ZFSet.Surreal.{u})).length = + Ordinal.omega0 ^ (2 : Ordinal) + 1 := by + rw [ZFSet.Surreal.toHahnSeries_eq_toSurreal, ← coe_toOmnificInteger, + toOmnificInteger_degreeTwoOz, _root_.Surreal.length_toHahnSeries] + exact _root_.Surreal.OmnificInteger.DegreeTwoExample.degreeTwoOz_length + +/-- The explicit class-valued example is reduced in the native Conway-support sense. -/ +theorem degreeTwoOz_isReduced : + ZFSet.Surreal.IsReduced (degreeTwoOz.{u} : ZFSet.Surreal.{u}) := by + apply (isReduced_iff_toSignedNonpositiveHahn degreeTwoOz).2 + rw [ringEquiv_apply, toOmnificInteger_degreeTwoOz] + exact _root_.Surreal.OmnificInteger.DegreeTwoExample.degreeTwoOz_isReduced + +/-- The explicit degree-two omnific class value is prime. -/ +theorem degreeTwoOz_prime : Prime degreeTwoOz.{u} := by + apply (MulEquiv.prime_iff ringEquiv).1 + rw [ringEquiv_apply, toOmnificInteger_degreeTwoOz] + exact _root_.Surreal.OmnificInteger.DegreeTwoExample.degreeTwoOz_prime + +end ZFSet.Surreal.OmnificInteger.DegreeTwoExample diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/FieldTheory.lean b/LeanPool/ConwayRefinement/ConwayRefinement/FieldTheory.lean new file mode 100644 index 0000000000..27088f8de6 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/FieldTheory.lean @@ -0,0 +1,14 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.FieldTheory.LatticeFactorCoefficients +public import LeanPool.ConwayRefinement.ConwayRefinement.FieldTheory.LaurentFactorCoefficients +public import LeanPool.ConwayRefinement.ConwayRefinement.FieldTheory.MonicFactorCoefficients +public import LeanPool.ConwayRefinement.ConwayRefinement.FieldTheory.RelativeAlgebraicClosure + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/FieldTheory/LatticeFactorCoefficients.lean b/LeanPool/ConwayRefinement/ConwayRefinement/FieldTheory/LatticeFactorCoefficients.lean new file mode 100644 index 0000000000..191632cbc1 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/FieldTheory/LatticeFactorCoefficients.lean @@ -0,0 +1,131 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.FieldTheory.LaurentFactorCoefficients +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MonoidAlgebra.LatticeFunctional + +/-! +# Clearing a scalar out of a factor over a finite-rank exponent lattice + +A functional separating the exponents that occur collapses the lattice to a single variable +without merging any of them, and relabelling exponents commutes with extending coefficients. So a +factorisation whose product has coefficients in the subfield descends to the one-variable case, +where a monic factor of a monic polynomial has coefficients integral, hence algebraic, hence in +the subfield when it is relatively algebraically closed. Reading the coefficients back through the +separating functional clears one scalar out of the factor. +-/ + +universe u v w + +namespace AddMonoidAlgebra + +public section + +variable {K : Type u} {L : Type v} [Field K] [Field L] [Algebra K L] + +omit [Algebra K L] in +/-- Coefficient extension is `Finsupp.mapRange` on the underlying finitely supported function. -/ +theorem mapRingHom_apply' {M : Type*} [AddMonoid M] (f : K →+* L) (x : AddMonoidAlgebra K M) : + AddMonoidAlgebra.mapRingHom M f x = ofCoeff (Finsupp.mapRange f (map_zero f) x.coeff) := rfl + +omit [Algebra K L] in +/-- Relabelling exponents commutes with extending coefficients. -/ +theorem mapDomain_mapRingHom {M N : Type*} [AddMonoid M] [AddMonoid N] (psi : M →+ N) + (f : K →+* L) (x : AddMonoidAlgebra K M) : + AddMonoidAlgebra.mapDomainRingHom L psi (AddMonoidAlgebra.mapRingHom M f x) = + AddMonoidAlgebra.mapRingHom N f (AddMonoidAlgebra.mapDomainRingHom K psi x) := by + exact (DFunLike.congr_fun (mapRingHom_comp_mapDomainRingHom f psi) x).symm + +/-- Lattice form of scalar clearing: collapse the lattice to one variable along a functional that +separates the exponents in play. -/ +theorem exists_scalar_of_mul_eq_map_lattice {k : ℕ} + (hclosed : Algebra.IsRelativelyAlgebraicallyClosed K L) + {q r : AddMonoidAlgebra L (Fin k → ℤ)} {P : AddMonoidAlgebra K (Fin k → ℤ)} + (hq : q ≠ 0) (hr : r ≠ 0) + (hqr : q * r = AddMonoidAlgebra.mapRingHom (Fin k → ℤ) (algebraMap K L) P) : + ∃ c : L, c ≠ 0 ∧ ∀ g, c * q.coeff g ∈ (algebraMap K L).range := by + classical + obtain ⟨psi, hpsi⟩ := AddMonoidHom.exists_injOn_finInt (q.coeff.support ∪ r.coeff.support) + have hsub : (q.coeff.support : Set (Fin k → ℤ)) ⊆ ((q.coeff.support ∪ r.coeff.support : Finset + _) : Set _) := + fun x hx ↦ Finset.mem_coe.mpr (Finset.mem_union_left _ (Finset.mem_coe.mp hx)) + have hinjq : Set.InjOn psi (q.coeff.support : Set (Fin k → ℤ)) := hpsi.mono hsub + have htransfer : ∀ g ∈ q.coeff.support, + (AddMonoidAlgebra.mapDomainRingHom L psi q).coeff (psi g) = q.coeff g := fun g hg ↦ + Finsupp.mapDomain_apply' _ q.coeff hsub hpsi (Finset.mem_union_left _ hg) + have hq0 : AddMonoidAlgebra.mapDomainRingHom L psi q ≠ 0 := by + obtain ⟨g, hg⟩ := Finsupp.support_nonempty_iff.mpr (coeff_eq_zero.not.mpr hq) + intro h0 + rw [h0] at htransfer + exact (Finsupp.mem_support_iff.mp hg) (htransfer g hg).symm + have hr0 : AddMonoidAlgebra.mapDomainRingHom L psi r ≠ 0 := by + obtain ⟨g, hg⟩ := Finsupp.support_nonempty_iff.mpr (coeff_eq_zero.not.mpr hr) + have hsubr : (r.coeff.support : Set (Fin k → ℤ)) ⊆ ((q.coeff.support ∪ r.coeff.support : + Finset _) : Set _) := + fun x hx ↦ Finset.mem_coe.mpr (Finset.mem_union_right _ (Finset.mem_coe.mp hx)) + intro h0 + have := Finsupp.mapDomain_apply' ((q.coeff.support ∪ r.coeff.support : Finset _) : Set _) + r.coeff hsubr hpsi + (Finset.mem_union_right _ hg) + have h0' : Finsupp.mapDomain psi r.coeff = 0 := by + simpa only [mapDomainRingHom_apply, mapDomain, coeff_ofCoeff, coeff_zero] + using congrArg AddMonoidAlgebra.coeff h0 + rw [h0'] at this + exact (Finsupp.mem_support_iff.mp hg) this.symm + have hrel : (AddMonoidAlgebra.mapDomainRingHom L psi q) * + (AddMonoidAlgebra.mapDomainRingHom L psi r) = + AddMonoidAlgebra.mapRingHom ℤ (algebraMap K L) + (AddMonoidAlgebra.mapDomainRingHom K psi P) := by + rw [← map_mul, hqr, mapDomain_mapRingHom] + obtain ⟨c, hc, hcoeff⟩ := + LaurentPolynomial.exists_scalar_of_mul_eq_map hclosed hq0 hr0 hrel + refine ⟨c, hc, fun g ↦ ?_⟩ + by_cases hg : g ∈ q.coeff.support + · rw [← htransfer g hg] + exact hcoeff _ + · rw [Finsupp.notMem_support_iff.mp hg, mul_zero] + exact ⟨0, map_zero _⟩ + +/-- Scalar clearing over any free exponent group of finite rank. -/ +theorem exists_scalar_of_mul_eq_map_free {H : Type w} [AddCommGroup H] + (hfree : ∃ k : ℕ, Nonempty (H ≃+ (Fin k → ℤ))) + (hclosed : Algebra.IsRelativelyAlgebraicallyClosed K L) + {q r : AddMonoidAlgebra L H} {P : AddMonoidAlgebra K H} (hq : q ≠ 0) (hr : r ≠ 0) + (hqr : q * r = AddMonoidAlgebra.mapRingHom H (algebraMap K L) P) : + ∃ c : L, c ≠ 0 ∧ ∀ g, c * q.coeff g ∈ (algebraMap K L).range := by + obtain ⟨k, ⟨e⟩⟩ := hfree + have hinj : Function.Injective (e : H → (Fin k → ℤ)) := e.injective + have htrans : ∀ (x : AddMonoidAlgebra L H) (g : H), + (AddMonoidAlgebra.mapDomainRingHom L e.toAddMonoidHom x).coeff (e g) = x.coeff g := by + intro x g + rw [mapDomainRingHom_apply] + exact Finsupp.mapDomain_apply_of_injective hinj x.coeff g + have hq0 : AddMonoidAlgebra.mapDomainRingHom L e.toAddMonoidHom q ≠ 0 := by + obtain ⟨g, hg⟩ := Finsupp.support_nonempty_iff.mpr (coeff_eq_zero.not.mpr hq) + intro h0 + apply Finsupp.mem_support_iff.mp hg + rw [← htrans q g, h0] + rfl + have hr0 : AddMonoidAlgebra.mapDomainRingHom L e.toAddMonoidHom r ≠ 0 := by + obtain ⟨g, hg⟩ := Finsupp.support_nonempty_iff.mpr (coeff_eq_zero.not.mpr hr) + intro h0 + apply Finsupp.mem_support_iff.mp hg + rw [← htrans r g, h0] + rfl + have hrel : (AddMonoidAlgebra.mapDomainRingHom L e.toAddMonoidHom q) * + (AddMonoidAlgebra.mapDomainRingHom L e.toAddMonoidHom r) = + AddMonoidAlgebra.mapRingHom (Fin k → ℤ) (algebraMap K L) + (AddMonoidAlgebra.mapDomainRingHom K e.toAddMonoidHom P) := by + rw [← map_mul, hqr, mapDomain_mapRingHom] + obtain ⟨c, hc, hcoeff⟩ := exists_scalar_of_mul_eq_map_lattice hclosed hq0 hr0 hrel + refine ⟨c, hc, fun g ↦ ?_⟩ + rw [← htrans q g] + exact hcoeff _ + +end + +end AddMonoidAlgebra diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/FieldTheory/LaurentFactorCoefficients.lean b/LeanPool/ConwayRefinement/ConwayRefinement/FieldTheory/LaurentFactorCoefficients.lean new file mode 100644 index 0000000000..7fa5af04ed --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/FieldTheory/LaurentFactorCoefficients.lean @@ -0,0 +1,174 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import Mathlib.Algebra.Polynomial.Laurent +public import Mathlib.Data.Finsupp.Basic +public import LeanPool.ConwayRefinement.ConwayRefinement.FieldTheory.MonicFactorCoefficients + +/-! +# Laurent factors over a relatively algebraically closed subfield + +A Laurent polynomial becomes an ordinary polynomial after multiplication by a large enough power +of the variable, and that multiplication is invertible, so divisibility and coefficients transfer +between the two settings. Coefficient extension commutes with the inclusion of polynomials into +Laurent polynomials and fixes the Laurent monomials. + +Combining these with the polynomial statement: if two Laurent polynomials over the extension have +monic polynomial shifts whose product is the extension of a polynomial over the subfield, then the +coefficients of each shift already lie in the subfield. +-/ + +universe u v + +namespace LaurentPolynomial + +public section + +variable {R : Type u} [Semiring R] + +/-- The Laurent image of a polynomial has the same coefficients at natural exponents. -/ +theorem toLaurent_apply_natCast (p : Polynomial R) (n : ℕ) : + (Polynomial.toLaurent p).coeff (n : ℤ) = p.coeff n := by + rw [coeff_toLaurent] + change (p.toFinsupp.coeff.mapDomain Nat.castEmbedding) (Nat.castEmbedding n) = p.coeff n + rw [Finsupp.mapDomain_apply_of_injective Nat.castEmbedding.injective] + rfl + +/-- The Laurent image of a polynomial vanishes at negative exponents. -/ +theorem toLaurent_apply_of_neg (p : Polynomial R) {z : ℤ} (hz : z < 0) : + (Polynomial.toLaurent p).coeff z = 0 := by + rw [coeff_toLaurent] + refine Finsupp.mapDomain_of_notMem_range _ _ ?_ + rintro ⟨n, rfl⟩ + change (n : ℤ) < 0 at hz + omega +/-- Coefficient extension commutes with the Laurent inclusion. -/ +theorem toLaurent_map {S : Type*} [Semiring S] (f : R →+* S) (p : Polynomial R) : + Polynomial.toLaurent (p.map f) = AddMonoidAlgebra.mapRingHom ℤ f (Polynomial.toLaurent p) := by + ext z + rcases lt_or_ge z 0 with hz | hz + · rw [toLaurent_apply_of_neg _ hz] + change (0 : S) = f ((Polynomial.toLaurent p).coeff z) + rw [toLaurent_apply_of_neg _ hz, map_zero] + · obtain ⟨n, rfl⟩ := Int.eq_ofNat_of_zero_le hz + rw [toLaurent_apply_natCast, Polynomial.coeff_map] + change f (p.coeff n) = f ((Polynomial.toLaurent p).coeff (n : ℤ)) + rw [toLaurent_apply_natCast] + +/-- Coefficient extension fixes the Laurent monomials. -/ +theorem mapRingHom_T {S : Type*} [Semiring S] (f : R →+* S) (z : ℤ) : + AddMonoidAlgebra.mapRingHom ℤ f (LaurentPolynomial.T z) = LaurentPolynomial.T z := by + simp only [LaurentPolynomial.T, AddMonoidAlgebra.mapRingHom_single, map_one] + +section Core + +variable {K : Type u} {L : Type v} [Field K] [Field L] [Algebra K L] + +/-- One-variable core, with the shifts supplied: two monic polynomial shifts of Laurent factors +whose product is an extension have coefficients in the base field. -/ +theorem coeff_mem_range_of_shifted + (hclosed : Algebra.IsRelativelyAlgebraicallyClosed K L) + {q r : AddMonoidAlgebra L ℤ} {P : AddMonoidAlgebra K ℤ} + (hmul : q * r = AddMonoidAlgebra.mapRingHom ℤ (algebraMap K L) P) + {q' r' : Polynomial L} {P' : Polynomial K} {n m : ℕ} + (hq' : Polynomial.toLaurent q' = q * LaurentPolynomial.T (n : ℤ)) + (hr' : Polynomial.toLaurent r' = r * LaurentPolynomial.T (m : ℤ)) + (hP' : Polynomial.toLaurent P' = P * LaurentPolynomial.T ((n : ℤ) + (m : ℤ))) + (hqm : q'.Monic) (hrm : r'.Monic) (j : ℕ) : + q'.coeff j ∈ (algebraMap K L).range := by + have hprod : q' * r' = P'.map (algebraMap K L) := by + refine Polynomial.toLaurent_injective ?_ + rw [map_mul, hq', hr', toLaurent_map, hP', map_mul, mul_mul_mul_comm, + ← LaurentPolynomial.T_add, hmul, mapRingHom_T] + exact Polynomial.coeff_mem_range_of_mul_eq_map hclosed hqm hrm hprod j + +end Core + +section Shift + +variable {R : Type u} [CommRing R] + +private theorem mul_T_apply (f : AddMonoidAlgebra R ℤ) (n : ℤ) (z : ℤ) : + (f * LaurentPolynomial.T n : AddMonoidAlgebra R ℤ).coeff z = f.coeff (z - n) := by + simp only [LaurentPolynomial.T, AddMonoidAlgebra.coeff_mul_single_apply, + mul_one, sub_eq_add_neg] + +/-- Coefficients of a Laurent polynomial read off a polynomial shift, at natural indices. -/ +theorem apply_sub_of_toLaurent_eq_mul_T {f : AddMonoidAlgebra R ℤ} {p : Polynomial R} {n : ℕ} + (h : Polynomial.toLaurent p = f * LaurentPolynomial.T (n : ℤ)) (j : ℕ) : + f.coeff ((j : ℤ) - n) = p.coeff j := by + have hj := mul_T_apply f (n : ℤ) (j : ℤ) + rw [← h, toLaurent_apply_natCast] at hj + exact hj.symm + +/-- Below the shift the Laurent polynomial vanishes. -/ +theorem apply_eq_zero_of_toLaurent_eq_mul_T {f : AddMonoidAlgebra R ℤ} {p : Polynomial R} {n : ℕ} + (h : Polynomial.toLaurent p = f * LaurentPolynomial.T (n : ℤ)) {z : ℤ} (hz : z + n < 0) : + f.coeff z = 0 := by + have hz' := mul_T_apply f (n : ℤ) (z + n) + simp only [add_sub_cancel_right] at hz' + rw [← h, toLaurent_apply_of_neg _ hz] at hz' + exact hz'.symm + +section Clearing + +variable {K : Type u} {L : Type v} [Field K] [Field L] [Algebra K L] + +/-- Laurent form of scalar clearing: one scalar carries the first factor into the subfield. -/ +theorem exists_scalar_of_mul_eq_map + (hclosed : Algebra.IsRelativelyAlgebraicallyClosed K L) + {q r : AddMonoidAlgebra L ℤ} {P : AddMonoidAlgebra K ℤ} (hq : q ≠ 0) (hr : r ≠ 0) + (hqr : q * r = AddMonoidAlgebra.mapRingHom ℤ (algebraMap K L) P) : + ∃ c : L, c ≠ 0 ∧ ∀ z, c * q.coeff z ∈ (algebraMap K L).range := by + obtain ⟨n₀, q₀, hq₀⟩ := LaurentPolynomial.exists_T_pow q + obtain ⟨m₀, r₀, hr₀⟩ := LaurentPolynomial.exists_T_pow r + obtain ⟨l, P₀, hP₀⟩ := LaurentPolynomial.exists_T_pow P + have hq'L : Polynomial.toLaurent (q₀ * Polynomial.X ^ l) = + q * LaurentPolynomial.T ((n₀ + l : ℕ) : ℤ) := by + rw [map_mul, hq₀, Polynomial.toLaurent_X_pow, mul_assoc, ← LaurentPolynomial.T_add] + norm_cast + have hr'L : Polynomial.toLaurent (r₀ * Polynomial.X ^ l) = + r * LaurentPolynomial.T ((m₀ + l : ℕ) : ℤ) := by + rw [map_mul, hr₀, Polynomial.toLaurent_X_pow, mul_assoc, ← LaurentPolynomial.T_add] + norm_cast + have hPL : Polynomial.toLaurent ((P₀ * Polynomial.X ^ (n₀ + m₀ + l)).map (algebraMap K L)) = + AddMonoidAlgebra.mapRingHom ℤ (algebraMap K L) P * + LaurentPolynomial.T (((n₀ + l : ℕ) : ℤ) + ((m₀ + l : ℕ) : ℤ)) := by + rw [toLaurent_map, map_mul, hP₀, Polynomial.toLaurent_X_pow, map_mul, mapRingHom_T, + map_mul, mapRingHom_T, mul_assoc, ← LaurentPolynomial.T_add] + push_cast + ring_nf + have hprod : (q₀ * Polynomial.X ^ l) * (r₀ * Polynomial.X ^ l) = + (P₀ * Polynomial.X ^ (n₀ + m₀ + l)).map (algebraMap K L) := by + refine Polynomial.toLaurent_injective ?_ + rw [map_mul, hq'L, hr'L, hPL, mul_mul_mul_comm, ← LaurentPolynomial.T_add, hqr] + have hq'0 : q₀ * Polynomial.X ^ l ≠ 0 := by + intro h0 + rw [h0, map_zero] at hq'L + exact hq ((mul_eq_zero.mp hq'L.symm).resolve_right (LaurentPolynomial.isUnit_T _).ne_zero) + have hr'0 : r₀ * Polynomial.X ^ l ≠ 0 := by + intro h0 + rw [h0, map_zero] at hr'L + exact hr ((mul_eq_zero.mp hr'L.symm).resolve_right (LaurentPolynomial.isUnit_T _).ne_zero) + obtain ⟨c, hc, hcoeff⟩ := Polynomial.exists_scalar_of_mul_eq_map hclosed hq'0 hr'0 hprod + refine ⟨c, hc, fun z ↦ ?_⟩ + rcases le_or_gt 0 (z + ((n₀ + l : ℕ) : ℤ)) with hcase | hcase + · have hz : z = ((z + (n₀ + l : ℕ)).toNat : ℤ) - ((n₀ + l : ℕ) : ℤ) := by + rw [Int.toNat_of_nonneg hcase] + ring + rw [hz, apply_sub_of_toLaurent_eq_mul_T hq'L] + exact hcoeff _ + · rw [apply_eq_zero_of_toLaurent_eq_mul_T hq'L hcase, mul_zero] + exact ⟨0, map_zero _⟩ + +end Clearing + + +end Shift + +end +end LaurentPolynomial diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/FieldTheory/MonicFactorCoefficients.lean b/LeanPool/ConwayRefinement/ConwayRefinement/FieldTheory/MonicFactorCoefficients.lean new file mode 100644 index 0000000000..c52212acda --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/FieldTheory/MonicFactorCoefficients.lean @@ -0,0 +1,86 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.FieldTheory.RelativeAlgebraicClosure +public import Mathlib.RingTheory.Polynomial.IsIntegral +public import Mathlib.Algebra.Polynomial.FieldDivision + +/-! +# Coefficients of a monic factor over a relatively algebraically closed subfield + +A monic divisor of a monic polynomial has coefficients integral over the base ring, because they +are symmetric functions of a subset of the roots. Over a field the integral elements are exactly +the algebraic ones, so if the base field is relatively algebraically closed in the coefficient +field then those coefficients already lie in the base field. +-/ + +universe u v + +namespace Polynomial + +public section + +variable {K : Type u} {L : Type v} [Field K] [Field L] [Algebra K L] + +/-- Over a relatively algebraically closed subfield, a monic factor of a monic polynomial has all +its coefficients in the subfield. -/ +theorem coeff_mem_range_of_monic_dvd + (hclosed : Algebra.IsRelativelyAlgebraicallyClosed K L) + {p : Polynomial K} {q : Polynomial L} (hp : p.Monic) (hq : q.Monic) + (hdvd : q ∣ p.map (algebraMap K L)) (i : ℕ) : + q.coeff i ∈ (algebraMap K L).range := by + obtain ⟨k, hk⟩ := (Algebra.isRelativelyAlgebraicallyClosed_iff K L).mp hclosed _ + (Polynomial.isIntegral_coeff_of_dvd p q hp hq hdvd i).isAlgebraic + exact ⟨k, hk⟩ + +/-- If a product of two monic polynomials over `L` is the extension of a polynomial over `K`, then +each factor already has all its coefficients in `K`. -/ +theorem coeff_mem_range_of_mul_eq_map + (hclosed : Algebra.IsRelativelyAlgebraicallyClosed K L) + {q r : Polynomial L} {P : Polynomial K} (hq : q.Monic) (hr : r.Monic) + (hqr : q * r = P.map (algebraMap K L)) (i : ℕ) : + q.coeff i ∈ (algebraMap K L).range := by + have hPmonic : P.Monic := Polynomial.monic_map_iff.mp (hqr ▸ hq.mul hr) + exact coeff_mem_range_of_monic_dvd hclosed hPmonic hq ⟨r, hqr.symm⟩ i + +/-- If a product of two nonzero polynomials over `L` is the extension of a polynomial over `K`, +one scalar clears the first factor into `K`. -/ +theorem exists_scalar_of_mul_eq_map + (hclosed : Algebra.IsRelativelyAlgebraicallyClosed K L) + {q r : Polynomial L} {P : Polynomial K} (hq : q ≠ 0) (hr : r ≠ 0) + (hqr : q * r = P.map (algebraMap K L)) : + ∃ c : L, c ≠ 0 ∧ ∀ j, c * q.coeff j ∈ (algebraMap K L).range := by + have hc : q.leadingCoeff ≠ 0 := Polynomial.leadingCoeff_ne_zero.mpr hq + have hd : r.leadingCoeff ≠ 0 := Polynomial.leadingCoeff_ne_zero.mpr hr + have hq1 : (Polynomial.C q.leadingCoeff⁻¹ * q).Monic := by + unfold Polynomial.Monic + rw [Polynomial.leadingCoeff_mul, Polynomial.leadingCoeff_C, inv_mul_cancel₀ hc] + have hr1 : (Polynomial.C r.leadingCoeff⁻¹ * r).Monic := by + unfold Polynomial.Monic + rw [Polynomial.leadingCoeff_mul, Polynomial.leadingCoeff_C, inv_mul_cancel₀ hd] + have hlc : (P.map (algebraMap K L)).leadingCoeff = q.leadingCoeff * r.leadingCoeff := by + rw [← hqr, Polynomial.leadingCoeff_mul] + have hPlc : (P.map (algebraMap K L)).leadingCoeff = algebraMap K L P.leadingCoeff := by + rw [Polynomial.leadingCoeff_map] + have hPne : P.leadingCoeff ≠ 0 := by + intro h0 + rw [hPlc, h0, map_zero] at hlc + exact (mul_ne_zero hc hd) hlc.symm + have hprod : (Polynomial.C q.leadingCoeff⁻¹ * q) * (Polynomial.C r.leadingCoeff⁻¹ * r) = + (Polynomial.C P.leadingCoeff⁻¹ * P).map (algebraMap K L) := by + rw [Polynomial.map_mul, Polynomial.map_C, ← hqr] + rw [show algebraMap K L P.leadingCoeff⁻¹ = (q.leadingCoeff * r.leadingCoeff)⁻¹ by + rw [← hlc, hPlc, map_inv₀]] + rw [mul_inv, Polynomial.C_mul] + ring + refine ⟨q.leadingCoeff⁻¹, inv_ne_zero hc, fun j ↦ ?_⟩ + have := coeff_mem_range_of_mul_eq_map hclosed hq1 hr1 hprod j + rwa [Polynomial.coeff_C_mul] at this + +end + +end Polynomial diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/FieldTheory/RelativeAlgebraicClosure.lean b/LeanPool/ConwayRefinement/ConwayRefinement/FieldTheory/RelativeAlgebraicClosure.lean new file mode 100644 index 0000000000..57fd9e2cd1 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/FieldTheory/RelativeAlgebraicClosure.lean @@ -0,0 +1,68 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import Mathlib.FieldTheory.AlgebraicClosure + +/-! +# Relative algebraic closure + +This module packages the assertion that a field is relatively algebraically closed in a field +extension. The elementwise definition is convenient in theorem statements, while the +characteristic theorem identifies it with Mathlib's relative algebraic closure. +-/ + +universe u v + +namespace Algebra + +public noncomputable section + +variable (F : Type u) (E : Type v) [Field F] [Field E] [Algebra F E] + +/-- The field `F` is relatively algebraically closed in `E` when every element of `E` algebraic +over `F` belongs to the range of the scalar embedding. -/ +def IsRelativelyAlgebraicallyClosed : Prop := + ∀ x : E, IsAlgebraic F x → x ∈ (algebraMap F E).range + +theorem isRelativelyAlgebraicallyClosed_iff : + IsRelativelyAlgebraicallyClosed F E ↔ + ∀ x : E, IsAlgebraic F x → + ∃ k : F, algebraMap F E k = x := + Iff.rfl + +theorem isRelativelyAlgebraicallyClosed_iff_algebraicClosure_eq_bot : + IsRelativelyAlgebraicallyClosed F E ↔ + algebraicClosure F E = ⊥ := by + constructor + · intro h + ext x + rw [mem_algebraicClosure_iff, IntermediateField.mem_bot] + constructor + · exact h x + · rintro ⟨k, rfl⟩ + exact isAlgebraic_algebraMap k + · intro h x hx + have hx' : x ∈ algebraicClosure F E := + mem_algebraicClosure_iff.mpr hx + rw [h, IntermediateField.mem_bot] at hx' + exact hx' + +/-- A field is relatively algebraically closed in an extension if every algebraic element has +minimal polynomial of degree at most one. -/ +theorem isRelativelyAlgebraicallyClosed_of_minpoly_natDegree_le_one + (hlinear : ∀ x : E, IsAlgebraic F x → + (minpoly F x).natDegree ≤ 1) : + IsRelativelyAlgebraicallyClosed F E := by + rw [isRelativelyAlgebraicallyClosed_iff] + intro x hx + apply minpoly.natDegree_eq_one_iff.mp + apply le_antisymm (hlinear x hx) + exact minpoly.natDegree_pos (isAlgebraic_iff_isIntegral.mp hx) + +end + +end Algebra diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries.lean new file mode 100644 index 0000000000..b64620d915 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries.lean @@ -0,0 +1,73 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.ArchimedeanSplitting +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.CardinalTruncation +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.CardinalTruncationDomainEmbedding +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.CardinalTruncationDomainEquiv +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.CardinalTruncationIrreducible +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.CardinalTruncationResidue +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.CharZero +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.CoefficientMap +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.ConvexFactorSupport +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.ConvexQuotientSplitting +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Degree +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.DegreeTermCount +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.DegreeValuation +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Domain +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.DomainEmbedding +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.DomainEquiv +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.DomainOrderType +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.EPrimitive +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.FactorCoefficients +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.FiniteSupport +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.FiniteSupportConstantTermOne +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.FiniteSupportGCDProof +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.FiniteSupportMonoidAlgebra +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.FiniteSupportNormalization +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.FiniteSupportNormalizedGCD +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.FiniteSupportResidue +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.FiniteSupportScalarExtension +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.FiniteSupportScalarTensor +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.FiniteSupportUnit +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Iterate +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IterateOrderType +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.LimitTailQuotient +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Monomial +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Multiplicativity +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Negative +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.NegativeMonomialIdeal +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Nonpositive +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.NonpositiveCoefficientMap +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.NonpositiveDomainEquiv +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.NormalForm +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrderType +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrderedIntervalSum +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.PolynomialAlgebra +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Primality +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.PrincipalAddition +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.RealSupportSupremum +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.SeparatedPieceSum +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.SeparatedSupport +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.SourceStatements +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.SubgroupAlgebra +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.SubgroupGCD +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.SubgroupSupport +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.SupportArchimedeanClasses +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.SupportSupremum +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Tests +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Translation +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Truncation +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.TruncationIntegerPartPrimal +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.WeakNormalForm + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/ArchimedeanSplitting.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/ArchimedeanSplitting.lean new file mode 100644 index 0000000000..a42aec42fc --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/ArchimedeanSplitting.lean @@ -0,0 +1,63 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Order.Module.ArchimedeanBallSplitting +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.DomainEquiv +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Iterate + +/-! +# Hahn-series splitting along an Archimedean class + +The ordered splitting of a closed Archimedean ball reindexes Hahn series on that ball as Hahn +series on a lexicographic product. Flattening in reverse then presents them as iterated Hahn +series: the chosen stratum is the outer, dominant exponent and the open ball is the inner, +infinitesimal exponent. +-/ + +public noncomputable section + +namespace HahnSeries + +open FiniteArchimedeanClass + +variable {R K M : Type*} [Semiring R] +variable [DivisionRing K] [LinearOrder K] [IsOrderedRing K] [Archimedean K] +variable [AddCommGroup M] [LinearOrder M] [IsOrderedAddMonoid M] +variable [Module K M] [IsOrderedModule K M] + +/-- Hahn series on a closed Archimedean ball as iterated Hahn series, with the chosen stratum +as the outer exponent and the open ball as the coefficient-series exponent. -/ +def archimedeanSplitRingEquiv (u : HahnEmbedding.ArchimedeanStrata K M) + (c : FiniteArchimedeanClass M) : + R⟦closedBall K c⟧ ≃+* (R⟦ball K c⟧)⟦u.stratum c⟧ := + (embDomainRingEquiv + (HahnEmbedding.ArchimedeanStrata.closedBallEquivStratumLexBall u c)).trans + iterateRingEquiv.symm + +@[simp] +theorem archimedeanSplitRingEquiv_coeff + (u : HahnEmbedding.ArchimedeanStrata K M) (c : FiniteArchimedeanClass M) + (x : R⟦closedBall K c⟧) (s : u.stratum c) (b : ball K c) : + ((archimedeanSplitRingEquiv u c x).coeff s).coeff b = + x.coeff (HahnEmbedding.ArchimedeanStrata.stratumLexBallEquivClosedBall u c + (toLex (s, b))) := by + apply (iterateRingEquiv_coeff (archimedeanSplitRingEquiv u c x) s b).symm.trans + change (iterateRingEquiv + (iterateRingEquiv.symm + (embDomainRingEquiv + (HahnEmbedding.ArchimedeanStrata.closedBallEquivStratumLexBall u c) x))).coeff + (toLex (s, b)) = _ + rw [RingEquiv.apply_symm_apply] + have h := embDomainRingEquiv_coeff + (R := R) + (HahnEmbedding.ArchimedeanStrata.closedBallEquivStratumLexBall u c) x + (HahnEmbedding.ArchimedeanStrata.stratumLexBallEquivClosedBall u c (toLex (s, b))) + rw [HahnEmbedding.ArchimedeanStrata.closedBallEquivStratumLexBall_stratumLexBallEquivClosedBall] + at h + exact h + +end HahnSeries diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/CardinalTruncation.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/CardinalTruncation.lean new file mode 100644 index 0000000000..b0b481f06a --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/CardinalTruncation.lean @@ -0,0 +1,320 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Divisibility.PrimalPreimage +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Nonpositive +public import LeanPool.ConwayRefinement.ConwayRefinement.Order.Archimedean +public import Mathlib.RingTheory.HahnSeries.Cardinal +public import Mathlib.SetTheory.Cardinal.Cofinality.Basic + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint + +/-! +# Cardinal-bounded Hahn truncation integer parts + +This file models the support-cardinality bound in the Hahn fields `K((G))_κ` used by LM24. +It intersects the nonpositive-support and constant-coefficient conditions with Mathlib's subfield +of series having fewer than `κ` terms. + +The fraction-subring lemmas isolate the two nonzero-class alternatives in LM24, assumption +`(A2)_σ`. If `κ ≤ cof(G)`, a support of cardinality less than `κ` is not cofinal, so a +monomial shift supplies a denominator in the truncation integer part. If `G = {0}`, the same +conclusion follows exactly when the coefficient subring has fraction subring equal to the whole +coefficient field. +-/ + +universe u v + +public noncomputable section + +open Cardinal + +namespace HahnSeries + +variable {G : Type u} {R : Type v} {κ : Cardinal.{u}} +variable [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] [Field R] + +/-- A Hahn series over an Archimedean exponent group has countable support. -/ +theorem cardSupp_le_aleph0_of_archimedean [Archimedean G] (x : R⟦G⟧) : + x.cardSupp ≤ ℵ₀ := by + rw [cardSupp, Cardinal.le_aleph0_iff_set_countable] + exact x.isPWO_support.countable_of_archimedean + +variable [Fact (ℵ₀ < κ)] + +/-- The field of Hahn series with fewer than `κ` support terms. -/ +abbrev CardSuppLTField := ↥(cardSuppLTSubfield G R κ) + +/-- The `κ`-bounded nonpositive Hahn series whose coefficient at zero belongs to `Z`. -/ +def cardSuppLTTruncationIntegerPart (Z : Subring R) : Subring (CardSuppLTField (G := G) (R := R) + (κ := κ)) where + carrier x := (x : R⟦G⟧).support ⊆ Set.Iic 0 ∧ (x : R⟦G⟧).coeff 0 ∈ Z + zero_mem' := by + constructor + · simp + · simp + one_mem' := by + constructor + · intro g hg + have hg0 : g = 0 := support_single_subset hg + simp [hg0] + · simp + add_mem' := fun {x y} hx hy => by + constructor + · intro g hg + rcases support_add_subset (x : R⟦G⟧) (y : R⟦G⟧) hg with hg | hg + · exact hx.1 hg + · exact hy.1 hg + · change (((x : R⟦G⟧) + (y : R⟦G⟧)).coeff 0) ∈ Z + rw [coeff_add] + exact Z.add_mem hx.2 hy.2 + neg_mem' := fun {x} hx => by + constructor + · exact (support_neg_subset (x : R⟦G⟧)).trans hx.1 + · change ((-(x : R⟦G⟧)).coeff 0) ∈ Z + rw [coeff_neg] + exact Z.neg_mem hx.2 + mul_mem' := fun {x y} hx hy => by + constructor + · intro g hg + obtain ⟨i, hi, j, hj, rfl⟩ := support_mul_subset hg + exact add_nonpos (hx.1 hi) (hy.1 hj) + · let x' : Nonpositive G R := ⟨x, hx.1⟩ + let y' : Nonpositive G R := ⟨y, hy.1⟩ + change (((x' : R⟦G⟧) * (y' : R⟦G⟧)).coeff 0) ∈ Z + rw [Nonpositive.coeff_zero_mul] + exact Z.mul_mem hx.2 hy.2 + +/-- Membership in the `κ`-bounded truncation integer part. -/ +@[simp] +theorem mem_cardSuppLTTruncationIntegerPart {Z : Subring R} {x : CardSuppLTField (G := G) (R := R) + (κ := κ)} : + x ∈ cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z ↔ + (x : R⟦G⟧).support ⊆ Set.Iic 0 ∧ (x : R⟦G⟧).coeff 0 ∈ Z := + Iff.rfl + +namespace CardSuppLTTruncationIntegerPart + +/-- Forget the cardinal bound while retaining the nonpositive-support witness. -/ +def toNonpositiveRingHom (Z : Subring R) : + cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z →+* + Nonpositive G R where + toFun x := ⟨x, x.2.1⟩ + map_one' := rfl + map_mul' _ _ := rfl + map_zero' := rfl + map_add' _ _ := rfl + +/-- Forgetting the bound and then coercing to a Hahn series preserves the underlying series. -/ +@[simp] +theorem coe_toNonpositiveRingHom (Z : Subring R) + (x : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) : + (toNonpositiveRingHom Z x : R⟦G⟧) = (x : CardSuppLTField (G := G) (R := R) (κ := κ)) := + (rfl) + +/-- Forgetting the cardinal bound is injective. -/ +theorem toNonpositiveRingHom_injective (Z : Subring R) : + Function.Injective (toNonpositiveRingHom (G := G) (R := R) (κ := κ) Z) := by + intro x y hxy + apply Subtype.ext + apply Subtype.ext + have hraw := congrArg (fun q : Nonpositive G R ↦ (q : R⟦G⟧)) hxy + simpa only [coe_toNonpositiveRingHom] using hraw + +/-- Forgetting the bound retains the proof that the support has cardinality less than `κ`. -/ +theorem cardSupp_toNonpositiveRingHom_lt (Z : Subring R) + (x : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) : + (toNonpositiveRingHom Z x : R⟦G⟧).cardSupp < κ := by + rw [coe_toNonpositiveRingHom] + exact (mem_cardSuppLTSubfield (Γ := G) (R := R) (κ := κ)).mp x.1.2 + +/-- Forget the cardinal bound on a bounded truncation-integer-part element. -/ +def toTruncationIntegerPartRingHom (Z : Subring R) : + cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z →+* + truncationIntegerPart G Z where + toFun x := ⟨toNonpositiveRingHom Z x, + (mem_truncationIntegerPart (R := R) (Γ := G)).mpr x.2.2⟩ + map_one' := rfl + map_mul' _ _ := rfl + map_zero' := rfl + map_add' _ _ := rfl + +/-- Forgetting the bound preserves the underlying nonpositive Hahn series. -/ +@[simp] +theorem coe_toTruncationIntegerPartRingHom (Z : Subring R) + (x : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) : + (toTruncationIntegerPartRingHom Z x : Nonpositive G R) = toNonpositiveRingHom Z x := + (rfl) + +/-- Forgetting the cardinal bound on a truncation integer part is injective. -/ +theorem toTruncationIntegerPartRingHom_injective (Z : Subring R) : + Function.Injective + (toTruncationIntegerPartRingHom (G := G) (R := R) (κ := κ) Z) := by + intro x y hxy + apply toNonpositiveRingHom_injective Z + have h := congrArg (fun q : truncationIntegerPart G Z ↦ (q : Nonpositive G R)) hxy + simpa only [coe_toTruncationIntegerPartRingHom] using h + +end CardSuppLTTruncationIntegerPart + +/-- If `κ ≤ cof(G)`, the `κ`-bounded truncation integer part has the whole bounded Hahn +field as its fraction subring. -/ +@[blueprint "thm:bounded-hahn-integer-part-fraction-field" + (phase := "Finitely many Archimedean classes") + (title := "Fraction fields of bounded Hahn integer parts") + (statement := /-- + Let $G$ be an ordered abelian group, let $K$ be a field, and let + $\kappa>\aleph_0$. If $\kappa\le\operatorname{cof}(G)$, then the bounded + Hahn field $K((G))_\kappa$ is the fraction field of + $Z+K((G^{<0}))_\kappa$ for every subring $Z\subseteq K$. + -/) + (proof := /-- + The support of a series in $K((G))_\kappa$ has cardinality less than + $\kappa$, so it is not cofinal in $G$. Choose an upper bound $x$ for the + support and put $u=\max\{x,0\}$. Multiplication by $t^{-u}$ moves the + support strictly below zero and gives constant coefficient zero. Thus + both $t^{-u}$ and $t^{-u}b$ belong to the bounded Hahn integer part, and + $b=(t^{-u}b)/t^{-u}$. + -/)] +theorem fracSubring_cardSuppLTTruncationIntegerPart_eq_top_of_le_cof (Z : Subring R) + (hcof : κ ≤ Order.cof G) : + Subring.fracSubring + (cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) = ⊤ := by + apply top_unique + intro b _ + have hsnot : ¬ IsCofinal (b : R⟦G⟧).support := by + intro hs + have hκcard : κ ≤ #(b : R⟦G⟧).support := + (Order.le_cof_iff.mp hcof) _ hs + exact (not_lt_of_ge hκcard) b.2 + obtain ⟨x, hx⟩ := not_isCofinal_iff.mp hsnot + let u : G := max x 0 + let d0 : R⟦G⟧ := single (-u) 1 + have hdcard : d0.cardSupp < κ := + (cardSupp_single_le (-u) (1 : R)).trans_lt + (one_lt_aleph0.trans (Fact.out : ℵ₀ < κ)) + let d : CardSuppLTField (G := G) (R := R) (κ := κ) := ⟨d0, hdcard⟩ + have hdu : -u ≤ 0 := neg_nonpos.mpr (le_max_right x 0) + have hdmem : d ∈ cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z := by + rw [mem_cardSuppLTTruncationIntegerPart] + constructor + · intro g hg + have hg' : g ∈ (single (-u) (1 : R)).support := by + simpa [d, d0] using hg + have hg_eq : g = -u := by + exact eq_of_mem_support_single hg' + rw [hg_eq] + exact hdu + · by_cases hu : u = 0 + · simp [d, d0, hu] + · have hnu : -u ≠ 0 := neg_ne_zero.mpr hu + have hzero : (single (-u) (1 : R)).coeff 0 = 0 := + coeff_single_of_ne (Ne.symm hnu) + simp [d, d0, hzero] + let a0 : R⟦G⟧ := d0 * (b : R⟦G⟧) + have hacard : a0.cardSupp < κ := + (cardSupp_single_mul_le (b : R⟦G⟧) (-u) (1 : R)).trans_lt b.2 + let a : CardSuppLTField (G := G) (R := R) (κ := κ) := ⟨a0, hacard⟩ + have hamem : a ∈ cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z := by + rw [mem_cardSuppLTTruncationIntegerPart] + constructor + · intro g hg + have hcoeff : (b : R⟦G⟧).coeff (g + u) ≠ 0 := by + simpa [a, a0, d0, coeff_single_mul, sub_eq_add_neg] using hg + have hlt : g + u < x := hx _ hcoeff + have hxu : x ≤ u := le_max_left x 0 + have hxu' : x ≤ 0 + u := by simpa using hxu + have hgu : g + u < 0 + u := hlt.trans_le hxu' + simpa using hgu.le + · have : (a0.coeff 0) = (b : R⟦G⟧).coeff u := by + simp [a0, d0, coeff_single_mul, sub_eq_add_neg] + rw [this] + have hnot : u ∉ (b : R⟦G⟧).support := by + intro humem + have := hx u humem + exact (not_lt_of_ge (le_max_left x 0)) this + have hzero : (b : R⟦G⟧).coeff u = 0 := by + simpa [mem_support] using hnot + rw [hzero] + exact Z.zero_mem + have hdF : d ∈ Subring.fracSubring + (cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) := + Subring.le_fracSubring hdmem + have haF : a ∈ Subring.fracSubring + (cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) := + Subring.le_fracSubring hamem + have hd0 : d ≠ 0 := by + intro h + have := congrArg (fun z : CardSuppLTField (G := G) (R := R) (κ := κ) => + (z : R⟦G⟧).coeff (-u)) h + simp [d, d0] at this + have hba : a = d * b := rfl + rw [show b = a * d⁻¹ by rw [hba, mul_comm d b, mul_inv_cancel_right₀ hd0]] + exact (Subring.fracSubring _).mul_mem haF (Subring.inv_mem_fracSubring hdF) + +/-- For the zero exponent group, a coefficient-level fraction-subring equality lifts to the +`κ`-bounded Hahn truncation integer part. -/ +theorem fracSubring_cardSuppLTTruncationIntegerPart_eq_top_of_subsingleton (Z : Subring R) + [Subsingleton G] (hfrac : Subring.fracSubring Z = ⊤) : + Subring.fracSubring + (cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) = ⊤ := by + apply top_unique + intro b _ + let r : R := (b : R⟦G⟧).coeff 0 + have hrF : r ∈ Subring.fracSubring Z := by + rw [hfrac] + trivial + obtain ⟨z, hzZ, hz0, hzrZ⟩ := Subring.exists_den hrF + let d0 : R⟦G⟧ := single 0 z + have hdcard : d0.cardSupp < κ := + (cardSupp_single_le (0 : G) z).trans_lt + (one_lt_aleph0.trans (Fact.out : ℵ₀ < κ)) + let d : CardSuppLTField (G := G) (R := R) (κ := κ) := ⟨d0, hdcard⟩ + have hdmem : d ∈ cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z := by + rw [mem_cardSuppLTTruncationIntegerPart] + constructor + · intro g hg + have hg_eq : g = 0 := Subsingleton.elim _ _ + simp [hg_eq] + · simpa [d, d0] using hzZ + let a0 : R⟦G⟧ := single 0 (z * r) + have hacard : a0.cardSupp < κ := + (cardSupp_single_le (0 : G) (z * r)).trans_lt + (one_lt_aleph0.trans (Fact.out : ℵ₀ < κ)) + let a : CardSuppLTField (G := G) (R := R) (κ := κ) := ⟨a0, hacard⟩ + have hamem : a ∈ cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z := by + rw [mem_cardSuppLTTruncationIntegerPart] + constructor + · intro g hg + have hg_eq : g = 0 := Subsingleton.elim _ _ + simp [hg_eq] + · simpa [a, a0] using hzrZ + have hbC : (b : R⟦G⟧) = single 0 r := by + ext g + have hg : g = 0 := Subsingleton.elim _ _ + subst g + simp [r] + have hdF : d ∈ Subring.fracSubring + (cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) := + Subring.le_fracSubring hdmem + have haF : a ∈ Subring.fracSubring + (cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) := + Subring.le_fracSubring hamem + have hd0 : d ≠ 0 := by + intro h + have := congrArg (fun w : CardSuppLTField (G := G) (R := R) (κ := κ) => + (w : R⟦G⟧).coeff 0) h + simp [d, d0, hz0] at this + have hba : a = d * b := by + apply Subtype.ext + change a0 = d0 * (b : R⟦G⟧) + rw [hbC] + simp [a0, d0] + rw [show b = a * d⁻¹ by rw [hba, mul_comm d b, mul_inv_cancel_right₀ hd0]] + exact (Subring.fracSubring _).mul_mem haF (Subring.inv_mem_fracSubring hdF) + +end HahnSeries diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/CardinalTruncationDomainEmbedding.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/CardinalTruncationDomainEmbedding.lean new file mode 100644 index 0000000000..63dd300245 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/CardinalTruncationDomainEmbedding.lean @@ -0,0 +1,364 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.CardinalTruncation +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.ConvexFactorSupport +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.ConvexQuotientSplitting +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Domain +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.DomainEmbedding + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.SubgroupSupport + +/-! +# Exponent-domain embeddings of cardinal-bounded Hahn integer parts + +An additive order embedding of exponent groups induces embeddings of the cardinal-bounded Hahn +fields and their nonpositive integer parts. Restriction along the exponent embedding is a left +inverse, and a right inverse on series whose support lies in the embedding's range. +-/ + +open Cardinal + +universe u v w + +public noncomputable section + +namespace HahnSeries + +variable {G : Type u} {H : Type u} {R : Type v} {κ : Cardinal.{u}} +variable [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] +variable [AddCommGroup H] [LinearOrder H] [IsOrderedAddMonoid H] +variable [Field R] [Fact (aleph0 < κ)] + +/-- Map a cardinal-bounded Hahn field along an injective additive order embedding. -/ +def cardSuppLTFieldMapDomain (f : G →+ H) (hfi : Function.Injective f) + (hf : ∀ g g' : G, f g ≤ f g' ↔ g ≤ g') : + CardSuppLTField (G := G) (R := R) (κ := κ) →+* + CardSuppLTField (G := H) (R := R) (κ := κ) where + toFun x := ⟨HahnSeries.embDomain (⟨⟨f, hfi⟩, hf _ _⟩ : G ↪o H) x, by + rw [HahnSeries.mem_cardSuppLTSubfield, HahnSeries.cardSupp_embDomain] + exact x.2⟩ + map_one' := by + apply Subtype.ext + exact map_one (HahnSeries.embDomainRingHom f hfi hf) + map_mul' x y := by + apply Subtype.ext + exact map_mul (HahnSeries.embDomainRingHom f hfi hf) (x : R⟦G⟧) y + map_zero' := by + apply Subtype.ext + exact map_zero (HahnSeries.embDomainRingHom f hfi hf) + map_add' x y := by + apply Subtype.ext + exact map_add (HahnSeries.embDomainRingHom f hfi hf) (x : R⟦G⟧) y + +@[simp] +theorem coe_cardSuppLTFieldMapDomain (f : G →+ H) (hfi : Function.Injective f) + (hf : ∀ g g' : G, f g ≤ f g' ↔ g ≤ g') + (x : CardSuppLTField (G := G) (R := R) (κ := κ)) : + (cardSuppLTFieldMapDomain f hfi hf x : R⟦H⟧) = + HahnSeries.embDomain (⟨⟨f, hfi⟩, hf _ _⟩ : G ↪o H) (x : R⟦G⟧) := + (rfl) + +/-- Map a cardinal-bounded Hahn integer part along an injective additive order embedding. -/ +def CardSuppLTTruncationIntegerPart.mapDomain (f : G →+ H) + (hfi : Function.Injective f) (hf : ∀ g g' : G, f g ≤ f g' ↔ g ≤ g') + (Z : Subring R) : + cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z →+* + cardSuppLTTruncationIntegerPart (G := H) (R := R) (κ := κ) Z := + ((cardSuppLTFieldMapDomain f hfi hf).domRestrict + (cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z)).codRestrict + (cardSuppLTTruncationIntegerPart (G := H) (R := R) (κ := κ) Z) (fun x ↦ by + rw [mem_cardSuppLTTruncationIntegerPart] + have hx := (mem_cardSuppLTTruncationIntegerPart (Z := Z)).mp x.2 + constructor + · change (HahnSeries.embDomain + (⟨⟨f, hfi⟩, hf _ _⟩ : G ↪o H) (x : R⟦G⟧)).support ⊆ Set.Iic 0 + rw [HahnSeries.support_embDomain] + rintro _ ⟨g, hg, rfl⟩ + change f g ≤ 0 + simpa only [map_zero] using (hf g 0).mpr (hx.1 hg) + · change (HahnSeries.embDomain + (⟨⟨f, hfi⟩, hf _ _⟩ : G ↪o H) (x : R⟦G⟧)).coeff 0 ∈ Z + have h := HahnSeries.embDomain_coeff + (f := (⟨⟨f, hfi⟩, hf _ _⟩ : G ↪o H)) (x := (x : R⟦G⟧)) (a := 0) + have he0 : (⟨⟨f, hfi⟩, hf _ _⟩ : G ↪o H) 0 = 0 := f.map_zero + rw [he0] at h + exact h.symm ▸ hx.2 + ) + +@[simp] +theorem CardSuppLTTruncationIntegerPart.coe_mapDomain + (f : G →+ H) (hfi : Function.Injective f) + (hf : ∀ g g' : G, f g ≤ f g' ↔ g ≤ g') (Z : Subring R) + (x : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) : + (((CardSuppLTTruncationIntegerPart.mapDomain f hfi hf Z x : + cardSuppLTTruncationIntegerPart (G := H) (R := R) (κ := κ) Z) : + CardSuppLTField (G := H) (R := R) (κ := κ)) : R⟦H⟧) = + HahnSeries.embDomain (⟨⟨f, hfi⟩, hf _ _⟩ : G ↪o H) (x : R⟦G⟧) := + (rfl) + +/-- Restrict a cardinal-bounded Hahn integer-part element to an embedded exponent domain. -/ +def CardSuppLTTruncationIntegerPart.restrictDomain + (f : G →+ H) (hfi : Function.Injective f) + (hf : ∀ g g' : G, f g ≤ f g' ↔ g ≤ g') (Z : Subring R) + (x : cardSuppLTTruncationIntegerPart (G := H) (R := R) (κ := κ) Z) : + cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z := by + let e : G ↪o H := ⟨⟨f, hfi⟩, hf _ _⟩ + let y : R⟦G⟧ := HahnSeries.restrictDomain e (x : R⟦H⟧) + have hycard : y.cardSupp < κ := by + rw [HahnSeries.cardSupp] + apply (Cardinal.mk_le_of_injective (f := fun g : y.support ↦ + (⟨f g.1, by + rw [HahnSeries.mem_support] + have hg := (HahnSeries.mem_support _ _).mp g.2 + change (x : R⟦H⟧).coeff (e g.1) ≠ 0 + simpa only [y, HahnSeries.restrictDomain_coeff] using hg⟩ : + (x : R⟦H⟧).support)) ?_).trans_lt x.1.2 + intro a b hab + apply Subtype.ext + exact hfi (congrArg Subtype.val hab) + exact ⟨⟨y, hycard⟩, by + rw [mem_cardSuppLTTruncationIntegerPart] + have hx := (mem_cardSuppLTTruncationIntegerPart (Z := Z)).mp x.2 + constructor + · intro g hg + apply (hf g 0).mp + have hfg : f g ∈ (x : R⟦H⟧).support := by + rw [HahnSeries.mem_support] + have hg' := (HahnSeries.mem_support _ _).mp hg + change (x : R⟦H⟧).coeff (e g) ≠ 0 + simpa only [y, HahnSeries.restrictDomain_coeff] using hg' + rw [f.map_zero] + exact hx.1 hfg + · change y.coeff 0 ∈ Z + rw [HahnSeries.restrictDomain_coeff] + change (x : R⟦H⟧).coeff (f 0) ∈ Z + rw [f.map_zero] + exact hx.2⟩ + +@[simp] +theorem CardSuppLTTruncationIntegerPart.coe_restrictDomain + (f : G →+ H) (hfi : Function.Injective f) + (hf : ∀ g g' : G, f g ≤ f g' ↔ g ≤ g') (Z : Subring R) + (x : cardSuppLTTruncationIntegerPart (G := H) (R := R) (κ := κ) Z) : + ((CardSuppLTTruncationIntegerPart.restrictDomain f hfi hf Z x : + cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) : R⟦G⟧) = + HahnSeries.restrictDomain (⟨⟨f, hfi⟩, hf _ _⟩ : G ↪o H) (x : R⟦H⟧) := + (rfl) + +/-- The bundled outer-zero coefficient of convex quotient regrouping is bounded integer-part +restriction to the convex submodule. -/ +theorem CardSuppLTTruncationIntegerPart.coeff_zero_convexQuotientSplitRingEquiv + {K : Type w} [Field K] [Module K H] [Fact κ.IsRegular] + (P : Submodule K H) [P.toAddSubgroup.IsConvex] (Z : Subring R) + (x : cardSuppLTTruncationIntegerPart (G := H) (R := R) (κ := κ) Z) : + (⟨((cardSuppLTTruncationIntegerPartConvexQuotientSplitRingEquiv P Z x).1.1.coeff 0), + ((mem_cardSuppLTTruncationIntegerPart + (Z := cardSuppLTTruncationIntegerPart + (G := P) (R := R) (κ := κ) Z)).mp + (cardSuppLTTruncationIntegerPartConvexQuotientSplitRingEquiv P Z x).2).2⟩ : + cardSuppLTTruncationIntegerPart (G := P) (R := R) (κ := κ) Z) = + CardSuppLTTruncationIntegerPart.restrictDomain + P.toAddSubgroup.subtype P.toAddSubgroup.subtype_injective (fun _ _ ↦ ⟨fun h ↦ h, fun h ↦ + h⟩) Z x := by + apply Subtype.ext + apply Subtype.ext + rw [coe_restrictDomain] + ext p + have hzero : + ((((cardSuppLTTruncationIntegerPartConvexQuotientSplitRingEquiv P Z x : + cardSuppLTTruncationIntegerPart (G := H ⧸ P) + (R := CardSuppLTField (G := P) (R := R) (κ := κ)) (κ := κ) + (cardSuppLTTruncationIntegerPart (G := P) (R := R) (κ := κ) Z)) : + CardSuppLTField (G := H ⧸ P) + (R := CardSuppLTField (G := P) (R := R) (κ := κ)) (κ := κ)).1.coeff 0 : + CardSuppLTField (G := P) (R := R) (κ := κ)) : R⟦P⟧) = + HahnSeries.restrictDomain (submoduleOrderEmbedding P) (x : R⟦H⟧) := by + rw [coe_cardSuppLTTruncationIntegerPartConvexQuotientSplitRingEquiv] + exact coe_coeff_zero_boundedConvexQuotientSplit P x.1 + have hp := congrArg (fun z : R⟦P⟧ ↦ z.coeff p) hzero + rw [HahnSeries.restrictDomain_coeff] at hp ⊢ + change (↑((cardSuppLTTruncationIntegerPartConvexQuotientSplitRingEquiv + P Z x).1.1.coeff 0) : R⟦P⟧).coeff p = (x : R⟦H⟧).coeff (p : H) + simpa only [submoduleOrderEmbedding_apply] using hp + +@[simp] +theorem CardSuppLTTruncationIntegerPart.restrictDomain_mapDomain + (f : G →+ H) (hfi : Function.Injective f) + (hf : ∀ g g' : G, f g ≤ f g' ↔ g ≤ g') (Z : Subring R) + (x : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) : + CardSuppLTTruncationIntegerPart.restrictDomain f hfi hf Z + (CardSuppLTTruncationIntegerPart.mapDomain f hfi hf Z x) = x := by + apply Subtype.ext + apply Subtype.ext + exact HahnSeries.restrictDomain_embDomain _ _ + +theorem CardSuppLTTruncationIntegerPart.mapDomain_restrictDomain + (f : G →+ H) (hfi : Function.Injective f) + (hf : ∀ g g' : G, f g ≤ f g' ↔ g ≤ g') (Z : Subring R) + (x : cardSuppLTTruncationIntegerPart (G := H) (R := R) (κ := κ) Z) + (hx : (x : R⟦H⟧).support ⊆ Set.range f) : + CardSuppLTTruncationIntegerPart.mapDomain f hfi hf Z + (CardSuppLTTruncationIntegerPart.restrictDomain f hfi hf Z x) = x := by + apply Subtype.ext + apply Subtype.ext + exact HahnSeries.embDomain_restrictDomain _ _ hx + +open Classical in +/-- Embedding after restriction keeps exactly the exponents in the embedding's range. -/ +theorem CardSuppLTTruncationIntegerPart.coe_mapDomain_restrictDomain + (f : G →+ H) (hfi : Function.Injective f) + (hf : ∀ g g' : G, f g ≤ f g' ↔ g ≤ g') (Z : Subring R) + (x : cardSuppLTTruncationIntegerPart (G := H) (R := R) (κ := κ) Z) : + ((CardSuppLTTruncationIntegerPart.mapDomain f hfi hf Z + (CardSuppLTTruncationIntegerPart.restrictDomain f hfi hf Z x) : + cardSuppLTTruncationIntegerPart (G := H) (R := R) (κ := κ) Z) : R⟦H⟧) = + HahnSeries.filter (· ∈ f.range) (x : R⟦H⟧) := by + ext h + rw [CardSuppLTTruncationIntegerPart.coe_mapDomain, + CardSuppLTTruncationIntegerPart.coe_restrictDomain] + let e : G ↪o H := ⟨⟨f, hfi⟩, hf _ _⟩ + change (HahnSeries.embDomain e + (HahnSeries.restrictDomain e (x : R⟦H⟧))).coeff h = _ + by_cases hh : h ∈ f.range + · obtain ⟨g, rfl⟩ := hh + change (HahnSeries.embDomain e + (HahnSeries.restrictDomain e (x : R⟦H⟧))).coeff (e g) = _ + rw [HahnSeries.embDomain_coeff, HahnSeries.restrictDomain_coeff, + HahnSeries.coeff_filter, ite_eq_left] + · rfl + · exact Set.mem_range_self g + · rw [HahnSeries.embDomain_of_notMem_range] + · rw [HahnSeries.coeff_filter, ite_eq_right hh] + · exact hh + +namespace CardSuppLTTruncationIntegerPart + +/-- If the image exponent subgroup is convex, primality of an embedded bounded integer-part +element descends to the original exponent domain. -/ +theorem isPrimal_of_isPrimal_mapDomain + (f : G →+ H) (hfi : Function.Injective f) + (hf : ∀ g g' : G, f g ≤ f g' ↔ g ≤ g') (Z : Subring R) + (hrange : (Set.range f).OrdConnected) + (a : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) + (ha : IsPrimal (mapDomain f hfi hf Z a)) : IsPrimal a := by + let F : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z →+* + cardSuppLTTruncationIntegerPart (G := H) (R := R) (κ := κ) Z := + mapDomain f hfi hf Z + let C : AddSubgroup H := f.range + have hC : (C : Set H).OrdConnected := by + simpa only [C, AddMonoidHom.coe_range] using hrange + rcases eq_or_ne a 0 with rfl | ha0 + · exact isPrimal_zero + intro b c ⟨q, hq⟩ + have hdiv : F a ∣ F b * F c := by + refine ⟨F q, ?_⟩ + rw [← map_mul, hq, map_mul] + obtain ⟨a₁, a₂, ⟨q₁, hq₁⟩, ⟨q₂, hq₂⟩, ha₁a₂⟩ := ha hdiv + have hFa0 : F a ≠ 0 := by + intro h + apply ha0 + apply Subtype.ext + apply Subtype.ext + have hraw := congrArg (fun x : cardSuppLTTruncationIntegerPart + (G := H) (R := R) (κ := κ) Z ↦ (x : R⟦H⟧)) h + rw [coe_mapDomain] at hraw + exact HahnSeries.embDomain_injective (by simpa using hraw) + have ha₁0 : a₁ ≠ 0 := fun h ↦ hFa0 (by rw [ha₁a₂, h, zero_mul]) + have ha₂0 : a₂ ≠ 0 := fun h ↦ hFa0 (by rw [ha₁a₂, h, mul_zero]) + have ha₁N0 : toNonpositiveRingHom Z a₁ ≠ 0 := by + intro h + apply ha₁0 + apply toNonpositiveRingHom_injective Z + exact h.trans (map_zero _).symm + have ha₂N0 : toNonpositiveRingHom Z a₂ ≠ 0 := by + intro h + apply ha₂0 + apply toNonpositiveRingHom_injective Z + exact h.trans (map_zero _).symm + have hFasupp : ((F a : cardSuppLTTruncationIntegerPart + (G := H) (R := R) (κ := κ) Z) : R⟦H⟧).support ⊆ (C : Set H) := by + rw [coe_mapDomain, HahnSeries.support_embDomain] + exact Set.image_subset_range _ _ + have ha₁a₂raw : ((a₁ * a₂ : cardSuppLTTruncationIntegerPart + (G := H) (R := R) (κ := κ) Z) : R⟦H⟧) = (F a : R⟦H⟧) := by + exact congrArg (fun x : cardSuppLTTruncationIntegerPart + (G := H) (R := R) (κ := κ) Z ↦ (x : R⟦H⟧)) ha₁a₂.symm + have hsuppFactors := HahnSeries.Nonpositive.support_subset_convex_of_mul_support_subset + hC (a := toNonpositiveRingHom Z a₁) (b := toNonpositiveRingHom Z a₂) + ha₁N0 ha₂N0 (by + have heq : (toNonpositiveRingHom Z a₁ * toNonpositiveRingHom Z a₂ : + HahnSeries.Nonpositive H R) = toNonpositiveRingHom Z (a₁ * a₂) := by + rw [map_mul] + rw [heq, coe_toNonpositiveRingHom, ha₁a₂raw] + exact hFasupp) + have ha₁supp : (a₁ : R⟦H⟧).support ⊆ (C : Set H) := by + simpa only [coe_toNonpositiveRingHom] using hsuppFactors.1 + have ha₂supp : (a₂ : R⟦H⟧).support ⊆ (C : Set H) := by + simpa only [coe_toNonpositiveRingHom] using hsuppFactors.2 + have hq₁supp : (q₁ : R⟦H⟧).support ⊆ (C : Set H) := by + apply HahnSeries.support_subset_of_mul_eq + (e := (a₁ : R⟦H⟧)) (u := (q₁ : R⟦H⟧)) (f := (F b : R⟦H⟧)) + · exact ha₁supp + · exact fun h ↦ ha₁0 (Subtype.ext (Subtype.ext h)) + · rw [coe_mapDomain, HahnSeries.support_embDomain] + exact Set.image_subset_range _ _ + · exact congrArg (fun x : cardSuppLTTruncationIntegerPart + (G := H) (R := R) (κ := κ) Z ↦ (x : R⟦H⟧)) hq₁ + have hq₂supp : (q₂ : R⟦H⟧).support ⊆ (C : Set H) := by + apply HahnSeries.support_subset_of_mul_eq + (e := (a₂ : R⟦H⟧)) (u := (q₂ : R⟦H⟧)) (f := (F c : R⟦H⟧)) + · exact ha₂supp + · exact fun h ↦ ha₂0 (Subtype.ext (Subtype.ext h)) + · rw [coe_mapDomain, HahnSeries.support_embDomain] + exact Set.image_subset_range _ _ + · exact congrArg (fun x : cardSuppLTTruncationIntegerPart + (G := H) (R := R) (κ := κ) Z ↦ (x : R⟦H⟧)) hq₂ + let A₁ := restrictDomain f hfi hf Z a₁ + let A₂ := restrictDomain f hfi hf Z a₂ + let Q₁ := restrictDomain f hfi hf Z q₁ + let Q₂ := restrictDomain f hfi hf Z q₂ + have hmapA₁ : F A₁ = a₁ := mapDomain_restrictDomain f hfi hf Z a₁ (by + simpa only [C, AddMonoidHom.coe_range] using ha₁supp) + have hmapA₂ : F A₂ = a₂ := mapDomain_restrictDomain f hfi hf Z a₂ (by + simpa only [C, AddMonoidHom.coe_range] using ha₂supp) + have hmapQ₁ : F Q₁ = q₁ := mapDomain_restrictDomain f hfi hf Z q₁ (by + simpa only [C, AddMonoidHom.coe_range] using hq₁supp) + have hmapQ₂ : F Q₂ = q₂ := mapDomain_restrictDomain f hfi hf Z q₂ (by + simpa only [C, AddMonoidHom.coe_range] using hq₂supp) + refine ⟨A₁, A₂, ⟨Q₁, ?_⟩, ⟨Q₂, ?_⟩, ?_⟩ + · apply Subtype.ext + apply Subtype.ext + have hF : F b = F (A₁ * Q₁) := by + rw [map_mul, hmapA₁, hmapQ₁] + exact hq₁ + have hraw := congrArg (fun x : cardSuppLTTruncationIntegerPart + (G := H) (R := R) (κ := κ) Z ↦ (x : R⟦H⟧)) hF + rw [coe_mapDomain, coe_mapDomain] at hraw + exact HahnSeries.embDomain_injective hraw + · apply Subtype.ext + apply Subtype.ext + have hF : F c = F (A₂ * Q₂) := by + rw [map_mul, hmapA₂, hmapQ₂] + exact hq₂ + have hraw := congrArg (fun x : cardSuppLTTruncationIntegerPart + (G := H) (R := R) (κ := κ) Z ↦ (x : R⟦H⟧)) hF + rw [coe_mapDomain, coe_mapDomain] at hraw + exact HahnSeries.embDomain_injective hraw + · apply Subtype.ext + apply Subtype.ext + have hF : F a = F (A₁ * A₂) := by + rw [map_mul, hmapA₁, hmapA₂] + exact ha₁a₂ + have hraw := congrArg (fun x : cardSuppLTTruncationIntegerPart + (G := H) (R := R) (κ := κ) Z ↦ (x : R⟦H⟧)) hF + rw [coe_mapDomain, coe_mapDomain] at hraw + exact HahnSeries.embDomain_injective hraw + +end CardSuppLTTruncationIntegerPart + +end HahnSeries diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/CardinalTruncationDomainEquiv.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/CardinalTruncationDomainEquiv.lean new file mode 100644 index 0000000000..804dfc6d01 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/CardinalTruncationDomainEquiv.lean @@ -0,0 +1,135 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.CardinalTruncation +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.DomainEquiv + +/-! +# Exponent reindexing for cardinal-bounded Hahn integer parts + +An ordered additive equivalence of exponent groups preserves support cardinality, nonpositive +support, and the coefficient at zero. It therefore reindexes both the cardinal-bounded Hahn field +and its truncation integer part. +-/ + +universe u v + +public noncomputable section + +namespace HahnSeries + +open Cardinal + +variable {G H : Type u} {R : Type v} {κ : Cardinal.{u}} +variable [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] +variable [AddCommGroup H] [LinearOrder H] [IsOrderedAddMonoid H] +variable [Field R] [Fact (ℵ₀ < κ)] + +/-- Reindex a cardinal-bounded Hahn field along an ordered additive equivalence. -/ +def cardSuppLTFieldRingEquiv (e : G ≃+o H) : + CardSuppLTField (G := G) (R := R) (κ := κ) ≃+* + CardSuppLTField (G := H) (R := R) (κ := κ) where + toFun x := ⟨embDomainRingEquiv e x, by + rw [mem_cardSuppLTSubfield, cardSupp_embDomainRingEquiv] + exact x.2⟩ + invFun x := ⟨embDomainRingEquiv e.symm x, by + rw [mem_cardSuppLTSubfield, cardSupp_embDomainRingEquiv] + exact x.2⟩ + left_inv x := by + apply Subtype.ext + ext g + have houter := embDomainRingEquiv_coeff e.symm + (embDomainRingEquiv e (x : R⟦G⟧)) (e g) + rw [e.symm_apply_apply, embDomainRingEquiv_coeff] at houter + exact houter + right_inv x := by + apply Subtype.ext + ext h + have houter := embDomainRingEquiv_coeff e + (embDomainRingEquiv e.symm (x : R⟦H⟧)) (e.symm h) + rw [e.apply_symm_apply, embDomainRingEquiv_coeff] at houter + exact houter + map_mul' x y := by + apply Subtype.ext + exact map_mul (embDomainRingEquiv e) (x : R⟦G⟧) y + map_add' x y := by + apply Subtype.ext + exact map_add (embDomainRingEquiv e) (x : R⟦G⟧) y + +/-- Coercing a reindexed bounded series gives unrestricted exponent reindexing. -/ +@[simp] +theorem coe_cardSuppLTFieldRingEquiv (e : G ≃+o H) + (x : CardSuppLTField (G := G) (R := R) (κ := κ)) : + (cardSuppLTFieldRingEquiv e x : R⟦H⟧) = embDomainRingEquiv e x := + (rfl) + +/-- Reindex a cardinal-bounded truncation integer part along an ordered additive equivalence. -/ +def cardSuppLTTruncationIntegerPartRingEquiv (e : G ≃+o H) (Z : Subring R) : + cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z ≃+* + cardSuppLTTruncationIntegerPart (G := H) (R := R) (κ := κ) Z where + toFun x := ⟨cardSuppLTFieldRingEquiv e x, by + rw [mem_cardSuppLTTruncationIntegerPart] + have hx := (mem_cardSuppLTTruncationIntegerPart (Z := Z)).mp x.2 + constructor + · intro h hh + rw [coe_cardSuppLTFieldRingEquiv, support_embDomainRingEquiv] at hh + obtain ⟨g, hg, rfl⟩ := hh + change e g ≤ 0 + calc + e g ≤ e 0 := e.map_le_map_iff'.mpr (hx.1 hg) + _ = 0 := map_zero e + · change (embDomainRingEquiv e (x : R⟦G⟧)).coeff 0 ∈ Z + rw [← map_zero e, embDomainRingEquiv_coeff] + exact hx.2⟩ + invFun x := ⟨cardSuppLTFieldRingEquiv e.symm x, by + rw [mem_cardSuppLTTruncationIntegerPart] + have hx := (mem_cardSuppLTTruncationIntegerPart (Z := Z)).mp x.2 + constructor + · intro g hg + rw [coe_cardSuppLTFieldRingEquiv, support_embDomainRingEquiv] at hg + obtain ⟨h, hh, rfl⟩ := hg + change e.symm h ≤ 0 + calc + e.symm h ≤ e.symm 0 := e.symm.map_le_map_iff'.mpr (hx.1 hh) + _ = 0 := map_zero e.symm + · change (embDomainRingEquiv e.symm (x : R⟦H⟧)).coeff 0 ∈ Z + rw [← map_zero e.symm, embDomainRingEquiv_coeff] + exact hx.2⟩ + left_inv x := by + apply Subtype.ext + apply Subtype.ext + ext g + have houter := embDomainRingEquiv_coeff e.symm + (embDomainRingEquiv e (x : R⟦G⟧)) (e g) + rw [e.symm_apply_apply, embDomainRingEquiv_coeff] at houter + exact houter + right_inv x := by + apply Subtype.ext + apply Subtype.ext + ext h + have houter := embDomainRingEquiv_coeff e + (embDomainRingEquiv e.symm (x : R⟦H⟧)) (e.symm h) + rw [e.apply_symm_apply, embDomainRingEquiv_coeff] at houter + exact houter + map_mul' x y := by + apply Subtype.ext + exact map_mul (cardSuppLTFieldRingEquiv e) x.1 y.1 + map_add' x y := by + apply Subtype.ext + exact map_add (cardSuppLTFieldRingEquiv e) x.1 y.1 + +/-- The bounded integer-part equivalence applies through the bounded field equivalence. -/ +@[simp] +theorem coe_cardSuppLTTruncationIntegerPartRingEquiv + (e : G ≃+o H) (Z : Subring R) + (x : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) : + ((cardSuppLTTruncationIntegerPartRingEquiv e Z x : + CardSuppLTField (G := H) (R := R) (κ := κ)) : R⟦H⟧) = + embDomainRingEquiv e (x : CardSuppLTField (G := G) (R := R) (κ := κ)) := + (rfl) + +end HahnSeries diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/CardinalTruncationIrreducible.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/CardinalTruncationIrreducible.lean new file mode 100644 index 0000000000..52b11a2be8 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/CardinalTruncationIrreducible.lean @@ -0,0 +1,95 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.CardinalTruncation + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Monomial + +/-! +# Irreducibility and support-cardinality bounds + +Forgetting a support-cardinality bound embeds a bounded truncation integer part into its +unbounded counterpart. This embedding reflects units: an inverse in the unbounded ring is a +nonzero constant series, hence still has bounded support. It therefore also reflects +irreducibility. +-/ + +universe u v + +public noncomputable section + +open Cardinal + +namespace HahnSeries.CardSuppLTTruncationIntegerPart + +variable {G : Type u} {R : Type v} {κ : Cardinal.{u}} +variable [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] [Field R] +variable [Fact (ℵ₀ < κ)] + +/-- A bounded truncation-integer-part element is a unit whenever it becomes a unit after the +support-cardinality bound is forgotten. -/ +theorem isUnit_of_isUnit_toTruncationIntegerPart + (Z : Subring R) + {x : HahnSeries.cardSuppLTTruncationIntegerPart + (G := G) (R := R) (κ := κ) Z} + (hx : IsUnit (toTruncationIntegerPartRingHom Z x)) : + IsUnit x := by + obtain ⟨u, hu⟩ := hx + let y : HahnSeries.truncationIntegerPart G Z := ↑u⁻¹ + have hyUnit : IsUnit (y : HahnSeries.Nonpositive G R) := by + exact (HahnSeries.truncationIntegerPart G Z).subtype.isUnit_map + (show IsUnit y by exact (u⁻¹).isUnit) + have hySupport : ((y : HahnSeries.Nonpositive G R) : R⟦G⟧).support = {0} := + HahnSeries.Nonpositive.support_eq_singleton_zero_of_isUnit hyUnit + have hyCard : ((y : HahnSeries.Nonpositive G R) : R⟦G⟧).cardSupp < κ := by + rw [HahnSeries.cardSupp, hySupport, Cardinal.mk_singleton] + exact Cardinal.one_lt_aleph0.trans (Fact.out : ℵ₀ < κ) + let yBounded : HahnSeries.cardSuppLTTruncationIntegerPart + (G := G) (R := R) (κ := κ) Z := + ⟨⟨(y : HahnSeries.Nonpositive G R), hyCard⟩, by + rw [HahnSeries.mem_cardSuppLTTruncationIntegerPart] + exact ⟨HahnSeries.Nonpositive.support_subset (y : HahnSeries.Nonpositive G R), + (HahnSeries.mem_truncationIntegerPart (R := R) (Γ := G)).mp y.2⟩⟩ + have hyForget : toTruncationIntegerPartRingHom Z yBounded = y := by + apply Subtype.ext + apply Subtype.ext + rw [coe_toTruncationIntegerPartRingHom, coe_toNonpositiveRingHom] + apply isUnit_iff_exists.mpr + refine ⟨yBounded, ?_, ?_⟩ + · apply toTruncationIntegerPartRingHom_injective Z + rw [map_mul, map_one, hyForget] + change toTruncationIntegerPartRingHom Z x * y = 1 + rw [← hu] + simp [y] + · apply toTruncationIntegerPartRingHom_injective Z + rw [map_mul, map_one, hyForget] + change y * toTruncationIntegerPartRingHom Z x = 1 + rw [← hu] + simp [y] + +/-- Irreducibility after forgetting a support-cardinality bound implies irreducibility before +forgetting it. -/ +theorem irreducible_of_irreducible_toTruncationIntegerPart + (Z : Subring R) + {x : HahnSeries.cardSuppLTTruncationIntegerPart + (G := G) (R := R) (κ := κ) Z} + (hx : Irreducible (toTruncationIntegerPartRingHom Z x)) : + Irreducible x := by + rw [irreducible_iff] + refine ⟨?_, ?_⟩ + · intro hunit + exact hx.not_isUnit (hunit.map (toTruncationIntegerPartRingHom Z)) + · intro c d hfactor + have hfactor' : toTruncationIntegerPartRingHom Z x = + toTruncationIntegerPartRingHom Z c * + toTruncationIntegerPartRingHom Z d := by + rw [← map_mul, hfactor] + rcases hx.isUnit_or_isUnit hfactor' with hc | hd + · exact Or.inl (isUnit_of_isUnit_toTruncationIntegerPart Z hc) + · exact Or.inr (isUnit_of_isUnit_toTruncationIntegerPart Z hd) + +end HahnSeries.CardSuppLTTruncationIntegerPart diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/CardinalTruncationResidue.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/CardinalTruncationResidue.lean new file mode 100644 index 0000000000..53315cd9ff --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/CardinalTruncationResidue.lean @@ -0,0 +1,248 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.CardinalTruncation + +/-! +# Residues of cardinal-bounded nonpositive Hahn series + +The cardinal-bounded nonpositive Hahn series form an algebra over their coefficient field. +Coefficient at exponent zero is an algebra retraction, and imposing that this residue lie in a +coefficient subring recovers the usual cardinal-bounded truncation integer part. + +This is the bounded counterpart of +`HahnSeries.Nonpositive.truncationIntegerPartEquivResidueSubring`. It allows equation-local +residue normalization without forgetting the support-cardinality bound. +-/ + +public noncomputable section + +open Cardinal +open scoped HahnSeries + +universe u v + +namespace HahnSeries + +variable {G : Type u} {L : Type v} {κ : Cardinal.{u}} +variable [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] +variable [Field L] [Fact (aleph0 < κ)] + +/-- Cardinal-bounded Hahn series with nonpositive support. -/ +abbrev CardSuppLTNonpositive := cardSuppLTTruncationIntegerPart + (G := G) (R := L) (κ := κ) (⊤ : Subring L) + +/-- Constant series as a ring map into cardinal-bounded nonpositive Hahn series. -/ +noncomputable def CardSuppLTNonpositive.C : + L →+* CardSuppLTNonpositive (G := G) (L := L) (κ := κ) where + toFun r := ⟨⟨HahnSeries.C r, by + exact (HahnSeries.cardSupp_single_le (0 : G) r).trans_lt + (one_lt_aleph0.trans (Fact.out : aleph0 < κ))⟩, by + rw [mem_cardSuppLTTruncationIntegerPart] + constructor + · intro g hg + have hg0 : g = 0 := HahnSeries.support_single_subset hg + exact hg0 ▸ le_rfl + · exact Subring.mem_top _⟩ + map_one' := by + apply Subtype.ext + apply Subtype.ext + exact map_one HahnSeries.C + map_mul' x y := by + apply Subtype.ext + apply Subtype.ext + exact map_mul HahnSeries.C x y + map_zero' := by + apply Subtype.ext + apply Subtype.ext + exact map_zero HahnSeries.C + map_add' x y := by + apply Subtype.ext + apply Subtype.ext + exact map_add HahnSeries.C x y + +/-- Cardinal-bounded nonpositive Hahn series form an algebra over their coefficient field. -/ +noncomputable instance : Algebra L (CardSuppLTNonpositive (G := G) (L := L) (κ := κ)) where + algebraMap := CardSuppLTNonpositive.C + smul r x := CardSuppLTNonpositive.C r * x + commutes' _ _ := mul_comm _ _ + smul_def' _ _ := rfl + +namespace CardSuppLTNonpositive + +/-- Coefficient at exponent zero as an algebra retraction on bounded nonpositive series. -/ +def constantCoeffAlgHom : + CardSuppLTNonpositive (G := G) (L := L) (κ := κ) →ₐ[L] L where + toFun x := (x : L⟦G⟧).coeff 0 + map_one' := by simp + map_mul' x y := by + have hx := (mem_cardSuppLTTruncationIntegerPart (Z := (⊤ : Subring L))).mp x.2 + have hy := (mem_cardSuppLTTruncationIntegerPart (Z := (⊤ : Subring L))).mp y.2 + let x' : HahnSeries.Nonpositive G L := ⟨x, hx.1⟩ + let y' : HahnSeries.Nonpositive G L := ⟨y, hy.1⟩ + exact HahnSeries.Nonpositive.coeff_zero_mul x' y' + map_zero' := by simp + map_add' x y := by simp + commutes' r := by + change (HahnSeries.C r : L⟦G⟧).coeff 0 = r + simp + +@[simp] +theorem constantCoeffAlgHom_apply + (x : CardSuppLTNonpositive (G := G) (L := L) (κ := κ)) : + constantCoeffAlgHom x = (x : L⟦G⟧).coeff 0 := + (rfl) + +/-- The canonical identity-on-series equivalence between the bounded truncation integer part and +the residue-preimage presentation inside bounded nonpositive Hahn series. -/ +def truncationIntegerPartEquivResidueSubring (S : Subring L) : + cardSuppLTTruncationIntegerPart (G := G) (R := L) (κ := κ) S ≃+* + Subring.residueSubring + (constantCoeffAlgHom (G := G) (L := L) (κ := κ)) S where + toFun x := ⟨⟨x, by + rw [mem_cardSuppLTTruncationIntegerPart] + exact ⟨((mem_cardSuppLTTruncationIntegerPart (Z := S)).mp x.2).1, + Subring.mem_top _⟩⟩, by + rw [Subring.mem_residueSubring, constantCoeffAlgHom_apply] + exact ((mem_cardSuppLTTruncationIntegerPart (Z := S)).mp x.2).2⟩ + invFun x := ⟨x.1.1, by + rw [mem_cardSuppLTTruncationIntegerPart] + exact ⟨((mem_cardSuppLTTruncationIntegerPart (Z := (⊤ : Subring L))).mp x.1.2).1, + x.2⟩⟩ + left_inv _ := rfl + right_inv _ := rfl + map_mul' _ _ := rfl + map_add' _ _ := rfl + +/-- The residue-subring presentation does not change the underlying Hahn series. -/ +@[simp] +theorem coe_truncationIntegerPartEquivResidueSubring (S : Subring L) + (x : cardSuppLTTruncationIntegerPart (G := G) (R := L) (κ := κ) S) : + ((((truncationIntegerPartEquivResidueSubring S x : + Subring.residueSubring constantCoeffAlgHom S) : + CardSuppLTNonpositive (G := G) (L := L) (κ := κ)) : L⟦G⟧)) = + (x : L⟦G⟧) := + (rfl) + +/-- An exact ambient refinement of bounded nonpositive series can be normalized into the bounded +truncation integer part using primality of the first constant coefficient. -/ +theorem exists_refinement_truncationIntegerPart_of_ambient + (S : Subring L) + {a b c d : cardSuppLTTruncationIntegerPart + (G := G) (R := L) (κ := κ) S} + (haS : IsPrimal (⟨(a : L⟦G⟧).coeff 0, + ((mem_cardSuppLTTruncationIntegerPart (Z := S)).mp a.2).2⟩ : S)) + (hfrac : Subring.fracSubring S = ⊤) (ha0 : a ≠ 0) + (habcd : a * b = c * d) + {e f g h : CardSuppLTNonpositive (G := G) (L := L) (κ := κ)} + (ha : ((truncationIntegerPartEquivResidueSubring S a : + Subring.residueSubring constantCoeffAlgHom S) : + CardSuppLTNonpositive (G := G) (L := L) (κ := κ)) = e * f) + (hb : ((truncationIntegerPartEquivResidueSubring S b : + Subring.residueSubring constantCoeffAlgHom S) : + CardSuppLTNonpositive (G := G) (L := L) (κ := κ)) = g * h) + (hc : ((truncationIntegerPartEquivResidueSubring S c : + Subring.residueSubring constantCoeffAlgHom S) : + CardSuppLTNonpositive (G := G) (L := L) (κ := κ)) = e * g) + (hd : ((truncationIntegerPartEquivResidueSubring S d : + Subring.residueSubring constantCoeffAlgHom S) : + CardSuppLTNonpositive (G := G) (L := L) (κ := κ)) = f * h) : + ∃ E F H₁ H₂ : cardSuppLTTruncationIntegerPart + (G := G) (R := L) (κ := κ) S, + a = E * F ∧ b = H₁ * H₂ ∧ c = E * H₁ ∧ d = F * H₂ := by + let Φ := truncationIntegerPartEquivResidueSubring + (G := G) (L := L) (κ := κ) S + have haS' : IsPrimal + (⟨constantCoeffAlgHom ((Φ a : Subring.residueSubring constantCoeffAlgHom S) : + CardSuppLTNonpositive (G := G) (L := L) (κ := κ)), (Φ a).2⟩ : S) := by + convert haS using 1 + apply Subtype.ext + rfl + have ha0' : Φ a ≠ 0 := Φ.injective.ne ha0 + have habcd' : Φ a * Φ b = Φ c * Φ d := by + simpa only [map_mul] using congrArg Φ habcd + obtain ⟨E, F, H₁, H₂, ha', hb', hc', hd'⟩ := + Subring.exists_refinement_residueSubring_of_ambient haS' hfrac ha0' habcd' + ha hb hc hd + exact ⟨Φ.symm E, Φ.symm F, Φ.symm H₁, Φ.symm H₂, + by simpa using congrArg Φ.symm ha', + by simpa using congrArg Φ.symm hb', + by simpa using congrArg Φ.symm hc', + by simpa using congrArg Φ.symm hd'⟩ + +end CardSuppLTNonpositive + +namespace CardSuppLTTruncationIntegerPart + +private theorem isUnit_map_of_isUnit {M N : Type*} [Monoid M] [Monoid N] + (f : M →* N) {x : M} (hx : IsUnit x) : IsUnit (f x) := + hx.map f + +private theorem isPrimal_residueSubring_of_isUnit + {F A : Type*} [Field F] [CommRing A] [Algebra F A] [IsDomain A] + (π : A →ₐ[F] F) (S : Subring F) [DecompositionMonoid S] + {x : A} (hx : π x ∈ S) (hx0 : π x ≠ 0) (hunit : IsUnit x) : + IsPrimal (⟨x, hx⟩ : Subring.residueSubring π S) := + Subring.isPrimal_residueSubring_of_isPrimal + hx hx0 (DecompositionMonoid.primal _) hunit.isPrimal + +private theorem isPrimal_equiv_preimage + {A B : Type*} [CommRing A] [CommRing B] (e : A ≃+* B) {x : A} + (hx : IsPrimal (e x)) : IsPrimal x := + (RingEquiv.isPrimal_iff e x).mp hx + +/-- An order-zero element of a cardinal-bounded truncation integer part is primal when its +coefficient subring is pre-Schreier. -/ +theorem isPrimal_of_order_eq_zero + (S : Subring L) [DecompositionMonoid S] + (x : cardSuppLTTruncationIntegerPart (G := G) (R := L) (κ := κ) S) + (horder : ((toNonpositiveRingHom S x : Nonpositive G L) : HahnSeries G L).order = 0) : + IsPrimal x := by + let A := CardSuppLTNonpositive (G := G) (L := L) (κ := κ) + let π := CardSuppLTNonpositive.constantCoeffAlgHom (G := G) (L := L) (κ := κ) + let Φ := CardSuppLTNonpositive.truncationIntegerPartEquivResidueSubring + (G := G) (L := L) (κ := κ) S + by_cases hx : x = 0 + · rw [hx] + exact isPrimal_zero + let xN := toNonpositiveRingHom S x + have hconstant : (xN : HahnSeries G L) = HahnSeries.C ((xN : HahnSeries G L).coeff 0) := by + ext g + by_cases hg : g = 0 + · subst g + simp + · rw [HahnSeries.C_apply, HahnSeries.coeff_single_of_ne hg] + by_contra hcoeff + have hgNonpos : g ≤ 0 := Nonpositive.support_subset xN + ((HahnSeries.mem_support _ _).mpr hcoeff) + have hzeroLe : 0 ≤ g := horder ▸ HahnSeries.order_le_of_coeff_ne_zero hcoeff + exact hg (le_antisymm hgNonpos hzeroLe) + have hcoeff : (x : HahnSeries G L).coeff 0 ≠ 0 := by + intro hzero + apply hx + apply Subtype.ext + apply Subtype.ext + change (x : HahnSeries G L) = 0 + simpa only [xN, coe_toNonpositiveRingHom, hzero, map_zero] using hconstant + have hxC : (Φ x : A) = algebraMap L A ((x : HahnSeries G L).coeff 0) := by + apply Subtype.ext + apply Subtype.ext + change (x : HahnSeries G L) = HahnSeries.C ((x : HahnSeries G L).coeff 0) + simpa only [xN, coe_toNonpositiveRingHom] using hconstant + have hunit : IsUnit (Φ x : A) := by + rw [hxC] + have hcoeffUnit : IsUnit ((x : HahnSeries G L).coeff 0) := + isUnit_iff_ne_zero.mpr hcoeff + exact isUnit_map_of_isUnit (algebraMap L A).toMonoidHom hcoeffUnit + have hπ : π (Φ x : A) = (x : HahnSeries G L).coeff 0 := rfl + have hΦ : IsPrimal (Φ x) := + isPrimal_residueSubring_of_isUnit π S (Φ x).2 (hπ ▸ hcoeff) hunit + exact isPrimal_equiv_preimage Φ hΦ + +end CardSuppLTTruncationIntegerPart + +end HahnSeries diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/CharZero.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/CharZero.lean new file mode 100644 index 0000000000..7db137d736 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/CharZero.lean @@ -0,0 +1,34 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import Mathlib.RingTheory.HahnSeries.Multiplication +public import Mathlib.Algebra.CharZero.Defs + +/-! +# Hahn series over a characteristic-zero base + +A Hahn series ring inherits characteristic zero from its coefficients, because the natural numbers +embed as constant series. Mathlib carries no such instance. + +This is needed to apply results stated for a characteristic-zero coefficient field to a Hahn-series +field. That happens whenever the exponent group is not Archimedean and has to be split into an +Archimedean quotient over a coefficient field that is itself a Hahn-series field. +-/ + +public section + +namespace HahnSeries + +instance instCharZero {Γ R : Type*} [LinearOrder Γ] [AddCommMonoid Γ] + [NonAssocSemiring R] [CharZero R] : CharZero (HahnSeries Γ R) where + cast_injective m n h := by + have hm : ((m : ℕ) : R) = ((n : ℕ) : R) := by + have := congrArg (fun x : HahnSeries Γ R => x.coeff 0) h + simpa [← single_zero_natCast] using this + exact Nat.cast_injective hm + +end HahnSeries diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/CoefficientMap.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/CoefficientMap.lean new file mode 100644 index 0000000000..6227b375f8 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/CoefficientMap.lean @@ -0,0 +1,86 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Nonpositive + +/-! +# Coefficientwise ring homomorphisms of Hahn series + +A ring homomorphism on coefficients acts coefficientwise on Hahn series and on their +nonpositive-support subrings. Injective coefficient maps preserve support exactly. These bundled +maps provide the module-safe interface needed when a bounded Hahn field is embedded in the full +Hahn field. +-/ + +public noncomputable section + +namespace HahnSeries + +universe u v w + +section Full + +variable {Γ : Type u} {R : Type v} {S : Type w} +variable [AddCommMonoid Γ] [PartialOrder Γ] [IsOrderedCancelAddMonoid Γ] +variable [Semiring R] [Semiring S] + +/-- Apply a ring homomorphism to every coefficient of a Hahn series. -/ +def coefficientMapRingHom (f : R →+* S) : R⟦Γ⟧ →+* S⟦Γ⟧ where + toFun x := x.map f + map_one' := HahnSeries.map_one f.toMonoidWithZeroHom + map_mul' _ _ := HahnSeries.map_mul f.toNonUnitalRingHom + map_zero' := HahnSeries.map_zero f.toMonoidWithZeroHom.toZeroHom + map_add' _ _ := HahnSeries.map_add f.toAddMonoidHom + +/-- Coefficientwise mapping evaluates by applying the coefficient homomorphism. -/ +@[simp] +theorem coefficientMapRingHom_coeff (f : R →+* S) (x : R⟦Γ⟧) (g : Γ) : + (coefficientMapRingHom f x).coeff g = f (x.coeff g) := + (rfl) + +/-- An injective coefficient homomorphism preserves Hahn-series support. -/ +theorem support_coefficientMapRingHom (f : R →+* S) (hf : Function.Injective f) + (x : R⟦Γ⟧) : + (coefficientMapRingHom f x).support = x.support := by + ext g + rw [mem_support, mem_support, coefficientMapRingHom_coeff] + exact not_congr (map_eq_zero_iff f hf) + +end Full + +namespace Nonpositive + +variable {Γ : Type u} {R : Type v} {S : Type w} +variable [AddCommGroup Γ] [LinearOrder Γ] [IsOrderedAddMonoid Γ] +variable [Ring R] [Ring S] + +/-- Apply a ring homomorphism coefficientwise to a nonpositive Hahn series. -/ +def coefficientMapRingHom (f : R →+* S) : Nonpositive Γ R →+* Nonpositive Γ S where + toFun x := ⟨HahnSeries.coefficientMapRingHom f (x : R⟦Γ⟧), + (HahnSeries.support_map_subset (x : R⟦Γ⟧) f.toZeroHom).trans (support_subset x)⟩ + map_one' := Subtype.ext (map_one (HahnSeries.coefficientMapRingHom f)) + map_mul' x y := Subtype.ext + (map_mul (HahnSeries.coefficientMapRingHom f) (x : R⟦Γ⟧) (y : R⟦Γ⟧)) + map_zero' := Subtype.ext (map_zero (HahnSeries.coefficientMapRingHom f)) + map_add' x y := Subtype.ext + (map_add (HahnSeries.coefficientMapRingHom f) (x : R⟦Γ⟧) (y : R⟦Γ⟧)) + +/-- The nonpositive coefficient map acts coefficientwise. -/ +@[simp] +theorem coe_coefficientMapRingHom (f : R →+* S) (x : Nonpositive Γ R) : + (coefficientMapRingHom f x : S⟦Γ⟧) = HahnSeries.coefficientMapRingHom f x := + (rfl) + +/-- An injective coefficient homomorphism preserves nonpositive Hahn-series support. -/ +theorem support_coefficientMapRingHom (f : R →+* S) (hf : Function.Injective f) + (x : Nonpositive Γ R) : + (coefficientMapRingHom f x : S⟦Γ⟧).support = (x : R⟦Γ⟧).support := by + rw [coe_coefficientMapRingHom, HahnSeries.support_coefficientMapRingHom f hf] + +end Nonpositive + +end HahnSeries diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/ConvexFactorSupport.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/ConvexFactorSupport.lean new file mode 100644 index 0000000000..e3d9915aaf --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/ConvexFactorSupport.lean @@ -0,0 +1,94 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Nonpositive +public import Mathlib.RingTheory.HahnSeries.Multiplication + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint + +/-! +# Factors supported in a convex exponent subgroup + +If a product of two nonzero nonpositive Hahn series is supported in a convex subgroup of the +exponents, then both factors are supported there. Their lowest exponents add to the lowest +exponent of the product. Convexity first puts each lowest exponent in the subgroup, then puts +every later nonpositive support exponent there as well. +-/ + +universe u v + +public noncomputable section + +namespace HahnSeries.Nonpositive + +variable {G : Type u} {K : Type v} +variable [LinearOrder G] [AddCommGroup G] [IsOrderedAddMonoid G] [Field K] + +/-- Nonzero nonpositive factors of a series supported in a convex exponent subgroup are +themselves supported in that subgroup. -/ +@[blueprint "lem:convex-support-of-factors" + (phase := "Finitely many Archimedean classes") + (title := "Convexity of the supports of factors") + (statement := /-- + Let $H$ be a convex subgroup of a linearly ordered abelian group $G$. If + $a,b\in K((G^{\le0}))$ are nonzero and + $\operatorname{supp}(ab)\subseteq H$, then + \[ + \operatorname{supp}(a)\subseteq H, + \qquad + \operatorname{supp}(b)\subseteq H. + \] + -/) + (proof := /-- + The least support exponents satisfy + $\min\operatorname{supp}(ab)=\min\operatorname{supp}(a)+ + \min\operatorname{supp}(b)$. This sum and zero lie in $H$, while both + summands are nonpositive, so convexity puts each least exponent in $H$. + Every later support exponent lies between its least exponent and zero and + therefore also belongs to $H$. + -/)] +theorem support_subset_convex_of_mul_support_subset + {H : AddSubgroup G} (hH : (H : Set G).OrdConnected) + {a b : Nonpositive G K} (ha0 : a ≠ 0) (hb0 : b ≠ 0) + (habH : ((a * b : Nonpositive G K) : K⟦G⟧).support ⊆ (H : Set G)) : + (a : K⟦G⟧).support ⊆ (H : Set G) ∧ (b : K⟦G⟧).support ⊆ (H : Set G) := by + have ha0' : (a : K⟦G⟧) ≠ 0 := fun h ↦ ha0 (Subtype.ext h) + have hb0' : (b : K⟦G⟧) ≠ 0 := fun h ↦ hb0 (Subtype.ext h) + have hab0' : ((a * b : Nonpositive G K) : K⟦G⟧) ≠ 0 := mul_ne_zero ha0' hb0' + have habOrder : (a : K⟦G⟧).order + (b : K⟦G⟧).order ∈ H := by + rw [← HahnSeries.order_mul_of_ne_zero (mul_ne_zero + (HahnSeries.leadingCoeff_ne_zero.mpr ha0') + (HahnSeries.leadingCoeff_ne_zero.mpr hb0'))] + apply habH + exact (HahnSeries.mem_support _ _).mpr + (HahnSeries.coeff_order_eq_zero.not.mpr hab0') + have haOrderMem : (a : K⟦G⟧).order ∈ (a : K⟦G⟧).support := + (HahnSeries.mem_support _ _).mpr (HahnSeries.coeff_order_eq_zero.not.mpr ha0') + have hbOrderMem : (b : K⟦G⟧).order ∈ (b : K⟦G⟧).support := + (HahnSeries.mem_support _ _).mpr (HahnSeries.coeff_order_eq_zero.not.mpr hb0') + have haOrderH : (a : K⟦G⟧).order ∈ H := by + apply hH.out habOrder H.zero_mem + constructor + · simpa using add_le_add_left (support_subset b hbOrderMem) (a : K⟦G⟧).order + · exact support_subset a haOrderMem + have hbOrderH : (b : K⟦G⟧).order ∈ H := by + apply hH.out habOrder H.zero_mem + constructor + · simpa [add_comm] using + add_le_add_left (support_subset a haOrderMem) (b : K⟦G⟧).order + · exact support_subset b hbOrderMem + constructor + · intro g hg + apply hH.out haOrderH H.zero_mem + exact ⟨HahnSeries.order_le_of_coeff_ne_zero ((HahnSeries.mem_support _ _).mp hg), + support_subset a hg⟩ + · intro g hg + apply hH.out hbOrderH H.zero_mem + exact ⟨HahnSeries.order_le_of_coeff_ne_zero ((HahnSeries.mem_support _ _).mp hg), + support_subset b hg⟩ + +end HahnSeries.Nonpositive diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/ConvexQuotientSplitting.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/ConvexQuotientSplitting.lean new file mode 100644 index 0000000000..122d55ad08 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/ConvexQuotientSplitting.lean @@ -0,0 +1,717 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Order.Module.ConvexQuotientSplitting +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.CardinalTruncation +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.DomainEquiv +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Iterate +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Truncation +public import Mathlib.SetTheory.Cardinal.Regular + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.CoefficientMap + +/-! +# Hahn-series splitting by a convex subspace + +An ordered vector space splits additively as the lexicographic product of the quotient by a convex +subspace and that subspace. Reindexing exponents by this splitting and unflattening the +lexicographic product regroups a Hahn series into an outer series on the quotient whose +coefficients are Hahn series on the subspace. Because the splitting is additive, this regrouping +is a ring equivalence. +-/ + +public noncomputable section + +namespace HahnSeries + +universe u v w + +variable {R : Type v} {K : Type w} {G : Type u} [Semiring R] +variable [Field K] [AddCommGroup G] [Module K G] +variable [LinearOrder G] [IsOrderedAddMonoid G] + +noncomputable instance quotientLinearOrder (P : Submodule K G) + [P.toAddSubgroup.IsConvex] : LinearOrder (G ⧸ P) := + ConvexQuotient.instLinearOrder (H := P.toAddSubgroup) + +instance quotientIsOrderedAddMonoid (P : Submodule K G) [P.toAddSubgroup.IsConvex] : + IsOrderedAddMonoid (G ⧸ P) := + ConvexQuotient.instIsOrderedAddMonoid (H := P.toAddSubgroup) + +local instance submoduleIsOrderedAddMonoid (P : Submodule K G) : IsOrderedAddMonoid P := + AddSubgroup.instIsOrderedAddMonoid P.toAddSubgroup + +/-- Regroup Hahn series by the cosets of a convex subspace. The quotient exponent is the outer, +dominant coordinate, while exponents in the subspace form the coefficient Hahn series. -/ +def convexQuotientSplitRingEquiv (P : Submodule K G) [P.toAddSubgroup.IsConvex] : + R⟦G⟧ ≃+* (R⟦P⟧)⟦G ⧸ P⟧ := + (embDomainRingEquiv (Submodule.quotientLexEquiv P).symm).trans iterateRingEquiv.symm + +@[simp] +theorem convexQuotientSplitRingEquiv_coeff (P : Submodule K G) [P.toAddSubgroup.IsConvex] + (x : R⟦G⟧) (q : G ⧸ P) (p : P) : + ((convexQuotientSplitRingEquiv P x).coeff q).coeff p = + x.coeff (Submodule.quotientLexEquiv P (toLex (q, p))) := by + apply (iterateRingEquiv_coeff (convexQuotientSplitRingEquiv P x) q p).symm.trans + change (iterateRingEquiv + (iterateRingEquiv.symm + (embDomainRingEquiv (Submodule.quotientLexEquiv P).symm x))).coeff + (toLex (q, p)) = _ + rw [RingEquiv.apply_symm_apply] + have h := embDomainRingEquiv_coeff (R := R) (Submodule.quotientLexEquiv P).symm x + (Submodule.quotientLexEquiv P (toLex (q, p))) + rw [OrderAddMonoidIso.symm_apply_apply] at h + exact h + +open Classical in +/-- Regrouping commutes with restriction to the preimage of a subgroup of the quotient. -/ +theorem convexQuotientSplitRingEquiv_filter_comap + (P : Submodule K G) [P.toAddSubgroup.IsConvex] + (D : AddSubgroup (G ⧸ P)) (x : R⟦G⟧) : + convexQuotientSplitRingEquiv P + (HahnSeries.filter (· ∈ D.comap P.mkQ.toAddMonoidHom) x) = + HahnSeries.filter (· ∈ D) (convexQuotientSplitRingEquiv P x) := by + ext q p + rw [convexQuotientSplitRingEquiv_coeff, HahnSeries.coeff_filter, + HahnSeries.coeff_filter] + have hmk : Submodule.Quotient.mk + (Submodule.quotientLexEquiv P (toLex (q, p))) = q := by + rw [Submodule.quotientLexEquiv_apply, Submodule.mk_quotientProdLinearEquiv] + rfl + have hiff : Submodule.quotientLexEquiv P (toLex (q, p)) ∈ + D.comap P.mkQ.toAddMonoidHom ↔ q ∈ D := by + rw [AddSubgroup.mem_comap] + change Submodule.Quotient.mk (Submodule.quotientLexEquiv P (toLex (q, p))) ∈ D ↔ _ + rw [hmk] + split + · rename_i hmem + rw [ite_eq_left (hiff.mp hmem), convexQuotientSplitRingEquiv_coeff] + · rename_i hmem + rw [ite_eq_right (fun hq ↦ hmem (hiff.mpr hq))] + rfl + +open Classical in +/-- The regrouped outer support lies in a quotient subgroup exactly when the ambient support lies +in its preimage. -/ +theorem support_convexQuotientSplitRingEquiv_subset_iff + (P : Submodule K G) [P.toAddSubgroup.IsConvex] + (D : AddSubgroup (G ⧸ P)) (x : R⟦G⟧) : + (convexQuotientSplitRingEquiv P x).support ⊆ (D : Set (G ⧸ P)) ↔ + x.support ⊆ (D.comap P.mkQ.toAddMonoidHom : Set G) := by + constructor + · intro hs g hg + let z : (G ⧸ P) ×ₗ P := (Submodule.quotientLexEquiv P).symm g + let q : G ⧸ P := (ofLex z).1 + let p : P := (ofLex z).2 + have hz : Submodule.quotientLexEquiv P (toLex (q, p)) = g := + (Submodule.quotientLexEquiv P).apply_symm_apply g + have hcoeff : ((convexQuotientSplitRingEquiv P x).coeff q).coeff p ≠ 0 := by + rw [convexQuotientSplitRingEquiv_coeff, hz] + exact (HahnSeries.mem_support _ _).mp hg + have hqsupp : q ∈ (convexQuotientSplitRingEquiv P x).support := by + rw [HahnSeries.mem_support] + intro hzero + exact hcoeff (congrArg (fun y : R⟦P⟧ ↦ y.coeff p) hzero) + have hqD := hs hqsupp + change Submodule.Quotient.mk g ∈ D + have hmk : Submodule.Quotient.mk + (Submodule.quotientLexEquiv P (toLex (q, p))) = q := by + rw [Submodule.quotientLexEquiv_apply, Submodule.mk_quotientProdLinearEquiv] + rfl + rwa [← hz, hmk] + · intro hs q hq + rw [HahnSeries.mem_support] at hq + obtain ⟨p, hp⟩ : ∃ p : P, + ((convexQuotientSplitRingEquiv P x).coeff q).coeff p ≠ 0 := by + by_contra h + push Not at h + apply hq + ext p + exact h p + have hxp : Submodule.quotientLexEquiv P (toLex (q, p)) ∈ x.support := by + rw [HahnSeries.mem_support, ← convexQuotientSplitRingEquiv_coeff] + exact hp + have hmem := hs hxp + change Submodule.Quotient.mk + (Submodule.quotientLexEquiv P (toLex (q, p))) ∈ D at hmem + have hmk : Submodule.Quotient.mk + (Submodule.quotientLexEquiv P (toLex (q, p))) = q := by + rw [Submodule.quotientLexEquiv_apply, Submodule.mk_quotientProdLinearEquiv] + rfl + rwa [hmk] at hmem + +open Classical in +/-- The outer support after regrouping along a convex submodule is exactly the quotient image of +the original support. -/ +theorem support_convexQuotientSplitRingEquiv + (P : Submodule K G) [P.toAddSubgroup.IsConvex] (x : R⟦G⟧) : + (convexQuotientSplitRingEquiv P x).support = P.mkQ '' x.support := by + ext q + constructor + · intro hq + rw [HahnSeries.mem_support] at hq + obtain ⟨p, hp⟩ : ∃ p : P, + ((convexQuotientSplitRingEquiv P x).coeff q).coeff p ≠ 0 := by + by_contra h + push Not at h + apply hq + ext p + exact h p + let g := Submodule.quotientLexEquiv P (toLex (q, p)) + refine ⟨g, ?_, ?_⟩ + · rw [HahnSeries.mem_support, ← convexQuotientSplitRingEquiv_coeff] + exact hp + · dsimp only [g] + change Submodule.Quotient.mk + (Submodule.quotientLexEquiv P (toLex (q, p))) = q + rw [Submodule.quotientLexEquiv_apply, Submodule.mk_quotientProdLinearEquiv] + rfl + · rintro ⟨g, hg, rfl⟩ + let z : (G ⧸ P) ×ₗ P := (Submodule.quotientLexEquiv P).symm g + let q : G ⧸ P := (ofLex z).1 + let p : P := (ofLex z).2 + have hz : Submodule.quotientLexEquiv P (toLex (q, p)) = g := + (Submodule.quotientLexEquiv P).apply_symm_apply g + have hmk : P.mkQ g = q := by + rw [← hz] + change Submodule.Quotient.mk + (Submodule.quotientLexEquiv P (toLex (q, p))) = q + rw [Submodule.quotientLexEquiv_apply, Submodule.mk_quotientProdLinearEquiv] + rfl + rw [hmk, HahnSeries.mem_support] + intro hzero + have hcoeff := congrArg (fun y : R⟦P⟧ ↦ y.coeff p) hzero + rw [convexQuotientSplitRingEquiv_coeff, hz] at hcoeff + exact (HahnSeries.mem_support _ _).mp hg hcoeff + +/-- Regrouping a nonpositive Hahn series produces no positive quotient exponent. -/ +theorem support_convexQuotientSplitRingEquiv_subset_Iic + (P : Submodule K G) [P.toAddSubgroup.IsConvex] (x : R⟦G⟧) + (hx : x.support ⊆ Set.Iic 0) : + (convexQuotientSplitRingEquiv P x).support ⊆ Set.Iic 0 := by + intro q hq + rw [HahnSeries.mem_support] at hq + obtain ⟨p, hp⟩ : ∃ p : P, ((convexQuotientSplitRingEquiv P x).coeff q).coeff p ≠ 0 := by + by_contra h + push Not at h + apply hq + ext p + exact h p + rw [convexQuotientSplitRingEquiv_coeff] at hp + have hnonpos : Submodule.quotientLexEquiv P (toLex (q, p)) ≤ 0 := + hx ((HahnSeries.mem_support _ _).mpr hp) + have hlex : toLex (q, p) ≤ 0 := by + rw [← (Submodule.quotientLexEquiv P).map_zero] at hnonpos + exact (Submodule.quotientLexEquiv P).map_le_map_iff'.mp hnonpos + rcases Prod.Lex.le_iff.mp hlex with hqneg | ⟨hqzero, -⟩ + · exact hqneg.le + · exact hqzero.le + +/-- The ordered inclusion of a subspace into its ambient exponent group. -/ +def submoduleOrderEmbedding (P : Submodule K G) : P ↪o G where + toFun := (↑) + inj' := Subtype.val_injective + map_rel_iff' := Iff.rfl + +omit [IsOrderedAddMonoid G] in +@[simp] +theorem submoduleOrderEmbedding_apply (P : Submodule K G) (p : P) : + submoduleOrderEmbedding P p = (p : G) := + (rfl) + +/-- The outer-zero coefficient of quotient regrouping is precisely exponent-domain restriction +to the convex subspace. -/ +theorem coeff_zero_convexQuotientSplitRingEquiv + (P : Submodule K G) [P.toAddSubgroup.IsConvex] (x : R⟦G⟧) : + (convexQuotientSplitRingEquiv P x).coeff 0 = + HahnSeries.restrictDomain (submoduleOrderEmbedding P) x := by + ext p + rw [convexQuotientSplitRingEquiv_coeff, HahnSeries.restrictDomain_coeff] + rw [Submodule.quotientLexEquiv_apply] + change x.coeff (Submodule.quotientProdLinearEquiv P (0, p)) = x.coeff (p : G) + rw [Submodule.quotientProdLinearEquiv_zero_left] + +/-- A series is nonpositive exactly when quotient regrouping has nonpositive outer support and +its coefficient at outer exponent zero has nonpositive inner support. -/ +theorem support_convexQuotientSplitRingEquiv_subset_Iic_iff + (P : Submodule K G) [P.toAddSubgroup.IsConvex] (x : R⟦G⟧) : + x.support ⊆ Set.Iic 0 ↔ + (convexQuotientSplitRingEquiv P x).support ⊆ Set.Iic 0 ∧ + ((convexQuotientSplitRingEquiv P x).coeff 0).support ⊆ Set.Iic 0 := by + constructor + · intro hx + refine ⟨support_convexQuotientSplitRingEquiv_subset_Iic P x hx, ?_⟩ + intro p hp + have hpx : (p : G) ∈ x.support := by + rw [HahnSeries.mem_support] at hp ⊢ + rw [coeff_zero_convexQuotientSplitRingEquiv, + HahnSeries.restrictDomain_coeff] at hp + simpa only [submoduleOrderEmbedding_apply] using hp + exact hx hpx + · rintro ⟨houter, hinner⟩ g hg + let z : (G ⧸ P) ×ₗ P := (Submodule.quotientLexEquiv P).symm g + let q : G ⧸ P := (ofLex z).1 + let p : P := (ofLex z).2 + have hz : Submodule.quotientLexEquiv P z = g := + (Submodule.quotientLexEquiv P).apply_symm_apply g + have hcoeff : ((convexQuotientSplitRingEquiv P x).coeff q).coeff p ≠ 0 := by + rw [convexQuotientSplitRingEquiv_coeff] + rw [show toLex (q, p) = z from rfl, hz] + exact (HahnSeries.mem_support _ _).mp hg + have hq : q ∈ (convexQuotientSplitRingEquiv P x).support := by + rw [HahnSeries.mem_support] + intro hzero + exact hcoeff (congrArg (fun y : R⟦P⟧ ↦ y.coeff p) hzero) + have hq0 : q ≤ 0 := houter hq + change g ≤ 0 + rw [← hz, ← map_zero (Submodule.quotientLexEquiv P)] + apply (Submodule.quotientLexEquiv P).map_le_map_iff'.mpr + apply Prod.Lex.le_iff.mpr + rcases hq0.eq_or_lt with hqzero | hqneg + · right + refine ⟨hqzero, ?_⟩ + apply hinner + rw [HahnSeries.mem_support] + simpa only [q, hqzero] using hcoeff + · exact Or.inl hqneg + +/-- Suppose the support classes of a nonpositive series lie in the union of a block with no +greatest element and a finite block. After regrouping along the common tail of the first block, +the inner series at outer exponent zero meets only finitely many Archimedean classes. -/ +theorem supportArchimedeanClasses_coeff_zero_convexQuotientSplitRingEquiv_finite + [LinearOrder K] [IsOrderedRing K] [Archimedean K] [PosSMulMono K G] + (T₀ T₁ : Set (ArchimedeanClass G)) + (hT₀gt : ∀ a ∈ T₀, ∃ b ∈ T₀, a < b) (hT₁ : T₁.Finite) + (x : R⟦G⟧) (hxclasses : ArchimedeanClass.mk '' x.support ⊆ T₀ ∪ T₁) : + (ArchimedeanClass.mk '' + ((convexQuotientSplitRingEquiv + (FiniteArchimedeanClass.tailSubmodule K + {c : FiniteArchimedeanClass G | c.1 ∈ T₀}) + x).coeff 0).support).Finite := by + let T : Set (FiniteArchimedeanClass G) := {c | c.1 ∈ T₀} + let P := FiniteArchimedeanClass.tailSubmodule K T + let inner := (convexQuotientSplitRingEquiv P x).coeff 0 + let inc : P →+o G := + { toFun := fun p ↦ (p : G) + map_zero' := rfl + map_add' := fun _ _ ↦ rfl + monotone' := fun _ _ h ↦ h } + have himage : ArchimedeanClass.orderHom inc '' + (ArchimedeanClass.mk '' inner.support) ⊆ T₁ := by + rintro c ⟨d, ⟨p, hp, rfl⟩, rfl⟩ + rw [ArchimedeanClass.orderHom_mk] + have hpx : (p : G) ∈ x.support := by + apply (HahnSeries.mem_support _ _).mpr + have hpne := (HahnSeries.mem_support _ _).mp hp + dsimp only [inner] at hpne + rw [coeff_zero_convexQuotientSplitRingEquiv, + HahnSeries.restrictDomain_coeff] at hpne + simpa only [submoduleOrderEmbedding_apply] using hpne + rcases hxclasses ⟨p, hpx, rfl⟩ with hpT₀ | hpT₁ + · obtain ⟨a, haT₀, hpa⟩ := hT₀gt _ hpT₀ + have hpP : (p : G) ∈ P := p.2 + have ha0 : a ≠ ⊤ := fun ha ↦ by + obtain ⟨b, -, hab⟩ := hT₀gt a haT₀ + exact (not_lt_of_ge le_top) (ha ▸ hab) + have hpTail : (p : G) ∈ FiniteArchimedeanClass.tailKernel T := by + rw [← FiniteArchimedeanClass.tailSubmodule_toAddSubgroup K T] + exact hpP + have ha_le_p : a ≤ ArchimedeanClass.mk (p : G) := + FiniteArchimedeanClass.mem_tailKernel_iff.mp hpTail ⟨⟨a, ha0⟩, haT₀⟩ + exact (not_lt_of_ge ha_le_p) hpa |>.elim + · exact hpT₁ + change (ArchimedeanClass.mk '' inner.support).Finite + exact Set.Finite.of_finite_image (hT₁.subset himage) + (ArchimedeanClass.orderHom_injective Subtype.val_injective).injOn + +/-- The support cardinality of every outer coefficient is bounded by that of the original +unregrouped series. -/ +theorem cardSupp_coeff_convexQuotientSplitRingEquiv_le + (P : Submodule K G) [P.toAddSubgroup.IsConvex] (x : R⟦G⟧) (q : G ⧸ P) : + ((convexQuotientSplitRingEquiv P x).coeff q).cardSupp ≤ x.cardSupp := by + apply (cardSupp_coeff_le_cardSupp_iterateRingEquiv + (iterateRingEquiv.symm (embDomainRingEquiv (Submodule.quotientLexEquiv P).symm x)) q).trans + rw [RingEquiv.apply_symm_apply] + rw [cardSupp_embDomainRingEquiv] + +/-- Regrouping preserves a regular support bound on the outer support and on every coefficient. -/ +theorem cardSupp_convexQuotientSplitRingEquiv_lt + {κ : Cardinal.{u}} (P : Submodule K G) [P.toAddSubgroup.IsConvex] + (x : R⟦G⟧) (hx : x.cardSupp < κ) : + (convexQuotientSplitRingEquiv P x).cardSupp < κ ∧ + ∀ q, ((convexQuotientSplitRingEquiv P x).coeff q).cardSupp < κ := by + constructor + · have h := cardSupp_outer_le_cardSupp_iterateRingEquiv + (iterateRingEquiv.symm (embDomainRingEquiv (Submodule.quotientLexEquiv P).symm x)) + rw [RingEquiv.apply_symm_apply] at h + exact h.trans_lt (by rw [cardSupp_embDomainRingEquiv]; exact hx) + · exact fun q ↦ (cardSupp_coeff_convexQuotientSplitRingEquiv_le P x q).trans_lt hx + +/-- If the outer support and every coefficient support satisfy a regular bound, flattening the +regrouped Hahn series satisfies the same bound. -/ +theorem cardSupp_convexQuotientSplitRingEquiv_symm_lt_of_isRegular + {κ : Cardinal.{u}} (hκ : κ.IsRegular) (P : Submodule K G) + [P.toAddSubgroup.IsConvex] (x : (R⟦P⟧)⟦G ⧸ P⟧) + (houter : x.cardSupp < κ) (hcoeff : ∀ q, (x.coeff q).cardSupp < κ) : + ((convexQuotientSplitRingEquiv P).symm x).cardSupp < κ := by + have heq : (convexQuotientSplitRingEquiv P).symm x = + embDomainRingEquiv (Submodule.quotientLexEquiv P) (iterateRingEquiv x) := by + apply (convexQuotientSplitRingEquiv P).injective + rw [RingEquiv.apply_symm_apply] + rw [eq_comm] + change iterateRingEquiv.symm + (embDomainRingEquiv (Submodule.quotientLexEquiv P).symm + (embDomainRingEquiv (Submodule.quotientLexEquiv P) (iterateRingEquiv x))) = x + have hdomain : embDomainRingEquiv (Submodule.quotientLexEquiv P).symm + (embDomainRingEquiv (Submodule.quotientLexEquiv P) (iterateRingEquiv x)) = + iterateRingEquiv x := by + ext p + have h₁ := embDomainRingEquiv_coeff (R := R) + (Submodule.quotientLexEquiv P).symm + (embDomainRingEquiv (Submodule.quotientLexEquiv P) (iterateRingEquiv x)) + (Submodule.quotientLexEquiv P p) + have h₂ := embDomainRingEquiv_coeff (R := R) + (Submodule.quotientLexEquiv P) (iterateRingEquiv x) p + rw [OrderAddMonoidIso.symm_apply_apply] at h₁ + exact h₁.trans h₂ + rw [hdomain, RingEquiv.symm_apply_apply] + rw [heq] + rw [cardSupp_embDomainRingEquiv] + exact cardSupp_iterateRingEquiv_lt_of_isRegular hκ x houter hcoeff + +end HahnSeries + +namespace HahnSeries + +section Bounded + +open Cardinal + +universe u v w + +variable {R : Type v} {K : Type w} {G : Type u} [Field R] +variable [Field K] [AddCommGroup G] [Module K G] +variable [LinearOrder G] [IsOrderedAddMonoid G] + +/-- The quotient order induced by a convex submodule of the ordered exponent group. -/ +noncomputable local instance boundedQuotientLinearOrder (P : Submodule K G) + [P.toAddSubgroup.IsConvex] : LinearOrder (G ⧸ P) := + ConvexQuotient.instLinearOrder (H := P.toAddSubgroup) + +local instance boundedQuotientIsOrderedAddMonoid + (P : Submodule K G) [P.toAddSubgroup.IsConvex] : + IsOrderedAddMonoid (G ⧸ P) := + ConvexQuotient.instIsOrderedAddMonoid (H := P.toAddSubgroup) + +local instance boundedSubmoduleIsOrderedAddMonoid (P : Submodule K G) : + IsOrderedAddMonoid P := + AddSubgroup.instIsOrderedAddMonoid P.toAddSubgroup + +variable {κ : Cardinal.{u}} [Fact (aleph0 < κ)] [Fact κ.IsRegular] + +/-- Embed a cardinal-bounded iterated Hahn field coefficientwise into the unrestricted iterated +Hahn field. -/ +def boundedOuterCoefficientInclusion (P : Submodule K G) [P.toAddSubgroup.IsConvex] : + CardSuppLTField (G := G ⧸ P) + (R := CardSuppLTField (G := P) (R := R) (κ := κ)) (κ := κ) →+* + (R⟦P⟧)⟦G ⧸ P⟧ := + (coefficientMapRingHom + ((cardSuppLTSubfield P R κ).subtype : + CardSuppLTField (G := P) (R := R) (κ := κ) →+* R⟦P⟧)).comp + ((cardSuppLTSubfield (G ⧸ P) + (CardSuppLTField (G := P) (R := R) (κ := κ)) κ).subtype) + +omit [Fact κ.IsRegular] in +@[simp] +theorem boundedOuterCoefficientInclusion_coeff + (P : Submodule K G) [P.toAddSubgroup.IsConvex] + (x : CardSuppLTField (G := G ⧸ P) + (R := CardSuppLTField (G := P) (R := R) (κ := κ)) (κ := κ)) + (q : G ⧸ P) : + (boundedOuterCoefficientInclusion P x).coeff q = (x.1.coeff q : R⟦P⟧) := by + change + (coefficientMapRingHom + ((cardSuppLTSubfield P R κ).subtype : + CardSuppLTField (G := P) (R := R) (κ := κ) →+* R⟦P⟧) + (x : (CardSuppLTField (G := P) (R := R) (κ := κ))⟦G ⧸ P⟧)).coeff q = _ + rw [coefficientMapRingHom_coeff] + rfl + +omit [Fact κ.IsRegular] in +/-- Coefficientwise inclusion of a bounded iterated Hahn field is injective. -/ +theorem boundedOuterCoefficientInclusion_injective + (P : Submodule K G) [P.toAddSubgroup.IsConvex] : + Function.Injective (boundedOuterCoefficientInclusion + (R := R) (κ := κ) P) := by + intro x y hxy + apply Subtype.ext + ext q p + have hcoeff := congrArg (fun z : (R⟦P⟧)⟦G ⧸ P⟧ ↦ (z.coeff q).coeff p) hxy + simpa using hcoeff + +/-- Regroup a bounded Hahn series into a bounded outer Hahn series whose coefficients are bounded +inner Hahn series. -/ +def boundedConvexQuotientSplit (P : Submodule K G) [P.toAddSubgroup.IsConvex] + (x : CardSuppLTField (G := G) (R := R) (κ := κ)) : + CardSuppLTField (G := G ⧸ P) + (R := CardSuppLTField (G := P) (R := R) (κ := κ)) (κ := κ) := by + let y := convexQuotientSplitRingEquiv P (x : R⟦G⟧) + have hy := cardSupp_convexQuotientSplitRingEquiv_lt P (x : R⟦G⟧) x.2 + let f : G ⧸ P → CardSuppLTField (G := P) (R := R) (κ := κ) := + fun q ↦ ⟨y.coeff q, hy.2 q⟩ + let z : (CardSuppLTField (G := P) (R := R) (κ := κ))⟦G ⧸ P⟧ := + { coeff := f + isPWO_support' := by + have hsupport : Function.support f = y.support := by + ext q + simp only [Function.mem_support, ne_eq, HahnSeries.mem_support] + constructor + · intro hf hyq + apply hf + apply Subtype.ext + exact hyq + · intro hyq hf + apply hyq + exact congrArg Subtype.val hf + rw [hsupport] + exact y.isPWO_support } + exact ⟨z, by + change z.cardSupp < κ + have hsupport : z.support = y.support := by + ext q + simp only [HahnSeries.mem_support, z] + constructor + · intro hf hyq + apply hf + apply Subtype.ext + exact hyq + · intro hyq hf + apply hyq + exact congrArg Subtype.val hf + rw [HahnSeries.cardSupp_congr hsupport] + exact hy.1⟩ + +omit [Fact κ.IsRegular] in +/-- Bounded regrouping agrees with unrestricted regrouping after coefficientwise inclusion. -/ +theorem boundedOuterCoefficientInclusion_split + (P : Submodule K G) [P.toAddSubgroup.IsConvex] + (x : CardSuppLTField (G := G) (R := R) (κ := κ)) : + boundedOuterCoefficientInclusion P (boundedConvexQuotientSplit P x) = + convexQuotientSplitRingEquiv P (x : R⟦G⟧) := by + ext q p + rw [boundedOuterCoefficientInclusion_coeff] + rfl + +omit [Fact κ.IsRegular] in +/-- Bounded quotient regrouping has the same outer support as unrestricted regrouping. -/ +theorem support_boundedConvexQuotientSplit + (P : Submodule K G) [P.toAddSubgroup.IsConvex] + (x : CardSuppLTField (G := G) (R := R) (κ := κ)) : + ((boundedConvexQuotientSplit P x : + CardSuppLTField (G := G ⧸ P) + (R := CardSuppLTField (G := P) (R := R) (κ := κ)) (κ := κ)) : + (CardSuppLTField (G := P) (R := R) (κ := κ))⟦G ⧸ P⟧).support = + (convexQuotientSplitRingEquiv P (x : R⟦G⟧)).support := by + rw [← support_coefficientMapRingHom + ((cardSuppLTSubfield P R κ).subtype) Subtype.val_injective] + exact congrArg HahnSeries.support (boundedOuterCoefficientInclusion_split P x) + +/-- Flatten a bounded outer Hahn series with bounded inner coefficients. Regularity of the bound +ensures that the flattened support is still bounded. -/ +def boundedConvexQuotientUnsplit (P : Submodule K G) [P.toAddSubgroup.IsConvex] + (x : CardSuppLTField (G := G ⧸ P) + (R := CardSuppLTField (G := P) (R := R) (κ := κ)) (κ := κ)) : + CardSuppLTField (G := G) (R := R) (κ := κ) := + ⟨(convexQuotientSplitRingEquiv P).symm + (boundedOuterCoefficientInclusion P x), by + apply cardSupp_convexQuotientSplitRingEquiv_symm_lt_of_isRegular + (Fact.out : κ.IsRegular) P (boundedOuterCoefficientInclusion P x) + · have hsupport : (boundedOuterCoefficientInclusion P x).support = + (x : (CardSuppLTField (G := P) (R := R) (κ := κ))⟦G ⧸ P⟧).support := + support_coefficientMapRingHom _ Subtype.val_injective _ + rw [HahnSeries.cardSupp_congr hsupport] + exact x.2 + · intro q + rw [boundedOuterCoefficientInclusion_coeff] + exact (x.1.coeff q).2⟩ + +/-- Cardinal-bounded Hahn series split as bounded outer Hahn series with bounded inner Hahn +coefficients along a convex subspace. -/ +def boundedConvexQuotientSplitRingEquiv + (P : Submodule K G) [P.toAddSubgroup.IsConvex] : + CardSuppLTField (G := G) (R := R) (κ := κ) ≃+* + CardSuppLTField (G := G ⧸ P) + (R := CardSuppLTField (G := P) (R := R) (κ := κ)) (κ := κ) where + toFun := boundedConvexQuotientSplit P + invFun := boundedConvexQuotientUnsplit P + left_inv := by + intro x + apply Subtype.ext + change (convexQuotientSplitRingEquiv P).symm + (boundedOuterCoefficientInclusion P (boundedConvexQuotientSplit P x)) = _ + rw [boundedOuterCoefficientInclusion_split, RingEquiv.symm_apply_apply] + right_inv := by + intro x + apply boundedOuterCoefficientInclusion_injective P + rw [boundedOuterCoefficientInclusion_split] + change convexQuotientSplitRingEquiv P + ((convexQuotientSplitRingEquiv P).symm + (boundedOuterCoefficientInclusion P x)) = _ + rw [RingEquiv.apply_symm_apply] + map_mul' := by + intro x y + apply boundedOuterCoefficientInclusion_injective P + rw [boundedOuterCoefficientInclusion_split, map_mul, + boundedOuterCoefficientInclusion_split, boundedOuterCoefficientInclusion_split] + exact map_mul (convexQuotientSplitRingEquiv P) (x : R⟦G⟧) (y : R⟦G⟧) + map_add' := by + intro x y + apply boundedOuterCoefficientInclusion_injective P + rw [boundedOuterCoefficientInclusion_split, map_add, + boundedOuterCoefficientInclusion_split, boundedOuterCoefficientInclusion_split] + exact map_add (convexQuotientSplitRingEquiv P) (x : R⟦G⟧) (y : R⟦G⟧) + +/-- The bounded splitting equivalence applies by bounded quotient regrouping. -/ +@[simp] +theorem boundedConvexQuotientSplitRingEquiv_apply + (P : Submodule K G) [P.toAddSubgroup.IsConvex] + (x : CardSuppLTField (G := G) (R := R) (κ := κ)) : + boundedConvexQuotientSplitRingEquiv P x = boundedConvexQuotientSplit P x := + (rfl) + +omit [Fact κ.IsRegular] in +/-- The outer-zero coefficient of bounded quotient regrouping is exponent-domain restriction to +the convex subspace. -/ +@[simp] +theorem coe_coeff_zero_boundedConvexQuotientSplit + (P : Submodule K G) [P.toAddSubgroup.IsConvex] + (x : CardSuppLTField (G := G) (R := R) (κ := κ)) : + (((boundedConvexQuotientSplit P x).1.coeff 0 : + CardSuppLTField (G := P) (R := R) (κ := κ)) : R⟦P⟧) = + HahnSeries.restrictDomain (submoduleOrderEmbedding P) (x : R⟦G⟧) := by + have h := congrArg (fun z : (R⟦P⟧)⟦G ⧸ P⟧ ↦ z.coeff 0) + (boundedOuterCoefficientInclusion_split P x) + rw [boundedOuterCoefficientInclusion_coeff, + coeff_zero_convexQuotientSplitRingEquiv] at h + exact h + +/-- Bounded regrouping preserves membership in the integer part when the allowed outer constant +coefficients are the corresponding bounded inner integer part. -/ +theorem mem_cardSuppLTTruncationIntegerPart_boundedConvexQuotientSplitRingEquiv_iff + (P : Submodule K G) [P.toAddSubgroup.IsConvex] (Z : Subring R) + (x : CardSuppLTField (G := G) (R := R) (κ := κ)) : + x ∈ cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z ↔ + boundedConvexQuotientSplitRingEquiv P x ∈ + cardSuppLTTruncationIntegerPart (G := G ⧸ P) + (R := CardSuppLTField (G := P) (R := R) (κ := κ)) (κ := κ) + (cardSuppLTTruncationIntegerPart (G := P) (R := R) (κ := κ) Z) := by + rw [mem_cardSuppLTTruncationIntegerPart, mem_cardSuppLTTruncationIntegerPart] + change + (x : R⟦G⟧).support ⊆ Set.Iic 0 ∧ (x : R⟦G⟧).coeff 0 ∈ Z ↔ + ((boundedConvexQuotientSplitRingEquiv P x : + CardSuppLTField (G := G ⧸ P) + (R := CardSuppLTField (G := P) (R := R) (κ := κ)) (κ := κ)) : + (CardSuppLTField (G := P) (R := R) (κ := κ))⟦G ⧸ P⟧).support ⊆ + Set.Iic 0 ∧ + ((boundedConvexQuotientSplitRingEquiv P x : + CardSuppLTField (G := G ⧸ P) + (R := CardSuppLTField (G := P) (R := R) (κ := κ)) (κ := κ)) : + (CardSuppLTField (G := P) (R := R) (κ := κ))⟦G ⧸ P⟧).coeff 0 ∈ + cardSuppLTTruncationIntegerPart (G := P) (R := R) (κ := κ) Z + rw [mem_cardSuppLTTruncationIntegerPart, boundedConvexQuotientSplitRingEquiv_apply] + let y := boundedConvexQuotientSplit P x + have hcoeff (q : G ⧸ P) : ((y.1.coeff q : + CardSuppLTField (G := P) (R := R) (κ := κ)) : R⟦P⟧) = + (convexQuotientSplitRingEquiv P (x : R⟦G⟧)).coeff q := by + have h := congrArg (fun z : (R⟦P⟧)⟦G ⧸ P⟧ ↦ z.coeff q) + (boundedOuterCoefficientInclusion_split P x) + rw [boundedOuterCoefficientInclusion_coeff] at h + exact h + have hsupport : (y : + (CardSuppLTField (G := P) (R := R) (κ := κ))⟦G ⧸ P⟧).support = + (convexQuotientSplitRingEquiv P (x : R⟦G⟧)).support := by + ext q + rw [HahnSeries.mem_support, HahnSeries.mem_support] + constructor + · intro hy hzero + apply hy + apply Subtype.ext + exact (hcoeff q).trans hzero + · intro hxq hzero + apply hxq + rw [← hcoeff q] + exact congrArg Subtype.val hzero + change + (x : R⟦G⟧).support ⊆ Set.Iic 0 ∧ (x : R⟦G⟧).coeff 0 ∈ Z ↔ + ((boundedConvexQuotientSplit P x : + CardSuppLTField (G := G ⧸ P) + (R := CardSuppLTField (G := P) (R := R) (κ := κ)) (κ := κ)) : + (CardSuppLTField (G := P) (R := R) (κ := κ))⟦G ⧸ P⟧).support ⊆ + Set.Iic 0 ∧ + (((boundedConvexQuotientSplit P x : + CardSuppLTField (G := G ⧸ P) + (R := CardSuppLTField (G := P) (R := R) (κ := κ)) (κ := κ)).1.coeff 0 : + CardSuppLTField (G := P) (R := R) (κ := κ)) : R⟦P⟧).support ⊆ + Set.Iic 0 ∧ + (((boundedConvexQuotientSplit P x : + CardSuppLTField (G := G ⧸ P) + (R := CardSuppLTField (G := P) (R := R) (κ := κ)) (κ := κ)).1.coeff 0 : + CardSuppLTField (G := P) (R := R) (κ := κ)) : R⟦P⟧).coeff 0 ∈ Z + rw [hsupport, hcoeff 0] + change + (x : R⟦G⟧).support ⊆ Set.Iic 0 ∧ (x : R⟦G⟧).coeff 0 ∈ Z ↔ + (convexQuotientSplitRingEquiv P (x : R⟦G⟧)).support ⊆ Set.Iic 0 ∧ + (((convexQuotientSplitRingEquiv P (x : R⟦G⟧)).coeff 0).support ⊆ + Set.Iic 0 ∧ + ((convexQuotientSplitRingEquiv P (x : R⟦G⟧)).coeff 0).coeff 0 ∈ Z) + rw [← and_assoc, ← support_convexQuotientSplitRingEquiv_subset_Iic_iff] + refine and_congr Iff.rfl ?_ + rw [convexQuotientSplitRingEquiv_coeff] + simp + +/-- Regrouping identifies a bounded Hahn integer part with the outer Hahn integer part whose +allowed constant coefficients are the corresponding bounded inner Hahn integer part. -/ +def cardSuppLTTruncationIntegerPartConvexQuotientSplitRingEquiv + (P : Submodule K G) [P.toAddSubgroup.IsConvex] (Z : Subring R) : + cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z ≃+* + cardSuppLTTruncationIntegerPart (G := G ⧸ P) + (R := CardSuppLTField (G := P) (R := R) (κ := κ)) (κ := κ) + (cardSuppLTTruncationIntegerPart (G := P) (R := R) (κ := κ) Z) := + RingEquiv.restrict (boundedConvexQuotientSplitRingEquiv P) _ _ + (mem_cardSuppLTTruncationIntegerPart_boundedConvexQuotientSplitRingEquiv_iff P Z) + +/-- The restricted integer-part equivalence is bounded quotient regrouping on underlying +series. -/ +@[simp] +theorem coe_cardSuppLTTruncationIntegerPartConvexQuotientSplitRingEquiv + (P : Submodule K G) [P.toAddSubgroup.IsConvex] (Z : Subring R) + (x : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) : + (((cardSuppLTTruncationIntegerPartConvexQuotientSplitRingEquiv P Z x : + cardSuppLTTruncationIntegerPart (G := G ⧸ P) + (R := CardSuppLTField (G := P) (R := R) (κ := κ)) (κ := κ) + (cardSuppLTTruncationIntegerPart (G := P) (R := R) (κ := κ) Z)) : + CardSuppLTField (G := G ⧸ P) + (R := CardSuppLTField (G := P) (R := R) (κ := κ)) (κ := κ)) : + (CardSuppLTField (G := P) (R := R) (κ := κ))⟦G ⧸ P⟧) = + (boundedConvexQuotientSplit P x.1 : + (CardSuppLTField (G := P) (R := R) (κ := κ))⟦G ⧸ P⟧) := + (rfl) + +/-- The integer-part splitting equivalence preserves the outer support of unrestricted +regrouping. -/ +theorem support_cardSuppLTTruncationIntegerPartConvexQuotientSplitRingEquiv + (P : Submodule K G) [P.toAddSubgroup.IsConvex] (Z : Subring R) + (x : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) : + ((cardSuppLTTruncationIntegerPartConvexQuotientSplitRingEquiv P Z x : + (CardSuppLTField (G := P) (R := R) (κ := κ))⟦G ⧸ P⟧).support) = + (convexQuotientSplitRingEquiv P (x : R⟦G⟧)).support := by + rw [coe_cardSuppLTTruncationIntegerPartConvexQuotientSplitRingEquiv] + exact support_boundedConvexQuotientSplit P x.1 + +end Bounded + +end HahnSeries diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Degree.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Degree.lean new file mode 100644 index 0000000000..fdf008b7de --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Degree.lean @@ -0,0 +1,14 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Degree.PrincipalMultiplicativity +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Degree.Statements +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Degree.SupportSupremumMultiplicativity +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Degree.Tests + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Degree/PrincipalMultiplicativity.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Degree/PrincipalMultiplicativity.lean new file mode 100644 index 0000000000..0687538317 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Degree/PrincipalMultiplicativity.lean @@ -0,0 +1,54 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Multiplicativity +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.NegativeMonomialIdeal +public import Mathlib.RingTheory.Ideal.Prime + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrderTypeMultiplicativity +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Degree.SupportSupremumMultiplicativity +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Statements.ProductValue + +/-! +# Multiplication of principal real Hahn series + +LM24, Proposition 3.6.1 combines Fact 3.4.1 with Proposition 3.5.1: the product of two principal +series is principal. The first theorem below exposes the two cited Berarducci inputs explicitly. +The second discharges them using their formalized characteristic-zero theorems. + +The theorem below directly combines the two cited Berarducci inputs. +-/ + +universe v + +public noncomputable section + +namespace HahnSeries.Nonpositive + +variable {K : Type v} [Field K] + +/-- LM24, Proposition 3.6.1, reduced to the two Berarducci prerequisites used by LM24. -/ +theorem IsPrincipal.mul_of_multiplicativity + {b c : Nonpositive ℝ K} + (hb : IsPrincipal b) (hc : IsPrincipal c) + (hOrder : OrderTypeMultiplicativeOnWeaklyPrincipal K) + (hJ : (negativeMonomialIdeal K).IsPrime) : + IsPrincipal (b * c) := by + rw [isPrincipal_iff] + constructor + · exact hOrder.isWeaklyPrincipal_mul hb.isWeaklyPrincipal hc.isWeaklyPrincipal + · rw [supportSup_mul_of_negativeMonomialIdeal_isPrime hJ, + hb.supportSup_eq_zero, hc.supportSup_eq_zero, add_zero] + +/-- LM24, Proposition 3.6.1: the product of two principal real Hahn series is principal. -/ +theorem IsPrincipal.mul [CharZero K] + {b c : Nonpositive ℝ K} (hb : IsPrincipal b) (hc : IsPrincipal c) : + IsPrincipal (b * c) := + hb.mul_of_multiplicativity hc orderTypeMultiplicativeOnWeaklyPrincipal + Berarducci.negativeMonomialIdeal_isPrime + +end HahnSeries.Nonpositive diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Degree/Statements.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Degree/Statements.lean new file mode 100644 index 0000000000..94d783f062 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Degree/Statements.lean @@ -0,0 +1,13 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Degree.Statements.Degree +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Degree.Statements.DegreeResidue +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Degree.Statements.DegreeValuation + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Degree/Statements/Degree.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Degree/Statements/Degree.lean new file mode 100644 index 0000000000..f4de7489a4 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Degree/Statements/Degree.lean @@ -0,0 +1,75 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Nonpositive +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrderType +public import Mathlib.Basic.Real.Basic + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrderTypeMultiplicativity + +/-! +# LM24 degree valuation statement + +This module proves LM24, Theorem D with its printed quantifier domain: both input series are +nonzero. The ultrametric inequality and separation at zero are proved directly, while +multiplicativity uses LM24's reduction to Berarducci, Corollary 9.9. + +The addition on degrees is Hessenberg addition transported to `NatOrdinal`, with an absorbing +bottom element for the zero series. The source's third clause is retained even though its fixed +input `b` is assumed nonzero. The stronger all-input separation theorem is +`HahnSeries.degree_eq_bot`. +-/ + +universe v + +open scoped HahnSeries + +public noncomputable section + +namespace HahnSeries.Nonpositive + +variable {K : Type v} [Field K] [CharZero K] + +/-- The all-input multiplicativity law underlying LM24, Theorem D. The printed theorem assumes +both inputs are nonzero; the zero cases follow from the ring laws. -/ +@[blueprint "fact:degree-multiplicativity" + (phase := "Ordinal value and degree") + (title := "Multiplicativity of the degree (LM24, Theorem D)") + (statement := /-- + For $b,c\in\Kser$, $\deg(bc)=\deg(b)\nsum\deg(c)$. + -/) + (proof := /-- + Decompose each nonzero series into a principal leading summand and a remainder + of no larger degree. By + \ref{fact:weakly-principal-order-type-multiplicativity}, the support order + types of the two principal summands multiply. Together with the strict degree + bounds for the remaining products, this shows that the leading term of + $bc$ has degree $\deg(b)\mathbin\oplus\deg(c)$. Hence + $\deg(bc)=\deg(b)\mathbin\oplus\deg(c)$. The zero cases follow from the + ring laws. + -/)] +theorem degree_mul (b c : Nonpositive ℝ K) : + ((b * c : Nonpositive ℝ K) : K⟦ℝ⟧).degree = + (b : K⟦ℝ⟧).degree + (c : K⟦ℝ⟧).degree := + degree_mul_of_orderTypeMultiplicativeOnWeaklyPrincipal + orderTypeMultiplicativeOnWeaklyPrincipal b c + +/-- LM24, Theorem D: degree is a multiplicative valuation on nonpositive real Hahn series. -/ +theorem real_hahn_series_degree_valuation + (b c : Nonpositive ℝ K) (_hb : b ≠ 0) (_hc : c ≠ 0) : + ((b + c : Nonpositive ℝ K) : K⟦ℝ⟧).degree ≤ + max (b : K⟦ℝ⟧).degree (c : K⟦ℝ⟧).degree ∧ + ((b * c : Nonpositive ℝ K) : K⟦ℝ⟧).degree = + (b : K⟦ℝ⟧).degree + (c : K⟦ℝ⟧).degree ∧ + ((b : K⟦ℝ⟧).degree = ⊥ ↔ b = 0) := by + refine ⟨HahnSeries.degree_add_le _ _, ?_, ?_⟩ + · exact degree_mul b c + · simp + +end HahnSeries.Nonpositive diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Degree/Statements/DegreeResidue.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Degree/Statements/DegreeResidue.lean new file mode 100644 index 0000000000..a07fb68f2d --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Degree/Statements/DegreeResidue.lean @@ -0,0 +1,59 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.Residue +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.FiniteSupport +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrderType +public import Mathlib.Basic.Real.Basic + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.DegreeValuation +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.FiniteSupportResidue +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrderTypeMultiplicativity + +/-! +# LM24 degree-residue statement + +This module states LM24, Proposition 5.1.1 in the grade-zero-component presentation of the +residue ring. The degree valuation is exhibited together with its exact value function, its +finite-support nonpositive subring, its zero negative ideal, and the bijective residue map. + +The construction uses LM24's reduction of degree multiplicativity to Berarducci, Corollary 9.9. +The residue identifications are proved in +`ConwayRefinement.HahnSeries.FiniteSupportResidue`. +-/ + +universe v + +public noncomputable section + +open scoped DirectSum HahnSeries + +namespace HahnSeries.Nonpositive + +variable {K : Type v} [Field K] [CharZero K] + +/-- LM24, Proposition 5.1.1: the degree-zero residue ring of the multiplicative degree valuation +is the finite-support ring. -/ +theorem real_hahn_series_finite_support_residue : + ∃ w : MaxAddDegree (Nonpositive ℝ K) NatOrdinal, w.IsMultiplicative ∧ + (∀ b, w b = (b : K⟦ℝ⟧).degree) ∧ + w.nonpositiveSubring = finiteSupportSubring ∧ + w.negativeIdeal = ⊥ ∧ Function.Bijective w.residueMap := by + let hmul : ∀ b c : Nonpositive ℝ K, + ((b * c : Nonpositive ℝ K) : K⟦ℝ⟧).degree = + (b : K⟦ℝ⟧).degree + (c : K⟦ℝ⟧).degree := + degree_mul_of_orderTypeMultiplicativeOnWeaklyPrincipal + orderTypeMultiplicativeOnWeaklyPrincipal + let w := degreeValuation K + have hvalue : ∀ b, w b = (b : K⟦ℝ⟧).degree := degreeValuation_apply + have hwmul : w.IsMultiplicative := ⟨fun b c ↦ by rw [hvalue, hvalue, hvalue]; exact hmul b c⟩ + refine ⟨w, hwmul, hvalue, + nonpositiveSubring_eq_finiteSupportSubring_of_value_eq_degree w hvalue, + negativeIdeal_eq_bot_of_value_eq_degree w hvalue, ?_, w.residueMap_surjective⟩ + exact residueMap_injective_of_value_eq_degree w hvalue + +end HahnSeries.Nonpositive diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Degree/Statements/DegreeValuation.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Degree/Statements/DegreeValuation.lean new file mode 100644 index 0000000000..36f626dd03 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Degree/Statements/DegreeValuation.lean @@ -0,0 +1,40 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.DegreeValuation +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.FiniteSupportResidue +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Degree.Statements.Degree + +/-! +# Multiplicativity of the degree valuation in characteristic zero + +Hahn-series degree on `K((ℝ^{≤0}))` is a max-additive degree over every coefficient field, +bundled as `degreeValuation K` from the submultiplicative bound of LM24, Corollary 3.1.2 alone. +Over a field of characteristic zero it is exactly multiplicative (LM24, Theorem D, proved as +`degree_mul`), so it is LM24's multiplicative valuation `deg`. This module +records Theorem D once, as the instance `(degreeValuation K).IsMultiplicative`; the degree-graded +ring `gr_deg K((ℝ^{≤0}))` therefore has no homogeneous zero divisors under `[CharZero K]`, and +every statement that needs exact degrees of products reads this instance. +-/ + +universe v + +open scoped HahnSeries + +public noncomputable section + +namespace HahnSeries.Nonpositive + +variable (K : Type v) [Field K] [CharZero K] + +/-- LM24, Theorem D: the degree valuation is multiplicative. -/ +instance degreeValuation_isMultiplicative : (degreeValuation K).IsMultiplicative := + ⟨fun b c ↦ by + simp only [degreeValuation_apply] + exact degree_mul b c⟩ + +end HahnSeries.Nonpositive diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Degree/SupportSupremumMultiplicativity.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Degree/SupportSupremumMultiplicativity.lean new file mode 100644 index 0000000000..588c7e88dc --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Degree/SupportSupremumMultiplicativity.lean @@ -0,0 +1,168 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.NegativeMonomialIdeal +public import Mathlib.RingTheory.Ideal.Prime + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Statements.ProductValue + +/-! +# Multiplicativity of the support supremum + +LM24, Proposition 3.5.1(2) states that support supremum is multiplicative on nonpositive real +Hahn series. The paragraph preceding the proposition cites Berarducci, Corollary 9.8: the ideal +`negativeMonomialIdeal K` is prime. This module first proves the proposition from that exact +prerequisite, with zero factors handled explicitly, and then discharges the prerequisite using +the formalized Berarducci theorem. + +For nonzero `b` and `c`, normalize both supports to have supremum zero. Primality prevents the +normalized product from having strictly negative supremum. Translating the product back then +adds the original real suprema. The resulting theorem is valid for all inputs because `⊥` is +absorbing under addition. + +The converse is also proved: full support-supremum multiplicativity implies that the +negative-monomial ideal is prime. Thus +`negativeMonomialIdeal_isPrime_iff_supportSup_mul` records the equivalence. + +The optional normal-form proof printed after LM24, Proposition 3.5.1 assumes strict inequalities +between consecutive normal-form exponents, although the source definition permits equality. The +prime-ideal argument above does not require that extra assumption. +-/ + +universe v + +public noncomputable section + +namespace HahnSeries.Nonpositive + +variable {K : Type v} [Field K] + +/-- If the negative-monomial ideal is prime, the product of two series with support supremum zero +again has support supremum zero. -/ +theorem supportSup_mul_eq_zero_of_negativeMonomialIdeal_isPrime + (hJ : (negativeMonomialIdeal K).IsPrime) + {b c : Nonpositive ℝ K} + (hb : supportSup b = 0) (hc : supportSup c = 0) : + supportSup (b * c) = 0 := by + apply le_antisymm (supportSup_le_zero (b * c)) + apply le_of_not_gt + intro hproduct + have hmem : b * c ∈ negativeMonomialIdeal K := + mem_negativeMonomialIdeal_iff_supportSup_lt_zero.mpr hproduct + rcases hJ.mem_or_mem hmem with hbmem | hcmem + · rw [mem_negativeMonomialIdeal_iff_supportSup_lt_zero, hb] at hbmem + exact (lt_irrefl (0 : WithBot ℝ)) hbmem + · rw [mem_negativeMonomialIdeal_iff_supportSup_lt_zero, hc] at hcmem + exact (lt_irrefl (0 : WithBot ℝ)) hcmem + +/-- LM24, Proposition 3.5.1(2), reduced to its cited Berarducci prerequisite that the +negative-monomial ideal is prime. The equality includes zero factors via the absorbing bottom +convention. -/ +theorem supportSup_mul_of_negativeMonomialIdeal_isPrime + (hJ : (negativeMonomialIdeal K).IsPrime) + (b c : Nonpositive ℝ K) : + supportSup (b * c) = supportSup b + supportSup c := by + by_cases hb : b = 0 + · subst b + simp + by_cases hc : c = 0 + · subst c + simp + have hbc : b * c ≠ 0 := mul_ne_zero hb hc + have hnormalizedProduct : + supportSup (normalize b * normalize c) = 0 := + supportSup_mul_eq_zero_of_negativeMonomialIdeal_isPrime hJ + (supportSup_normalize hb) (supportSup_normalize hc) + have hnormalizedProductNe : normalize b * normalize c ≠ 0 := + mul_ne_zero (normalize_ne_zero hb) (normalize_ne_zero hc) + have hnormalizedProductNe' : + (((normalize b * normalize c : Nonpositive ℝ K) : K⟦ℝ⟧)) ≠ 0 := by + intro hzero + exact hnormalizedProductNe (Subtype.ext hzero) + have hnormalizedProductSup : + sSup (((normalize b * normalize c : Nonpositive ℝ K) : K⟦ℝ⟧).support) = 0 := by + rw [supportSup_of_ne hnormalizedProductNe] at hnormalizedProduct + exact WithBot.coe_eq_coe.mp hnormalizedProduct + have hproduct : + (((b * c : Nonpositive ℝ K) : K⟦ℝ⟧)) = + translate + (sSup (b : K⟦ℝ⟧).support + sSup (c : K⟦ℝ⟧).support) + ((normalize b * normalize c : Nonpositive ℝ K) : K⟦ℝ⟧) := by + calc + (((b * c : Nonpositive ℝ K) : K⟦ℝ⟧)) = + (b : K⟦ℝ⟧) * (c : K⟦ℝ⟧) := rfl + _ = translate (sSup (b : K⟦ℝ⟧).support) (normalize b : K⟦ℝ⟧) * + translate (sSup (c : K⟦ℝ⟧).support) (normalize c : K⟦ℝ⟧) := by + rw [translate_csSup_normalize, translate_csSup_normalize] + _ = _ := translate_mul_translate _ _ _ _ + rw [supportSup_of_ne hbc, supportSup_of_ne hb, supportSup_of_ne hc] + norm_cast + calc + sSup ((((b * c : Nonpositive ℝ K) : K⟦ℝ⟧)).support) = + sSup + (translate + (sSup (b : K⟦ℝ⟧).support + sSup (c : K⟦ℝ⟧).support) + ((normalize b * normalize c : Nonpositive ℝ K) : K⟦ℝ⟧)).support := + congrArg (fun z : K⟦ℝ⟧ ↦ sSup z.support) hproduct + _ = (sSup (b : K⟦ℝ⟧).support + sSup (c : K⟦ℝ⟧).support) + + sSup (((normalize b * normalize c : Nonpositive ℝ K) : K⟦ℝ⟧).support) := + csSup_support_translate + (x := ((normalize b * normalize c : Nonpositive ℝ K) : K⟦ℝ⟧)) + hnormalizedProductNe' (bddAbove_support (normalize b * normalize c)) _ + _ = sSup (b : K⟦ℝ⟧).support + sSup (c : K⟦ℝ⟧).support := by + rw [hnormalizedProductSup, add_zero] + +/-- LM24, Proposition 3.5.1(2): support supremum is multiplicative on nonpositive real Hahn +series. The equality includes zero factors via the absorbing bottom convention. -/ +theorem supportSup_mul [CharZero K] (b c : Nonpositive ℝ K) : + supportSup (b * c) = supportSup b + supportSup c := + supportSup_mul_of_negativeMonomialIdeal_isPrime + Berarducci.negativeMonomialIdeal_isPrime b c + +/-- Primality of the negative-monomial ideal is equivalent to multiplicativity of support +supremum on all nonpositive real Hahn series. -/ +theorem negativeMonomialIdeal_isPrime_iff_supportSup_mul : + (negativeMonomialIdeal K).IsPrime ↔ + ∀ b c : Nonpositive ℝ K, + supportSup (b * c) = supportSup b + supportSup c := by + constructor + · exact fun hJ b c => + supportSup_mul_of_negativeMonomialIdeal_isPrime hJ b c + · intro hmul + rw [Ideal.isPrime_iff] + refine ⟨negativeMonomialIdeal_ne_top, ?_⟩ + intro b c hbc + rw [mem_negativeMonomialIdeal_iff_supportSup_lt_zero] at hbc + rw [hmul] at hbc + by_cases hb : b = 0 + · left + rw [hb] + exact (negativeMonomialIdeal K).zero_mem + by_cases hc : c = 0 + · right + rw [hc] + exact (negativeMonomialIdeal K).zero_mem + have hbSup : sSup (b : K⟦ℝ⟧).support ≤ 0 := + csSup_le + (support_nonempty_iff.mpr (by simpa using hb)) + (support_subset b) + rw [supportSup_of_ne hb, supportSup_of_ne hc] at hbc + have hbc' : + sSup (b : K⟦ℝ⟧).support + sSup (c : K⟦ℝ⟧).support < 0 := by + exact_mod_cast hbc + rcases lt_or_eq_of_le hbSup with hbNeg | hbZero + · left + rw [mem_negativeMonomialIdeal_iff_supportSup_lt_zero, + supportSup_of_ne hb] + exact WithBot.coe_lt_coe.mpr hbNeg + · right + rw [hbZero, zero_add] at hbc' + rw [mem_negativeMonomialIdeal_iff_supportSup_lt_zero, + supportSup_of_ne hc] + exact WithBot.coe_lt_coe.mpr hbc' + +end HahnSeries.Nonpositive diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Degree/Tests.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Degree/Tests.lean new file mode 100644 index 0000000000..9215bef1a8 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Degree/Tests.lean @@ -0,0 +1,11 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Degree.Tests.SupportSupremumMultiplicativity + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Degree/Tests/SupportSupremumMultiplicativity.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Degree/Tests/SupportSupremumMultiplicativity.lean new file mode 100644 index 0000000000..c25b91c43c --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Degree/Tests/SupportSupremumMultiplicativity.lean @@ -0,0 +1,121 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.NegativeMonomialIdeal +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.NormalForm +public import Mathlib.RingTheory.Ideal.Prime +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Degree.PrincipalMultiplicativity +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Degree.SupportSupremumMultiplicativity +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Tests.Fixtures.ApproachZero + +/-! +# API checks for support-supremum multiplicativity + +The first certificate distinguishes Berarducci's negative-monomial ideal from the kernel of the +constant-coefficient map. A negative monomial and the infinite `approachZero` series both have +zero constant coefficient, but only the negative monomial belongs to the ideal: `approachZero` +has support cofinal in zero and support supremum zero. + +The next certificates apply the parameterized LM24, Proposition 3.5.1(2) bridge to the same +unattained boundary. One checks a normalized square, while another translates one factor to +support supremum `-1`; the latter would fail to exercise the translation-back step if both +factors remained normalized. A further certificate invokes the theorem obtained from +Berarducci, Corollary 9.8. + +The final certificate invokes LM24, Proposition 3.6.1 for a nonconstant principal series whose +support does not contain zero. +-/ + +public noncomputable section + +namespace Tests + +open scoped HahnSeries + +/-- The negative-monomial ideal is not the kernel of the constant-coefficient map. -/ +theorem negativeMonomialIdeal_constantCoeff_separator : + ∃ b c : HahnSeries.Nonpositive ℝ ℚ, + HahnSeries.Nonpositive.constantCoeff b = 0 ∧ + b ∈ HahnSeries.Nonpositive.negativeMonomialIdeal ℚ ∧ + HahnSeries.Nonpositive.constantCoeff c = 0 ∧ + HahnSeries.Nonpositive.supportSup c = 0 ∧ + (c : ℚ⟦ℝ⟧).supportOrderType = Ordinal.omega0 ∧ + 0 ∉ (c : ℚ⟦ℝ⟧).support ∧ + c ∉ HahnSeries.Nonpositive.negativeMonomialIdeal ℚ := by + let b : HahnSeries.Nonpositive ℝ ℚ := + HahnSeries.Nonpositive.single (-1) 1 (by norm_num) + refine ⟨b, approachZeroNonpositive, ?_, ?_, ?_, approachZero_supportSup, ?_, ?_, ?_⟩ + · simp [b, HahnSeries.Nonpositive.constantCoeff_apply] + · exact HahnSeries.Nonpositive.single_one_mem_negativeMonomialIdeal (by norm_num) + · rw [HahnSeries.Nonpositive.constantCoeff_apply, + coe_approachZeroNonpositive] + exact not_ne_iff.mp (by + simpa [HahnSeries.mem_support] using zero_not_mem_approachZero_support) + · simpa only [coe_approachZeroNonpositive] using + approachZero_supportOrderType + · simpa only [coe_approachZeroNonpositive] using + zero_not_mem_approachZero_support + · exact + HahnSeries.Nonpositive.not_mem_negativeMonomialIdeal_of_supportSup_eq_zero + approachZero_supportSup + +/-- The prime-ideal form of support-supremum multiplicativity holds at an unattained normalized +boundary. -/ +theorem exists_unattained_zeroSup_square_of_isPrime + (hJ : (HahnSeries.Nonpositive.negativeMonomialIdeal ℚ).IsPrime) : + ∃ b : HahnSeries.Nonpositive ℝ ℚ, + HahnSeries.Nonpositive.supportSup b = 0 ∧ + 0 ∉ (b : ℚ⟦ℝ⟧).support ∧ + HahnSeries.Nonpositive.supportSup (b * b) = 0 := by + refine ⟨approachZeroNonpositive, approachZero_supportSup, ?_, ?_⟩ + · simpa only [coe_approachZeroNonpositive] using + zero_not_mem_approachZero_support + · rw [HahnSeries.Nonpositive.supportSup_mul_of_negativeMonomialIdeal_isPrime hJ, + approachZero_supportSup, zero_add] + +/-- Conditional support-supremum multiplicativity translates an unattained boundary correctly. -/ +theorem exists_translated_unattained_product + (hJ : (HahnSeries.Nonpositive.negativeMonomialIdeal ℚ).IsPrime) : + ∃ b c : HahnSeries.Nonpositive ℝ ℚ, + HahnSeries.Nonpositive.supportSup b = (-1 : ℝ) ∧ + HahnSeries.Nonpositive.supportSup c = 0 ∧ + 0 ∉ (c : ℚ⟦ℝ⟧).support ∧ + HahnSeries.Nonpositive.supportSup (b * c) = (-1 : ℝ) := by + let b : HahnSeries.Nonpositive ℝ ℚ := + HahnSeries.Nonpositive.single (-1) 1 (by norm_num) + refine ⟨b, approachZeroNonpositive, ?_, approachZero_supportSup, ?_, ?_⟩ + · exact HahnSeries.Nonpositive.supportSup_single one_ne_zero (by norm_num) + · simpa only [coe_approachZeroNonpositive] using + zero_not_mem_approachZero_support + · rw [HahnSeries.Nonpositive.supportSup_mul_of_negativeMonomialIdeal_isPrime hJ, + HahnSeries.Nonpositive.supportSup_single one_ne_zero, + approachZero_supportSup] + norm_num + +/-- Support-supremum multiplicativity holds at an unattained normalized boundary. -/ +theorem exists_unattained_zeroSup_square : + ∃ b : HahnSeries.Nonpositive ℝ ℚ, + HahnSeries.Nonpositive.supportSup b = 0 ∧ + 0 ∉ (b : ℚ⟦ℝ⟧).support ∧ + HahnSeries.Nonpositive.supportSup (b * b) = 0 := by + refine ⟨approachZeroNonpositive, approachZero_supportSup, ?_, ?_⟩ + · simpa only [coe_approachZeroNonpositive] using + zero_not_mem_approachZero_support + · rw [HahnSeries.Nonpositive.supportSup_mul, approachZero_supportSup, zero_add] + +/-- Nonconstant principal series are closed under squaring. -/ +theorem exists_nonconstant_principal_square : + ∃ b : HahnSeries.Nonpositive ℝ ℚ, + HahnSeries.Nonpositive.IsPrincipal b ∧ + 0 ∉ (b : ℚ⟦ℝ⟧).support ∧ + HahnSeries.Nonpositive.IsPrincipal (b * b) := by + refine ⟨approachZeroNonpositive, approachZero_isPrincipal, ?_, ?_⟩ + · simpa only [coe_approachZeroNonpositive] using + zero_not_mem_approachZero_support + · exact approachZero_isPrincipal.mul approachZero_isPrincipal + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/DegreeTermCount.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/DegreeTermCount.lean new file mode 100644 index 0000000000..2bfece5f27 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/DegreeTermCount.lean @@ -0,0 +1,91 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrderType +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.CantorTermCount + +/-! +# Cantor term count of Hahn-series degree + +LM24, Proposition 5.6.1 bounds the number of infinite-support irreducible factors by the +number of terms in the Cantor normal form of the degree. `HahnSeries.degreeCantorTermCount` +is that number, with value zero at the bottom degree of the zero series. + +Under exact degree multiplicativity, this count is additive on products of nonzero series. +This is the numerical identity used by the factorisation induction. +-/ + +open scoped HahnSeries NatOrdinal + +universe u v + +public noncomputable section + +namespace HahnSeries + +variable {R : Type v} {G : Type u} [LinearOrder G] + +/-- The number of terms in the uncompressed Cantor normal form of a Hahn-series degree, +with value zero at degree `⊥`. -/ +def degreeCantorTermCount [Zero R] (x : R⟦G⟧) : ℕ := + NatOrdinal.cantorTermCount (x.degree.unbotD 0) + +/-- Evaluation of the term count at a specified nonbottom degree. -/ +theorem degreeCantorTermCount_eq_of_degree [Zero R] {x : R⟦G⟧} + {a : NatOrdinal} (hx : x.degree = a) : + degreeCantorTermCount x = NatOrdinal.cantorTermCount a := by + rw [degreeCantorTermCount, hx, WithBot.unbotD_coe] + +/-- Hahn series with equal degree have equal Cantor term counts. -/ +theorem degreeCantorTermCount_congr [Zero R] {x y : R⟦G⟧} + (hxy : x.degree = y.degree) : + degreeCantorTermCount x = degreeCantorTermCount y := by + rw [degreeCantorTermCount, degreeCantorTermCount, hxy] + +@[simp] +theorem degreeCantorTermCount_zero [Zero R] : + degreeCantorTermCount (0 : R⟦G⟧) = 0 := by + rw [degreeCantorTermCount, degree_zero, WithBot.unbotD_bot, + NatOrdinal.cantorTermCount_zero] + +/-- Positive Hahn-series degree has at least one Cantor term. -/ +theorem degreeCantorTermCount_pos_of_degree_pos [Zero R] {x : R⟦G⟧} + (hx : 0 < x.degree) : + 0 < degreeCantorTermCount x := by + have hxNe : x ≠ 0 := by + intro hzero + subst x + simp at hx + have hxDegree : x.degree ≠ ⊥ := degree_eq_bot.not.mpr hxNe + obtain ⟨a, ha⟩ := WithBot.ne_bot_iff_exists.mp hxDegree + rw [degreeCantorTermCount, ← ha, WithBot.unbotD_coe] + apply NatOrdinal.cantorTermCount_pos + intro hzero + subst a + have hdegreeZero : (0 : WithBot NatOrdinal) = x.degree := by + simpa using ha + rw [← hdegreeZero] at hx + exact (lt_irrefl 0 hx).elim + +/-- The Cantor term count of degree is additive on nonzero products when degree is +multiplicative. -/ +theorem degreeCantorTermCount_mul + [Semiring R] [AddCommMonoid G] [IsOrderedCancelAddMonoid G] + {x y : R⟦G⟧} (hdegree : (x * y).degree = x.degree + y.degree) + (hx : x ≠ 0) (hy : y ≠ 0) : + degreeCantorTermCount (x * y) = + degreeCantorTermCount x + degreeCantorTermCount y := by + have hxDegree : x.degree ≠ ⊥ := degree_eq_bot.not.mpr hx + have hyDegree : y.degree ≠ ⊥ := degree_eq_bot.not.mpr hy + obtain ⟨a, ha⟩ := WithBot.ne_bot_iff_exists.mp hxDegree + obtain ⟨b, hb⟩ := WithBot.ne_bot_iff_exists.mp hyDegree + rw [degreeCantorTermCount, degreeCantorTermCount, + degreeCantorTermCount, hdegree, ← ha, ← hb, ← WithBot.coe_add, + WithBot.unbotD_coe, NatOrdinal.cantorTermCount_add] + simp only [WithBot.unbotD_coe] + +end HahnSeries diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/DegreeValuation.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/DegreeValuation.lean new file mode 100644 index 0000000000..0ffd69b8e0 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/DegreeValuation.lean @@ -0,0 +1,105 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.MaxAddDegree +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Nonpositive +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrderType +public import Mathlib.Basic.Real.Basic + +/-! +# The degree valuation on nonpositive real Hahn series + +Hahn-series degree on `K((ℝ^{≤0}))` is a max-additive degree over every nontrivial coefficient +ring: the degree of a sum is at most the larger degree, and the degree of a product is at most +the Hessenberg sum of the degrees, because the support of a product lies in the sumset of the +supports and the order type of a sumset is at most the Hessenberg product of the order types +(`HahnSeries.degree_mul_le`, LM24, Corollary 3.1.2). The degree is separated: only `0` has +degree `⊥`. + +Exact multiplicativity of the degree, LM24, Theorem D, holds over a field of characteristic zero; +it is recorded separately as an `IsMultiplicative` instance on `degreeValuation K` and is not +needed for the valuation itself. +-/ + +universe v + +public noncomputable section + +namespace HahnSeries.Nonpositive + +variable (K : Type v) [CommRing K] [Nontrivial K] + +/-- Hahn-series degree on `K((ℝ^{≤0}))` as a max-additive valuation: the value of `b` is the +leading Cantor exponent of the order type of its support, with `⊥` on `0`. -/ +def degreeValuation : MaxAddDegree (Nonpositive ℝ K) NatOrdinal where + toFun b := (b : K⟦ℝ⟧).degree + map_zero' := by simp + map_one_le_zero' := by + change ((1 : Nonpositive ℝ K) : K⟦ℝ⟧).degree ≤ 0 + apply le_of_eq + rw [HahnSeries.degree_eq_zero] + exact ⟨one_ne_zero, + Set.Finite.subset (Set.finite_singleton (0 : ℝ)) HahnSeries.support_single_subset⟩ + map_neg' b := HahnSeries.degree_neg (b : K⟦ℝ⟧) + map_add_le_max' b c := HahnSeries.degree_add_le _ _ + map_mul_le_add' b c := HahnSeries.degree_mul_le _ _ + +variable {K} + +/-- The degree valuation has Hahn-series degree as its value. -/ +@[simp] +theorem degreeValuation_apply (b : Nonpositive ℝ K) : + degreeValuation K b = (b : K⟦ℝ⟧).degree := + (rfl) + +variable (K) + +/-- The degree valuation is separated: only `0` has degree `⊥`. -/ +theorem degreeValuation_isSeparated : (degreeValuation K).IsSeparated := by + rw [MaxAddDegree.isSeparated_iff] + intro b + rw [degreeValuation_apply, HahnSeries.degree_eq_bot] + simp + +variable {K} + +/-- A unit of the nonpositive Hahn-series ring has degree zero whenever degree is exactly +multiplicative. -/ +theorem degree_eq_zero_of_isUnit + (hmul : ∀ b c : Nonpositive ℝ K, + ((b * c : Nonpositive ℝ K) : K⟦ℝ⟧).degree = + (b : K⟦ℝ⟧).degree + (c : K⟦ℝ⟧).degree) + {b : Nonpositive ℝ K} (hb : IsUnit b) : + (b : K⟦ℝ⟧).degree = 0 := by + let c : Nonpositive ℝ K := ↑hb.unit⁻¹ + have hc : c ≠ 0 := Units.ne_zero hb.unit⁻¹ + have hbDegreeNonneg : 0 ≤ (b : K⟦ℝ⟧).degree := + HahnSeries.zero_le_degree_of_ne_zero (by + intro hzero + exact hb.ne_zero (Subtype.ext hzero)) + have hcDegreeNonneg : 0 ≤ (c : K⟦ℝ⟧).degree := + HahnSeries.zero_le_degree_of_ne_zero (by + intro hzero + exact hc (Subtype.ext hzero)) + have hdegreeOne : (((1 : Nonpositive ℝ K) : K⟦ℝ⟧).degree) = 0 := by + rw [HahnSeries.degree_eq_zero] + exact ⟨one_ne_zero, + Set.Finite.subset (Set.finite_singleton (0 : ℝ)) HahnSeries.support_single_subset⟩ + have hdegree := hmul b c + have hproduct : b * c = 1 := hb.mul_val_inv + rw [hproduct, hdegreeOne] at hdegree + have hsum : + (b : K⟦ℝ⟧).degree + (c : K⟦ℝ⟧).degree = 0 := hdegree.symm + exact le_antisymm + (calc + (b : K⟦ℝ⟧).degree ≤ + (b : K⟦ℝ⟧).degree + (c : K⟦ℝ⟧).degree := by + simpa using add_le_add_right hcDegreeNonneg (b : K⟦ℝ⟧).degree + _ = 0 := hsum) + hbDegreeNonneg + +end HahnSeries.Nonpositive diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Domain.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Domain.lean new file mode 100644 index 0000000000..f0292518aa --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Domain.lean @@ -0,0 +1,90 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import Mathlib.RingTheory.HahnSeries.Cardinal + +/-! +# Exponent-domain embeddings of Hahn series + +Mathlib's exponent-domain embedding has a one-sided support inclusion. Injectivity of the order +embedding gives the exact support formula needed by the translation and nonpositive-series APIs. +-/ + +universe u v w + +public section + +namespace HahnSeries + +variable {G : Type u} {H : Type v} {K : Type w} + [PartialOrder G] [PartialOrder H] [Zero K] + +/-- Extending the exponent domain maps the support exactly onto its image. -/ +@[simp] +theorem support_embDomain (f : G ↪o H) (x : K⟦G⟧) : + (embDomain f x).support = f '' x.support := by + apply Set.Subset.antisymm support_embDomain_subset + rintro _ ⟨g, hg, rfl⟩ + rw [mem_support] at hg ⊢ + intro hzero + exact hg (embDomain_coeff.symm.trans hzero) + +/-- Restrict a Hahn series along an ordered embedding by retaining the coefficients in its +range. This is a left inverse to `embDomain`; it is also a right inverse when the original +series is supported in the embedding's range. -/ +noncomputable def restrictDomain (f : G ↪o H) (x : K⟦H⟧) : K⟦G⟧ where + coeff g := x.coeff (f g) + isPWO_support' := by + rw [Set.isPWO_iff_exists_monotone_subseq] + intro a ha + have hfa : ∀ n, f (a n) ∈ x.support := fun n ↦ ha n + obtain ⟨g, hg⟩ := x.isPWO_support.exists_monotone_subseq hfa + exact ⟨g, fun _ _ h ↦ f.le_iff_le.mp (hg h)⟩ + +@[simp] +theorem restrictDomain_coeff (f : G ↪o H) (x : K⟦H⟧) (g : G) : + (restrictDomain f x).coeff g = x.coeff (f g) := + (rfl) + +/-- Extending an exponent domain after restricting it recovers a series supported in the +embedding's range. -/ +theorem embDomain_restrictDomain (f : G ↪o H) (x : K⟦H⟧) + (hx : x.support ⊆ Set.range f) : + embDomain f (restrictDomain f x) = x := by + ext h + by_cases hh : h ∈ Set.range f + · obtain ⟨g, rfl⟩ := hh + rw [embDomain_coeff, restrictDomain_coeff] + · rw [HahnSeries.embDomain_of_notMem_range hh] + have hzero : x.coeff h = 0 := by + by_contra hne + exact hh (hx hne) + exact hzero.symm + +/-- Restricting an extended Hahn series recovers the original series. -/ +@[simp] +theorem restrictDomain_embDomain (f : G ↪o H) (x : K⟦G⟧) : + restrictDomain f (embDomain f x) = x := by + ext g + rw [restrictDomain_coeff, embDomain_coeff] + +section Cardinal + +universe u' v' + +variable {G' H' : Type u'} {K' : Type v'} +variable [PartialOrder G'] [PartialOrder H'] [Zero K'] + +/-- Extending the exponent domain along an order embedding preserves support cardinality. -/ +theorem cardSupp_embDomain (f : G' ↪o H') (x : K'⟦G'⟧) : + (embDomain f x).cardSupp = x.cardSupp := by + rw [cardSupp, cardSupp, support_embDomain] + exact Cardinal.mk_image_eq f.injective + +end Cardinal + +end HahnSeries diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/DomainEmbedding.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/DomainEmbedding.lean new file mode 100644 index 0000000000..3a06da8d91 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/DomainEmbedding.lean @@ -0,0 +1,185 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.FiniteSupport +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrderType + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Domain + +/-! +# Embeddings between exponent domains of nonpositive Hahn series + +An injective additive order embedding of exponent groups induces a ring embedding between the +corresponding nonpositive Hahn-series rings. This is the nonpositive restriction of Mathlib's +`HahnSeries.embDomainRingHom`. + +The construction is used in LM24, Section 6.5 to regard a series with exponents in a subgroup +`H ⊆ ℝ` as a real-exponent Hahn series. The public support formula ensures that later statements +about real suprema refer to the same support, transported along the given embedding. +-/ + +universe u v w + +public noncomputable section + +namespace HahnSeries.Nonpositive + +variable {G : Type u} {H : Type v} {K : Type w} + [LinearOrder G] [AddCommGroup G] [IsOrderedAddMonoid G] + [LinearOrder H] [AddCommGroup H] [IsOrderedAddMonoid H] + [CommRing K] + +/-- Map a nonpositive Hahn series along an injective additive order embedding of exponent +groups. -/ +def mapDomain (f : G →+ H) (hfi : Function.Injective f) + (hf : ∀ g g' : G, f g ≤ f g' ↔ g ≤ g') : + Nonpositive G K →+* Nonpositive H K := + ((HahnSeries.embDomainRingHom f hfi hf).domRestrict + (HahnSeries.nonpositiveSubring G K)).codRestrict + (HahnSeries.nonpositiveSubring H K) (fun b ↦ by + rw [HahnSeries.mem_nonpositiveSubring] + intro h hh + change h ∈ (HahnSeries.embDomain + (⟨⟨f, hfi⟩, hf _ _⟩ : G ↪o H) (b : K⟦G⟧)).support at hh + obtain ⟨g, hg, rfl⟩ := HahnSeries.support_embDomain_subset hh + simpa using (hf g 0).mpr (support_subset b hg)) + +/-- The underlying Hahn series of `mapDomain` is Mathlib's exponent-domain embedding. -/ +@[simp] +theorem coe_mapDomain (f : G →+ H) (hfi : Function.Injective f) + (hf : ∀ g g' : G, f g ≤ f g' ↔ g ≤ g') + (b : Nonpositive G K) : + (mapDomain f hfi hf b : K⟦H⟧) = + HahnSeries.embDomain (⟨⟨f, hfi⟩, hf _ _⟩ : G ↪o H) (b : K⟦G⟧) := + (rfl) + +/-- Mapping the exponent domain preserves the coefficient at every mapped exponent. -/ +theorem mapDomain_coeff_image (f : G →+ H) (hfi : Function.Injective f) + (hf : ∀ g g' : G, f g ≤ f g' ↔ g ≤ g') + (b : Nonpositive G K) (g : G) : + ((mapDomain f hfi hf b : Nonpositive H K) : K⟦H⟧).coeff (f g) = + (b : K⟦G⟧).coeff g := by + rw [coe_mapDomain] + exact HahnSeries.embDomain_coeff + +/-- Mapping the exponent domain maps the support pointwise. -/ +theorem support_mapDomain (f : G →+ H) (hfi : Function.Injective f) + (hf : ∀ g g' : G, f g ≤ f g' ↔ g ≤ g') + (b : Nonpositive G K) : + (mapDomain f hfi hf b : K⟦H⟧).support = f '' (b : K⟦G⟧).support := by + rw [coe_mapDomain, HahnSeries.support_embDomain] + rfl + +/-- Mapping along an exponent-domain embedding preserves support order type, after lifting both +ordinals to account for possibly different exponent universes. -/ +theorem lift_supportOrderType_mapDomain (f : G →+ H) (hfi : Function.Injective f) + (hf : ∀ g g' : G, f g ≤ f g' ↔ g ≤ g') (b : Nonpositive G K) : + Ordinal.lift.{u, v} + (HahnSeries.supportOrderType (mapDomain f hfi hf b : K⟦H⟧)) = + Ordinal.lift.{v, u} (HahnSeries.supportOrderType (b : K⟦G⟧)) := by + let e : G ↪o H := ⟨⟨f, hfi⟩, hf _ _⟩ + let : WellFoundedLT (b : K⟦G⟧).support := (b : K⟦G⟧).isWF_support + let : WellFoundedLT (mapDomain f hfi hf b : K⟦H⟧).support := + (mapDomain f hfi hf b : K⟦H⟧).isWF_support + let supportEquiv : (mapDomain f hfi hf b : K⟦H⟧).support ≃o + (b : K⟦G⟧).support := + (Set.orderIsoOfEq _ (f '' (b : K⟦G⟧).support) + (support_mapDomain f hfi hf b)).trans + (StrictMonoOn.orderIso e (b : K⟦G⟧).support + (e.strictMono.strictMonoOn (b : K⟦G⟧).support)).symm + rw [HahnSeries.supportOrderType_eq_typeLT (OrderIso.refl _), + HahnSeries.supportOrderType_eq_typeLT (OrderIso.refl _)] + exact supportEquiv.toRelIsoLT.ordinal_lift_type_eq + +/-- Mapping the exponent domain preserves the constant coefficient. -/ +theorem constantCoeff_mapDomain (f : G →+ H) (hfi : Function.Injective f) + (hf : ∀ g g' : G, f g ≤ f g' ↔ g ≤ g') + (b : Nonpositive G K) : + constantCoeff (mapDomain f hfi hf b) = constantCoeff b := by + rw [constantCoeff_apply, constantCoeff_apply, coe_mapDomain, ← f.map_zero] + exact HahnSeries.embDomain_coeff + +/-- Mapping along an injective exponent-domain map is injective on nonpositive series. -/ +theorem mapDomain_injective (f : G →+ H) (hfi : Function.Injective f) + (hf : ∀ g g' : G, f g ≤ f g' ↔ g ≤ g') : + Function.Injective (mapDomain (K := K) f hfi hf) := by + intro b c hbc + apply Subtype.ext + have hbc' := congrArg Subtype.val hbc + change HahnSeries.embDomain (⟨⟨f, hfi⟩, hf _ _⟩ : G ↪o H) (b : K⟦G⟧) = + HahnSeries.embDomain (⟨⟨f, hfi⟩, hf _ _⟩ : G ↪o H) (c : K⟦G⟧) at hbc' + exact HahnSeries.embDomain_injective hbc' + +/-- Restrict a nonpositive Hahn series whose support lies in the range of an exponent-domain +embedding. -/ +def restrictDomain (f : G →+ H) (hfi : Function.Injective f) + (hf : ∀ g g' : G, f g ≤ f g' ↔ g ≤ g') + (b : Nonpositive H K) : Nonpositive G K := + ⟨HahnSeries.restrictDomain (⟨⟨f, hfi⟩, hf _ _⟩ : G ↪o H) (b : K⟦H⟧), by + intro g hg + have hcoeff : (b : K⟦H⟧).coeff (f g) ≠ 0 := by + change (HahnSeries.restrictDomain + (⟨⟨f, hfi⟩, hf _ _⟩ : G ↪o H) (b : K⟦H⟧)).coeff g ≠ 0 at hg + rw [HahnSeries.restrictDomain_coeff] at hg + exact hg + apply (hf g 0).mp + simpa only [map_zero, Set.mem_Iic] using + b.property ((HahnSeries.mem_support _ _).mpr hcoeff)⟩ + +/-- Extending a restricted nonpositive Hahn series recovers the original series. -/ +@[simp] +theorem mapDomain_restrictDomain (f : G →+ H) (hfi : Function.Injective f) + (hf : ∀ g g' : G, f g ≤ f g' ↔ g ≤ g') + (b : Nonpositive H K) (hb : (b : K⟦H⟧).support ⊆ Set.range f) : + mapDomain f hfi hf (restrictDomain f hfi hf b) = b := by + apply Subtype.ext + rw [coe_mapDomain] + exact HahnSeries.embDomain_restrictDomain _ _ hb + +/-- Mapping the exponent domain sends a monomial to the monomial at the mapped exponent. -/ +@[simp] +theorem mapDomain_single (f : G →+ H) (hfi : Function.Injective f) + (hf : ∀ g g' : G, f g ≤ f g' ↔ g ≤ g') + (g : G) (k : K) (hg : g ≤ 0) : + mapDomain f hfi hf (single g k hg) = + single (f g) k (by simpa only [map_zero] using (hf g 0).mpr hg) := by + apply Subtype.ext + rw [coe_mapDomain, coe_single, coe_single, HahnSeries.embDomain_single] + rfl + +/-- Map a finite-support nonpositive Hahn series along an injective additive order embedding of +exponent groups. -/ +def mapDomainFiniteSupport (f : G →+ H) (hfi : Function.Injective f) + (hf : ∀ g g' : G, f g ≤ f g' ↔ g ≤ g') : + (finiteSupportSubring : Subring (Nonpositive G K)) →+* + (finiteSupportSubring : Subring (Nonpositive H K)) := + ((mapDomain (K := K) f hfi hf).domRestrict finiteSupportSubring).codRestrict + finiteSupportSubring (fun b ↦ by + rw [mem_finiteSupportSubring_iff] + change (mapDomain f hfi hf (b : Nonpositive G K) : K⟦H⟧).support.Finite + rw [support_mapDomain] + exact ((mem_finiteSupportSubring_iff (b : Nonpositive G K)).mp b.2).image f) + +/-- The finite-support exponent-domain map is the restriction of `mapDomain`. -/ +@[simp] +theorem coe_mapDomainFiniteSupport (f : G →+ H) (hfi : Function.Injective f) + (hf : ∀ g g' : G, f g ≤ f g' ↔ g ≤ g') + (b : (finiteSupportSubring : Subring (Nonpositive G K))) : + ((mapDomainFiniteSupport f hfi hf b : + (finiteSupportSubring : Subring (Nonpositive H K))) : Nonpositive H K) = + mapDomain f hfi hf (b : Nonpositive G K) := + (rfl) + +/-- Mapping a finite-support series along an injective exponent-domain map is injective. -/ +theorem mapDomainFiniteSupport_injective (f : G →+ H) + (hfi : Function.Injective f) (hf : ∀ g g' : G, f g ≤ f g' ↔ g ≤ g') : + Function.Injective (mapDomainFiniteSupport (K := K) f hfi hf) := by + intro b c hbc + apply Subtype.ext + exact mapDomain_injective f hfi hf (congrArg Subtype.val hbc) + +end HahnSeries.Nonpositive diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/DomainEquiv.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/DomainEquiv.lean new file mode 100644 index 0000000000..7dd825bde6 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/DomainEquiv.lean @@ -0,0 +1,97 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Domain +public import Mathlib.RingTheory.HahnSeries.Multiplication +public import Mathlib.RingTheory.HahnSeries.Cardinal +public import Mathlib.Algebra.Order.Hom.Monoid + +/-! +# Reindexing Hahn series along an ordered additive equivalence + +An ordered additive equivalence of exponent groups induces a ring equivalence of Hahn-series +rings. This packages Mathlib's one-way exponent-domain embedding together with its inverse. +-/ + +public noncomputable section + +namespace HahnSeries + +variable {R G H : Type*} +variable [Semiring R] +variable [AddCommMonoid G] [LinearOrder G] [IsOrderedCancelAddMonoid G] +variable [AddCommMonoid H] [LinearOrder H] [IsOrderedCancelAddMonoid H] + +/-- Reindex Hahn-series exponents along an ordered additive equivalence. -/ +def embDomainRingEquiv (e : G ≃+o H) : R⟦G⟧ ≃+* R⟦H⟧ := by + let f : G →+ H := e.toAddEquiv.toAddMonoidHom + let F : R⟦G⟧ →+* R⟦H⟧ := + embDomainRingHom f e.injective fun _ _ ↦ e.map_le_map_iff' + apply RingEquiv.ofBijective F + constructor + · exact embDomain_injective + · intro y + refine ⟨embDomain e.symm.toOrderIso.toOrderEmbedding y, ?_⟩ + ext h + dsimp [F, f] + have outer := embDomain_coeff (f := e.toOrderIso.toOrderEmbedding) + (x := embDomain e.symm.toOrderIso.toOrderEmbedding y) (a := e.symm h) + have inner := embDomain_coeff (f := e.symm.toOrderIso.toOrderEmbedding) (x := y) (a := h) + have heh : e.toOrderIso.toOrderEmbedding (e.symm h) = h := e.apply_symm_apply h + rw [heh] at outer + exact outer.trans inner + +@[simp] +theorem embDomainRingEquiv_coeff (e : G ≃+o H) (x : R⟦G⟧) (g : G) : + (embDomainRingEquiv e x).coeff (e g) = x.coeff g := + embDomain_coeff + +/-- Reindexing exponents maps a singleton Hahn series to the corresponding singleton. -/ +@[simp] +theorem embDomainRingEquiv_single (e : G ≃+o H) (g : G) (r : R) : + embDomainRingEquiv e (single g r) = single (e g) r := by + change embDomain e.toOrderIso.toOrderEmbedding (single g r) = single (e g) r + exact embDomain_single + +/-- Reindexing exponents along an ordered additive equivalence maps support pointwise. -/ +@[simp] +theorem support_embDomainRingEquiv (e : G ≃+o H) (x : R⟦G⟧) : + (embDomainRingEquiv e x).support = e '' x.support := by + change (embDomain e.toOrderIso.toOrderEmbedding x).support = _ + exact support_embDomain e.toOrderIso.toOrderEmbedding x + +section Cardinal + +universe u v + +variable {S : Type v} {G' H' : Type u} +variable [Semiring S] +variable [AddCommMonoid G'] [LinearOrder G'] [IsOrderedCancelAddMonoid G'] +variable [AddCommMonoid H'] [LinearOrder H'] [IsOrderedCancelAddMonoid H'] + +/-- Reindexing exponents along an ordered additive equivalence preserves support cardinality. -/ +theorem cardSupp_embDomainRingEquiv (e : G' ≃+o H') (x : S⟦G'⟧) : + (embDomainRingEquiv e x).cardSupp = x.cardSupp := by + rw [cardSupp, cardSupp] + have hsupport : (embDomainRingEquiv e x).support = (fun g ↦ e g) '' x.support := by + ext h + constructor + · intro hh + refine ⟨e.symm h, ?_, e.apply_symm_apply h⟩ + rw [HahnSeries.mem_support] + have hhCoeff := (HahnSeries.mem_support _ _).mp hh + rw [← e.apply_symm_apply h, embDomainRingEquiv_coeff] at hhCoeff + exact hhCoeff + · rintro ⟨g, hg, rfl⟩ + rw [HahnSeries.mem_support, embDomainRingEquiv_coeff] + exact (HahnSeries.mem_support _ _).mp hg + rw [hsupport] + exact Cardinal.mk_image_eq (f := fun g : G' ↦ e g) e.injective + +end Cardinal + +end HahnSeries diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/DomainOrderType.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/DomainOrderType.lean new file mode 100644 index 0000000000..0d85d3ed28 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/DomainOrderType.lean @@ -0,0 +1,86 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.DomainEquiv +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Translation + +/-! +# Support order type under exponent-domain restriction + +Restricting a Hahn series to the range of an ordered exponent embedding cannot increase its +ordinary support order type. The support inclusion itself crosses exponent types, so the proof +uses the induced order embedding between the two support subtypes. +-/ + +public noncomputable section + +open Ordinal + +namespace HahnSeries + +universe u v + +variable {R : Type v} {G H : Type u} +variable [LinearOrder G] [LinearOrder H] + +section Restrict + +variable [Zero R] + +/-- Restricting the exponent domain along an order embedding cannot increase support order type. +-/ +theorem supportOrderType_restrictDomain_le (f : G ↪o H) (x : R⟦H⟧) : + (restrictDomain f x).supportOrderType ≤ x.supportOrderType := by + let e : ↑(restrictDomain f x).support → ↑x.support := fun g ↦ + ⟨f g.1, by + rw [mem_support] + have hg := (mem_support (restrictDomain f x) g.1).mp g.2 + rw [restrictDomain_coeff] at hg + exact hg⟩ + have he : StrictMono e := by + intro a b hab + exact f.strictMono hab + let : WellFoundedLT ↑(restrictDomain f x).support := + (restrictDomain f x).isPWO_support.isWF + let : WellFoundedLT ↑x.support := x.isPWO_support.isWF + rw [supportOrderType_eq_setOrderType, supportOrderType_eq_setOrderType] + calc + (restrictDomain f x).isPWO_support.orderType = + typeLT ↑(restrictDomain f x).support := + (restrictDomain f x).isPWO_support.orderType_eq_typeLT_of_orderIso + (OrderIso.refl ↑(restrictDomain f x).support) + _ ≤ typeLT ↑x.support := + (OrderEmbedding.ofStrictMono e he).ltEmbedding.ordinal_type_le + _ = x.isPWO_support.orderType := + (x.isPWO_support.orderType_eq_typeLT_of_orderIso + (OrderIso.refl ↑x.support)).symm + +end Restrict + +section RingEquiv + +variable [Semiring R] +variable [AddCommMonoid G] [IsOrderedCancelAddMonoid G] +variable [AddCommMonoid H] [IsOrderedCancelAddMonoid H] + +/-- Reindexing exponents along an ordered additive equivalence preserves support order type. -/ +@[simp] +theorem supportOrderType_embDomainRingEquiv (e : G ≃+o H) (x : R⟦G⟧) : + (embDomainRingEquiv e x).supportOrderType = x.supportOrderType := by + rw [supportOrderType_eq_setOrderType, supportOrderType_eq_setOrderType] + let : WellFoundedLT x.support := x.isWF_support + let supportEquiv : (embDomainRingEquiv e x).support ≃o x.support := + (Set.orderIsoOfEq _ (e '' x.support) (support_embDomainRingEquiv e x)).trans + (StrictMonoOn.orderIso e x.support + (e.strictMono.strictMonoOn x.support)).symm + exact (embDomainRingEquiv e x).isPWO_support.orderType_eq_typeLT_of_orderIso + supportEquiv |>.trans + (x.isPWO_support.orderType_eq_typeLT_of_orderIso (OrderIso.refl x.support)).symm + +end RingEquiv + +end HahnSeries diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/EPrimitive.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/EPrimitive.lean new file mode 100644 index 0000000000..dc7c1440eb --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/EPrimitive.lean @@ -0,0 +1,332 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Translation + +/-! +# Exponent-primitive finite-support series + +Gilmer and Parker call a semigroup-ring element exponent-primitive when the greatest common +divisor of its exponents is zero. In `G ^ (≤ 0)` divisibility is the reverse order, so that +greatest common divisor is the largest exponent, and an element is exponent-primitive exactly when +its support meets zero. That reading is taken as the definition here. + +This is the reduction step of Gilmer and Parker, Theorem 6.4, specialized to a totally ordered +exponent group, where it replaces their Theorem 3.1 and their Propositions 4.6, 6.2 and 6.3. The +largest exponent is additive on products, so every nonzero element is a monomial times an +exponent-primitive element and divisibility splits along that decomposition. +-/ + +open scoped HahnSeries + +universe u v + +public noncomputable section + +namespace HahnSeries + +variable {G : Type u} {K : Type v} +variable [LinearOrder G] [AddCommGroup G] [IsOrderedAddMonoid G] +variable [Field K] + +/-- A series supported in the nonpositive exponents is exponent-primitive when its largest +exponent is zero. -/ +def IsEPrimitive (x : K⟦G⟧) : Prop := + x.support ⊆ Set.Iic 0 ∧ x.coeff 0 ≠ 0 + +omit [IsOrderedAddMonoid G] in +theorem IsEPrimitive.support_subset {x : K⟦G⟧} (hx : IsEPrimitive x) : + x.support ⊆ Set.Iic 0 := hx.1 + +omit [IsOrderedAddMonoid G] in +theorem IsEPrimitive.ne_zero {x : K⟦G⟧} (hx : IsEPrimitive x) : x ≠ 0 := + fun h ↦ hx.2 (by simp [h]) + +/-- At the sum of two exponents dominating the respective supports, the coefficient of a product +is the product of the coefficients: that decomposition of the sum is the only one available. -/ +theorem coeff_add_of_forall_le {x y : K⟦G⟧} {a b : G} + (ha : ∀ g ∈ x.support, g ≤ a) (hb : ∀ g ∈ y.support, g ≤ b) : + (x * y).coeff (a + b) = x.coeff a * y.coeff b := by + classical + have hsplit : ∀ c ∈ Finset.antidiagonal x.isPWO_support y.isPWO_support (a + b), + c = (a, b) := by + intro c hc + rw [Finset.mem_antidiagonal] at hc + obtain ⟨hc1, hc2, hc0⟩ := hc + have h1 : c.1 = a := by + refine le_antisymm (ha _ hc1) ?_ + by_contra hlt + rw [not_le] at hlt + exact absurd hc0 (ne_of_lt (add_lt_add_of_lt_of_le hlt (hb _ hc2))) + refine Prod.ext h1 ?_ + have h2 := hc0 + rw [h1] at h2 + exact add_left_cancel h2 + rw [HahnSeries.coeff_mul] + by_cases hx0 : x.coeff a = 0 + · rw [hx0, zero_mul] + refine Finset.sum_eq_zero fun c hc ↦ ?_ + rw [hsplit c hc, hx0, zero_mul] + by_cases hy0 : y.coeff b = 0 + · rw [hy0, mul_zero] + refine Finset.sum_eq_zero fun c hc ↦ ?_ + rw [hsplit c hc, hy0, mul_zero] + refine Finset.sum_eq_single_of_mem (a, b) ?_ (fun c hc hne ↦ absurd (hsplit c hc) hne) + refine Finset.mem_antidiagonal.mpr ⟨?_, ?_, rfl⟩ + · exact (HahnSeries.mem_support x a).mpr hx0 + · exact (HahnSeries.mem_support y b).mpr hy0 + +/-- Zero has a unique decomposition into nonpositive exponents, so the coefficient there is +multiplicative on series supported in the nonpositive exponents. -/ +theorem coeff_zero_mul_of_support_subset {x y : K⟦G⟧} (hx : x.support ⊆ Set.Iic 0) + (hy : y.support ⊆ Set.Iic 0) : (x * y).coeff 0 = x.coeff 0 * y.coeff 0 := by + have h := coeff_add_of_forall_le (x := x) (y := y) (a := 0) (b := 0) hx hy + rwa [add_zero] at h + +theorem IsEPrimitive.mul {x y : K⟦G⟧} (hx : IsEPrimitive x) (hy : IsEPrimitive y) : + IsEPrimitive (x * y) := by + refine ⟨?_, ?_⟩ + · intro g hg + obtain ⟨i, hi, j, hj, rfl⟩ := HahnSeries.support_mul_subset hg + exact add_nonpos (hx.1 hi) (hy.1 hj) + · rw [coeff_zero_mul_of_support_subset hx.1 hy.1] + exact mul_ne_zero hx.2 hy.2 + +omit [AddCommGroup G] [IsOrderedAddMonoid G] in +/-- A nonzero finite-support series has a largest exponent. -/ +theorem exists_max_mem_support {x : K⟦G⟧} (hfin : x.support.Finite) (hx : x ≠ 0) : + ∃ a ∈ x.support, ∀ g ∈ x.support, g ≤ a := by + classical + have hne : hfin.toFinset.Nonempty := by + rw [Set.Finite.toFinset_nonempty] + exact HahnSeries.support_nonempty_iff.mpr hx + obtain ⟨a, ha, hmax⟩ := hfin.toFinset.exists_max_image id hne + exact ⟨a, (Set.Finite.mem_toFinset hfin).mp ha, + fun g hg ↦ hmax g ((Set.Finite.mem_toFinset hfin).mpr hg)⟩ + +/-- The largest exponent is additive on products. -/ +theorem isMax_support_mul {x y : K⟦G⟧} {a b : G} + (ha : a ∈ x.support) (hamax : ∀ g ∈ x.support, g ≤ a) + (hb : b ∈ y.support) (hbmax : ∀ g ∈ y.support, g ≤ b) : + a + b ∈ (x * y).support ∧ ∀ g ∈ (x * y).support, g ≤ a + b := by + refine ⟨?_, fun g hg ↦ ?_⟩ + · rw [HahnSeries.mem_support, coeff_add_of_forall_le hamax hbmax] + exact mul_ne_zero ((HahnSeries.mem_support _ _).mp ha) ((HahnSeries.mem_support _ _).mp hb) + · obtain ⟨i, hi, j, hj, rfl⟩ := HahnSeries.support_mul_subset hg + exact add_le_add (hamax i hi) (hbmax j hj) + +/-- Every nonzero finite-support series is a monomial times an exponent-primitive one, the +monomial exponent being the largest exponent of its support. -/ +theorem exists_eprimitive_decomposition' {x : K⟦G⟧} (hfin : x.support.Finite) (hx : x ≠ 0) : + ∃ m : G, ∃ y : K⟦G⟧, + m ∈ x.support ∧ y.support.Finite ∧ IsEPrimitive y ∧ x = translate m y := by + classical + obtain ⟨m, hm, hmax⟩ := exists_max_mem_support hfin hx + refine ⟨m, translate (-m) x, hm, ?_, ⟨?_, ?_⟩, ?_⟩ + · rw [HahnSeries.support_translate] + exact hfin.image _ + · intro g hg + rw [HahnSeries.support_translate] at hg + obtain ⟨a, ha, rfl⟩ := hg + simpa using hmax a ha + · rw [HahnSeries.coeff_translate] + simpa using (HahnSeries.mem_support _ _).mp hm + · rw [HahnSeries.translate_add_apply] + simp + +/-- The same decomposition in the nonpositive exponents, where the monomial exponent is +nonpositive. -/ +theorem exists_eprimitive_decomposition {x : K⟦G⟧} (hfin : x.support.Finite) + (hsub : x.support ⊆ Set.Iic 0) (hx : x ≠ 0) : + ∃ m : G, ∃ y : K⟦G⟧, + m ≤ 0 ∧ y.support.Finite ∧ IsEPrimitive y ∧ x = translate m y := by + obtain ⟨m, y, hm, hyf, hy, hxy⟩ := exists_eprimitive_decomposition' hfin hx + exact ⟨m, y, hsub hm, hyf, hy, hxy⟩ + +/-- Divisibility among finite-support series in the nonpositive exponents, with the divisor +exponent-primitive: the quotient may be taken exponent-primitive as well. -/ +theorem eprimitive_of_mul_eq {x y w : K⟦G⟧} (hx : IsEPrimitive x) (hy : IsEPrimitive y) + (hw : w.support ⊆ Set.Iic 0) (hmul : y = x * w) : IsEPrimitive w := by + refine ⟨hw, ?_⟩ + intro h0 + apply hy.2 + rw [hmul, coeff_zero_mul_of_support_subset hx.1 hw, h0, mul_zero] + +/-- Two exponent-primitive series differing by a translation are equal: the translation must be +trivial, since it moves both the largest exponent and the exponent carrying a nonzero +coefficient. -/ +theorem eq_zero_of_isEPrimitive_translate {d : G} {u v : K⟦G⟧} (hu : IsEPrimitive u) + (hv : IsEPrimitive v) (h : u = translate d v) : d = 0 := by + have hmem : d ∈ u.support := by + refine (HahnSeries.mem_support _ _).mpr ?_ + rw [h, HahnSeries.coeff_translate] + simpa using hv.2 + have hneg : -d ∈ v.support := by + refine (HahnSeries.mem_support _ _).mpr ?_ + have h0 := hu.2 + rw [h, HahnSeries.coeff_translate] at h0 + simpa [sub_eq_add_neg] using h0 + exact le_antisymm (hu.1 hmem) (neg_nonpos.mp (hv.1 hneg)) + +/-- Divisibility in the finite-support ring on the nonpositive exponents. -/ +def DvdNP (x z : K⟦G⟧) : Prop := + ∃ w : K⟦G⟧, w.support.Finite ∧ w.support ⊆ Set.Iic 0 ∧ z = x * w + +/-- Divisibility in the finite-support ring on the whole exponent group. -/ +def DvdFS (x z : K⟦G⟧) : Prop := + ∃ w : K⟦G⟧, w.support.Finite ∧ z = x * w + +theorem dvdNP_iff {x z : K⟦G⟧} : + DvdNP x z ↔ + ∃ w : K⟦G⟧, w.support.Finite ∧ w.support ⊆ Set.Iic 0 ∧ z = x * w := (Iff.rfl) + +theorem dvdFS_iff {x z : K⟦G⟧} : + DvdFS x z ↔ ∃ w : K⟦G⟧, w.support.Finite ∧ z = x * w := (Iff.rfl) + +theorem DvdNP.dvdFS {x z : K⟦G⟧} (h : DvdNP x z) : DvdFS x z := by + obtain ⟨w, hwf, -, hw⟩ := h + exact ⟨w, hwf, hw⟩ + +/-- On exponent-primitive elements the two divisibilities agree: a quotient with a positive +exponent would push the largest exponent of the product above zero. -/ +theorem dvdNP_iff_dvdFS {x z : K⟦G⟧} (hx : IsEPrimitive x) (hz : IsEPrimitive z) : + DvdNP x z ↔ DvdFS x z := by + refine ⟨DvdNP.dvdFS, ?_⟩ + rintro ⟨w, hwf, rfl⟩ + have hw0 : w ≠ 0 := by + rintro rfl + exact hz.ne_zero (by simp) + obtain ⟨m, hm, hmmax⟩ := exists_max_mem_support hwf hw0 + obtain ⟨hmem, hmax⟩ := + isMax_support_mul ((HahnSeries.mem_support x 0).mpr hx.2) hx.1 hm hmmax + rw [zero_add] at hmem hmax + have hm0 : m = 0 := + le_antisymm (hz.1 hmem) (hmax 0 ((HahnSeries.mem_support _ _).mpr hz.2)) + exact ⟨w, hwf, fun g hg ↦ hm0 ▸ hmmax g hg, rfl⟩ + +/-- Divisibility splits along the monomial decomposition: the monomial exponents compare and the +exponent-primitive parts divide. -/ +theorem dvdNP_translate_iff {a c : G} {x₀ z₀ : K⟦G⟧} + (hx₀ : IsEPrimitive x₀) (hz₀ : IsEPrimitive z₀) : + DvdNP (translate a x₀) (translate c z₀) ↔ c ≤ a ∧ DvdNP x₀ z₀ := by + constructor + · rintro ⟨w, hwf, hws, hw⟩ + have hw0 : w ≠ 0 := by + rintro rfl + rw [mul_zero] at hw + exact hz₀.ne_zero ((translate c).injective (by simpa using hw)) + obtain ⟨e, y, hele, hyf, hy, rfl⟩ := exists_eprimitive_decomposition hwf hws hw0 + have hprod : translate c z₀ = translate (a + e) (x₀ * y) := by + rw [hw, HahnSeries.translate_mul_translate] + have hshift : x₀ * y = translate (c - (a + e)) z₀ := by + have h2 := congrArg (translate (-(a + e))) hprod + rw [HahnSeries.translate_add_apply, HahnSeries.translate_add_apply] at h2 + simp only [neg_add_cancel, HahnSeries.translate_zero_apply] at h2 + rw [← h2] + congr 1 + abel_nf + have hzero : c - (a + e) = 0 := + eq_zero_of_isEPrimitive_translate (hx₀.mul hy) hz₀ hshift + have hce : c = a + e := by + have := hzero + rwa [sub_eq_zero] at this + refine ⟨?_, y, hyf, hy.1, ?_⟩ + · rw [hce] + simpa using add_le_add_left hele a + · rw [hshift, hzero] + simp + · rintro ⟨hca, w, hwf, hws, rfl⟩ + refine ⟨translate (c - a) w, ?_, ?_, ?_⟩ + · rw [HahnSeries.support_translate] + exact hwf.image _ + · rw [HahnSeries.support_translate] + rintro _ ⟨g, hg, rfl⟩ + exact add_nonpos (by simpa using sub_nonpos.mpr hca) (hws hg) + · rw [HahnSeries.translate_mul_translate] + congr 1 + abel_nf + +theorem dvdNP_zero (e : K⟦G⟧) : DvdNP e 0 := ⟨0, by simp, by simp, by simp⟩ + +theorem translate_mul_left (a : G) (x y : K⟦G⟧) : translate a (x * y) = x * translate a y := by + have h := HahnSeries.translate_mul_translate (0 : G) a x y + rw [HahnSeries.translate_zero_apply, zero_add] at h + exact h.symm + +/-- Divisibility in the whole group ring is unchanged by translating the dividend, since a +translation is multiplication by a unit. -/ +theorem dvdFS_translate_iff {b : G} {e w : K⟦G⟧} : DvdFS e (translate b w) ↔ DvdFS e w := by + constructor + · rintro ⟨v, hvf, hv⟩ + refine ⟨translate (-b) v, ?_, ?_⟩ + · rw [HahnSeries.support_translate] + exact hvf.image _ + · have h2 := congrArg (translate (-b)) hv + rw [HahnSeries.translate_add_apply] at h2 + simp only [neg_add_cancel, HahnSeries.translate_zero_apply] at h2 + rw [h2] + exact translate_mul_left _ _ _ + · rintro ⟨v, hvf, hv⟩ + refine ⟨translate b v, ?_, ?_⟩ + · rw [HahnSeries.support_translate] + exact hvf.image _ + · rw [hv] + exact translate_mul_left _ _ _ + +/-- Gilmer and Parker, Theorem 6.4 for a totally ordered exponent group: greatest common divisors +in the whole group ring produce greatest common divisors in the nonpositive ring. -/ +theorem exists_gcd_nonpositive_of_exists_gcd + (Hgcd : ∀ x z : K⟦G⟧, x.support.Finite → z.support.Finite → + ∃ d : K⟦G⟧, d.support.Finite ∧ + ∀ e : K⟦G⟧, e.support.Finite → (DvdFS e x ∧ DvdFS e z ↔ DvdFS e d)) + {x z : K⟦G⟧} (hxf : x.support.Finite) (hxs : x.support ⊆ Set.Iic 0) + (hzf : z.support.Finite) (hzs : z.support ⊆ Set.Iic 0) : + ∃ d : K⟦G⟧, d.support.Finite ∧ d.support ⊆ Set.Iic 0 ∧ + ∀ e : K⟦G⟧, e.support.Finite → e.support ⊆ Set.Iic 0 → + (DvdNP e x ∧ DvdNP e z ↔ DvdNP e d) := by + classical + rcases eq_or_ne x 0 with rfl | hx0 + · exact ⟨z, hzf, hzs, fun e _ _ ↦ ⟨fun h ↦ h.2, fun h ↦ ⟨dvdNP_zero e, h⟩⟩⟩ + rcases eq_or_ne z 0 with rfl | hz0 + · exact ⟨x, hxf, hxs, fun e _ _ ↦ ⟨fun h ↦ h.1, fun h ↦ ⟨h, dvdNP_zero e⟩⟩⟩ + obtain ⟨a, x₀, hale, hx₀f, hx₀, rfl⟩ := exists_eprimitive_decomposition hxf hxs hx0 + obtain ⟨c, z₀, hcle, hz₀f, hz₀, rfl⟩ := exists_eprimitive_decomposition hzf hzs hz0 + obtain ⟨d₀, hd₀f, hd₀⟩ := Hgcd x₀ z₀ hx₀f hz₀f + have hd₀ne : d₀ ≠ 0 := by + rintro rfl + obtain ⟨hdx, -⟩ := (hd₀ 0 (by simp)).mpr ⟨1, by simp, by simp⟩ + obtain ⟨w, -, hw⟩ := hdx + exact hx₀.ne_zero (by simpa using hw) + obtain ⟨b, d₁, -, hd₁f, hd₁, hd₀eq⟩ := exists_eprimitive_decomposition' hd₀f hd₀ne + have hd₁gcd : ∀ e : K⟦G⟧, e.support.Finite → + (DvdFS e x₀ ∧ DvdFS e z₀ ↔ DvdFS e d₁) := by + intro e hef + rw [hd₀ e hef, hd₀eq, dvdFS_translate_iff] + refine ⟨translate (max a c) d₁, ?_, ?_, ?_⟩ + · rw [HahnSeries.support_translate] + exact hd₁f.image _ + · rw [HahnSeries.support_translate] + rintro _ ⟨g, hg, rfl⟩ + exact add_nonpos (max_le hale hcle) (hd₁.1 hg) + · intro e hef hes + rcases eq_or_ne e 0 with rfl | he0 + · constructor + · rintro ⟨⟨w, -, -, hw⟩, -⟩ + refine absurd ?_ hx₀.ne_zero + have hz : translate a x₀ = 0 := by simpa using hw + exact (translate a).injective (by simpa using hz) + · rintro ⟨w, -, -, hw⟩ + refine absurd ?_ hd₁.ne_zero + have hz : translate (max a c) d₁ = 0 := by simpa using hw + exact (translate (max a c)).injective (by simpa using hz) + obtain ⟨f, e₀, -, he₀f, he₀, rfl⟩ := exists_eprimitive_decomposition hef hes he0 + rw [dvdNP_translate_iff he₀ hx₀, dvdNP_translate_iff he₀ hz₀, + dvdNP_translate_iff he₀ hd₁, dvdNP_iff_dvdFS he₀ hx₀, dvdNP_iff_dvdFS he₀ hz₀, + dvdNP_iff_dvdFS he₀ hd₁, ← hd₁gcd e₀ he₀f, max_le_iff] + tauto + +end HahnSeries diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/FactorCoefficients.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/FactorCoefficients.lean new file mode 100644 index 0000000000..57ad0e6174 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/FactorCoefficients.lean @@ -0,0 +1,99 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.FieldTheory.LatticeFactorCoefficients +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.FiniteSupportGCDProof +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.SubgroupAlgebra + +/-! +# Clearing a scalar out of a finite-support Hahn factor + +Two finite-support series have finitely many exponents between them, so both lie in the group ring +of the subgroup those exponents generate, which is free of finite rank. Coefficient extension +commutes with the inclusion of that group ring into the series ring, so a factorisation whose +product has coefficients in the subfield transports to the group ring, where one scalar clears a +factor into the subfield. +-/ + +universe u v w + +namespace HahnSeries + +public section + +variable {K : Type u} {L : Type v} [Field K] [Field L] [Algebra K L] +variable {G : Type w} [LinearOrder G] [AddCommGroup G] [IsOrderedAddMonoid G] + +/-- Coefficient extension commutes with the subgroup-algebra inclusion. -/ +theorem subgroupAlgebraHom_mapRingHom (H : AddSubgroup G) (P : AddMonoidAlgebra K H) : + HahnSeries.subgroupAlgebraHom H (AddMonoidAlgebra.mapRingHom H (algebraMap K L) P) = + (HahnSeries.subgroupAlgebraHom H P).map (algebraMap K L) := by + classical + refine HahnSeries.coeff_injective (funext fun g ↦ ?_) + rw [HahnSeries.coeff_subgroupAlgebraHom, HahnSeries.map_coeff, + HahnSeries.coeff_subgroupAlgebraHom] + by_cases hg : g ∈ H + · rw [dite_eq_left hg, dite_eq_left hg, AddMonoidAlgebra.mapRingHom_apply', + Finsupp.mapRange_apply] + · rw [dite_eq_right hg, dite_eq_right hg, map_zero] + +/-- Hahn-series form of scalar clearing for finite-support factors. -/ +theorem exists_scalar_of_hahn_mul_eq_map + (hclosed : Algebra.IsRelativelyAlgebraicallyClosed K L) + {p q : HahnSeries G L} {a : HahnSeries G K} (hp : p ≠ 0) (hq : q ≠ 0) + (hpfin : p.support.Finite) (hqfin : q.support.Finite) + (hrel : p * q = a.map (algebraMap K L)) : + ∃ c : L, c ≠ 0 ∧ ∀ x, c * p.coeff x ∈ (algebraMap K L).range := by + classical + set S : Finset G := hpfin.toFinset ∪ hqfin.toFinset with hS + set H : AddSubgroup G := AddSubgroup.closure (S : Set G) with hH + have hpH : p.support ⊆ (H : Set G) := fun x hx ↦ AddSubgroup.subset_closure + (Finset.mem_coe.mpr (Finset.mem_union_left _ (hpfin.mem_toFinset.mpr hx))) + have hqH : q.support ⊆ (H : Set G) := fun x hx ↦ AddSubgroup.subset_closure + (Finset.mem_coe.mpr (Finset.mem_union_right _ (hqfin.mem_toFinset.mpr hx))) + have haH : a.support ⊆ (H : Set G) := by + intro x hx + have hxa : x ∈ (a.map (algebraMap K L)).support := by + rw [HahnSeries.mem_support, HahnSeries.map_coeff] + exact fun h0 ↦ (HahnSeries.mem_support _ _).mp hx + ((algebraMap K L).injective (by rw [h0, map_zero])) + rw [← hrel] at hxa + obtain ⟨u, hu, v, hv, rfl⟩ := Set.mem_add.mp (HahnSeries.support_mul_subset hxa) + exact AddSubgroup.add_mem H (hpH hu) (hqH hv) + have hafin : a.support.Finite := by + refine Set.Finite.subset (Set.Finite.add hpfin hqfin) ?_ + intro x hx + have hxa : x ∈ (a.map (algebraMap K L)).support := by + rw [HahnSeries.mem_support, HahnSeries.map_coeff] + exact fun h0 ↦ (HahnSeries.mem_support _ _).mp hx + ((algebraMap K L).injective (by rw [h0, map_zero])) + rw [← hrel] at hxa + exact HahnSeries.support_mul_subset hxa + obtain ⟨p₁, hp₁⟩ := HahnSeries.exists_subgroupAlgebraHom_eq H hpfin hpH + obtain ⟨q₁, hq₁⟩ := HahnSeries.exists_subgroupAlgebraHom_eq H hqfin hqH + obtain ⟨a₁, ha₁⟩ := HahnSeries.exists_subgroupAlgebraHom_eq H hafin haH + have hp₁0 : p₁ ≠ 0 := fun h0 ↦ hp (by rw [← hp₁, h0, map_zero]) + have hq₁0 : q₁ ≠ 0 := fun h0 ↦ hq (by rw [← hq₁, h0, map_zero]) + have hrel₁ : p₁ * q₁ = AddMonoidAlgebra.mapRingHom H (algebraMap K L) a₁ := by + refine HahnSeries.subgroupAlgebraHom_injective H ?_ + rw [map_mul, hp₁, hq₁, hrel, subgroupAlgebraHom_mapRingHom, ha₁] + obtain ⟨c, hc, hcoeff⟩ := AddMonoidAlgebra.exists_scalar_of_mul_eq_map_free + (HahnSeries.exists_addEquiv_fin S) hclosed hp₁0 hq₁0 hrel₁ + refine ⟨c, hc, fun x ↦ ?_⟩ + by_cases hx : x ∈ H + · have : p.coeff x = p₁.coeff ⟨x, hx⟩ := by + rw [← hp₁, HahnSeries.coeff_subgroupAlgebraHom, dite_eq_left hx] + rw [this] + exact hcoeff _ + · have : p.coeff x = 0 := by + rw [← hp₁, HahnSeries.coeff_subgroupAlgebraHom, dite_eq_right hx] + rw [this, mul_zero] + exact ⟨0, map_zero _⟩ + +end + +end HahnSeries diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization.lean new file mode 100644 index 0000000000..0bedcf6e94 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization.lean @@ -0,0 +1,36 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.AlmostIrreducible +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.AlmostIrreducibleFactorization +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.DegreeTwo +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.FiniteSupportFactorUniqueness +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.GermLike +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.GradedDivisibility +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.InfiniteSupport +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.MaximalFinite +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.MaximalFiniteMultiplicativity +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.NormalizedHPart +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.NormalizedHPartMultiplicativity +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.NormalizedHPartSeries +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.NormalizedMaximalFinite +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.NormalizedSeriesMaximalFinite +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.PreSchreier +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.PrincipalMaximalFinite +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.PrincipalSubringLocalization +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.PrincipalSubringPrimality +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.RVGradedMaximalFinite +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.RVMaximalFinite +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Random +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.SeriesMaximalFinite +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.SeriesMaximalMultiplicativity +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.SeriesPrimality +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Statements +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Tests + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/AlmostIrreducible.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/AlmostIrreducible.lean new file mode 100644 index 0000000000..fc6fa22437 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/AlmostIrreducible.lean @@ -0,0 +1,187 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Monomial +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.RealSupportSupremum +public import Mathlib.Algebra.Group.Irreducible.Defs +public import Mathlib.GroupTheory.Divisible + +import Mathlib.Algebra.GroupWithZero.Divisibility + +/-! +# Almost-irreducible Hahn series + +LM24, Section 6.5 weakens irreducibility for a divisible additive subgroup `H ⊆ ℝ`. A +series is almost irreducible when, in every factorisation, a nonmonomial factor forces the other +factor to be a monomial. + +The three consequences surrounding LM24, Remark 6.5.1 are formalized explicitly. Irreducibility +implies almost irreducibility, and a strictly negative real support supremum prevents +irreducibility. The printed converse at support supremum zero omits the condition that the series +is not a unit: `1` is almost irreducible and has support supremum zero, but is not irreducible. +The corrected theorem below adds exactly that missing condition. The definition itself is not +changed, because monomials are intended to remain almost irreducible later in LM24. +-/ + +open scoped HahnSeries + +universe v + +public noncomputable section + +namespace HahnSeries.Nonpositive + +variable {H : AddSubgroup ℝ} {K : Type v} [Field K] + +/-- Every factorisation with a nonmonomial left factor has a monomial right factor. This is +LM24's notion of an almost-irreducible series from Section 6.5. -/ +def IsAlmostIrreducible (b : Nonpositive H K) : Prop := + ∀ c d : Nonpositive H K, b = c * d → ¬IsMonomial c → IsMonomial d + +/-- Characterization of almost irreducibility by factorisations. -/ +theorem isAlmostIrreducible_iff {b : Nonpositive H K} : + IsAlmostIrreducible b ↔ + ∀ c d : Nonpositive H K, b = c * d → ¬IsMonomial c → IsMonomial d := + Iff.rfl + +/-- An almost-irreducible series is nonzero. -/ +theorem IsAlmostIrreducible.ne_zero {b : Nonpositive H K} + (hb : IsAlmostIrreducible b) : b ≠ 0 := by + intro hzero + subst b + have hzeroNotMonomial : ¬IsMonomial (0 : Nonpositive H K) := + fun h ↦ h.ne_zero rfl + exact (hb 0 0 (by simp) hzeroNotMonomial).ne_zero rfl + +/-- An irreducible nonpositive Hahn series is almost irreducible. This is the first assertion of +LM24, Remark 6.5.1. -/ +theorem Irreducible.isAlmostIrreducible {b : Nonpositive H K} + (hb : Irreducible b) : IsAlmostIrreducible b := by + intro c d hfactor hc + rcases hb.isUnit_or_isUnit hfactor with hcUnit | hdUnit + · exact (hc (isMonomial_of_isUnit hcUnit)).elim + · exact isMonomial_of_isUnit hdUnit + +/-- The multiplicative identity is almost irreducible. This is the counterexample showing that +the printed support-supremum-zero implication in LM24, Remark 6.5.1 needs a nonunit hypothesis. +-/ +theorem one_isAlmostIrreducible : + IsAlmostIrreducible (1 : Nonpositive H K) := by + intro c d hfactor _ + exact isMonomial_of_isUnit (IsUnit.of_mul_eq_one_right c hfactor.symm) + +/-- A monomial divisor of a series with real support supremum zero is a unit. -/ +theorem IsMonomial.isUnit_of_dvd_of_realSupportSup_eq_zero + {b c : Nonpositive H K} (hc : IsMonomial c) (hcb : c ∣ b) + (hbSup : realSupportSup H b = 0) : IsUnit c := by + obtain ⟨d, hfactor⟩ := hcb + obtain ⟨g, k, hg, hk, rfl⟩ := isMonomial_iff.mp hc + rcases lt_or_eq_of_le hg with hgNeg | rfl + · have hlub := (Iff.mp (realSupportSup_eq_coe_iff H) hbSup).2 + have hgUpper : (g : ℝ) ∈ upperBounds + ((fun h : H ↦ (h : ℝ)) '' (b : K⟦H⟧).support) := by + rintro _ ⟨z, hz, rfl⟩ + rw [hfactor] at hz + obtain ⟨x, hx, y, hy, rfl⟩ := HahnSeries.support_mul_subset hz + have hxg : x = g := by + have hx' : x ∈ (HahnSeries.single g k : K⟦H⟧).support := by + simpa only [coe_single] using hx + simpa [HahnSeries.support_single_of_ne hk] using hx' + subst x + have hyNonpos := support_subset d hy + exact_mod_cast (add_le_of_nonpos_right hyNonpos) + have hzeroLe : (0 : ℝ) ≤ g := hlub.2 hgUpper + exfalso + exact (not_le_of_gt (show (g : ℝ) < 0 by exact_mod_cast hgNeg)) hzeroLe + · have hconstant : single (0 : H) k le_rfl = (C : K →+* Nonpositive H K) k := by + apply Subtype.ext + rw [coe_single, coe_C] + rfl + rw [hconstant] + exact (isUnit_iff_ne_zero.mpr hk).map C + +/-- Corrected support-supremum-zero implication from LM24, Remark 6.5.1. An +almost-irreducible nonunit with real support supremum zero is irreducible. -/ +theorem IsAlmostIrreducible.irreducible_of_not_isUnit_of_realSupportSup_eq_zero + {b : Nonpositive H K} (hb : IsAlmostIrreducible b) (hbNotUnit : ¬IsUnit b) + (hbSup : realSupportSup H b = 0) : Irreducible b := by + rw [irreducible_iff] + refine ⟨hbNotUnit, ?_⟩ + intro c d hfactor + by_cases hc : IsMonomial c + · exact Or.inl (hc.isUnit_of_dvd_of_realSupportSup_eq_zero + ⟨d, hfactor⟩ hbSup) + · have hd := hb c d hfactor hc + exact Or.inr (hd.isUnit_of_dvd_of_realSupportSup_eq_zero + ⟨c, by simpa [mul_comm] using hfactor⟩ hbSup) + +/-- A series with strictly negative real support supremum is not irreducible. This is the final +assertion of LM24, Remark 6.5.1. -/ +theorem not_irreducible_of_realSupportSup_lt_zero [DivisibleBy H ℤ] + {b : Nonpositive H K} (hbSup : realSupportSup H b < 0) : ¬Irreducible b := by + let : DivisibleBy H ℕ := AddGroup.divisibleByNatOfDivisibleByInt H + intro hbIrreducible + have hbNe : b ≠ 0 := hbIrreducible.ne_zero + have hbSupNeBot : realSupportSup H b ≠ ⊥ := by + intro hbot + exact hbNe (Iff.mp (realSupportSup_eq_bot H) hbot) + obtain ⟨s, hsSup⟩ := WithBot.ne_bot_iff_exists.mp hbSupNeBot + have hsSup' : realSupportSup H b = (s : WithBot ℝ) := hsSup.symm + have hsNeg : s < 0 := by + rw [hsSup'] at hbSup + exact_mod_cast hbSup + have hlub := (Iff.mp (realSupportSup_eq_coe_iff H) hsSup').2 + have htwoSNotUpper : (2 * s : ℝ) ∉ upperBounds + ((fun h : H ↦ (h : ℝ)) '' (b : K⟦H⟧).support) := by + intro htwoSUpper + have hsLeTwoS := hlub.2 htwoSUpper + linarith + rw [mem_upperBounds] at htwoSNotUpper + push Not at htwoSNotUpper + obtain ⟨_, ⟨y, hySupport, rfl⟩, hyLower⟩ := htwoSNotUpper + have hyUpper : (y : ℝ) ≤ s := hlub.1 ⟨y, hySupport, rfl⟩ + have hyNeg : (y : ℝ) < 0 := hyUpper.trans_lt hsNeg + let x : H := DivisibleBy.div y (2 : ℕ) + have htwoX : 2 • x = y := DivisibleBy.div_cancel y (by norm_num) + have htwoXReal : (x : ℝ) + x = y := by + exact_mod_cast (by simpa [two_nsmul] using htwoX) + have hsLtX : s < (x : ℝ) := by linarith + have hxNeg : (x : ℝ) < 0 := by linarith + have hxNonpos : x ≤ 0 := by exact_mod_cast hxNeg.le + let dFull : K⟦H⟧ := HahnSeries.single (-x) 1 * (b : K⟦H⟧) + have hdSupportStrict : ∀ z ∈ dFull.support, z < 0 := by + intro z hz + obtain ⟨u, hu, v, hv, rfl⟩ := HahnSeries.support_mul_subset hz + have huEq : u = -x := by + simpa [HahnSeries.support_single_of_ne one_ne_zero] using hu + subst u + have hvLe : (v : ℝ) ≤ s := hlub.1 ⟨v, hv, rfl⟩ + exact_mod_cast (show (-(x : ℝ) + v) < 0 by linarith) + let d : Nonpositive H K := + ⟨dFull, by + rw [HahnSeries.mem_nonpositiveSubring] + exact fun z hz ↦ (hdSupportStrict z hz).le⟩ + have hfactor : b = single x 1 hxNonpos * d := by + apply Subtype.ext + rw [Subring.coe_mul, coe_single] + change (b : K⟦H⟧) = HahnSeries.single x 1 * dFull + simp [dFull, ← mul_assoc] + have hxNonzero : x ≠ 0 := by + intro hxZero + exact (ne_of_lt hxNeg) (congrArg Subtype.val hxZero) + have hxNotUnit : ¬IsUnit (single x (1 : K) hxNonpos) := by + rw [isUnit_single_iff (G := H) (K := K) one_ne_zero hxNonpos] + exact hxNonzero + have hdNotUnit : ¬IsUnit d := by + intro hdUnit + have hsupport := support_eq_singleton_zero_of_isUnit hdUnit + have hzeroMem : (0 : H) ∈ (d : K⟦H⟧).support := by simp [hsupport] + exact (lt_irrefl (0 : H)) (hdSupportStrict 0 hzeroMem) + exact hxNotUnit + (hbIrreducible.isUnit_or_isUnit hfactor |>.resolve_right hdNotUnit) + +end HahnSeries.Nonpositive diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/AlmostIrreducibleFactorization.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/AlmostIrreducibleFactorization.lean new file mode 100644 index 0000000000..a21aeae1c9 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/AlmostIrreducibleFactorization.lean @@ -0,0 +1,132 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.AlmostIrreducible +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.FiniteSupportConstantTermOne + +/-! +# Factorisations over a divisible exponent subgroup + +This file defines the factorisation objects in LM24, Theorem 6.5.7. The coefficient scalar is +retained explicitly: the printed product omits it, and therefore does not represent a nonunit +constant series. A nonpositive subgroup exponent represents the monomial factor, while a list +represents the finite family of almost irreducible factors. + +The normalized finite-support factor and the monomial exponent have separate uniqueness +predicates. No uniqueness is asserted for the list of almost irreducible or irreducible factors. +-/ + +open scoped HahnSeries + +universe v + +public noncomputable section + +namespace HahnSeries.Nonpositive + +variable {H : AddSubgroup ℝ} {K : Type v} [Field K] + +/-- A corrected LM24, Theorem 6.5.7 factorisation: a nonzero coefficient scalar, a normalized +finite-support factor, a coefficient-one monomial, and finitely many almost irreducible factors +with infinite support. -/ +def IsAlmostIrreducibleFactorization + (b : Nonpositive H K) (k : Kˣ) + (p : ConstantTermOneFiniteSupport (G := H) (K := K)) + (x : exponentMonoid H) (factors : List (Nonpositive H K)) : Prop := + b = C (k : K) * + ((p : FiniteSupportRing (G := H) (K := K)) : Nonpositive H K) * + (finiteSupportMonomial (K := K) x : Nonpositive H K) * factors.prod ∧ + ∀ c ∈ factors, IsAlmostIrreducible c ∧ (c : K⟦H⟧).support.Infinite + +/-- Characterization of an almost-irreducible factorisation over an exponent subgroup. -/ +theorem isAlmostIrreducibleFactorization_iff + (b : Nonpositive H K) (k : Kˣ) + (p : ConstantTermOneFiniteSupport (G := H) (K := K)) + (x : exponentMonoid H) (factors : List (Nonpositive H K)) : + IsAlmostIrreducibleFactorization b k p x factors ↔ + b = C (k : K) * + ((p : FiniteSupportRing (G := H) (K := K)) : Nonpositive H K) * + (finiteSupportMonomial (K := K) x : Nonpositive H K) * factors.prod ∧ + ∀ c ∈ factors, IsAlmostIrreducible c ∧ (c : K⟦H⟧).support.Infinite := + Iff.rfl + +/-- The normalized finite-support factor is unique among all corrected almost-irreducible +factorisations of the same series. -/ +def IsUniqueNormalizedHFactor + (b : Nonpositive H K) + (p : ConstantTermOneFiniteSupport (G := H) (K := K)) : Prop := + ∀ (k : Kˣ) (q : ConstantTermOneFiniteSupport (G := H) (K := K)) + (x : exponentMonoid H) (factors : List (Nonpositive H K)), + IsAlmostIrreducibleFactorization b k q x factors → q = p + +/-- Characterization of uniqueness of the normalized finite-support factor. -/ +theorem isUniqueNormalizedHFactor_iff + (b : Nonpositive H K) + (p : ConstantTermOneFiniteSupport (G := H) (K := K)) : + IsUniqueNormalizedHFactor b p ↔ + ∀ (k : Kˣ) (q : ConstantTermOneFiniteSupport (G := H) (K := K)) + (x : exponentMonoid H) (factors : List (Nonpositive H K)), + IsAlmostIrreducibleFactorization b k q x factors → q = p := + Iff.rfl + +/-- The strengthened factorisation in LM24, Theorem 6.5.7, in which every infinite-support +factor is irreducible rather than merely almost irreducible. -/ +def IsIrreducibleSubgroupFactorization + (b : Nonpositive H K) (k : Kˣ) + (p : ConstantTermOneFiniteSupport (G := H) (K := K)) + (x : exponentMonoid H) (factors : List (Nonpositive H K)) : Prop := + b = C (k : K) * + ((p : FiniteSupportRing (G := H) (K := K)) : Nonpositive H K) * + (finiteSupportMonomial (K := K) x : Nonpositive H K) * factors.prod ∧ + ∀ c ∈ factors, Irreducible c ∧ (c : K⟦H⟧).support.Infinite + +/-- Characterization of an irreducible infinite-support factorisation over an exponent +subgroup. -/ +theorem isIrreducibleSubgroupFactorization_iff + (b : Nonpositive H K) (k : Kˣ) + (p : ConstantTermOneFiniteSupport (G := H) (K := K)) + (x : exponentMonoid H) (factors : List (Nonpositive H K)) : + IsIrreducibleSubgroupFactorization b k p x factors ↔ + b = C (k : K) * + ((p : FiniteSupportRing (G := H) (K := K)) : Nonpositive H K) * + (finiteSupportMonomial (K := K) x : Nonpositive H K) * factors.prod ∧ + ∀ c ∈ factors, Irreducible c ∧ (c : K⟦H⟧).support.Infinite := + Iff.rfl + +/-- An irreducible subgroup factorisation is, in particular, an almost-irreducible +factorisation with the same data. -/ +theorem IsIrreducibleSubgroupFactorization.isAlmostIrreducibleFactorization + {b : Nonpositive H K} {k : Kˣ} + {p : ConstantTermOneFiniteSupport (G := H) (K := K)} + {x : exponentMonoid H} {factors : List (Nonpositive H K)} + (h : IsIrreducibleSubgroupFactorization b k p x factors) : + IsAlmostIrreducibleFactorization b k p x factors := by + rw [isIrreducibleSubgroupFactorization_iff] at h + rw [isAlmostIrreducibleFactorization_iff] + refine ⟨h.1, fun c hc ↦ ?_⟩ + exact ⟨HahnSeries.Nonpositive.Irreducible.isAlmostIrreducible + (h.2 c hc).1, (h.2 c hc).2⟩ + +/-- The monomial exponent is unique among all irreducible subgroup factorisations of the same +series. -/ +def IsUniqueIrreducibleFactorizationExponent + (b : Nonpositive H K) (x : exponentMonoid H) : Prop := + ∀ (k : Kˣ) (p : ConstantTermOneFiniteSupport (G := H) (K := K)) + (y : exponentMonoid H) (factors : List (Nonpositive H K)), + IsIrreducibleSubgroupFactorization b k p y factors → y = x + +/-- Characterization of uniqueness of the monomial exponent in irreducible subgroup +factorisations. -/ +theorem isUniqueIrreducibleFactorizationExponent_iff + (b : Nonpositive H K) (x : exponentMonoid H) : + IsUniqueIrreducibleFactorizationExponent b x ↔ + ∀ (k : Kˣ) (p : ConstantTermOneFiniteSupport (G := H) (K := K)) + (y : exponentMonoid H) (factors : List (Nonpositive H K)), + IsIrreducibleSubgroupFactorization b k p y factors → y = x := + Iff.rfl + +end HahnSeries.Nonpositive diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/DegreeTwo.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/DegreeTwo.lean new file mode 100644 index 0000000000..b549747e21 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/DegreeTwo.lean @@ -0,0 +1,16 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.DegreeTwo.DegreeTwo +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.DegreeTwo.DegreeTwoExample +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.DegreeTwo.Factorization +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.DegreeTwo.FactorizationClassification +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.DegreeTwo.TranslatedSpanFactorization +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.DegreeTwo.TranslatedTruncationSpan + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/DegreeTwo/DegreeTwo.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/DegreeTwo/DegreeTwo.lean new file mode 100644 index 0000000000..ce4dd821c6 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/DegreeTwo/DegreeTwo.lean @@ -0,0 +1,266 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.DegreeTwo.Factorization + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValueFinalSegment +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.GermDegree +import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.SetOrderType + +/-! +# Support and ordinal value in PS06 degree two + +This module supplies the support-theoretic input to Pommersheim--Shahriari, Lemma 3.1. A series +outside `J + K` whose support has order type `ω²` or `ω² + 1` has negative support of +order type exactly `ω²`. Its value is therefore `ω²`, while every translated truncation at +a strictly negative cutoff has smaller value. + +These conclusions precede the factorisation argument: they derive Berarducci's value hypotheses +directly from the two visible support-order alternatives used in PS06. + +## References + +* J. Pommersheim, S. Shahriari, *Unique factorization in generalized power series rings*, +Proc. Amer. Math. Soc. 134 (2006), 1277–1287, cited as [PS06]. +-/ + +universe v + +open scoped HahnSeries NatOrdinal + +public noncomputable section + +namespace PommersheimShahriari + +open Berarducci HahnSeries Ordinal + +variable {K : Type v} [Field K] + +private theorem truncGE_zero_eq_single (a : Series K) : + HahnSeries.truncGE 0 (a : K⟦ℝ⟧) = + HahnSeries.single 0 ((a : K⟦ℝ⟧).coeff 0) := by + ext x + rcases lt_trichotomy x 0 with hx | rfl | hx + · simp [HahnSeries.coeff_truncGE, not_le_of_gt hx, hx.ne] + · simp + · have hcoeff : (a : K⟦ℝ⟧).coeff x = 0 := by + apply not_ne_iff.mp + rw [← HahnSeries.mem_support] + exact fun hmem ↦ (not_le_of_gt hx) + (HahnSeries.Nonpositive.support_subset a hmem) + simp [HahnSeries.coeff_truncGE, hx.le, hcoeff, hx.ne'] + +private theorem supportOrderType_truncGE_zero_eq_zero_or_one (a : Series K) : + (HahnSeries.truncGE 0 (a : K⟦ℝ⟧)).supportOrderType = 0 ∨ + (HahnSeries.truncGE 0 (a : K⟦ℝ⟧)).supportOrderType = 1 := by + rw [truncGE_zero_eq_single] + by_cases hcoeff : (a : K⟦ℝ⟧).coeff 0 = 0 + · left + simp [hcoeff] + · right + exact HahnSeries.supportOrderType_single hcoeff + +/-- A series outside `J + K`, of support order type `ω²` or `ω² + 1`, has strictly +negative support of order type exactly `ω²`. -/ +theorem negativeSupport_orderType_eq_wpow_two + {a : Series K} (haNear : a ∉ nearConstantSubgroup K) + (haType : (a : K⟦ℝ⟧).supportOrderType = + (Ordinal.omega0 ^ (2 : Ordinal)) ∨ + (a : K⟦ℝ⟧).supportOrderType = + Ordinal.omega0 ^ (2 : Ordinal) + 1) : + ((a : K⟦ℝ⟧).isPWO_support.mono + (s := (a : K⟦ℝ⟧).support ∩ Set.Iio 0) + Set.inter_subset_left).orderType = Ordinal.omega0 ^ (2 : Ordinal) := by + let S : Set ℝ := (a : K⟦ℝ⟧).support ∩ Set.Iio 0 + let hS : S.IsPWO := (a : K⟦ℝ⟧).isPWO_support.mono Set.inter_subset_left + have haOne : 1 < ordinalValue a := one_lt_ordinalValue_iff.mpr haNear + have hSLUB : IsLUB S 0 := isLUB_negativeSupport_zero_of_one_lt_ordinalValue haOne + have hSne : S.Nonempty := by + obtain ⟨x, hx, -, -⟩ := hSLUB.exists_between (show (-1 : ℝ) < 0 by norm_num) + exact ⟨x, hx⟩ + have hSgt : ∀ x ∈ S, ∃ y ∈ S, x < y := by + intro x hx + obtain ⟨y, hy, hxy, -⟩ := hSLUB.exists_between hx.2 + exact ⟨y, hy, hxy⟩ + have hSlimit : Order.IsSuccLimit hS.orderType := + Set.IsPWO.isSuccLimit_orderType_of_forall_exists_gt hS hSne hSgt + have htruncSupport : + (HahnSeries.truncLT 0 (a : K⟦ℝ⟧)).support = S := by + rw [HahnSeries.support_truncLT] + rfl + have htruncType : + (HahnSeries.truncLT 0 (a : K⟦ℝ⟧)).supportOrderType = hS.orderType := by + rw [HahnSeries.supportOrderType_eq_setOrderType] + exact (HahnSeries.truncLT 0 (a : K⟦ℝ⟧)).isPWO_support.orderType_congr + hS htruncSupport + have hsplit := HahnSeries.supportOrderType_eq_truncLT_add_truncGE + 0 (a : K⟦ℝ⟧) + rcases supportOrderType_truncGE_zero_eq_zero_or_one a with hz | hz + · rw [hz, add_zero, htruncType] at hsplit + rcases haType with haType | haType + · exact hsplit.symm.trans haType + · have hbad : hS.orderType = Ordinal.omega0 ^ (2 : Ordinal) + 1 := + hsplit.symm.trans haType + rw [hbad, ← Order.succ_eq_add_one] at hSlimit + exact (Order.not_isSuccLimit_succ _ hSlimit).elim + · rw [hz, htruncType] at hsplit + rcases haType with haType | haType + · have hbad : Ordinal.omega0 ^ (2 : Ordinal) = hS.orderType + 1 := + haType.symm.trans hsplit + have homegaLimit : Order.IsSuccLimit (Ordinal.omega0 ^ (2 : Ordinal)) := + Ordinal.isSuccLimit_opow_left Ordinal.isSuccLimit_omega0 (by norm_num) + rw [hbad, ← Order.succ_eq_add_one] at homegaLimit + exact (Order.not_isSuccLimit_succ _ homegaLimit).elim + · have heq : Ordinal.omega0 ^ (2 : Ordinal) + 1 = hS.orderType + 1 := + haType.symm.trans hsplit + exact (Ordinal.add_right_cancel 1).mp (by simpa using heq) |>.symm + +/-- Every translated truncation at a strictly negative cutoff has ordinal value below `ω²` +under the degree-two PS06 hypotheses. -/ +theorem ordinalValue_translatedTruncation_lt_wpow_two + {a : Series K} (haNear : a ∉ nearConstantSubgroup K) + (haType : (a : K⟦ℝ⟧).supportOrderType = + (Ordinal.omega0 ^ (2 : Ordinal)) ∨ + (a : K⟦ℝ⟧).supportOrderType = + Ordinal.omega0 ^ (2 : Ordinal) + 1) + {u : ℝ} (hu : u < 0) : + ordinalValue (translatedTruncation (a : K⟦ℝ⟧) u) < ω^ (2 : NatOrdinal) := by + let S : Set ℝ := (a : K⟦ℝ⟧).support ∩ Set.Iio 0 + let hS : S.IsPWO := (a : K⟦ℝ⟧).isPWO_support.mono Set.inter_subset_left + have hSType : hS.orderType = Ordinal.omega0 ^ (2 : Ordinal) := + negativeSupport_orderType_eq_wpow_two haNear haType + have haOne : 1 < ordinalValue a := one_lt_ordinalValue_iff.mpr haNear + have hSLUB : IsLUB S 0 := isLUB_negativeSupport_zero_of_one_lt_ordinalValue haOne + obtain ⟨y, hy, huy, -⟩ := hSLUB.exists_between hu + let T : Set ℝ := (HahnSeries.truncLE u (a : K⟦ℝ⟧)).support + let hT : T.IsPWO := (HahnSeries.truncLE u (a : K⟦ℝ⟧)).isPWO_support + have hTsub : T ⊆ S ∩ Set.Iio y := by + intro x hx + change x ∈ (HahnSeries.truncLE u (a : K⟦ℝ⟧)).support at hx + rw [HahnSeries.support_truncLE] at hx + exact ⟨⟨hx.1, hx.2.trans_lt hu⟩, hx.2.trans_lt huy⟩ + have hTlt : hT.orderType < hS.orderType := + (hT.orderType_mono + (hS.mono (s := S ∩ Set.Iio y) Set.inter_subset_left) hTsub).trans_lt + (hS.orderType_inter_Iio_lt hy) + calc + ordinalValue (translatedTruncation (a : K⟦ℝ⟧) u) ≤ + NatOrdinal.of + ((translatedTruncation (a : K⟦ℝ⟧) u : Series K) : K⟦ℝ⟧).supportOrderType := + ordinalValue_le_supportOrderType _ + _ = NatOrdinal.of hT.orderType := by + rw [coe_translatedTruncation, HahnSeries.supportOrderType_translate, + HahnSeries.supportOrderType_eq_setOrderType] + _ < NatOrdinal.of (Ordinal.omega0 ^ (2 : Ordinal)) := by + apply NatOrdinal.of.lt_iff_lt.mpr + rwa [hSType] at hTlt + _ = ω^ (2 : NatOrdinal) := by + rw [NatOrdinal.of_omega0_opow] + congr 1 + +private theorem degree_eq_two + {a : Series K} (haNear : a ∉ nearConstantSubgroup K) + (haType : (a : K⟦ℝ⟧).supportOrderType = + (Ordinal.omega0 ^ (2 : Ordinal)) ∨ + (a : K⟦ℝ⟧).supportOrderType = + Ordinal.omega0 ^ (2 : Ordinal) + 1) : + (a : K⟦ℝ⟧).degree = (2 : WithBot NatOrdinal) := by + change (a : K⟦ℝ⟧).degree = + ((NatOrdinal.of (2 : Ordinal)) : WithBot NatOrdinal) + have haNe : (a : K⟦ℝ⟧) ≠ 0 := by + intro ha + apply haNear + have haSeries : a = 0 := Subtype.ext ha + rw [haSeries] + exact (nearConstantSubgroup K).zero_mem + apply le_antisymm + · rw [← Order.lt_succ_iff] + change (a : K⟦ℝ⟧).degree < + Order.succ ((NatOrdinal.of (2 : Ordinal)) : WithBot NatOrdinal) + rw [WithBot.orderSucc_coe, Order.succ_eq_add_one] + apply (HahnSeries.degree_lt_coe_iff_supportOrderType_lt_wpow + (a : K⟦ℝ⟧) (NatOrdinal.of (2 : Ordinal) + 1)).mpr + simp only [NatOrdinal.val_wpow, NatOrdinal.val_add_one, NatOrdinal.val_of] + rcases haType with haType | haType + · rw [haType] + exact (Ordinal.opow_lt_opow_iff_right Ordinal.one_lt_omega0).mpr + (Order.lt_succ (2 : Ordinal)) + · rw [haType] + simpa [Ordinal.opow_add] using + (Ordinal.opow_mul_add_lt_opow_mul + (b := Ordinal.omega0) (u := 2) (w := 1) (v := 1) (x := Ordinal.omega0) + (by norm_num) Ordinal.one_lt_omega0) + · have hlow := (HahnSeries.coe_le_degree_iff + (x := (a : K⟦ℝ⟧)) (a := (2 : Ordinal)) haNe).mpr (by + rcases haType with haType | haType + · exact haType.ge + · rw [haType] + exact le_self_add) + exact hlow + +/-- A non-near-constant series of support order type `ω²` or `ω² + 1` has +Berarducci ordinal value exactly `ω²`. -/ +theorem ordinalValue_eq_wpow_two + {a : Series K} (haNear : a ∉ nearConstantSubgroup K) + (haType : (a : K⟦ℝ⟧).supportOrderType = + (Ordinal.omega0 ^ (2 : Ordinal)) ∨ + (a : K⟦ℝ⟧).supportOrderType = + Ordinal.omega0 ^ (2 : Ordinal) + 1) : + ordinalValue a = ω^ (2 : NatOrdinal) := by + let S : Set ℝ := (a : K⟦ℝ⟧).support ∩ Set.Iio 0 + let hS : S.IsPWO := (a : K⟦ℝ⟧).isPWO_support.mono Set.inter_subset_left + have hSType : hS.orderType = Ordinal.omega0 ^ (2 : Ordinal) := + negativeSupport_orderType_eq_wpow_two haNear haType + have hSLUB : IsLUB S 0 := + isLUB_negativeSupport_zero_of_one_lt_ordinalValue (one_lt_ordinalValue_iff.mpr haNear) + have hvalueLower : ω^ (2 : NatOrdinal) ≤ ordinalValue a := by + have hordinary : NatOrdinal.of (Ordinal.omega0 ^ (2 : Ordinal)) ≤ + ordinalValue (translatedTruncation (a : K⟦ℝ⟧) 0) := by + apply le_ordinalValue_translatedTruncation_of_forall_le_orderType + intro θ hθ + obtain ⟨y, hy, hθy, -⟩ := hSLUB.exists_between hθ + let U : Set ℝ := S ∩ Set.Ioi θ + let hU : U.IsPWO := hS.mono Set.inter_subset_left + let W : Set ℝ := (a : K⟦ℝ⟧).support ∩ Set.Ioo θ 0 + let hW : W.IsPWO := (a : K⟦ℝ⟧).isPWO_support.mono Set.inter_subset_left + have hprincipal : IsPrincipal (fun x y : Ordinal ↦ x + y) hS.orderType := by + rw [hSType] + exact Ordinal.isPrincipal_add_omega0_opow 2 + have hUType : hU.orderType = hS.orderType := + hS.orderType_inter_Ioi_eq_of_isPrincipal hprincipal ⟨y, hy, hθy⟩ + have hUW : U = W := by + ext x + simp only [U, W, S, Set.mem_inter_iff, Set.mem_Iio, Set.mem_Ioi, + Set.mem_Ioo] + tauto + have hwindowType : Ordinal.omega0 ^ (2 : Ordinal) = + ((a : K⟦ℝ⟧).isPWO_support.mono + (s := (a : K⟦ℝ⟧).support ∩ Set.Ioo θ 0) + Set.inter_subset_left).orderType := by + calc + Ordinal.omega0 ^ (2 : Ordinal) = hS.orderType := hSType.symm + _ = hU.orderType := hUType.symm + _ = ((a : K⟦ℝ⟧).isPWO_support.mono + (s := (a : K⟦ℝ⟧).support ∩ Set.Ioo θ 0) + Set.inter_subset_left).orderType := by + simpa only [hW, W] using hU.orderType_congr hW hUW + exact hwindowType.le + rw [translatedTruncation_zero] at hordinary + rw [NatOrdinal.of_omega0_opow] at hordinary + convert hordinary using 1 + have hdegree : (a : K⟦ℝ⟧).degree = (2 : WithBot NatOrdinal) := + degree_eq_two haNear haType + have hvalueDegreeGe : (2 : WithBot NatOrdinal) ≤ ordinalValueDegree a := by + rw [← not_lt] + intro hlt + exact (not_lt_of_ge hvalueLower) ((ordinalValueDegree_lt_coe_iff a 2).mp hlt) + have hvalueDegreeLe : ordinalValueDegree a ≤ (2 : WithBot NatOrdinal) := + (ordinalValueDegree_le_degree a).trans_eq hdegree + exact (ordinalValueDegree_eq_coe_iff a 2).mp + (le_antisymm hvalueDegreeLe hvalueDegreeGe) + +end PommersheimShahriari diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/DegreeTwo/DegreeTwoExample.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/DegreeTwo/DegreeTwoExample.lean new file mode 100644 index 0000000000..58c51ce022 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/DegreeTwo/DegreeTwoExample.lean @@ -0,0 +1,773 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.DegreeTwo.TranslatedSpanFactorization +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.NonpositiveCoefficientMap +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.TruncationIntegerPartPrimal +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Domain +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrderType +import Mathlib.Data.Prod.Lex +import Mathlib.SetTheory.Ordinal.Arithmetic + +/-! +# An explicit PS06 degree-two irreducible + +This module constructs a coefficient-one series whose support consists of rows converging to +`-1/(m+1)`, with those row limits converging to zero. Its support has exact order type `ω²`; after +adding the constant term one, it has order type `ω² + 1`. + +The translated-truncation classes at the first three row limits have pairwise separated cofinal +supports and are linearly independent modulo `J + K`. Thus `V(a)` has dimension greater than two, +and PS06, Corollary 3.3 proves the series irreducible over every characteristic-zero coefficient +field. This is the explicit witness used by the omnific-integer example. +-/ + +open scoped HahnSeries + +public noncomputable section + +namespace PommersheimShahriari.DegreeTwoExample + +universe v + +variable {K : Type v} [Field K] + +/-- The limit point of block `m` in the explicit degree-two support. -/ +def degreeTwoCutoff (m : ℕ) : ℝ := + -(1 / (m + 1 : ℝ)) + +@[simp] +theorem degreeTwoCutoff_apply (m : ℕ) : + degreeTwoCutoff m = -(1 / (m + 1 : ℝ)) := (rfl) + +/-- The exponent in block `p.1` at position `p.2`. -/ +def degreeTwoExponentPair (p : ℕ × ℕ) : ℝ := + degreeTwoCutoff p.1 - + 1 / ((p.1 + 1 : ℝ) * (p.1 + 2 : ℝ) * (p.2 + 1 : ℝ)) + +theorem degreeTwoExponentPair_apply (p : ℕ × ℕ) : + degreeTwoExponentPair p = + -(1 / (p.1 + 1 : ℝ)) - 1 / ((p.1 + 1 : ℝ) * (p.1 + 2 : ℝ) * (p.2 + 1 : ℝ)) := (rfl) + +private theorem degreeTwoExponentPair_strictMono_second (m : ℕ) : + StrictMono (fun n : ℕ ↦ degreeTwoExponentPair (m, n)) := by + apply strictMono_nat_of_lt_succ + intro n + dsimp [degreeTwoExponentPair] + apply sub_lt_sub_left + apply one_div_lt_one_div_of_lt + · positivity + · gcongr + omega + +private theorem degreeTwoExponentPair_lt_cutoff (m n : ℕ) : + degreeTwoExponentPair (m, n) < degreeTwoCutoff m := by + dsimp [degreeTwoExponentPair] + have : 0 < + 1 / ((m + 1 : ℝ) * (m + 2 : ℝ) * (n + 1 : ℝ)) := by + positivity + linarith + +private theorem degreeTwoCutoff_lt_next_exponent_zero (m : ℕ) : + degreeTwoCutoff m < degreeTwoExponentPair (m + 1, 0) := by + dsimp [degreeTwoCutoff, degreeTwoExponentPair] + field_simp + norm_num [Nat.cast_add, Nat.cast_one] + ring_nf + nlinarith + +private theorem degreeTwoExponentPair_lt_of_first_lt + {m m' n n' : ℕ} (hmm' : m < m') : + degreeTwoExponentPair (m, n) < degreeTwoExponentPair (m', n') := by + calc + degreeTwoExponentPair (m, n) < degreeTwoCutoff m := + degreeTwoExponentPair_lt_cutoff m n + _ < degreeTwoExponentPair (m + 1, 0) := + degreeTwoCutoff_lt_next_exponent_zero m + _ ≤ degreeTwoExponentPair (m', n') := by + by_cases hsucc : m + 1 = m' + · subst m' + exact (degreeTwoExponentPair_strictMono_second (m + 1)).monotone + (Nat.zero_le n') + · have hfirst : m + 1 < m' := lt_of_le_of_ne (Nat.succ_le_iff.mpr hmm') hsucc + exact (degreeTwoExponentPair_lt_of_first_lt hfirst).le +termination_by m' - m + +private theorem degreeTwoExponent_strictMono : + StrictMono (fun p : Lex (ℕ × ℕ) ↦ degreeTwoExponentPair (ofLex p)) := by + intro p q hpq + rw [Prod.Lex.lt_iff] at hpq + rcases hpq with hfirst | ⟨hfirst, hsecond⟩ + · exact degreeTwoExponentPair_lt_of_first_lt hfirst + · change degreeTwoExponentPair ((ofLex p).1, (ofLex p).2) < + degreeTwoExponentPair ((ofLex q).1, (ofLex q).2) + rw [hfirst] + exact degreeTwoExponentPair_strictMono_second _ hsecond + +/-- The explicit order embedding used by the degree-two witness. -/ +def degreeTwoExponentEmbedding : Lex (ℕ × ℕ) ↪o ℝ := + OrderEmbedding.ofStrictMono _ degreeTwoExponent_strictMono + +@[simp] +theorem degreeTwoExponentEmbedding_apply (m n : ℕ) : + degreeTwoExponentEmbedding (toLex (m, n)) = degreeTwoExponentPair (m, n) := + (rfl) + +/-- The coefficient-one series on the natural numbers. -/ +def natOnes : K⟦ℕ⟧ where + coeff _ := 1 + isPWO_support' := by + simpa [Function.support] using Set.IsPWO.of_linearOrder (Set.univ : Set ℕ) + +@[simp] +theorem natOnes_coeff (n : ℕ) : (natOnes (K := K)).coeff n = 1 := + (rfl) + +@[simp] +theorem natOnes_support : (natOnes (K := K)).support = Set.univ := by + ext n + simp [natOnes] + +/-- The coefficient-one series indexed by two lexicographic natural coordinates. -/ +def lexNatPairOnes : K⟦Lex (ℕ × ℕ)⟧ where + coeff _ := 1 + isPWO_support' := by + simpa [Function.support] using + Set.IsPWO.of_linearOrder (Set.univ : Set (Lex (ℕ × ℕ))) + +@[simp] +theorem lexNatPairOnes_support : + (lexNatPairOnes (K := K)).support = Set.univ := by + ext p + simp [lexNatPairOnes] + +/-- An explicit coefficient-one Hahn series of support order type `ω²`. -/ +def degreeTwoSeries : K⟦ℝ⟧ := + HahnSeries.embDomain degreeTwoExponentEmbedding (lexNatPairOnes (K := K)) + +theorem degreeTwoSeries_coeff_embedding (m n : ℕ) : + (degreeTwoSeries (K := K)).coeff + (degreeTwoExponentEmbedding (toLex (m, n))) = 1 := by + rw [degreeTwoSeries, HahnSeries.embDomain_coeff] + rfl + +theorem degreeTwoSeries_support : + (degreeTwoSeries (K := K)).support = Set.range degreeTwoExponentEmbedding := by + rw [degreeTwoSeries, HahnSeries.support_embDomain, lexNatPairOnes_support, + Set.image_univ] + +@[simp] +theorem degreeTwoSeries_coeff_zero : (degreeTwoSeries (K := K)).coeff 0 = 0 := by + rw [← not_ne_iff, ← HahnSeries.mem_support, degreeTwoSeries_support (K := K)] + rintro ⟨p, hp⟩ + rcases p with ⟨m, n⟩ + have hneg := (degreeTwoExponentPair_lt_cutoff m n).trans (by + rw [degreeTwoCutoff_apply] + exact neg_neg_of_pos (by positivity)) + change degreeTwoExponentPair (m, n) = 0 at hp + linarith + +theorem degreeTwoSeries_supportOrderType : + (degreeTwoSeries (K := K)).supportOrderType = + Ordinal.omega0 ^ (2 : Ordinal) := by + rw [HahnSeries.supportOrderType_eq_setOrderType] + have e : (degreeTwoSeries (K := K)).support ≃o Lex (ℕ × ℕ) := + (Set.orderIsoOfEq (degreeTwoSeries (K := K)).support + (Set.range degreeTwoExponentEmbedding) + (degreeTwoSeries_support (K := K))).trans + degreeTwoExponentEmbedding.orderIso.symm + rw [(degreeTwoSeries (K := K)).isPWO_support.orderType_eq_typeLT_of_orderIso e] + change Ordinal.type (Prod.Lex (fun a b : ℕ ↦ a < b) (fun a b : ℕ ↦ a < b)) = _ + rw [Ordinal.type_prod_lex] + simp only [Ordinal.type_nat_lt] + have hsucc : (1 : Ordinal) + 1 = 2 := one_add_one_eq_two + rw [← hsucc, Ordinal.opow_add_one, Ordinal.opow_one] + +/-- The degree-two series regarded as a nonpositive real Hahn series. -/ +def degreeTwoNonpositive : HahnSeries.Nonpositive ℝ K := + ⟨degreeTwoSeries (K := K), by + rw [HahnSeries.mem_nonpositiveSubring, degreeTwoSeries_support (K := K)] + rintro _ ⟨p, rfl⟩ + rcases p with ⟨m, n⟩ + exact (degreeTwoExponentPair_lt_cutoff m n).le.trans + (by rw [degreeTwoCutoff_apply] + exact neg_nonpos.mpr (by positivity))⟩ + +/-- The exponent in block `m` after translating its limit point to zero. -/ +def degreeTwoBlockExponent (m n : ℕ) : ℝ := + -(1 / ((m + 1 : ℝ) * (m + 2 : ℝ) * (n + 1 : ℝ))) + +@[simp] +theorem degreeTwoBlockExponent_apply (m n : ℕ) : + degreeTwoBlockExponent m n = + -(1 / ((m + 1 : ℝ) * (m + 2 : ℝ) * (n + 1 : ℝ))) := (rfl) + +private theorem degreeTwoBlockExponent_strictMono (m : ℕ) : + StrictMono (degreeTwoBlockExponent m) := by + apply strictMono_nat_of_lt_succ + intro n + dsimp [degreeTwoBlockExponent] + apply neg_lt_neg + apply one_div_lt_one_div_of_lt + · positivity + · gcongr + omega + +/-- The translated support of block `m`, approaching exponent zero from below. -/ +def degreeTwoBlockEmbedding (m : ℕ) : ℕ ↪o ℝ := + OrderEmbedding.ofStrictMono _ (degreeTwoBlockExponent_strictMono m) + +@[simp] +theorem degreeTwoBlockEmbedding_apply (m n : ℕ) : + degreeTwoBlockEmbedding m n = degreeTwoBlockExponent m n := + (rfl) + +/-- Block `m` translated so that its limiting cutoff is zero. -/ +def degreeTwoBlock (m : ℕ) : Berarducci.Series K := + ⟨HahnSeries.embDomain (degreeTwoBlockEmbedding m) (natOnes (K := K)), by + rw [HahnSeries.mem_nonpositiveSubring, HahnSeries.support_embDomain, + natOnes_support, Set.image_univ] + rintro _ ⟨n, rfl⟩ + rw [degreeTwoBlockEmbedding_apply, degreeTwoBlockExponent_apply] + have h : (0 : ℝ) < + 1 / ((m + 1 : ℝ) * (m + 2 : ℝ) * (n + 1 : ℝ)) := by + positivity + exact neg_nonpos.mpr h.le⟩ + +theorem degreeTwoBlock_coeff_embedding (m n : ℕ) : + ((degreeTwoBlock (K := K) m : Berarducci.Series K) : K⟦ℝ⟧).coeff + (degreeTwoBlockEmbedding m n) = 1 := by + rw [degreeTwoBlock, HahnSeries.embDomain_coeff] + exact natOnes_coeff n + +theorem degreeTwoBlock_support (m : ℕ) : + ((degreeTwoBlock (K := K) m : Berarducci.Series K) : K⟦ℝ⟧).support = + Set.range (degreeTwoBlockEmbedding m) := by + rw [degreeTwoBlock, HahnSeries.support_embDomain, natOnes_support, + Set.image_univ] + +private theorem degreeTwoCutoff_strictMono : StrictMono degreeTwoCutoff := by + apply strictMono_nat_of_lt_succ + intro m + rw [degreeTwoCutoff_apply, degreeTwoCutoff_apply] + apply neg_lt_neg + apply one_div_lt_one_div_of_lt + · positivity + · norm_num + +private theorem degreeTwoExponentPair_eq_cutoff_add_block (m n : ℕ) : + degreeTwoExponentPair (m, n) = + degreeTwoCutoff m + degreeTwoBlockExponent m n := by + rw [degreeTwoCutoff_apply, degreeTwoBlockExponent_apply] + rfl + +private theorem degreeTwoCutoff_lt_exponentPair_of_lt + {m m' n' : ℕ} (hmm' : m < m') : + degreeTwoCutoff m < degreeTwoExponentPair (m', n') := by + calc + degreeTwoCutoff m < degreeTwoExponentPair (m + 1, 0) := + degreeTwoCutoff_lt_next_exponent_zero m + _ ≤ degreeTwoExponentPair (m', n') := by + by_cases hsucc : m + 1 = m' + · subst m' + exact (degreeTwoExponentPair_strictMono_second (m + 1)).monotone + (Nat.zero_le n') + · have hfirst : m + 1 < m' := lt_of_le_of_ne (Nat.succ_le_iff.mpr hmm') hsucc + exact (degreeTwoExponentPair_lt_of_first_lt hfirst).le + +private def degreeTwoGermLowerBound : ℕ → ℝ + | 0 => -2 + | m + 1 => degreeTwoCutoff m - degreeTwoCutoff (m + 1) + +private theorem degreeTwoGermLowerBound_neg (m : ℕ) : + degreeTwoGermLowerBound m < 0 := by + cases m with + | zero => norm_num [degreeTwoGermLowerBound] + | succ m => + rw [degreeTwoGermLowerBound] + exact sub_neg.mpr (degreeTwoCutoff_strictMono (Nat.lt_succ_self m)) + +private theorem first_eq_of_exponent_eq_cutoff_add_of_lowerBound_lt + {m m' n' : ℕ} {delta : ℝ} + (hdelta : degreeTwoGermLowerBound m < delta) (hdelta0 : delta ≤ 0) + (hexponent : degreeTwoExponentPair (m', n') = degreeTwoCutoff m + delta) : + m' = m := by + rcases lt_trichotomy m' m with hlt | heq | hgt + · cases m with + | zero => omega + | succ m => + have hm'le : m' ≤ m := Nat.lt_succ_iff.mp hlt + have hcutoff : degreeTwoCutoff m' ≤ degreeTwoCutoff m := + degreeTwoCutoff_strictMono.monotone hm'le + have hexpLt : degreeTwoExponentPair (m', n') < degreeTwoCutoff m := + (degreeTwoExponentPair_lt_cutoff m' n').trans_le hcutoff + rw [hexponent] at hexpLt + rw [degreeTwoGermLowerBound] at hdelta + linarith + · exact heq + · have hbad := degreeTwoCutoff_lt_exponentPair_of_lt (n' := n') hgt + rw [hexponent] at hbad + linarith + +private theorem degreeTwo_germ_coeff_eq_block (m : ℕ) {delta : ℝ} + (hlower : degreeTwoGermLowerBound m < delta) (hdelta0 : delta ≤ 0) : + ((Berarducci.translatedTruncation (degreeTwoSeries (K := K) : K⟦ℝ⟧) + (degreeTwoCutoff m) : Berarducci.Series K) : K⟦ℝ⟧).coeff delta = + ((degreeTwoBlock (K := K) m : Berarducci.Series K) : K⟦ℝ⟧).coeff delta := by + rw [Berarducci.coeff_translatedTruncation, ite_eq_left hdelta0] + by_cases hblock : delta ∈ Set.range (degreeTwoBlockEmbedding m) + · obtain ⟨n, rfl⟩ := hblock + rw [degreeTwoBlock_coeff_embedding (K := K)] + have harg : degreeTwoCutoff m + degreeTwoBlockEmbedding m n = + degreeTwoExponentEmbedding (toLex (m, n)) := by + rw [degreeTwoBlockEmbedding_apply, degreeTwoExponentEmbedding_apply, + degreeTwoExponentPair_eq_cutoff_add_block] + rw [harg, degreeTwoSeries_coeff_embedding (K := K)] + · have hblockCoeff : + ((degreeTwoBlock (K := K) m : Berarducci.Series K) : K⟦ℝ⟧).coeff delta = 0 := by + apply not_ne_iff.mp + intro hne + apply hblock + rw [← degreeTwoBlock_support (K := K)] + exact (HahnSeries.mem_support _ _).mpr hne + rw [hblockCoeff] + apply not_ne_iff.mp + rw [← HahnSeries.mem_support, degreeTwoSeries_support (K := K)] + rintro ⟨p, hp⟩ + rcases p with ⟨m', n'⟩ + change degreeTwoExponentPair (m', n') = degreeTwoCutoff m + delta at hp + have hm' : m' = m := first_eq_of_exponent_eq_cutoff_add_of_lowerBound_lt + hlower hdelta0 hp + subst m' + apply hblock + refine ⟨n', ?_⟩ + rw [degreeTwoBlockEmbedding_apply] + rw [degreeTwoExponentPair_eq_cutoff_add_block] at hp + linarith + +/-- At cutoff `m`, the translated germ of the degree-two series is the germ of block `m`. -/ +theorem degreeTwo_translatedTruncationClass_eq_block (m : ℕ) : + PommersheimShahriari.translatedTruncationClass (degreeTwoSeries (K := K)) + (degreeTwoCutoff m) = + PommersheimShahriari.toSeriesQuotientByJAddConstants (degreeTwoBlock (K := K) m) := by + rw [PommersheimShahriari.translatedTruncationClass_apply, + PommersheimShahriari.toSeriesQuotientByJAddConstants_eq_iff] + apply Berarducci.negativeMonomialIdeal_le_nearConstantSubgroup + change Berarducci.translatedTruncation (degreeTwoSeries (K := K)) (degreeTwoCutoff m) - + degreeTwoBlock (K := K) m ∈ HahnSeries.Nonpositive.negativeMonomialIdeal K + rw [← Berarducci.toGerm_eq_toGerm_iff] + apply Berarducci.toGerm_eq_toGerm_iff_exists_coeff_eq.mpr + exact ⟨degreeTwoGermLowerBound m, degreeTwoGermLowerBound_neg m, + fun _ hlower hdelta0 ↦ degreeTwo_germ_coeff_eq_block (K := K) m hlower hdelta0⟩ + +private theorem degreeTwoBlock_zero_threeMul_not_mem_one (N : ℕ) : + degreeTwoBlockEmbedding 0 (3 * N) ∉ + Set.range (degreeTwoBlockEmbedding 1) := by + rintro ⟨k, hk⟩ + rw [degreeTwoBlockEmbedding_apply, degreeTwoBlockExponent_apply, + degreeTwoBlockEmbedding_apply, degreeTwoBlockExponent_apply] at hk + field_simp at hk + norm_num [Nat.cast_add, Nat.cast_mul] at hk + ring_nf at hk + have hkNat : 2 + N * 6 = 6 + k * 6 := by exact_mod_cast hk + omega + +private theorem degreeTwoBlock_zero_threeMul_not_mem_two (N : ℕ) : + degreeTwoBlockEmbedding 0 (3 * N) ∉ + Set.range (degreeTwoBlockEmbedding 2) := by + rintro ⟨k, hk⟩ + rw [degreeTwoBlockEmbedding_apply, degreeTwoBlockExponent_apply, + degreeTwoBlockEmbedding_apply, degreeTwoBlockExponent_apply] at hk + field_simp at hk + norm_num [Nat.cast_add, Nat.cast_mul] at hk + ring_nf at hk + have hkNat : 2 + N * 6 = 12 + k * 12 := by exact_mod_cast hk + omega + +private theorem degreeTwoBlock_one_twoMul_not_mem_two (N : ℕ) : + degreeTwoBlockEmbedding 1 (2 * N) ∉ + Set.range (degreeTwoBlockEmbedding 2) := by + rintro ⟨k, hk⟩ + rw [degreeTwoBlockEmbedding_apply, degreeTwoBlockExponent_apply, + degreeTwoBlockEmbedding_apply, degreeTwoBlockExponent_apply] at hk + field_simp at hk + norm_num [Nat.cast_add, Nat.cast_mul] at hk + ring_nf at hk + have hkNat : 6 + N * 12 = 12 + k * 12 := by exact_mod_cast hk + omega + +private theorem exists_degreeTwoBlockEmbedding_gt + (m scale : ℕ) (hscale : 0 < scale) {eta : ℝ} (heta : eta < 0) : + ∃ N, eta < degreeTwoBlockEmbedding m (scale * N) := by + obtain ⟨N, hN⟩ := exists_nat_one_div_lt (neg_pos.mpr heta) + refine ⟨N, ?_⟩ + rw [degreeTwoBlockEmbedding_apply, degreeTwoBlockExponent_apply] + have hdenNat : N + 1 ≤ (m + 1) * (m + 2) * (scale * N + 1) := by + calc + N + 1 ≤ scale * N + 1 := by + apply Nat.add_le_add_right + simpa using Nat.mul_le_mul_right N (Nat.succ_le_iff.mpr hscale) + _ ≤ (m + 1) * (m + 2) * (scale * N + 1) := + Nat.le_mul_of_pos_left _ (by positivity) + have hden : (N + 1 : ℝ) ≤ + (m + 1 : ℝ) * (m + 2 : ℝ) * (scale * N + 1 : ℝ) := by + exact_mod_cast hdenNat + have hrecip := one_div_le_one_div_of_le (by positivity : (0 : ℝ) < N + 1) hden + norm_num [Nat.cast_mul] at hN hrecip ⊢ + linarith + +private theorem degreeTwoBlock_coeff_eq_zero_of_not_mem_range + (m : ℕ) {delta : ℝ} + (hdelta : delta ∉ Set.range (degreeTwoBlockEmbedding m)) : + ((degreeTwoBlock (K := K) m : Berarducci.Series K) : K⟦ℝ⟧).coeff delta = 0 := by + apply not_ne_iff.mp + intro hne + apply hdelta + rw [← degreeTwoBlock_support (K := K)] + exact (HahnSeries.mem_support _ _).mpr hne + +private theorem degreeTwoBlock_coeff_smul (r : K) (m : ℕ) (delta : ℝ) : + ((r • degreeTwoBlock (K := K) m : Berarducci.Series K) : K⟦ℝ⟧).coeff delta = + r * ((degreeTwoBlock (K := K) m : Berarducci.Series K) : K⟦ℝ⟧).coeff delta := by + rw [HahnSeries.Nonpositive.coe_smul, HahnSeries.coeff_smul, smul_eq_mul] + +/-- The three translated row germs used to certify dimension greater than two. -/ +def degreeTwoTranslatedTruncationClass (i : Fin 3) : + PommersheimShahriari.SeriesQuotientByJAddConstants K := + PommersheimShahriari.toSeriesQuotientByJAddConstants (degreeTwoBlock (K := K) i) + +theorem degreeTwoTranslatedTruncationClass_linearIndependent : + LinearIndependent K (degreeTwoTranslatedTruncationClass (K := K)) := by + rw [Fintype.linearIndependent_iff] + intro g hsum i + have hsum' : + g 0 • degreeTwoTranslatedTruncationClass (K := K) 0 + + g 1 • degreeTwoTranslatedTruncationClass (K := K) 1 + + g 2 • degreeTwoTranslatedTruncationClass (K := K) 2 = 0 := by + simpa [Fin.sum_univ_three] using hsum + let b : Berarducci.Series K := + g 0 • degreeTwoBlock (K := K) 0 + g 1 • degreeTwoBlock (K := K) 1 + + g 2 • degreeTwoBlock (K := K) 2 + have hzero : PommersheimShahriari.toSeriesQuotientByJAddConstants b = 0 := by + simpa [b, degreeTwoTranslatedTruncationClass, map_add, map_smul] using hsum' + have hnear : b ∈ Berarducci.nearConstantSubgroup K := + PommersheimShahriari.toSeriesQuotientByJAddConstants_eq_zero_iff.mp hzero + obtain ⟨eta, heta, hcoeff⟩ := + Berarducci.exists_coeff_eq_of_sub_mem_nearConstantSubgroup + (b := b) (c := 0) (by simpa using hnear) + obtain ⟨N0, hN0⟩ := + exists_degreeTwoBlockEmbedding_gt 0 3 (by norm_num) heta + have hdelta0 : degreeTwoBlockEmbedding 0 (3 * N0) < 0 := by + rw [degreeTwoBlockEmbedding_apply, degreeTwoBlockExponent_apply] + exact neg_neg_of_pos (by positivity) + have heq0 := hcoeff (degreeTwoBlockEmbedding 0 (3 * N0)) hN0 hdelta0 + have h01 := degreeTwoBlock_coeff_eq_zero_of_not_mem_range (K := K) 1 + (degreeTwoBlock_zero_threeMul_not_mem_one N0) + have h02 := degreeTwoBlock_coeff_eq_zero_of_not_mem_range (K := K) 2 + (degreeTwoBlock_zero_threeMul_not_mem_two N0) + have hg0 : g 0 = 0 := by + simp only [b, Subring.coe_add, HahnSeries.coeff_add, + degreeTwoBlock_coeff_smul (K := K)] at heq0 + rw [degreeTwoBlock_coeff_embedding (K := K), h01, h02] at heq0 + simpa using heq0 + obtain ⟨N1, hN1⟩ := + exists_degreeTwoBlockEmbedding_gt 1 2 (by norm_num) heta + have hdelta1 : degreeTwoBlockEmbedding 1 (2 * N1) < 0 := by + rw [degreeTwoBlockEmbedding_apply, degreeTwoBlockExponent_apply] + exact neg_neg_of_pos (by positivity) + have heq1 := hcoeff (degreeTwoBlockEmbedding 1 (2 * N1)) hN1 hdelta1 + have h12 := degreeTwoBlock_coeff_eq_zero_of_not_mem_range (K := K) 2 + (degreeTwoBlock_one_twoMul_not_mem_two N1) + have hg1 : g 1 = 0 := by + simp only [b, Subring.coe_add, HahnSeries.coeff_add, + degreeTwoBlock_coeff_smul (K := K)] at heq1 + rw [hg0, degreeTwoBlock_coeff_embedding (K := K), h12] at heq1 + simpa using heq1 + obtain ⟨N2, hN2⟩ := + exists_degreeTwoBlockEmbedding_gt 2 1 (by norm_num) heta + have hdelta2 : degreeTwoBlockEmbedding 2 (1 * N2) < 0 := by + rw [degreeTwoBlockEmbedding_apply, degreeTwoBlockExponent_apply] + exact neg_neg_of_pos (by positivity) + have heq2 := hcoeff (degreeTwoBlockEmbedding 2 (1 * N2)) hN2 hdelta2 + have hg2 : g 2 = 0 := by + simp only [b, Subring.coe_add, HahnSeries.coeff_add, + degreeTwoBlock_coeff_smul (K := K)] at heq2 + rw [hg0, hg1, degreeTwoBlock_coeff_embedding (K := K)] at heq2 + simpa using heq2 + fin_cases i <;> assumption + +private theorem degreeTwoCutoff_neg (m : ℕ) : degreeTwoCutoff m < 0 := by + rw [degreeTwoCutoff_apply] + exact neg_neg_of_pos (by positivity) + +theorem degreeTwoTranslatedTruncationClass_mem_translatedTruncationSpan (i : Fin 3) : + degreeTwoTranslatedTruncationClass (K := K) i ∈ + PommersheimShahriari.translatedTruncationSpan (degreeTwoNonpositive (K := K)) := by + have h := PommersheimShahriari.translatedTruncationClass_mem_translatedTruncationSpan + (degreeTwoNonpositive (K := K)) (degreeTwoCutoff_neg i) + change PommersheimShahriari.translatedTruncationClass (degreeTwoSeries (K := K)) + (degreeTwoCutoff i) ∈ + PommersheimShahriari.translatedTruncationSpan (degreeTwoNonpositive (K := K)) at h + rw [degreeTwo_translatedTruncationClass_eq_block (K := K)] at h + exact h + +/-- The three row classes, regarded as elements of the witness's translated-truncation span. -/ +def degreeTwoTranslatedTruncationSpanVector (i : Fin 3) : + PommersheimShahriari.translatedTruncationSpan (degreeTwoNonpositive (K := K)) := + ⟨degreeTwoTranslatedTruncationClass (K := K) i, + degreeTwoTranslatedTruncationClass_mem_translatedTruncationSpan (K := K) i⟩ + +theorem degreeTwoTranslatedTruncationSpanVector_linearIndependent : + LinearIndependent K (degreeTwoTranslatedTruncationSpanVector (K := K)) := by + apply LinearIndependent.of_comp + (PommersheimShahriari.translatedTruncationSpan (degreeTwoNonpositive (K := K))).subtype + simpa [Function.comp_def, degreeTwoTranslatedTruncationSpanVector] using + (degreeTwoTranslatedTruncationClass_linearIndependent (K := K)) + +theorem two_lt_rank_degreeTwo_translatedTruncationSpan : + (2 : Cardinal) < Module.rank K + (PommersheimShahriari.translatedTruncationSpan (degreeTwoNonpositive (K := K))) := by + have h := + (degreeTwoTranslatedTruncationSpanVector_linearIndependent (K := K)).cardinal_lift_le_rank + simp only [Cardinal.mk_fintype, Fintype.card_fin, Cardinal.lift_natCast, + Cardinal.lift_id'] at h + exact (by norm_num : (2 : Cardinal) < 3).trans_le h + +private theorem exists_degreeTwoCutoff_gt {eta : ℝ} (heta : eta < 0) : + ∃ m, eta < degreeTwoCutoff m := by + obtain ⟨m, hm⟩ := exists_nat_one_div_lt (neg_pos.mpr heta) + refine ⟨m, ?_⟩ + rw [degreeTwoCutoff_apply] + linarith + +theorem degreeTwoNonpositive_not_mem_nearConstantSubgroup : + degreeTwoNonpositive (K := K) ∉ Berarducci.nearConstantSubgroup K := by + intro hnear + obtain ⟨eta, heta, hcoeff⟩ := + Berarducci.exists_coeff_eq_of_sub_mem_nearConstantSubgroup + (b := degreeTwoNonpositive (K := K)) (c := 0) (by simpa using hnear) + obtain ⟨m, hm⟩ := exists_degreeTwoCutoff_gt heta + obtain ⟨n, hn⟩ := exists_degreeTwoBlockEmbedding_gt m 1 (by norm_num) + (sub_neg.mpr hm) + have hdeltaEta : + eta < degreeTwoExponentEmbedding (toLex (m, 1 * n)) := by + rw [degreeTwoExponentEmbedding_apply, + degreeTwoExponentPair_eq_cutoff_add_block, + ← degreeTwoBlockEmbedding_apply] + linarith + have hdelta0 : + degreeTwoExponentEmbedding (toLex (m, 1 * n)) < 0 := by + rw [degreeTwoExponentEmbedding_apply] + exact (degreeTwoExponentPair_lt_cutoff m (1 * n)).trans + (degreeTwoCutoff_neg m) + have heq := hcoeff (degreeTwoExponentEmbedding (toLex (m, 1 * n))) + hdeltaEta hdelta0 + change (degreeTwoSeries (K := K)).coeff + (degreeTwoExponentEmbedding (toLex (m, 1 * n))) = 0 at heq + rw [degreeTwoSeries_coeff_embedding (K := K)] at heq + exact one_ne_zero heq + +theorem degreeTwoNonpositive_irreducible [CharZero K] : + Irreducible (degreeTwoNonpositive (K := K)) := by + apply PommersheimShahriari.irreducible_of_two_lt_rank_translatedTruncationSpan + (degreeTwoNonpositive_not_mem_nearConstantSubgroup (K := K)) + · left + change (degreeTwoSeries (K := K)).supportOrderType = _ + exact degreeTwoSeries_supportOrderType (K := K) + · exact two_lt_rank_degreeTwo_translatedTruncationSpan (K := K) + +/-- The degree-two witness with constant coefficient one. -/ +def degreeTwoWithConstant : Berarducci.Series K := + degreeTwoNonpositive (K := K) + HahnSeries.Nonpositive.C 1 + +theorem degreeTwoWithConstant_coe : + ((degreeTwoWithConstant (K := K) : Berarducci.Series K) : K⟦ℝ⟧) = + degreeTwoSeries (K := K) + HahnSeries.C 1 := by + rw [degreeTwoWithConstant, Subring.coe_add, HahnSeries.Nonpositive.coe_C] + rfl + +theorem degreeTwoWithConstant_coeff_embedding (m n : ℕ) : + ((degreeTwoWithConstant (K := K) : Berarducci.Series K) : K⟦ℝ⟧).coeff + (degreeTwoExponentEmbedding (toLex (m, n))) = 1 := by + rw [degreeTwoWithConstant_coe (K := K), HahnSeries.coeff_add, + degreeTwoSeries_coeff_embedding (K := K), HahnSeries.C_apply] + have hpair : degreeTwoExponentPair (m, n) ≠ 0 := + ((degreeTwoExponentPair_lt_cutoff m n).trans (by + rw [degreeTwoCutoff_apply] + exact neg_neg_of_pos (by positivity))).ne + simp [hpair] + +@[simp] +theorem degreeTwoWithConstant_coeff_zero : + ((degreeTwoWithConstant (K := K) : Berarducci.Series K) : K⟦ℝ⟧).coeff 0 = 1 := by + rw [degreeTwoWithConstant_coe (K := K), HahnSeries.coeff_add, + degreeTwoSeries_coeff_zero, HahnSeries.C_apply] + simp + +theorem degreeTwoWithConstant_coeff_eq_zero {x : ℝ} + (hrange : x ∉ Set.range degreeTwoExponentEmbedding) (hx0 : x ≠ 0) : + ((degreeTwoWithConstant (K := K) : Berarducci.Series K) : K⟦ℝ⟧).coeff x = 0 := by + rw [degreeTwoWithConstant_coe (K := K), HahnSeries.coeff_add] + simp only [HahnSeries.C_apply, HahnSeries.coeff_single, ite_eq_right hx0, add_zero] + rw [← not_ne_iff, ← HahnSeries.mem_support, degreeTwoSeries_support (K := K)] + exact hrange + +/-- The constant term together with the explicit two-dimensional exponent range is the whole +support of the degree-two witness. -/ +theorem degreeTwoWithConstant_support : + ((degreeTwoWithConstant (K := K) : Berarducci.Series K) : K⟦ℝ⟧).support = + Set.range degreeTwoExponentEmbedding ∪ {0} := by + ext x + constructor + · intro hx + by_cases hrange : x ∈ Set.range degreeTwoExponentEmbedding + · exact Set.mem_union_left _ hrange + · by_cases hx0 : x = 0 + · exact Set.mem_union_right _ (Set.mem_singleton_iff.mpr hx0) + · have hzero := degreeTwoWithConstant_coeff_eq_zero (K := K) hrange hx0 + rw [HahnSeries.mem_support] at hx + exact (hx hzero).elim + · intro hx + rcases hx with hrange | hx0 + · obtain ⟨p, rfl⟩ := hrange + rcases p with ⟨m, n⟩ + change ((degreeTwoWithConstant (K := K) : Berarducci.Series K) : K⟦ℝ⟧).coeff + (degreeTwoExponentEmbedding (toLex (m, n))) ≠ 0 + rw [degreeTwoWithConstant_coeff_embedding] + exact one_ne_zero + · have hx : x = 0 := by simpa using hx0 + subst x + rw [HahnSeries.mem_support, degreeTwoWithConstant_coeff_zero] + exact one_ne_zero + +theorem degreeTwoWithConstant_constantCoeff : + HahnSeries.Nonpositive.constantCoeff (degreeTwoWithConstant (K := K)) = 1 := by + rw [HahnSeries.Nonpositive.constantCoeff_apply, degreeTwoWithConstant_coe (K := K), + HahnSeries.coeff_add, degreeTwoSeries_coeff_zero, HahnSeries.C_apply] + simp + +private theorem degreeTwoSeries_supportBelow_C_one : + HahnSeries.SupportBelow (degreeTwoSeries (K := K)) (HahnSeries.C 1) := by + rw [HahnSeries.supportBelow_iff] + intro i hi j hj + rw [degreeTwoSeries_support (K := K)] at hi + obtain ⟨p, rfl⟩ := hi + rw [HahnSeries.C_apply] at hj + have hj0 : j = 0 := HahnSeries.eq_of_mem_support_single hj + subst j + rcases p with ⟨m, n⟩ + exact (degreeTwoExponentPair_lt_cutoff m n).trans (degreeTwoCutoff_neg m) +theorem degreeTwoWithConstant_supportOrderType : + ((degreeTwoWithConstant (K := K) : Berarducci.Series K) : K⟦ℝ⟧).supportOrderType = + Ordinal.omega0 ^ (2 : Ordinal) + 1 := by + apply (HahnSeries.supportOrderType_eq_add_iff _ _ _).mpr + refine ⟨degreeTwoSeries (K := K), HahnSeries.C 1, + degreeTwoSeries_supportBelow_C_one (K := K), degreeTwoSeries_supportOrderType (K := K), + ?_, ?_⟩ + · rw [HahnSeries.C_apply, HahnSeries.supportOrderType_single one_ne_zero] + · exact degreeTwoWithConstant_coe (K := K) + +theorem degreeTwoWithConstant_not_mem_nearConstantSubgroup : + degreeTwoWithConstant (K := K) ∉ Berarducci.nearConstantSubgroup K := by + intro hnear + have hconstant : HahnSeries.Nonpositive.C (1 : K) ∈ + Berarducci.nearConstantSubgroup K := by + rw [Berarducci.mem_nearConstantSubgroup_iff] + exact ⟨0, (HahnSeries.Nonpositive.negativeMonomialIdeal K).zero_mem, + 1, zero_add _⟩ + apply degreeTwoNonpositive_not_mem_nearConstantSubgroup (K := K) + have hsub := (Berarducci.nearConstantSubgroup K).sub_mem hnear hconstant + simpa [degreeTwoWithConstant] using hsub + +private theorem translatedTruncation_C_one_eq_zero {x : ℝ} (hx : x < 0) : + Berarducci.translatedTruncation (HahnSeries.C (1 : K)) x = 0 := by + apply Subtype.ext + apply HahnSeries.coeff_injective + funext delta + rw [Berarducci.coeff_translatedTruncation] + by_cases hdelta : delta ≤ 0 + · rw [ite_eq_left hdelta, HahnSeries.C_apply] + have hsum : x + delta ≠ 0 := ne_of_lt (add_neg_of_neg_of_nonpos hx hdelta) + simp [hsum] + · rw [ite_eq_right hdelta] + rfl + +theorem degreeTwoWithConstant_translatedTruncationClass_eq_block (m : ℕ) : + PommersheimShahriari.translatedTruncationClass + (degreeTwoWithConstant (K := K) : K⟦ℝ⟧) (degreeTwoCutoff m) = + PommersheimShahriari.toSeriesQuotientByJAddConstants (degreeTwoBlock (K := K) m) := by + rw [PommersheimShahriari.translatedTruncationClass_apply] + rw [degreeTwoWithConstant_coe (K := K)] + rw [Berarducci.translatedTruncation_add, + translatedTruncation_C_one_eq_zero (degreeTwoCutoff_neg m), add_zero] + simpa only [PommersheimShahriari.translatedTruncationClass_apply] using + degreeTwo_translatedTruncationClass_eq_block (K := K) m + +theorem degreeTwoWithConstant_translatedTruncationClass_mem_translatedTruncationSpan (i : Fin 3) : + degreeTwoTranslatedTruncationClass (K := K) i ∈ + PommersheimShahriari.translatedTruncationSpan (degreeTwoWithConstant (K := K)) := by + have h := PommersheimShahriari.translatedTruncationClass_mem_translatedTruncationSpan + (degreeTwoWithConstant (K := K)) (degreeTwoCutoff_neg i) + rw [degreeTwoWithConstant_translatedTruncationClass_eq_block (K := K)] at h + exact h + +/-- The three row classes in the constant-one witness's translated-truncation span. -/ +def degreeTwoWithConstantTranslatedTruncationSpanVector (i : Fin 3) : + PommersheimShahriari.translatedTruncationSpan (degreeTwoWithConstant (K := K)) := + ⟨degreeTwoTranslatedTruncationClass (K := K) i, + degreeTwoWithConstant_translatedTruncationClass_mem_translatedTruncationSpan (K := K) i⟩ + +theorem degreeTwoWithConstant_two_lt_rank_translatedTruncationSpan : + (2 : Cardinal) < Module.rank K + (PommersheimShahriari.translatedTruncationSpan (degreeTwoWithConstant (K := K))) := by + have hli : LinearIndependent K + (degreeTwoWithConstantTranslatedTruncationSpanVector (K := K)) := by + apply LinearIndependent.of_comp + (PommersheimShahriari.translatedTruncationSpan (degreeTwoWithConstant (K := K))).subtype + simpa [Function.comp_def, degreeTwoWithConstantTranslatedTruncationSpanVector] using + (degreeTwoTranslatedTruncationClass_linearIndependent (K := K)) + have h := hli.cardinal_lift_le_rank + simp only [Cardinal.mk_fintype, Fintype.card_fin, Cardinal.lift_natCast, + Cardinal.lift_id'] at h + exact (by norm_num : (2 : Cardinal) < 3).trans_le h +theorem degreeTwoWithConstant_irreducible [CharZero K] : + Irreducible (degreeTwoWithConstant (K := K)) := by + apply PommersheimShahriari.irreducible_of_two_lt_rank_translatedTruncationSpan + (degreeTwoWithConstant_not_mem_nearConstantSubgroup (K := K)) + · exact Or.inr (degreeTwoWithConstant_supportOrderType (K := K)) + · exact degreeTwoWithConstant_two_lt_rank_translatedTruncationSpan (K := K) + + +/-- Coefficient maps along a field homomorphism out of `ℝ` carry the degree-two series with +constant term over `ℝ` to the same series over the target field: all its coefficients are `0` or +`1`. -/ +theorem nonpositiveCoefficientMap_degreeTwoWithConstant {E : Type*} [Field E] (f : ℝ →+* E) : + HahnSeries.Nonpositive.nonpositiveCoefficientMap f (degreeTwoWithConstant (K := ℝ)) = + degreeTwoWithConstant (K := E) := by + apply Subtype.ext + apply HahnSeries.coeff_injective + funext x + rw [HahnSeries.Nonpositive.coe_nonpositiveCoefficientMap] + by_cases hx : x ∈ Set.range degreeTwoExponentEmbedding + · obtain ⟨p, rfl⟩ := hx + rcases p with ⟨m, n⟩ + have hR := degreeTwoWithConstant_coeff_embedding (K := ℝ) m n + have hE := degreeTwoWithConstant_coeff_embedding (K := E) m n + rw [degreeTwoExponentEmbedding_apply] at hR hE + change f (((degreeTwoWithConstant (K := ℝ) : Berarducci.Series ℝ) : ℝ⟦ℝ⟧).coeff + (degreeTwoExponentPair (m, n))) = + ((degreeTwoWithConstant (K := E) : Berarducci.Series E) : E⟦ℝ⟧).coeff + (degreeTwoExponentPair (m, n)) + rw [hR, hE, map_one] + · by_cases hx0 : x = 0 + · subst hx0 + rw [degreeTwoWithConstant_coeff_zero, degreeTwoWithConstant_coeff_zero, map_one] + · rw [degreeTwoWithConstant_coeff_eq_zero hx hx0, + degreeTwoWithConstant_coeff_eq_zero hx hx0, map_zero] + +end PommersheimShahriari.DegreeTwoExample diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/DegreeTwo/Factorization.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/DegreeTwo/Factorization.lean new file mode 100644 index 0000000000..1f2da741c2 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/DegreeTwo/Factorization.lean @@ -0,0 +1,143 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.CriticalPointExistence + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValueDegree +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Statements.ProductValue + +/-! +# Factorisations of series of ordinal value omega squared + +This module begins the proof of Pommersheim--Shahriari, Lemma 3.1. If a product has Berarducci +ordinal value `ω²`, the values of its ordered factors are either `1` and `ω²`, or `ω` and +`ω`. For a degree-two series whose negative translated truncations all have value below `ω²`, +Berarducci's critical-product formula then forces the two critical points to be zero. + +The remaining support-theoretic step—turning critical point zero into the precise factor order +types printed in PS06—is kept separate rather than hidden in the ordinal calculation. + +## References + +* J. Pommersheim, S. Shahriari, *Unique factorization in generalized power series rings*, +Proc. Amer. Math. Soc. 134 (2006), 1277–1287, cited as [PS06]. +-/ + +universe v + +open scoped HahnSeries NatOrdinal + +public noncomputable section + +namespace PommersheimShahriari + +open Berarducci HahnSeries Ordinal + +variable {K : Type v} [Field K] [CharZero K] + +omit [CharZero K] in +private theorem ordinalValue_ne_zero_of_mul_eq_wpow_two_left + {b c : Series K} (h : ordinalValue b * ordinalValue c = ω^ (2 : NatOrdinal)) : + ordinalValue b ≠ 0 := by + intro hb + rw [hb, zero_mul] at h + exact (NatOrdinal.wpow_ne_zero 2) h.symm + +omit [CharZero K] in +/-- PS06, Lemma 3.1, ordinal factorisation step: an ordered factorisation of value `ω²` +has factor values `1` and `ω²`, or two factor values `ω`. -/ +theorem ordinalValue_factors_of_mul_eq_wpow_two + {b c : Series K} + (hmul : ordinalValue b * ordinalValue c = ω^ (2 : NatOrdinal)) + (hle : ordinalValue b ≤ ordinalValue c) : + (ordinalValue b = 1 ∧ ordinalValue c = ω^ (2 : NatOrdinal)) ∨ + (ordinalValue b = ω^ (1 : NatOrdinal) ∧ + ordinalValue c = ω^ (1 : NatOrdinal)) := by + have hbNe := ordinalValue_ne_zero_of_mul_eq_wpow_two_left hmul + have hcNe : ordinalValue c ≠ 0 := by + intro hc + rw [hc, mul_zero] at hmul + exact (NatOrdinal.wpow_ne_zero 2) hmul.symm + have hbDegreeNe : ordinalValueDegree b ≠ ⊥ := fun hbot ↦ + hbNe (ordinalValue_eq_zero_iff.mpr (ordinalValueDegree_eq_bot_iff.mp hbot)) + have hcDegreeNe : ordinalValueDegree c ≠ ⊥ := fun hbot ↦ + hcNe (ordinalValue_eq_zero_iff.mpr (ordinalValueDegree_eq_bot_iff.mp hbot)) + let d := (ordinalValueDegree b).unbot hbDegreeNe + let e := (ordinalValueDegree c).unbot hcDegreeNe + have hdDegree : ordinalValueDegree b = (d : WithBot NatOrdinal) := + (WithBot.coe_unbot _ hbDegreeNe).symm + have heDegree : ordinalValueDegree c = (e : WithBot NatOrdinal) := + (WithBot.coe_unbot _ hcDegreeNe).symm + have hbValue : ordinalValue b = ω^ d := + (ordinalValueDegree_eq_coe_iff b d).mp hdDegree + have hcValue : ordinalValue c = ω^ e := + (ordinalValueDegree_eq_coe_iff c e).mp heDegree + have hde : d + e = 2 := by + rw [hbValue, hcValue, ← NatOrdinal.wpow_add] at hmul + exact NatOrdinal.wpow_inj.mp hmul + have hdele : d ≤ e := by + rw [hbValue, hcValue, NatOrdinal.wpow_le_wpow] at hle + exact hle + rcases eq_or_ne d 0 with hd | hd + · left + have he : e = 2 := by simpa [hd] using hde + rw [hd] at hbValue + rw [he] at hcValue + exact ⟨by simpa only [NatOrdinal.wpow_zero] using hbValue, hcValue⟩ + · right + have hdOne : 1 ≤ d := Order.one_le_iff_pos.mpr (pos_iff_ne_zero.mpr hd) + have heOne : 1 ≤ e := hdOne.trans hdele + have heLe : e ≤ 1 := by + apply (add_le_add_iff_left (a := (1 : NatOrdinal))).mp + calc + 1 + e ≤ d + e := add_le_add hdOne le_rfl + _ = 1 + 1 := hde.trans (one_add_one_eq_two (R := NatOrdinal)).symm + have he : e = 1 := le_antisymm heLe heOne + have hdLe : d ≤ 1 := hdele.trans heLe + have hdEq : d = 1 := le_antisymm hdLe hdOne + rw [hdEq] at hbValue + rw [he] at hcValue + simpa using ⟨hbValue, hcValue⟩ + +/-- In the PS06 degree-two situation, critical points of both factors must be zero once negative +translated truncations of the product all have value below `ω²`. -/ +theorem criticalPoints_eq_zero_of_product_wpow_two + {a b c : Series K} {x y : ℝ} + (habc : a = b * c) + (haValue : ordinalValue a = ω^ (2 : NatOrdinal)) + (haNegative : ∀ u : ℝ, u < 0 → + ordinalValue (translatedTruncation (a : K⟦ℝ⟧) u) < ω^ (2 : NatOrdinal)) + (hx : IsCriticalPoint b x) (hy : IsCriticalPoint c y) : + x = 0 ∧ y = 0 := by + have hbLe : ordinalValue b ≤ + ordinalValue (translatedTruncation (b : K⟦ℝ⟧) x) := by + simpa using hx.value_le 0 le_rfl + have hcLe : ordinalValue c ≤ + ordinalValue (translatedTruncation (c : K⟦ℝ⟧) y) := by + simpa using hy.value_le 0 le_rfl + have hcriticalLower : ω^ (2 : NatOrdinal) ≤ + ordinalValue (translatedTruncation (a : K⟦ℝ⟧) (x + y)) := by + calc + ω^ (2 : NatOrdinal) = ordinalValue a := haValue.symm + _ = ordinalValue b * ordinalValue c := by rw [habc, ordinalValue_mul] + _ ≤ ordinalValue (translatedTruncation (b : K⟦ℝ⟧) x) * + ordinalValue (translatedTruncation (c : K⟦ℝ⟧) y) := + mul_le_mul hbLe hcLe bot_le bot_le + _ = ordinalValue (translatedTruncation (a : K⟦ℝ⟧) (x + y)) := by + rw [habc, criticalPoint_product_value hx hy] + have hsumNonnegative : 0 ≤ x + y := by + apply le_of_not_gt + intro hnegative + exact (not_lt_of_ge hcriticalLower) (by + simpa [habc] using haNegative (x + y) hnegative) + have hsum : x + y = 0 := le_antisymm (add_nonpos hx.nonpositive hy.nonpositive) + hsumNonnegative + have hx0 := hx.nonpositive + have hy0 := hy.nonpositive + constructor <;> linarith + +end PommersheimShahriari diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/DegreeTwo/FactorizationClassification.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/DegreeTwo/FactorizationClassification.lean new file mode 100644 index 0000000000..8b130370e8 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/DegreeTwo/FactorizationClassification.lean @@ -0,0 +1,320 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.DegreeTwo.DegreeTwo + +import Mathlib.Topology.Compactness.Compact +import Mathlib.Topology.Instances.Real.Lemmas +import Mathlib.Topology.Order.OrderClosed +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValueFinalSegment +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValueImage +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValueConstantMul +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Statements.ProductValue + +/-! +# The degree-two factorisation classification + +This module proves Pommersheim--Shahriari, Lemma 3.1. For an ordered factorisation of a series +outside `J + K` whose support has order type `ω²` or `ω² + 1`, either the first factor is a +nonzero constant, or both factors have value `ω` and support order type `ω` or `ω + 1`. + +The final support step is topological. Critical point zero makes every negative translated +truncation of a value-`ω` factor constant modulo `J`. Thus the support is locally finite below +zero; compactness makes each closed negative initial segment finite, forcing order type `ω` with +an optional constant term. + +## References + +* J. Pommersheim, S. Shahriari, *Unique factorization in generalized power series rings*, +Proc. Amer. Math. Soc. 134 (2006), 1277–1287, cited as [PS06]. +-/ + +universe v + +open scoped HahnSeries NatOrdinal Topology + +public noncomputable section + +namespace PommersheimShahriari + +open Berarducci HahnSeries Ordinal + +variable {K : Type v} [Field K] + +private theorem not_accPt_support_of_translatedTruncation_mem_nearConstantSubgroup + {b : Series K} {z : ℝ} + (hzNear : translatedTruncation (b : K⟦ℝ⟧) z ∈ nearConstantSubgroup K) : + ¬ AccPt z (Filter.principal (b : K⟦ℝ⟧).support) := by + have hsub : translatedTruncation (b : K⟦ℝ⟧) z - 0 ∈ nearConstantSubgroup K := by + simpa using hzNear + obtain ⟨η, hη0, hcoeff⟩ := + exists_coeff_eq_of_sub_mem_nearConstantSubgroup hsub + let T : Set ℝ := (b : K⟦ℝ⟧).support ∩ Set.Ioi z + let hT : T.IsWF := (b : K⟦ℝ⟧).isPWO_support.isWF.mono Set.inter_subset_left + have hright : ∃ r : ℝ, z < r ∧ + ∀ w ∈ (b : K⟦ℝ⟧).support, z < w → r ≤ w := by + by_cases hTne : T.Nonempty + · let r := hT.min hTne + have hrT : r ∈ T := hT.min_mem hTne + refine ⟨r, hrT.2, ?_⟩ + intro w hw hzw + exact hT.min_le hTne ⟨hw, hzw⟩ + · refine ⟨z + 1, by linarith, ?_⟩ + intro w hw hzw + exact (hTne ⟨w, hw, hzw⟩).elim + intro hzAcc + rw [accPt_iff_nhds] at hzAcc + obtain ⟨r, hzr, hright⟩ := hright + have hnhds : Set.Ioo (z + η) r ∈ nhds z := Ioo_mem_nhds (by linarith) hzr + obtain ⟨w, ⟨⟨hwLeft, hwRight⟩, hwSupport⟩, hwNe⟩ := hzAcc _ hnhds + rcases lt_or_gt_of_ne hwNe with hwz | hzw + · let δ : ℝ := w - z + have hη0 : η < δ := by dsimp [δ]; linarith + have hδ0 : δ < 0 := by dsimp [δ]; linarith + have hzero := hcoeff δ hη0 hδ0 + rw [coeff_translatedTruncation, ite_eq_left hδ0.le] at hzero + have hcoeffZero : (b : K⟦ℝ⟧).coeff w = 0 := by + simpa [δ] using hzero + exact (HahnSeries.mem_support _ _).mp hwSupport hcoeffZero + · exact (not_lt_of_ge (hright w hwSupport hzw)) hwRight + +/-- A negative translated truncation of a value-`ω` series lies in `J + K` when the series has +critical point zero. -/ +theorem translatedTruncation_mem_nearConstantSubgroup_of_criticalPoint_zero_of_value_omega + {b : Series K} (hbCritical : IsCriticalPoint b 0) + (hbValue : ordinalValue b = ω^ (1 : NatOrdinal)) + {z : ℝ} (hz : z < 0) : + translatedTruncation (b : K⟦ℝ⟧) z ∈ nearConstantSubgroup K := by + have hcriticalValue : + ordinalValue (translatedTruncation (b : K⟦ℝ⟧) 0) = ω^ (1 : NatOrdinal) := by + simpa using hbValue + have hvalueLt : ordinalValue (translatedTruncation (b : K⟦ℝ⟧) z) < + ω^ (1 : NatOrdinal) := by + rw [← hcriticalValue] + apply lt_of_le_of_ne (hbCritical.value_le z hz.le) + intro heq + exact (not_le_of_gt hz) (hbCritical.le_of_value_eq z hz.le heq) + by_contra hnear + have hone : 1 < ordinalValue (translatedTruncation (b : K⟦ℝ⟧) z) := + one_lt_ordinalValue_iff.mpr hnear + have honeVal : (1 : Ordinal) < + (ordinalValue (translatedTruncation (b : K⟦ℝ⟧) z)).val := + NatOrdinal.of_lt_iff.mp hone + have homegaVal : Ordinal.omega0 ≤ + (ordinalValue (translatedTruncation (b : K⟦ℝ⟧) z)).val := + (ordinalValue_isAdditivelyPrincipal_of_one_lt hone).omega0_le_of_one_lt honeVal + have homega : NatOrdinal.of Ordinal.omega0 ≤ + ordinalValue (translatedTruncation (b : K⟦ℝ⟧) z) := + NatOrdinal.of_le_iff.mpr homegaVal + have homega' : ω^ (1 : NatOrdinal) ≤ + ordinalValue (translatedTruncation (b : K⟦ℝ⟧) z) := by + convert homega using 1 + apply NatOrdinal.val.injective + simp only [NatOrdinal.val_wpow, NatOrdinal.val_one, NatOrdinal.val_of, + Ordinal.opow_one] + exact (not_lt_of_ge homega') hvalueLt + +/-- If a factor has value one and critical point zero, it is a constant series. -/ +theorem mem_constantSubgroup_of_ordinalValue_one_of_criticalPoint_zero + {b : Series K} (hbValue : ordinalValue b = 1) + (hbCritical : IsCriticalPoint b 0) : + b ∈ constantSubgroup K := by + have hsupport : (b : K⟦ℝ⟧).support ⊆ {0} := by + intro z hz + have hz0 := HahnSeries.Nonpositive.support_subset b hz + by_cases hzero : z = 0 + · simp [hzero] + · have hzNeg : z < 0 := lt_of_le_of_ne hz0 hzero + have hcriticalValue : + ordinalValue (translatedTruncation (b : K⟦ℝ⟧) 0) = 1 := by + simpa using hbValue + have hvalueLt : ordinalValue (translatedTruncation (b : K⟦ℝ⟧) z) < 1 := by + rw [← hcriticalValue] + apply lt_of_le_of_ne (hbCritical.value_le z hz0) + intro heq + exact (not_le_of_gt hzNeg) (hbCritical.le_of_value_eq z hz0 heq) + have hvalueZero : ordinalValue (translatedTruncation (b : K⟦ℝ⟧) z) = 0 := by + rwa [Order.lt_one_iff] at hvalueLt + exact (ne_of_gt (ordinalValue_translatedTruncation_pos_of_mem_support hz) hvalueZero).elim + apply mem_constantSubgroup_iff.mpr + refine ⟨HahnSeries.Nonpositive.constantCoeff b, ?_⟩ + apply Subtype.ext + ext z + by_cases hz : z = 0 + · subst z + simp [HahnSeries.Nonpositive.constantCoeff_apply] + · have hzSupport : z ∉ (b : K⟦ℝ⟧).support := fun hmem ↦ + hz (Set.mem_singleton_iff.mp (hsupport hmem)) + rw [HahnSeries.mem_support] at hzSupport + rw [not_ne_iff.mp hzSupport] + simp [hz] + +private theorem supportOrderType_eq_omega_or_omega_add_one_of_ordinalValue_omega_criticalPoint_zero + {b : Series K} (hbValue : ordinalValue b = ω^ (1 : NatOrdinal)) + (hbCritical : IsCriticalPoint b 0) : + (b : K⟦ℝ⟧).supportOrderType = Ordinal.omega0 ∨ + (b : K⟦ℝ⟧).supportOrderType = Ordinal.omega0 + 1 := by + let S : Set ℝ := (b : K⟦ℝ⟧).support ∩ Set.Iio 0 + let hS : S.IsPWO := (b : K⟦ℝ⟧).isPWO_support.mono Set.inter_subset_left + have hIicFinite : ∀ x ∈ S, (S ∩ Set.Iic x).Finite := by + intro x hx + let I : Set ℝ := S ∩ Set.Iic x + let hI : I.IsPWO := hS.mono Set.inter_subset_left + by_cases hIne : I.Nonempty + · let m := hI.isWF.min hIne + have hmI : m ∈ I := hI.isWF.min_mem hIne + by_contra hIfinite + have hIsub : I ⊆ Set.Icc m x := by + intro y hy + exact ⟨hI.isWF.min_le hIne hy, hy.2⟩ + obtain ⟨z, hzIcc, hzAcc⟩ := + (show I.Infinite from hIfinite).exists_accPt_of_subset_isCompact + isCompact_Icc hIsub + have hzNeg : z < 0 := hzIcc.2.trans_lt hx.2 + have hzNear := + translatedTruncation_mem_nearConstantSubgroup_of_criticalPoint_zero_of_value_omega + hbCritical hbValue hzNeg + apply not_accPt_support_of_translatedTruncation_mem_nearConstantSubgroup hzNear + exact hzAcc.mono (Filter.principal_mono.mpr fun y hy ↦ hy.1.1) + · change I.Finite + rw [Set.not_nonempty_iff_eq_empty.mp hIne] + exact Set.finite_empty + have hSle : hS.orderType ≤ Ordinal.omega0 := by + apply hS.orderType_le_of_forall_inter_Iic_lt + intro x hx + exact Set.IsPWO.finite_iff_orderType_lt_omega + (hS.mono (s := S ∩ Set.Iic x) Set.inter_subset_left) |>.mp (hIicFinite x hx) + have hSLUB : IsLUB S 0 := by + apply isLUB_negativeSupport_zero_of_one_lt_ordinalValue + rw [hbValue] + apply NatOrdinal.val.lt_iff_lt.mpr + simp only [NatOrdinal.val_one, Ordinal.opow_one] + exact Ordinal.one_lt_omega0 + have hSne : S.Nonempty := by + obtain ⟨x, hx, -, -⟩ := hSLUB.exists_between (show (-1 : ℝ) < 0 by norm_num) + exact ⟨x, hx⟩ + have hSgt : ∀ x ∈ S, ∃ y ∈ S, x < y := by + intro x hx + obtain ⟨y, hy, hxy, -⟩ := hSLUB.exists_between hx.2 + exact ⟨y, hy, hxy⟩ + have hSlimit : Order.IsSuccLimit hS.orderType := + hS.isSuccLimit_orderType_of_forall_exists_gt hSne hSgt + have hSType : hS.orderType = Ordinal.omega0 := + le_antisymm hSle (Ordinal.omega0_le_of_isSuccLimit hSlimit) + have htruncSupport : + (HahnSeries.truncLT 0 (b : K⟦ℝ⟧)).support = S := by + rw [HahnSeries.support_truncLT] + rfl + have htruncType : + (HahnSeries.truncLT 0 (b : K⟦ℝ⟧)).supportOrderType = Ordinal.omega0 := by + rw [HahnSeries.supportOrderType_eq_setOrderType] + exact ((HahnSeries.truncLT 0 (b : K⟦ℝ⟧)).isPWO_support.orderType_congr + hS htruncSupport).trans hSType + have hge : HahnSeries.truncGE 0 (b : K⟦ℝ⟧) = + HahnSeries.single 0 ((b : K⟦ℝ⟧).coeff 0) := by + ext x + rcases lt_trichotomy x 0 with hx | rfl | hx + · simp [HahnSeries.coeff_truncGE, not_le_of_gt hx, hx.ne] + · simp + · have hcoeff : (b : K⟦ℝ⟧).coeff x = 0 := by + apply not_ne_iff.mp + rw [← HahnSeries.mem_support] + exact fun hmem ↦ (not_le_of_gt hx) + (HahnSeries.Nonpositive.support_subset b hmem) + simp [HahnSeries.coeff_truncGE, hx.le, hcoeff, hx.ne'] + have hsplit := HahnSeries.supportOrderType_eq_truncLT_add_truncGE + 0 (b : K⟦ℝ⟧) + by_cases hzero : 0 ∈ (b : K⟦ℝ⟧).support + · right + have hcoeff : (b : K⟦ℝ⟧).coeff 0 ≠ 0 := + (HahnSeries.mem_support _ _).mp hzero + have hgeType : + (HahnSeries.truncGE 0 (b : K⟦ℝ⟧)).supportOrderType = 1 := by + rw [hge] + exact HahnSeries.supportOrderType_single hcoeff + rw [htruncType, hgeType] at hsplit + exact hsplit + · left + have hcoeff : (b : K⟦ℝ⟧).coeff 0 = 0 := by + rw [HahnSeries.mem_support] at hzero + exact not_ne_iff.mp hzero + have hgeType : + (HahnSeries.truncGE 0 (b : K⟦ℝ⟧)).supportOrderType = 0 := by + rw [hge] + simp [hcoeff] + rw [htruncType, hgeType, add_zero] at hsplit + exact hsplit + +/-- PS06, Lemma 3.1: an ordered factorisation of a degree-two series has either a nonzero +constant first factor, or two factors of value `ω` and support order type `ω` or `ω + 1`. -/ +theorem factorization_cases_of_supportOrderType_wpow_two + [CharZero K] {a b c : Series K} + (haNear : a ∉ nearConstantSubgroup K) + (haType : (a : K⟦ℝ⟧).supportOrderType = + (Ordinal.omega0 ^ (2 : Ordinal)) ∨ + (a : K⟦ℝ⟧).supportOrderType = + Ordinal.omega0 ^ (2 : Ordinal) + 1) + (habc : a = b * c) (hle : ordinalValue b ≤ ordinalValue c) : + (∃ k : K, k ≠ 0 ∧ b = HahnSeries.Nonpositive.C k ∧ + c = HahnSeries.Nonpositive.C k⁻¹ * a ∧ + (c : K⟦ℝ⟧).supportOrderType = (a : K⟦ℝ⟧).supportOrderType) ∨ + (((b : K⟦ℝ⟧).supportOrderType = Ordinal.omega0 ∨ + (b : K⟦ℝ⟧).supportOrderType = Ordinal.omega0 + 1) ∧ + ((c : K⟦ℝ⟧).supportOrderType = Ordinal.omega0 ∨ + (c : K⟦ℝ⟧).supportOrderType = Ordinal.omega0 + 1) ∧ + ordinalValue b = ω^ (1 : NatOrdinal) ∧ + ordinalValue c = ω^ (1 : NatOrdinal)) := by + have haNe : a ≠ 0 := by + intro ha + apply haNear + rw [ha] + exact (nearConstantSubgroup K).zero_mem + have hbNe : b ≠ 0 := by + intro hb + apply haNe + rw [habc, hb, zero_mul] + have hcNe : c ≠ 0 := by + intro hc + apply haNe + rw [habc, hc, mul_zero] + obtain ⟨x, hx⟩ := exists_isCriticalPoint hbNe + obtain ⟨y, hy⟩ := exists_isCriticalPoint hcNe + have haValue : ordinalValue a = ω^ (2 : NatOrdinal) := + ordinalValue_eq_wpow_two haNear haType + have haNegative : ∀ u : ℝ, u < 0 → + ordinalValue (translatedTruncation (a : K⟦ℝ⟧) u) < ω^ (2 : NatOrdinal) := + fun _ hu ↦ ordinalValue_translatedTruncation_lt_wpow_two haNear haType hu + have hmulValue : ordinalValue b * ordinalValue c = ω^ (2 : NatOrdinal) := by + rw [← ordinalValue_mul, ← habc, haValue] + have hcritical := criticalPoints_eq_zero_of_product_wpow_two + habc haValue haNegative hx hy + obtain ⟨rfl, rfl⟩ := hcritical + rcases ordinalValue_factors_of_mul_eq_wpow_two hmulValue hle with + hconstant | hbalanced + · left + have hbConstant := + mem_constantSubgroup_of_ordinalValue_one_of_criticalPoint_zero hconstant.1 hx + obtain ⟨k, hk⟩ := mem_constantSubgroup_iff.mp hbConstant + have hkNe : k ≠ 0 := by + intro hkZero + apply hbNe + rw [← hk, hkZero] + simp + have hbc : b = HahnSeries.Nonpositive.C k := hk.symm + have hc : c = HahnSeries.Nonpositive.C k⁻¹ * a := by + rw [habc, hbc] + rw [← mul_assoc, ← map_mul, inv_mul_cancel₀ hkNe, map_one, one_mul] + refine ⟨k, hkNe, hbc, hc, ?_⟩ + rw [habc, hbc, supportOrderType_C_mul_of_ne_zero hkNe] + · right + exact ⟨supportOrderType_eq_omega_or_omega_add_one_of_ordinalValue_omega_criticalPoint_zero + hbalanced.1 hx, + supportOrderType_eq_omega_or_omega_add_one_of_ordinalValue_omega_criticalPoint_zero + hbalanced.2 hy, + hbalanced⟩ + +end PommersheimShahriari diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/DegreeTwo/TranslatedSpanFactorization.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/DegreeTwo/TranslatedSpanFactorization.lean new file mode 100644 index 0000000000..51409ee60f --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/DegreeTwo/TranslatedSpanFactorization.lean @@ -0,0 +1,442 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.DegreeTwo.FactorizationClassification +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.DegreeTwo.TranslatedTruncationSpan +public import Mathlib.LinearAlgebra.Dimension.Finrank + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Convolution +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Monomial +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Statements.ProductValue +import Mathlib.LinearAlgebra.Dimension.Constructions +import Mathlib.Topology.Instances.Real.Lemmas +import Mathlib.Topology.Order.OrderClosed + +/-! +# Translated-truncation spans of degree-two factorisations + +This module proves the part of Pommersheim--Shahriari, Proposition 3.2 used by their first +irreducibility criterion. If two nonpositive Hahn series have ordinal value `ω`, with critical +point zero, each negative translated-truncation class of their product is a coefficient-weighted +sum of the two factor classes modulo `J + K`. Consequently `V(bc)` has dimension at most two. + +Combining that bound with PS06, Lemma 3.1 gives Corollary 3.3: a series outside `J + K`, with +support order type `ω²` or `ω² + 1`, is irreducible whenever `dim V(a) > 2`. + +## References + +* J. Pommersheim, S. Shahriari, *Unique factorization in generalized power series rings*, +Proc. Amer. Math. Soc. 134 (2006), 1277–1287, cited as [PS06]. +-/ + +universe v + +open scoped Cardinal HahnSeries NatOrdinal + +public noncomputable section + +namespace PommersheimShahriari + +open Berarducci HahnSeries Ordinal + +variable {K : Type v} [Field K] + +private theorem toSeriesQuotientByJAddConstants_mul_eq_smul_of_sub_C_mem_negativeMonomialIdeal + {p q : Series K} {k : K} + (hp : p - HahnSeries.Nonpositive.C k ∈ + HahnSeries.Nonpositive.negativeMonomialIdeal K) : + toSeriesQuotientByJAddConstants (p * q) = k • toSeriesQuotientByJAddConstants q := by + rw [← map_smul toSeriesQuotientByJAddConstants] + change toSeriesQuotientByJAddConstants (p * q) = + toSeriesQuotientByJAddConstants (HahnSeries.Nonpositive.C k * q) + rw [toSeriesQuotientByJAddConstants_eq_iff] + have hJ : p * q - HahnSeries.Nonpositive.C k * q ∈ + HahnSeries.Nonpositive.negativeMonomialIdeal K := by + rw [← sub_mul] + exact Ideal.mul_mem_right q (HahnSeries.Nonpositive.negativeMonomialIdeal K) hp + exact Berarducci.negativeMonomialIdeal_le_nearConstantSubgroup hJ + +private theorem translatedTruncation_sub_C_coeff_mem_negativeMonomialIdeal + {b : Series K} {x : ℝ} + (hnear : translatedTruncation (b : K⟦ℝ⟧) x ∈ nearConstantSubgroup K) : + translatedTruncation (b : K⟦ℝ⟧) x - + HahnSeries.Nonpositive.C ((b : K⟦ℝ⟧).coeff x) ∈ + HahnSeries.Nonpositive.negativeMonomialIdeal K := by + have hJ := mem_nearConstantSubgroup_iff_sub_C_constantCoeff_mem.mp hnear + convert hJ using 1 + congr 2 + rw [HahnSeries.Nonpositive.constantCoeff_apply, coeff_translatedTruncation] + simp + +private theorem toSeriesQuotientByJAddConstants_translatedTruncation_mul_eq_coeff_smul + {b q : Series K} {x : ℝ} + (hnear : translatedTruncation (b : K⟦ℝ⟧) x ∈ nearConstantSubgroup K) : + toSeriesQuotientByJAddConstants (translatedTruncation (b : K⟦ℝ⟧) x * q) = + (b : K⟦ℝ⟧).coeff x • toSeriesQuotientByJAddConstants q := + toSeriesQuotientByJAddConstants_mul_eq_smul_of_sub_C_mem_negativeMonomialIdeal + (translatedTruncation_sub_C_coeff_mem_negativeMonomialIdeal hnear) + +private theorem toSeriesQuotientByJAddConstants_mul_translatedTruncation_eq_coeff_smul + {p b : Series K} {x : ℝ} + (hnear : translatedTruncation (b : K⟦ℝ⟧) x ∈ nearConstantSubgroup K) : + toSeriesQuotientByJAddConstants (p * translatedTruncation (b : K⟦ℝ⟧) x) = + (b : K⟦ℝ⟧).coeff x • toSeriesQuotientByJAddConstants p := by + rw [mul_comm] + exact toSeriesQuotientByJAddConstants_translatedTruncation_mul_eq_coeff_smul hnear + +private theorem translatedTruncationClass_mul_eq_sum (b c : Series K) (x : ℝ) : + translatedTruncationClass (((b * c : Series K) : K⟦ℝ⟧)) x = + ∑ β ∈ convolutionIndex (b : K⟦ℝ⟧) (c : K⟦ℝ⟧) x, + toSeriesQuotientByJAddConstants + (translatedTruncation (b : K⟦ℝ⟧) β * translatedTruncation (c : K⟦ℝ⟧) (x - β)) := by + let s : Series K := ∑ β ∈ convolutionIndex (b : K⟦ℝ⟧) (c : K⟦ℝ⟧) x, + translatedTruncation (b : K⟦ℝ⟧) β * translatedTruncation (c : K⟦ℝ⟧) (x - β) + have hgerm : toGerm (translatedTruncation (((b * c : Series K) : K⟦ℝ⟧)) x) = + toGerm s := by + have hconv := germAt_mul (b : K⟦ℝ⟧) (c : K⟦ℝ⟧) x + simpa only [germAt_apply, s, map_sum, map_mul, Subring.coe_mul] using hconv + have hnear : translatedTruncation (((b * c : Series K) : K⟦ℝ⟧)) x - s ∈ + nearConstantSubgroup K := + negativeMonomialIdeal_le_nearConstantSubgroup (toGerm_eq_toGerm_iff.mp hgerm) + rw [translatedTruncationClass_apply] + calc + toSeriesQuotientByJAddConstants (translatedTruncation (((b * c : Series K) : K⟦ℝ⟧)) x) = + toSeriesQuotientByJAddConstants s := toSeriesQuotientByJAddConstants_eq_iff.mpr hnear + _ = _ := by simp only [s, map_sum] + +/-- PS06, Proposition 3.2(2): at a negative cutoff, the translated-truncation class of a product +of two value-`ω` factors with critical point zero is the coefficient-weighted sum of the two +factor classes modulo `J + K`. -/ +theorem translatedTruncationClass_mul_eq + {b c : Series K} (hbValue : ordinalValue b = ω^ (1 : NatOrdinal)) + (hcValue : ordinalValue c = ω^ (1 : NatOrdinal)) + (hbCritical : IsCriticalPoint b 0) (hcCritical : IsCriticalPoint c 0) + {x : ℝ} (hx : x < 0) : + translatedTruncationClass (((b * c : Series K) : K⟦ℝ⟧)) x = + (c : K⟦ℝ⟧).coeff x • toSeriesQuotientByJAddConstants b + + (b : K⟦ℝ⟧).coeff x • toSeriesQuotientByJAddConstants c := by + classical + rw [translatedTruncationClass_mul_eq_sum] + let T := convolutionIndex (b : K⟦ℝ⟧) (c : K⟦ℝ⟧) x + have hbNear : ∀ {y : ℝ}, y < 0 → + translatedTruncation (b : K⟦ℝ⟧) y ∈ nearConstantSubgroup K := + translatedTruncation_mem_nearConstantSubgroup_of_criticalPoint_zero_of_value_omega + hbCritical hbValue + have hcNear : ∀ {y : ℝ}, y < 0 → + translatedTruncation (c : K⟦ℝ⟧) y ∈ nearConstantSubgroup K := + translatedTruncation_mem_nearConstantSubgroup_of_criticalPoint_zero_of_value_omega + hcCritical hcValue + have hbClosure : closure (b : K⟦ℝ⟧).support ⊆ Set.Iic 0 := + closure_minimal (HahnSeries.Nonpositive.support_subset b) isClosed_Iic + have hcClosure : closure (c : K⟦ℝ⟧).support ⊆ Set.Iic 0 := + closure_minimal (HahnSeries.Nonpositive.support_subset c) isClosed_Iic + have hterm : ∀ β ∈ T, + toSeriesQuotientByJAddConstants + (translatedTruncation (b : K⟦ℝ⟧) β * translatedTruncation (c : K⟦ℝ⟧) (x - β)) = + if β = 0 then + (c : K⟦ℝ⟧).coeff x • toSeriesQuotientByJAddConstants b + else if β = x then + (b : K⟦ℝ⟧).coeff x • toSeriesQuotientByJAddConstants c + else 0 := by + intro β hβ + have hβClosure := mem_convolutionIndex.mp hβ + have hβle : β ≤ 0 := hbClosure hβClosure.1 + have hxβle : x - β ≤ 0 := hcClosure hβClosure.2 + by_cases hβ0 : β = 0 + · subst β + rw [ite_eq_left rfl, _root_.sub_zero, translatedTruncation_zero] + exact toSeriesQuotientByJAddConstants_mul_translatedTruncation_eq_coeff_smul (hcNear hx) + · rw [ite_eq_right hβ0] + by_cases hβx : β = x + · subst β + rw [ite_eq_left rfl, _root_.sub_self, translatedTruncation_zero] + exact toSeriesQuotientByJAddConstants_translatedTruncation_mul_eq_coeff_smul (hbNear hx) + · rw [ite_eq_right hβx] + have hβneg : β < 0 := lt_of_le_of_ne hβle hβ0 + have hxβneg : x - β < 0 := by + apply lt_of_le_of_ne hxβle + intro heq + exact hβx (by linarith) + rw [toSeriesQuotientByJAddConstants_translatedTruncation_mul_eq_coeff_smul (hbNear hβneg)] + rw [toSeriesQuotientByJAddConstants_eq_zero_iff.mpr (hcNear hxβneg), smul_zero] + rw [Finset.sum_congr rfl hterm] + let B := (c : K⟦ℝ⟧).coeff x • toSeriesQuotientByJAddConstants b + let C := (b : K⟦ℝ⟧).coeff x • toSeriesQuotientByJAddConstants c + have hsplit : ∀ β : ℝ, + (if β = 0 then B else if β = x then C else 0) = + (if β = 0 then B else 0) + (if β = x then C else 0) := by + intro β + by_cases hβ0 : β = 0 + · subst β + simp [hx.ne'] + · simp [hβ0] + have hzero : (if 0 ∈ T then B else 0) = B := by + by_cases hxClosure : x ∈ closure (c : K⟦ℝ⟧).support + · rw [ite_eq_left] + exact mem_convolutionIndex.mpr + ⟨hbCritical.mem_closure_support, by simpa using hxClosure⟩ + · have hxSupport : x ∉ (c : K⟦ℝ⟧).support := + fun hmem ↦ hxClosure (subset_closure hmem) + rw [HahnSeries.mem_support, not_ne_iff] at hxSupport + have hnot : 0 ∉ T := by + rw [mem_convolutionIndex] + simp [hxClosure] + simp [hnot, B, hxSupport] + have hxIndex : (if x ∈ T then C else 0) = C := by + by_cases hxClosure : x ∈ closure (b : K⟦ℝ⟧).support + · rw [ite_eq_left] + exact mem_convolutionIndex.mpr + ⟨hxClosure, by simpa using hcCritical.mem_closure_support⟩ + · have hxSupport : x ∉ (b : K⟦ℝ⟧).support := + fun hmem ↦ hxClosure (subset_closure hmem) + rw [HahnSeries.mem_support, not_ne_iff] at hxSupport + have hnot : x ∉ T := by + rw [mem_convolutionIndex] + simp [hxClosure] + simp [hnot, C, hxSupport] + calc + (∑ β ∈ T, if β = 0 then B else if β = x then C else 0) = + (∑ β ∈ T, if β = 0 then B else 0) + + ∑ β ∈ T, if β = x then C else 0 := by + rw [← Finset.sum_add_distrib] + exact Finset.sum_congr rfl fun β _ ↦ hsplit β + _ = (if 0 ∈ T then B else 0) + (if x ∈ T then C else 0) := by simp + _ = B + C := by rw [hzero, hxIndex] + +/-- PS06, Proposition 3.2(5), upper-bound direction: `V(bc)` is contained in the span of the two +factor classes modulo `J + K`. -/ +theorem translatedTruncationSpan_mul_le_span_pair + {b c : Series K} (hbValue : ordinalValue b = ω^ (1 : NatOrdinal)) + (hcValue : ordinalValue c = ω^ (1 : NatOrdinal)) + (hbCritical : IsCriticalPoint b 0) (hcCritical : IsCriticalPoint c 0) : + translatedTruncationSpan (b * c) ≤ + Submodule.span K {toSeriesQuotientByJAddConstants b, toSeriesQuotientByJAddConstants c} := by + rw [translatedTruncationSpan_le_iff] + intro x hx + rw [translatedTruncationClass_mul_eq hbValue hcValue hbCritical hcCritical hx] + apply Submodule.add_mem + · apply Submodule.smul_mem + exact Submodule.subset_span (by simp) + · apply Submodule.smul_mem + exact Submodule.subset_span (by simp) + +/-- PS06, Proposition 3.2(5): a balanced product has translated-truncation-span dimension at most +two. -/ +theorem rank_translatedTruncationSpan_mul_le_two + {b c : Series K} (hbValue : ordinalValue b = ω^ (1 : NatOrdinal)) + (hcValue : ordinalValue c = ω^ (1 : NatOrdinal)) + (hbCritical : IsCriticalPoint b 0) (hcCritical : IsCriticalPoint c 0) : + Module.rank K (translatedTruncationSpan (b * c)) ≤ 2 := by + classical + let s : Set (SeriesQuotientByJAddConstants K) := + {toSeriesQuotientByJAddConstants b, toSeriesQuotientByJAddConstants c} + have hs : s.Finite := (Set.finite_singleton _).insert _ + let : Fintype s := hs.fintype + have hcard : s.toFinset.card ≤ 2 := by + change ({toSeriesQuotientByJAddConstants b, toSeriesQuotientByJAddConstants c} : + Set (SeriesQuotientByJAddConstants K)).toFinset.card ≤ 2 + rw [Set.toFinset_insert, Set.toFinset_singleton] + exact (Finset.card_insert_le _ _).trans (by simp) + calc + Module.rank K (translatedTruncationSpan (b * c)) ≤ + Module.rank K (Submodule.span K s) := + Submodule.rank_mono + (by simpa [s] using + translatedTruncationSpan_mul_le_span_pair hbValue hcValue hbCritical hcCritical) + _ ≤ #s := rank_span_le s + _ ≤ 2 := by + rw [Cardinal.mk_fintype, ← Set.toFinset_card] + exact_mod_cast hcard + +/-- The finite-rank form of PS06, Proposition 3.2(5). -/ +theorem finrank_translatedTruncationSpan_mul_le_two + {b c : Series K} (hbValue : ordinalValue b = ω^ (1 : NatOrdinal)) + (hcValue : ordinalValue c = ω^ (1 : NatOrdinal)) + (hbCritical : IsCriticalPoint b 0) (hcCritical : IsCriticalPoint c 0) : + Module.finrank K (translatedTruncationSpan (b * c)) ≤ 2 := by + classical + let s : Set (SeriesQuotientByJAddConstants K) := + {toSeriesQuotientByJAddConstants b, toSeriesQuotientByJAddConstants c} + have hs : s.Finite := (Set.finite_singleton _).insert _ + let : Fintype s := hs.fintype + let : Module.Finite K + (Submodule.span K s) := Module.Finite.span_of_finite K hs + have hcard : s.toFinset.card ≤ 2 := by + change ({toSeriesQuotientByJAddConstants b, toSeriesQuotientByJAddConstants c} : + Set (SeriesQuotientByJAddConstants K)).toFinset.card ≤ 2 + rw [Set.toFinset_insert, Set.toFinset_singleton] + exact (Finset.card_insert_le _ _).trans (by simp) + calc + Module.finrank K (translatedTruncationSpan (b * c)) ≤ + Module.finrank K (Submodule.span K s) := + Submodule.finrank_mono + (by simpa [s] using + translatedTruncationSpan_mul_le_span_pair hbValue hcValue hbCritical hcCritical) + _ ≤ s.toFinset.card := finrank_span_le_card s + _ ≤ 2 := hcard + +private theorem mem_nearConstantSubgroup_of_isUnit {a : Series K} (ha : IsUnit a) : + a ∈ nearConstantSubgroup K := by + have hsupport := HahnSeries.Nonpositive.support_eq_singleton_zero_of_isUnit ha + have hconstant : HahnSeries.Nonpositive.C + (HahnSeries.Nonpositive.constantCoeff a) = a := by + apply Subtype.ext + apply HahnSeries.coeff_injective + funext x + by_cases hx : x = 0 + · subst x + simp [HahnSeries.Nonpositive.constantCoeff_apply] + · have hxmem : x ∉ (a : K⟦ℝ⟧).support := by + rw [hsupport] + simpa using hx + rw [HahnSeries.mem_support, not_ne_iff] at hxmem + simp [hx, hxmem] + exact Berarducci.mem_nearConstantSubgroup_iff.mpr + ⟨0, (HahnSeries.Nonpositive.negativeMonomialIdeal K).zero_mem, + HahnSeries.Nonpositive.constantCoeff a, by simpa using hconstant⟩ + +/-- PS06, Corollary 3.3: a degree-two series outside `J + K` whose translated-truncation span has +dimension greater than two is irreducible. -/ +@[blueprint "fact:ps06-irreducibility" + (phase := "Primality and factorisation for real exponents") + (title := "Irreducibility from translated truncation dimension") + (statement := /-- + Let $K$ be a field of characteristic $0$ and + $a\in K((\mathbb R^{\le 0}))$. Assume that + \[ + \operatorname{ot}(a)=\omega^2\quad\text{or}\quad + \operatorname{ot}(a)=\omega^2+1, + \] + and that $0$ is an accumulation point of $\operatorname{supp}(a)$, + equivalently $a\notin J+K$. In + $K((\mathbb R^{\le 0}))/(J+K)$, take the $K$-linear span of the classes of + the translated truncations $a^{\vert x}$ for $x<0$. If this span has + dimension greater than $2$, then $a$ is irreducible in + $K((\mathbb R^{\le 0}))$. This is [PS06, Cor. 3.3] (Theorem A). + -/) + (proof := /-- + Suppose that $a=bc$. After exchanging the factors if necessary, the + factorisation classification for these two support order types leaves two + cases: either $b$ is a nonzero constant, or + $v_J(b)=v_J(c)=\omega$. In the second case, multiplicativity of $v_J$ from + \ref{fact:ordinal-value-multiplicativity}, together with the support-tail bound for + negative translated truncations, forces the critical points of $b$ and $c$ to be $0$. + The convolution formula modulo + $J+K$ then writes, for every $x<0$, the class of $a^{\vert x}$ as + \[ + c_x[b]+b_x[c]. + \] + Thus the classes of translated truncations of $a$ lie in the span of $[b]$ and + $[c]$, which has dimension at most $2$, a contradiction. Hence one factor + is a unit, and $a$ is irreducible. + -/)] +theorem irreducible_of_two_lt_rank_translatedTruncationSpan [CharZero K] {a : Series K} + (haNear : a ∉ nearConstantSubgroup K) + (haType : (a : K⟦ℝ⟧).supportOrderType = Ordinal.omega0 ^ (2 : Ordinal) ∨ + (a : K⟦ℝ⟧).supportOrderType = Ordinal.omega0 ^ (2 : Ordinal) + 1) + (haDimension : (2 : Cardinal) < Module.rank K (translatedTruncationSpan a)) : + Irreducible a := by + rw [irreducible_iff] + refine ⟨fun haUnit ↦ haNear (mem_nearConstantSubgroup_of_isUnit haUnit), ?_⟩ + intro b c habc + have haNe : a ≠ 0 := by + intro ha + apply haNear + rw [ha] + exact (nearConstantSubgroup K).zero_mem + have hbNe : b ≠ 0 := by + intro hb + apply haNe + rw [habc, hb, zero_mul] + have hcNe : c ≠ 0 := by + intro hc + apply haNe + rw [habc, hc, mul_zero] + have haValue : ordinalValue a = ω^ (2 : NatOrdinal) := + ordinalValue_eq_wpow_two haNear haType + have haNegative : ∀ u : ℝ, u < 0 → + ordinalValue (translatedTruncation (a : K⟦ℝ⟧) u) < ω^ (2 : NatOrdinal) := + fun _ hu ↦ ordinalValue_translatedTruncation_lt_wpow_two haNear haType hu + have balancedContradiction + (hbValue : ordinalValue b = ω^ (1 : NatOrdinal)) + (hcValue : ordinalValue c = ω^ (1 : NatOrdinal)) : False := by + obtain ⟨x, hx⟩ := exists_isCriticalPoint hbNe + obtain ⟨y, hy⟩ := exists_isCriticalPoint hcNe + obtain ⟨rfl, rfl⟩ := criticalPoints_eq_zero_of_product_wpow_two + habc haValue haNegative hx hy + have hdim : Module.rank K (translatedTruncationSpan a) ≤ 2 := by + rw [habc] + exact rank_translatedTruncationSpan_mul_le_two hbValue hcValue hx hy + exact (not_lt_of_ge hdim) haDimension + rcases le_total (ordinalValue b) (ordinalValue c) with hbc | hcb + · rcases factorization_cases_of_supportOrderType_wpow_two + haNear haType habc hbc with hconstant | hbalanced + · obtain ⟨k, hk, rfl, -⟩ := hconstant + exact Or.inl ((isUnit_iff_ne_zero.mpr hk).map HahnSeries.Nonpositive.C) + · exact (balancedContradiction hbalanced.2.2.1 hbalanced.2.2.2).elim + · have hacb : a = c * b := by simpa [mul_comm] using habc + rcases factorization_cases_of_supportOrderType_wpow_two + haNear haType hacb hcb with hconstant | hbalanced + · obtain ⟨k, hk, rfl, -⟩ := hconstant + exact Or.inr ((isUnit_iff_ne_zero.mpr hk).map HahnSeries.Nonpositive.C) + · exact (balancedContradiction hbalanced.2.2.2 hbalanced.2.2.1).elim + +/-- The finite-rank specialization of PS06, Corollary 3.3. -/ +theorem irreducible_of_two_lt_finrank_translatedTruncationSpan [CharZero K] {a : Series K} + (haNear : a ∉ nearConstantSubgroup K) + (haType : (a : K⟦ℝ⟧).supportOrderType = Ordinal.omega0 ^ (2 : Ordinal) ∨ + (a : K⟦ℝ⟧).supportOrderType = Ordinal.omega0 ^ (2 : Ordinal) + 1) + (haDimension : 2 < Module.finrank K (translatedTruncationSpan a)) : + Irreducible a := by + rw [irreducible_iff] + refine ⟨fun haUnit ↦ haNear (mem_nearConstantSubgroup_of_isUnit haUnit), ?_⟩ + intro b c habc + have haNe : a ≠ 0 := by + intro ha + apply haNear + rw [ha] + exact (nearConstantSubgroup K).zero_mem + have hbNe : b ≠ 0 := by + intro hb + apply haNe + rw [habc, hb, zero_mul] + have hcNe : c ≠ 0 := by + intro hc + apply haNe + rw [habc, hc, mul_zero] + have haValue : ordinalValue a = ω^ (2 : NatOrdinal) := + ordinalValue_eq_wpow_two haNear haType + have haNegative : ∀ u : ℝ, u < 0 → + ordinalValue (translatedTruncation (a : K⟦ℝ⟧) u) < ω^ (2 : NatOrdinal) := + fun _ hu ↦ ordinalValue_translatedTruncation_lt_wpow_two haNear haType hu + have balancedContradiction + (hbValue : ordinalValue b = ω^ (1 : NatOrdinal)) + (hcValue : ordinalValue c = ω^ (1 : NatOrdinal)) : False := by + obtain ⟨x, hx⟩ := exists_isCriticalPoint hbNe + obtain ⟨y, hy⟩ := exists_isCriticalPoint hcNe + obtain ⟨rfl, rfl⟩ := criticalPoints_eq_zero_of_product_wpow_two + habc haValue haNegative hx hy + have hdim : Module.finrank K (translatedTruncationSpan a) ≤ 2 := by + rw [habc] + exact finrank_translatedTruncationSpan_mul_le_two hbValue hcValue hx hy + exact (not_lt_of_ge hdim) haDimension + rcases le_total (ordinalValue b) (ordinalValue c) with hbc | hcb + · rcases factorization_cases_of_supportOrderType_wpow_two + haNear haType habc hbc with hconstant | hbalanced + · obtain ⟨k, hk, rfl, -⟩ := hconstant + exact Or.inl ((isUnit_iff_ne_zero.mpr hk).map HahnSeries.Nonpositive.C) + · exact (balancedContradiction hbalanced.2.2.1 hbalanced.2.2.2).elim + · have hacb : a = c * b := by simpa [mul_comm] using habc + rcases factorization_cases_of_supportOrderType_wpow_two + haNear haType hacb hcb with hconstant | hbalanced + · obtain ⟨k, hk, rfl, -⟩ := hconstant + exact Or.inr ((isUnit_iff_ne_zero.mpr hk).map HahnSeries.Nonpositive.C) + · exact (balancedContradiction hbalanced.2.2.2 hbalanced.2.2.1).elim + +end PommersheimShahriari diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/DegreeTwo/TranslatedTruncationSpan.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/DegreeTwo/TranslatedTruncationSpan.lean new file mode 100644 index 0000000000..91a1253090 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/DegreeTwo/TranslatedTruncationSpan.lean @@ -0,0 +1,132 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Truncation +public import Mathlib.LinearAlgebra.Quotient.Basic + +/-! +# Translated-truncation spans modulo `J + K` in Pommersheim--Shahriari + +Pommersheim--Shahriari [PS06] study the vector space +`K((ℝ⁽≤0⁾)) / (J + K)`. This differs from Berarducci's germ ring, whose denominator is only `J`: +the extra quotient by constant series is essential to their degree-two irreducibility criterion. + +The submodule `nearConstantSubmodule` is proved to have exactly the carrier of Berarducci's +additive subgroup `nearConstantSubgroup`. Thus the two developments use the same `J + K`, while +this module exposes the scalar quotient needed for linear spans and dimensions. + +For a series `a`, `translatedTruncationSpan a` is the space denoted `V(a)` in [PS06]: the +span, modulo `J + K`, of its translated truncations at negative exponents. + +## References + +* J. Pommersheim, S. Shahriari, *Unique factorization in generalized power series rings*, +Proc. Amer. Math. Soc. 134 (2006), 1277–1287, cited as [PS06]. +-/ + +universe v + +public noncomputable section + +namespace PommersheimShahriari + +open HahnSeries + +variable {K : Type v} [Field K] + +/-- Scalar multiplication on nonpositive Hahn series through the constant-series embedding. -/ +instance seriesAlgebra : Algebra K (Berarducci.Series K) := + (HahnSeries.Nonpositive.C : K →+* Berarducci.Series K).toAlgebra + +/-- The constant-series embedding as a linear map. -/ +def constantLinearMap : K →ₗ[K] Berarducci.Series K where + toFun := HahnSeries.Nonpositive.C + map_add' x y := + (HahnSeries.Nonpositive.C : K →+* Berarducci.Series K).map_add x y + map_smul' r x := by + change HahnSeries.Nonpositive.C (r * x) = + HahnSeries.Nonpositive.C r * HahnSeries.Nonpositive.C x + exact (HahnSeries.Nonpositive.C : K →+* Berarducci.Series K).map_mul r x + +/-- The scalar submodule `J + K` of negative-monomial-ideal elements plus constants. -/ +def nearConstantSubmodule (K : Type v) [Field K] : + Submodule K (Berarducci.Series K) := + ((HahnSeries.Nonpositive.negativeMonomialIdeal K : + Submodule (Berarducci.Series K) (Berarducci.Series K)).restrictScalars K) ⊔ + LinearMap.range (constantLinearMap (K := K)) + +/-- The scalar submodule `J + K` has exactly the carrier of Berarducci's additive subgroup with +the same name. -/ +theorem mem_nearConstantSubmodule_iff {b : Berarducci.Series K} : + b ∈ nearConstantSubmodule K ↔ b ∈ Berarducci.nearConstantSubgroup K := by + rw [nearConstantSubmodule, Submodule.mem_sup] + constructor + · rintro ⟨j, hj, c, hc, rfl⟩ + rw [LinearMap.mem_range] at hc + obtain ⟨k, rfl⟩ := hc + exact Berarducci.mem_nearConstantSubgroup_iff.mpr ⟨j, hj, k, rfl⟩ + · intro hb + obtain ⟨j, hj, k, rfl⟩ := Berarducci.mem_nearConstantSubgroup_iff.mp hb + exact ⟨j, hj, HahnSeries.Nonpositive.C k, ⟨k, rfl⟩, rfl⟩ + +/-- The [PS06] vector space `K((ℝ⁽≤0⁾)) / (J + K)`. -/ +abbrev SeriesQuotientByJAddConstants (K : Type v) [Field K] := + Berarducci.Series K ⧸ nearConstantSubmodule K + +/-- The quotient map from nonpositive Hahn series to the quotient by `J + K`. -/ +def toSeriesQuotientByJAddConstants : + Berarducci.Series K →ₗ[K] SeriesQuotientByJAddConstants K := + Submodule.mkQ (nearConstantSubmodule K) + +/-- Two series have the same class modulo `J + K` exactly when their difference lies in +Berarducci's subgroup `J + K`. -/ +theorem toSeriesQuotientByJAddConstants_eq_iff {b c : Berarducci.Series K} : + toSeriesQuotientByJAddConstants b = toSeriesQuotientByJAddConstants c ↔ + b - c ∈ Berarducci.nearConstantSubgroup K := by + rw [toSeriesQuotientByJAddConstants, Submodule.mkQ_apply, Submodule.mkQ_apply, + Submodule.Quotient.eq, mem_nearConstantSubmodule_iff] + +/-- A series has zero image modulo constants exactly when it lies in `J + K`. -/ +theorem toSeriesQuotientByJAddConstants_eq_zero_iff {b : Berarducci.Series K} : + toSeriesQuotientByJAddConstants b = 0 ↔ b ∈ Berarducci.nearConstantSubgroup K := by + rw [← map_zero toSeriesQuotientByJAddConstants, toSeriesQuotientByJAddConstants_eq_iff, sub_zero] + +/-- The class modulo `J + K` of the translated truncation at `x`. -/ +def translatedTruncationClass (b : K⟦ℝ⟧) (x : ℝ) : SeriesQuotientByJAddConstants K := + toSeriesQuotientByJAddConstants (Berarducci.translatedTruncation b x) + +/-- Evaluate a translated-truncation class modulo `J + K`. -/ +theorem translatedTruncationClass_apply (b : K⟦ℝ⟧) (x : ℝ) : + translatedTruncationClass b x = + toSeriesQuotientByJAddConstants (Berarducci.translatedTruncation b x) := (rfl) + +/-- [PS06]'s space `V(a)`, spanned modulo `J + K` by translated truncations at negative +exponents. -/ +def translatedTruncationSpan (a : Berarducci.Series K) : + Submodule K (SeriesQuotientByJAddConstants K) := + Submodule.span K (translatedTruncationClass (a : K⟦ℝ⟧) '' Set.Iio 0) + +/-- Every translated-truncation class at a negative exponent belongs to `V(a)`. -/ +theorem translatedTruncationClass_mem_translatedTruncationSpan (a : Berarducci.Series K) + {x : ℝ} (hx : x < 0) : + translatedTruncationClass (a : K⟦ℝ⟧) x ∈ translatedTruncationSpan a := + Submodule.subset_span ⟨x, hx, rfl⟩ + +/-- A subspace contains `V(a)` exactly when it contains every negative translated-truncation +class used to generate `V(a)`. -/ +theorem translatedTruncationSpan_le_iff {a : Berarducci.Series K} + {p : Submodule K (SeriesQuotientByJAddConstants K)} : + translatedTruncationSpan a ≤ p ↔ + ∀ x : ℝ, x < 0 → translatedTruncationClass (a : K⟦ℝ⟧) x ∈ p := by + rw [translatedTruncationSpan, Submodule.span_le] + constructor + · intro h x hx + exact h ⟨x, hx, rfl⟩ + · rintro h _ ⟨x, hx, rfl⟩ + exact h x hx + +end PommersheimShahriari diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/FiniteSupportFactorUniqueness.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/FiniteSupportFactorUniqueness.lean new file mode 100644 index 0000000000..3319138246 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/FiniteSupportFactorUniqueness.lean @@ -0,0 +1,280 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.InfiniteSupport + +import Mathlib.Algebra.GroupWithZero.Associated + +/-! +# Uniqueness of the finite-support factor + +This module proves the conditional core of LM24, Theorem 6.4.1. A factorisation consists of one +finite-support series followed by a finite list of irreducible series with infinite support. The +finite-support factor is unique up to multiplication by a nonzero coefficient scalar. + +The proof first shows that every irreducible infinite-support factor has normalized maximal +finite-support divisor `1`. Multiplicativity of the normalized maximal divisor then identifies the +finite-support factor with the canonical divisor up to a scalar. No uniqueness assertion is made +about the list of infinite-support irreducible factors. + +Finite-support greatest-common-divisor existence, finite-support unit classification, and +multiplicativity of the normalized maximal divisor remain explicit hypotheses; the coefficient +field has characteristic zero. +-/ + +open scoped HahnSeries NatOrdinal + +universe v + +namespace Berarducci + +public noncomputable section + +open HahnSeries.Nonpositive + +variable {K : Type v} [Field K] [CharZero K] + +private theorem degree_eq_of_associated {b c : Series K} (hbc : Associated b c) : + (b : K⟦ℝ⟧).degree = (c : K⟦ℝ⟧).degree := by + obtain ⟨u, hu⟩ := hbc + have huDegree : (((u : Series K) : K⟦ℝ⟧).degree) = 0 := + degree_eq_zero_of_isUnit HahnSeries.Nonpositive.degree_mul u.isUnit + have hdegree := HahnSeries.Nonpositive.degree_mul b (u : Series K) + rw [hu, huDegree, add_zero] at hdegree + exact hdegree.symm + +/-- An irreducible series with infinite support has no nonunit finite-support divisor. -/ +theorem hasOnlyUnitFiniteSupportDivisors_of_irreducible_of_support_infinite + {c : Series K} (hcIrreducible : Irreducible c) + (hcInfinite : (c : K⟦ℝ⟧).support.Infinite) : + HasOnlyUnitFiniteSupportDivisors c := by + apply (hasOnlyUnitFiniteSupportDivisors_iff c).mpr + intro p hp + rcases (hcIrreducible.dvd_iff).mp hp with hpUnit | hcp + · apply isUnit_of_dvd_one + apply (finiteSupport_dvd_iff_coe_dvd + (1 : FiniteSupportRing (K := K)) p).mpr + simpa using hpUnit.dvd + · have hcNe : c ≠ 0 := by + intro hzero + subst c + simp at hcInfinite + have hpSeriesNe : (p : Series K) ≠ 0 := hcp.ne_zero_iff.mp hcNe + have hpHahnNe : (p : K⟦ℝ⟧) ≠ 0 := by + intro hzero + exact hpSeriesNe (Subtype.ext hzero) + have hpDegree : (p : K⟦ℝ⟧).degree = 0 := by + rw [HahnSeries.degree_eq_zero] + exact ⟨hpHahnNe, (mem_finiteSupportSubring_iff (p : Series K)).mp p.2⟩ + have hcDegree : (c : K⟦ℝ⟧).degree = 0 := + (degree_eq_of_associated hcp).trans hpDegree + exact (not_le_of_gt + (HahnSeries.degree_pos_iff_support_infinite.mpr hcInfinite) hcDegree.le).elim + +/-- The normalized maximal finite-support divisor of an irreducible infinite-support series is +one. -/ +theorem seriesNormalizedMaximalFiniteSupportDivisor_eq_one_of_irreducible_of_support_infinite + (hgcd : ∀ p q : FiniteSupportRing (K := K), + ∃ d : FiniteSupportRing (K := K), + ∀ e : FiniteSupportRing (K := K), e ∣ p ∧ e ∣ q ↔ e ∣ d) + (hunits : ∀ p : FiniteSupportRing (K := K), + IsUnit p ↔ ∃ k : K, k ≠ 0 ∧ + p = finiteSupportScalarHom (G := ℝ) k) + {c : Series K} (hcIrreducible : Irreducible c) + (hcInfinite : (c : K⟦ℝ⟧).support.Infinite) : + seriesNormalizedMaximalFiniteSupportDivisor c = 1 := by + have hcPrimitive := + hasOnlyUnitFiniteSupportDivisors_of_irreducible_of_support_infinite + hcIrreducible hcInfinite + have hcPrimitive' := (hasOnlyUnitFiniteSupportDivisors_iff c).mp hcPrimitive + apply seriesNormalizedMaximalFiniteSupportDivisor_eq_of_is hgcd hunits + rw [isNormalizedSeriesMaximalFiniteSupportDivisor_iff] + constructor + · intro q + constructor + · exact fun hq ↦ (hcPrimitive' q hq).dvd + · intro hq + have hqSeries : (q : Series K) ∣ (1 : Series K) := + map_dvd (finiteSupportSubring (G := ℝ) (K := K)).subtype hq + exact hqSeries.trans (one_dvd c) + · refine Or.inr ⟨?_, isMonicFiniteSupport_one⟩ + intro hzero + subst c + simp at hcInfinite + +/-- The normalized maximal finite-support divisor of a product list of irreducible +infinite-support series is one. -/ +theorem seriesNormalizedMaximalFiniteSupportDivisor_list_prod_eq_one + (hgcd : ∀ p q : FiniteSupportRing (K := K), + ∃ d : FiniteSupportRing (K := K), + ∀ e : FiniteSupportRing (K := K), e ∣ p ∧ e ∣ q ↔ e ∣ d) + (hunits : ∀ p : FiniteSupportRing (K := K), + IsUnit p ↔ ∃ k : K, k ≠ 0 ∧ + p = finiteSupportScalarHom (G := ℝ) k) + (hmaxMul : ∀ b c : Series K, + seriesNormalizedMaximalFiniteSupportDivisor (b * c) = + seriesNormalizedMaximalFiniteSupportDivisor b * + seriesNormalizedMaximalFiniteSupportDivisor c) + (factors : List (Series K)) + (hfactors : ∀ c ∈ factors, + Irreducible c ∧ (c : K⟦ℝ⟧).support.Infinite) : + seriesNormalizedMaximalFiniteSupportDivisor factors.prod = 1 := by + induction factors with + | nil => + simpa using seriesNormalizedMaximalFiniteSupportDivisor_eq_one_of_isPrincipal hunits + (isPrincipal_one (R := K)) + | cons c factors ih => + rw [List.prod_cons, hmaxMul, + seriesNormalizedMaximalFiniteSupportDivisor_eq_one_of_irreducible_of_support_infinite hgcd + hunits (hfactors c (by simp)).1 + (hfactors c (by simp)).2, + ih (fun d hd ↦ hfactors d (by simp [hd]))] + exact one_mul 1 + +/-- A factorisation into one finite-support factor and finitely many irreducible +infinite-support factors. -/ +def IsInfiniteSupportIrreducibleFactorization (b : Series K) (p : FiniteSupportRing (K := K)) + (factors : List (Series K)) : Prop := + b = (p : Series K) * factors.prod ∧ + ∀ c ∈ factors, Irreducible c ∧ (c : K⟦ℝ⟧).support.Infinite + +omit [CharZero K] in +/-- Characterization of a factorisation into a finite-support factor and irreducible +infinite-support factors. -/ +theorem isInfiniteSupportIrreducibleFactorization_iff + (b : Series K) (p : FiniteSupportRing (K := K)) + (factors : List (Series K)) : + IsInfiniteSupportIrreducibleFactorization b p factors ↔ + b = (p : Series K) * factors.prod ∧ + ∀ c ∈ factors, Irreducible c ∧ (c : K⟦ℝ⟧).support.Infinite := + Iff.rfl + +/-- A finite-support factor is unique up to multiplication by a nonzero coefficient scalar +among all factorisations with irreducible infinite-support residual factors. -/ +def IsUniqueFiniteSupportFactorUpToScalar (b : Series K) (p : FiniteSupportRing (K := K)) : Prop := + ∀ (q : FiniteSupportRing (K := K)) (factors : List (Series K)), + IsInfiniteSupportIrreducibleFactorization b q factors → + ∃ k : K, k ≠ 0 ∧ q = finiteSupportScalarHom (G := ℝ) k * p + +omit [CharZero K] in +/-- Characterization of uniqueness of the finite-support factor up to a nonzero coefficient +scalar. -/ +theorem isUniqueFiniteSupportFactorUpToScalar_iff (b : Series K) (p : FiniteSupportRing (K := K)) : + IsUniqueFiniteSupportFactorUpToScalar b p ↔ + ∀ (q : FiniteSupportRing (K := K)) (factors : List (Series K)), + IsInfiniteSupportIrreducibleFactorization b q factors → + ∃ k : K, k ≠ 0 ∧ q = finiteSupportScalarHom (G := ℝ) k * p := + Iff.rfl + +/-- Any finite-support factor in such a factorisation differs from the canonical normalized +maximal finite-support divisor by a nonzero coefficient scalar. -/ +theorem seriesNormalizedMaximalFiniteSupportDivisor_eq_scalar_mul_of_factorization + (hgcd : ∀ p q : FiniteSupportRing (K := K), + ∃ d : FiniteSupportRing (K := K), + ∀ e : FiniteSupportRing (K := K), e ∣ p ∧ e ∣ q ↔ e ∣ d) + (hunits : ∀ p : FiniteSupportRing (K := K), + IsUnit p ↔ ∃ k : K, k ≠ 0 ∧ + p = finiteSupportScalarHom (G := ℝ) k) + (hmaxMul : ∀ b c : Series K, + seriesNormalizedMaximalFiniteSupportDivisor (b * c) = + seriesNormalizedMaximalFiniteSupportDivisor b * + seriesNormalizedMaximalFiniteSupportDivisor c) + {b : Series K} {p : FiniteSupportRing (K := K)} + {factors : List (Series K)} + (hfactorization : IsInfiniteSupportIrreducibleFactorization b p factors) : + ∃ k : K, k ≠ 0 ∧ + seriesNormalizedMaximalFiniteSupportDivisor b = + finiteSupportScalarHom (G := ℝ) k * p := by + obtain ⟨k, hk, hp⟩ := + exists_scalar_seriesNormalizedMaximalFiniteSupportDivisor_coe hunits p + refine ⟨k, hk, ?_⟩ + rw [hfactorization.1, hmaxMul, hp, + seriesNormalizedMaximalFiniteSupportDivisor_list_prod_eq_one hgcd hunits hmaxMul factors + hfactorization.2, + mul_one] + +/-- The finite-support factors in any two such factorisations differ by multiplication by a +nonzero coefficient scalar. -/ +theorem finiteSupportFactor_eq_scalar_mul_of_factorizations + (hgcd : ∀ p q : FiniteSupportRing (K := K), + ∃ d : FiniteSupportRing (K := K), + ∀ e : FiniteSupportRing (K := K), e ∣ p ∧ e ∣ q ↔ e ∣ d) + (hunits : ∀ p : FiniteSupportRing (K := K), + IsUnit p ↔ ∃ k : K, k ≠ 0 ∧ + p = finiteSupportScalarHom (G := ℝ) k) + (hmaxMul : ∀ b c : Series K, + seriesNormalizedMaximalFiniteSupportDivisor (b * c) = + seriesNormalizedMaximalFiniteSupportDivisor b * + seriesNormalizedMaximalFiniteSupportDivisor c) + {b : Series K} {p q : FiniteSupportRing (K := K)} + {factors otherFactors : List (Series K)} + (hp : IsInfiniteSupportIrreducibleFactorization b p factors) + (hq : IsInfiniteSupportIrreducibleFactorization b q otherFactors) : + ∃ k : K, k ≠ 0 ∧ q = finiteSupportScalarHom (G := ℝ) k * p := by + obtain ⟨a, ha, hpa⟩ := + seriesNormalizedMaximalFiniteSupportDivisor_eq_scalar_mul_of_factorization hgcd hunits hmaxMul + hp + obtain ⟨d, hd, hqd⟩ := + seriesNormalizedMaximalFiniteSupportDivisor_eq_scalar_mul_of_factorization hgcd hunits hmaxMul + hq + have haUnit : + IsUnit (finiteSupportScalarHom (G := ℝ) a : FiniteSupportRing (K := K)) := + (hunits _).mpr ⟨a, ha, rfl⟩ + have hdUnit : + IsUnit (finiteSupportScalarHom (G := ℝ) d : FiniteSupportRing (K := K)) := + (hunits _).mpr ⟨d, hd, rfl⟩ + have hmkP : Associates.mk (seriesNormalizedMaximalFiniteSupportDivisor b) = + Associates.mk p := by + rw [hpa, ← Associates.mk_mul_mk, Associates.mk_eq_one.mpr haUnit, one_mul] + have hmkQ : Associates.mk (seriesNormalizedMaximalFiniteSupportDivisor b) = + Associates.mk q := by + rw [hqd, ← Associates.mk_mul_mk, Associates.mk_eq_one.mpr hdUnit, one_mul] + exact exists_nonzero_scalar_mul_of_mk_eq_mk hunits (hmkP.symm.trans hmkQ) + +/-- Conditional existence, Cantor-term bound, and finite-support-factor uniqueness underlying +LM24, Theorem 6.4.1. -/ +theorem exists_factorization_with_unique_finiteSupportFactor + (hgcd : ∀ p q : FiniteSupportRing (K := K), + ∃ d : FiniteSupportRing (K := K), + ∀ e : FiniteSupportRing (K := K), e ∣ p ∧ e ∣ q ↔ e ∣ d) + (hunits : ∀ p : FiniteSupportRing (K := K), + IsUnit p ↔ ∃ k : K, k ≠ 0 ∧ + p = finiteSupportScalarHom (G := ℝ) k) + (hmaxMul : ∀ b c : Series K, + seriesNormalizedMaximalFiniteSupportDivisor (b * c) = + seriesNormalizedMaximalFiniteSupportDivisor b * + seriesNormalizedMaximalFiniteSupportDivisor c) + {b : Series K} (hb : b ≠ 0) : + ∃ (p : FiniteSupportRing (K := K)) (factors : List (Series K)), + IsInfiniteSupportIrreducibleFactorization b p factors ∧ + factors.length ≤ HahnSeries.degreeCantorTermCount (b : K⟦ℝ⟧) ∧ + IsUniqueFiniteSupportFactorUpToScalar b p := by + obtain ⟨k, factors, hk, hfactor, hfactors, hbound⟩ := + exists_series_infinite_support_factorization_of_exists_gcd hgcd hunits hb + let p := finiteSupportScalarHom (G := ℝ) k * + seriesNormalizedMaximalFiniteSupportDivisor b + have hpFactor : IsInfiniteSupportIrreducibleFactorization b p factors := by + constructor + · have hscalar : + ((finiteSupportScalarHom (G := ℝ) k : + FiniteSupportRing (K := K)) : Series K) = C k := by + apply Subtype.ext + rw [coe_finiteSupportScalarHom, coe_C] + change b = + ((finiteSupportScalarHom (G := ℝ) k * + seriesNormalizedMaximalFiniteSupportDivisor b : + FiniteSupportRing (K := K)) : Series K) * factors.prod + rw [Subring.coe_mul, hscalar] + exact hfactor + · exact hfactors + refine ⟨p, factors, hpFactor, hbound, ?_⟩ + intro q otherFactors hq + exact finiteSupportFactor_eq_scalar_mul_of_factorizations hgcd hunits hmaxMul hpFactor hq + +end + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/GermLike.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/GermLike.lean new file mode 100644 index 0000000000..7d517a20d6 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/GermLike.lean @@ -0,0 +1,339 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.CriticalPointExistence + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Statements.ProductValue +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.DegreeTwo.FactorizationClassification +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValueFinalSegment +import Mathlib.Tactic.Linarith + +/-! +# Factorisation of germ-like series + +L'Innocente--Mantova define a series `a` to be germ-like when its support order type is either +`v_J(a)` or, for `v_J(a) > 1`, `v_J(a) + 1`. Their Lemmas 4.4 and 4.5 identify this condition +with critical point zero and show that it passes to nonzero factors. Well-founded induction on +the ordinal value then gives their Theorem 4.8: every nonzero germ-like series factors into +irreducibles. + +The critical-point proof below uses the two defining support-order alternatives directly. In the +second alternative, the strictly negative support has order type exactly `v_J(a)`; every proper +negative translated truncation therefore has smaller ordinal value. + +## References + +* S. L'Innocente, V. Mantova, *Factorisation of germ-like series*, J. Log. Anal. 9 (2017), + paper no. 3, cited as [LM17]. +-/ + +universe v + +open scoped HahnSeries NatOrdinal + +public noncomputable section + +namespace LM17 + +open Berarducci HahnSeries Ordinal + +variable {K : Type v} [Field K] + +/-- LM17, Definition 4.1: a series is germ-like when its support order type is its ordinal value, +or is its ordinal value plus one when that value is greater than one. -/ +def IsGermLike (a : Series K) : Prop := + (a : K⟦ℝ⟧).supportOrderType = (ordinalValue a).val ∨ + (1 < ordinalValue a ∧ + (a : K⟦ℝ⟧).supportOrderType = (ordinalValue a).val + 1) + +/-- Characterisation of the germ-like predicate. -/ +theorem isGermLike_iff {a : Series K} : + IsGermLike a ↔ + (a : K⟦ℝ⟧).supportOrderType = (ordinalValue a).val ∨ + (1 < ordinalValue a ∧ + (a : K⟦ℝ⟧).supportOrderType = (ordinalValue a).val + 1) := + (Iff.rfl) + +/-- A germ-like series satisfies one of its two defining support-order identities. -/ +theorem IsGermLike.elim {a : Series K} (ha : IsGermLike a) : + (a : K⟦ℝ⟧).supportOrderType = (ordinalValue a).val ∨ + (1 < ordinalValue a ∧ + (a : K⟦ℝ⟧).supportOrderType = (ordinalValue a).val + 1) := + ha + +private theorem truncGE_zero_eq_single (a : Series K) : + HahnSeries.truncGE 0 (a : K⟦ℝ⟧) = + HahnSeries.single 0 ((a : K⟦ℝ⟧).coeff 0) := by + ext x + rcases lt_trichotomy x 0 with hx | rfl | hx + · simp [HahnSeries.coeff_truncGE, not_le_of_gt hx, hx.ne] + · simp + · have hcoeff : (a : K⟦ℝ⟧).coeff x = 0 := by + apply not_ne_iff.mp + rw [← HahnSeries.mem_support] + exact fun hmem ↦ (not_le_of_gt hx) + (HahnSeries.Nonpositive.support_subset a hmem) + simp [HahnSeries.coeff_truncGE, hx.le, hcoeff, hx.ne'] + +private theorem supportOrderType_truncGE_zero_eq_zero_or_one (a : Series K) : + (HahnSeries.truncGE 0 (a : K⟦ℝ⟧)).supportOrderType = 0 ∨ + (HahnSeries.truncGE 0 (a : K⟦ℝ⟧)).supportOrderType = 1 := by + rw [truncGE_zero_eq_single] + by_cases hcoeff : (a : K⟦ℝ⟧).coeff 0 = 0 + · left + simp [hcoeff] + · right + exact HahnSeries.supportOrderType_single hcoeff + +private theorem negativeSupport_orderType_eq_ordinalValue + {a : Series K} (haOne : 1 < ordinalValue a) + (haType : (a : K⟦ℝ⟧).supportOrderType = (ordinalValue a).val + 1) : + ((a : K⟦ℝ⟧).isPWO_support.mono + (s := (a : K⟦ℝ⟧).support ∩ Set.Iio 0) + Set.inter_subset_left).orderType = (ordinalValue a).val := by + let S : Set ℝ := (a : K⟦ℝ⟧).support ∩ Set.Iio 0 + let hS : S.IsPWO := (a : K⟦ℝ⟧).isPWO_support.mono Set.inter_subset_left + have hSLUB : IsLUB S 0 := isLUB_negativeSupport_zero_of_one_lt_ordinalValue haOne + have hSne : S.Nonempty := by + obtain ⟨x, hx, -, -⟩ := hSLUB.exists_between (show (-1 : ℝ) < 0 by norm_num) + exact ⟨x, hx⟩ + have hSgt : ∀ x ∈ S, ∃ y ∈ S, x < y := by + intro x hx + obtain ⟨y, hy, hxy, -⟩ := hSLUB.exists_between hx.2 + exact ⟨y, hy, hxy⟩ + have hSlimit : Order.IsSuccLimit hS.orderType := + Set.IsPWO.isSuccLimit_orderType_of_forall_exists_gt hS hSne hSgt + have htruncSupport : + (HahnSeries.truncLT 0 (a : K⟦ℝ⟧)).support = S := by + rw [HahnSeries.support_truncLT] + rfl + have htruncType : + (HahnSeries.truncLT 0 (a : K⟦ℝ⟧)).supportOrderType = hS.orderType := by + rw [HahnSeries.supportOrderType_eq_setOrderType] + exact (HahnSeries.truncLT 0 (a : K⟦ℝ⟧)).isPWO_support.orderType_congr + hS htruncSupport + have hsplit := HahnSeries.supportOrderType_eq_truncLT_add_truncGE + 0 (a : K⟦ℝ⟧) + rcases supportOrderType_truncGE_zero_eq_zero_or_one a with hz | hz + · rw [hz, add_zero, htruncType] at hsplit + have hbad : hS.orderType = (ordinalValue a).val + 1 := + hsplit.symm.trans haType + rw [hbad, ← Order.succ_eq_add_one] at hSlimit + exact (Order.not_isSuccLimit_succ _ hSlimit).elim + · rw [hz, htruncType] at hsplit + have heq : (ordinalValue a).val + 1 = hS.orderType + 1 := + haType.symm.trans hsplit + exact (Ordinal.add_right_cancel 1).mp (by simpa using heq) |>.symm + +private theorem ordinalValue_translatedTruncation_lt_of_supportOrderType_eq + {a : Series K} + (haValue : (a : K⟦ℝ⟧).supportOrderType = (ordinalValue a).val) + (haZero : ordinalValue a ≠ 0) {u : ℝ} (hu : u < 0) : + ordinalValue (translatedTruncation (a : K⟦ℝ⟧) u) < ordinalValue a := by + have hLUB := isLUB_support_zero_of_ordinalValue_ne_zero haZero + obtain ⟨gamma, hgammaSupport, hugamma, -⟩ := hLUB.exists_between hu + have htruncNe : HahnSeries.truncLE u (a : K⟦ℝ⟧) ≠ (a : K⟦ℝ⟧) := by + intro htrunc + have hgammaTrunc : gamma ∈ (HahnSeries.truncLE u (a : K⟦ℝ⟧)).support := by + rw [htrunc] + exact hgammaSupport + rw [HahnSeries.support_truncLE] at hgammaTrunc + exact (not_le_of_gt hugamma) hgammaTrunc.2 + calc + ordinalValue (translatedTruncation (a : K⟦ℝ⟧) u) ≤ + NatOrdinal.of + ((translatedTruncation (a : K⟦ℝ⟧) u : Series K) : K⟦ℝ⟧).supportOrderType := + ordinalValue_le_supportOrderType _ + _ = NatOrdinal.of (HahnSeries.truncLE u (a : K⟦ℝ⟧)).supportOrderType := by + rw [coe_translatedTruncation, HahnSeries.supportOrderType_translate] + _ < NatOrdinal.of (a : K⟦ℝ⟧).supportOrderType := + NatOrdinal.of.lt_iff_lt.mpr (HahnSeries.supportOrderType_truncLE_lt u htruncNe) + _ = ordinalValue a := by rw [haValue, NatOrdinal.of_val] + +private theorem ordinalValue_translatedTruncation_lt_of_negativeSupport_orderType_eq + {a : Series K} (haOne : 1 < ordinalValue a) + (hSType : ((a : K⟦ℝ⟧).isPWO_support.mono + (s := (a : K⟦ℝ⟧).support ∩ Set.Iio 0) + Set.inter_subset_left).orderType = (ordinalValue a).val) + {u : ℝ} (hu : u < 0) : + ordinalValue (translatedTruncation (a : K⟦ℝ⟧) u) < ordinalValue a := by + let S : Set ℝ := (a : K⟦ℝ⟧).support ∩ Set.Iio 0 + let hS : S.IsPWO := (a : K⟦ℝ⟧).isPWO_support.mono Set.inter_subset_left + have hSLUB : IsLUB S 0 := isLUB_negativeSupport_zero_of_one_lt_ordinalValue haOne + obtain ⟨y, hy, huy, -⟩ := hSLUB.exists_between hu + let T : Set ℝ := (HahnSeries.truncLE u (a : K⟦ℝ⟧)).support + let hT : T.IsPWO := (HahnSeries.truncLE u (a : K⟦ℝ⟧)).isPWO_support + have hTsub : T ⊆ S ∩ Set.Iio y := by + intro x hx + change x ∈ (HahnSeries.truncLE u (a : K⟦ℝ⟧)).support at hx + rw [HahnSeries.support_truncLE] at hx + exact ⟨⟨hx.1, hx.2.trans_lt hu⟩, hx.2.trans_lt huy⟩ + have hTlt : hT.orderType < hS.orderType := + (hT.orderType_mono + (hS.mono (s := S ∩ Set.Iio y) Set.inter_subset_left) hTsub).trans_lt + (hS.orderType_inter_Iio_lt hy) + calc + ordinalValue (translatedTruncation (a : K⟦ℝ⟧) u) ≤ + NatOrdinal.of + ((translatedTruncation (a : K⟦ℝ⟧) u : Series K) : K⟦ℝ⟧).supportOrderType := + ordinalValue_le_supportOrderType _ + _ = NatOrdinal.of hT.orderType := by + rw [coe_translatedTruncation, HahnSeries.supportOrderType_translate, + HahnSeries.supportOrderType_eq_setOrderType] + _ < NatOrdinal.of (ordinalValue a).val := by + apply NatOrdinal.of.lt_iff_lt.mpr + rwa [hSType] at hTlt + _ = ordinalValue a := by rw [NatOrdinal.of_val] + +private theorem ordinalValue_translatedTruncation_lt {a : Series K} + (ha : IsGermLike a) (ha0 : a ≠ 0) {u : ℝ} (hu : u < 0) : + ordinalValue (translatedTruncation (a : K⟦ℝ⟧) u) < ordinalValue a := by + rcases ha.elim with haType | ⟨haOne, haType⟩ + · exact ordinalValue_translatedTruncation_lt_of_supportOrderType_eq haType + (fun hzero ↦ ha0 (Subtype.ext (HahnSeries.supportOrderType_eq_zero.mp (by + simpa [hzero] using haType)))) hu + · exact ordinalValue_translatedTruncation_lt_of_negativeSupport_orderType_eq + haOne (negativeSupport_orderType_eq_ordinalValue haOne haType) hu + +/-- LM17, Lemma 4.4, forward direction: a nonzero germ-like series has critical point zero. -/ +theorem IsGermLike.isCriticalPoint_zero {a : Series K} + (ha : IsGermLike a) (ha0 : a ≠ 0) : + IsCriticalPoint a 0 := by + rw [isCriticalPoint_iff] + refine ⟨ha0, le_rfl, ?_, ?_⟩ + · intro y hy + rcases hy.eq_or_lt with rfl | hy + · exact le_rfl + · simpa using (ordinalValue_translatedTruncation_lt ha ha0 hy).le + · intro y _ hvalue + by_contra hnot + have hylt : y < 0 := lt_of_not_ge hnot + exact (ordinalValue_translatedTruncation_lt ha ha0 hylt).ne (by simpa using hvalue) + +/-- LM17, Lemma 4.5 and Corollary 4.6: if a series with critical point zero is a product of +two nonzero series, then both factors have critical point zero. -/ +theorem factors_isCriticalPoint_zero [CharZero K] + {a b c : Series K} (ha : IsCriticalPoint a 0) + (habc : a = b * c) (hb0 : b ≠ 0) (hc0 : c ≠ 0) : + IsCriticalPoint b 0 ∧ IsCriticalPoint c 0 := by + obtain ⟨x, hx⟩ := exists_isCriticalPoint hb0 + obtain ⟨y, hy⟩ := exists_isCriticalPoint hc0 + have hxy0 : x + y ≤ 0 := add_nonpos hx.nonpositive hy.nonpositive + have hbLe : + ordinalValue b ≤ ordinalValue (translatedTruncation (b : K⟦ℝ⟧) x) := by + simpa using hx.value_le 0 le_rfl + have hcLe : + ordinalValue c ≤ ordinalValue (translatedTruncation (c : K⟦ℝ⟧) y) := by + simpa using hy.value_le 0 le_rfl + have hcriticalEq : + ordinalValue (translatedTruncation (a : K⟦ℝ⟧) (x + y)) = + ordinalValue a := by + apply le_antisymm + · simpa using ha.value_le (x + y) hxy0 + · calc + ordinalValue a = ordinalValue b * ordinalValue c := by + rw [habc, ordinalValue_mul] + _ ≤ ordinalValue (translatedTruncation (b : K⟦ℝ⟧) x) * + ordinalValue (translatedTruncation (c : K⟦ℝ⟧) y) := + mul_le_mul hbLe hcLe bot_le bot_le + _ = ordinalValue + (translatedTruncation (((b * c : Series K) : K⟦ℝ⟧)) (x + y)) := + (criticalPoint_product_value hx hy).symm + _ = ordinalValue (translatedTruncation (a : K⟦ℝ⟧) (x + y)) := by + rw [habc] + have hzeroLe : 0 ≤ x + y := + ha.le_of_value_eq (x + y) hxy0 (by simpa using hcriticalEq) + have hx0 : x = 0 := + le_antisymm hx.nonpositive (by linarith [hzeroLe, hy.nonpositive]) + have hy0 : y = 0 := + le_antisymm hy.nonpositive (by linarith [hzeroLe, hx.nonpositive]) + exact ⟨hx0 ▸ hx, hy0 ▸ hy⟩ + +private theorem isUnit_of_ordinalValue_eq_one_of_isCriticalPoint_zero + {a : Series K} (haValue : ordinalValue a = 1) + (haCritical : IsCriticalPoint a 0) : IsUnit a := by + have haConstant := + PommersheimShahriari.mem_constantSubgroup_of_ordinalValue_one_of_criticalPoint_zero + haValue haCritical + obtain ⟨k, hk⟩ := Berarducci.mem_constantSubgroup_iff.mp haConstant + have hk0 : k ≠ 0 := by + intro hzero + apply haCritical.ne_zero + rw [← hk, hzero, map_zero] + rw [← hk] + exact (isUnit_iff_ne_zero.mpr hk0).map HahnSeries.Nonpositive.C + +private theorem one_lt_ordinalValue_of_not_isUnit_of_isCriticalPoint_zero + {a : Series K} (haUnit : ¬IsUnit a) + (haCritical : IsCriticalPoint a 0) : 1 < ordinalValue a := by + have hpos : 0 < ordinalValue a := by + simpa using haCritical.value_pos + have hone : ordinalValue a ≠ 1 := fun hvalue ↦ + haUnit (isUnit_of_ordinalValue_eq_one_of_isCriticalPoint_zero hvalue haCritical) + exact lt_of_le_of_ne (Order.one_le_iff_pos.mpr hpos) (Ne.symm hone) + +/-- LM17, Theorem 4.8: every nonzero series with critical point zero admits a finite +factorisation into irreducibles. The theorem is stated through association so that unit factors +are absorbed rather than chosen. -/ +theorem exists_factorization_of_isCriticalPoint_zero [CharZero K] + {a : Series K} (haCritical : IsCriticalPoint a 0) : + ∃ f : Multiset (Series K), + (∀ b ∈ f, Irreducible b) ∧ Associated f.prod a := by + let wf : WellFounded (Function.onFun (fun x y : NatOrdinal ↦ x < y) + (fun b : Series K ↦ ordinalValue b)) := wellFounded_lt.onFun + refine wf.induction (C := fun a ↦ IsCriticalPoint a 0 → + ∃ f : Multiset (Series K), + (∀ b ∈ f, Irreducible b) ∧ Associated f.prod a) a ?_ haCritical + intro a ih haCritical + by_cases haUnit : IsUnit a + · refine ⟨0, by simp, ?_⟩ + simpa using (associated_one_iff_isUnit.mpr haUnit).symm + by_cases haIrreducible : Irreducible a + · exact ⟨{a}, by simpa using haIrreducible, by simp⟩ + obtain ⟨b, c, hbUnit, hcUnit, habc⟩ := + (irreducible_or_factor haUnit).resolve_left haIrreducible + have hb0 : b ≠ 0 := by + intro hzero + apply haCritical.ne_zero + rw [habc, hzero, zero_mul] + have hc0 : c ≠ 0 := by + intro hzero + apply haCritical.ne_zero + rw [habc, hzero, mul_zero] + obtain ⟨hbCritical, hcCritical⟩ := + factors_isCriticalPoint_zero haCritical habc hb0 hc0 + have hbOne := + one_lt_ordinalValue_of_not_isUnit_of_isCriticalPoint_zero hbUnit hbCritical + have hcOne := + one_lt_ordinalValue_of_not_isUnit_of_isCriticalPoint_zero hcUnit hcCritical + have hbPos : 0 < ordinalValue b := zero_lt_one.trans hbOne + have hcPos : 0 < ordinalValue c := zero_lt_one.trans hcOne + have hbLt : ordinalValue b < ordinalValue a := by + rw [habc, ordinalValue_mul] + simpa only [mul_one] using mul_lt_mul_of_pos_left hcOne hbPos + have hcLt : ordinalValue c < ordinalValue a := by + rw [habc, ordinalValue_mul] + simpa only [one_mul] using mul_lt_mul_of_pos_right hbOne hcPos + obtain ⟨fb, hfbIrr, hfb⟩ := ih b hbLt hbCritical + obtain ⟨fc, hfcIrr, hfc⟩ := ih c hcLt hcCritical + refine ⟨fb + fc, ?_, ?_⟩ + · intro x hx + rcases Multiset.mem_add.mp hx with hx | hx + · exact hfbIrr x hx + · exact hfcIrr x hx + · rw [Multiset.prod_add] + simpa [habc] using hfb.mul_mul hfc + +/-- LM17, Theorem 4.8: every nonzero germ-like series admits a finite factorisation into +irreducibles. -/ +theorem IsGermLike.exists_factorization [CharZero K] + {a : Series K} (ha : IsGermLike a) (ha0 : a ≠ 0) : + ∃ f : Multiset (Series K), + (∀ b ∈ f, Irreducible b) ∧ Associated f.prod a := + exists_factorization_of_isCriticalPoint_zero (ha.isCriticalPoint_zero ha0) + +end LM17 diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/GradedDivisibility.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/GradedDivisibility.lean new file mode 100644 index 0000000000..e1cd99d16a --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/GradedDivisibility.lean @@ -0,0 +1,222 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.RVMaximalFinite + +import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.AssociatedGradedDivisibility +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalSubringMonoidAlgebra + +/-! +# Divisibility in the degree-graded ring + +This module formalizes LM24, Proposition 6.2.1, Corollaries 6.2.2--6.2.3, and Proposition +6.2.4. Degree RV is represented by the homogeneous classes in the associated graded ring. The +paper's set `P` of principal RV classes is represented intrinsically as the image of +`IsPrincipalRV` under the canonical RV embedding; `isPrincipalRVImage_iff` relates this exact +image predicate to homogeneous, componentwise-principal graded elements. + +The published results retain the characteristic-zero hypothesis. Their divisibility arguments use +field-generic results about trailing grades, homogeneous divisibility, and the monoid-algebra +presentation of the principal graded subring. +-/ + +open scoped DirectSum HahnSeries NatOrdinal + +universe v + +namespace Berarducci + +public noncomputable section + +open HahnSeries.Nonpositive + +variable {K : Type v} [Field K] [CharZero K] + +/-- Membership in the image of the paper's principal RV classes inside the degree-graded +graded ring. -/ +def IsPrincipalRVImage (x : DegreeGraded K) : Prop := + ∃ B : HahnDegreeRV K, IsPrincipalRV B ∧ + (degreeValuation K).rvInitialFormHom B = x + +/-- Introduction and elimination rule for the image of the principal RV classes. -/ +theorem isPrincipalRVImage_iff_exists (x : DegreeGraded K) : + IsPrincipalRVImage x ↔ + ∃ B : HahnDegreeRV K, IsPrincipalRV B ∧ + (degreeValuation K).rvInitialFormHom B = x := + Iff.rfl + +/-- The canonical graded image of a principal RV class belongs to `P`. -/ +theorem isPrincipalRVImage_initialForm (B : HahnDegreeRV K) (hB : IsPrincipalRV B) : + IsPrincipalRVImage + ((degreeValuation K).rvInitialFormHom B) := + (isPrincipalRVImage_iff_exists _).mpr ⟨B, hB, rfl⟩ + +/-- The image of `P` consists exactly of the nonzero homogeneous graded elements whose sole +component is principal. -/ +theorem isPrincipalRVImage_iff (x : DegreeGraded K) : + IsPrincipalRVImage x ↔ + x ≠ 0 ∧ + x ∈ (degreeValuation K).homogeneousClasses ∧ + IsPrincipalGraded x := by + let w := degreeValuation K + constructor + · rintro ⟨B, hBPrincipal, rfl⟩ + obtain ⟨α, C, hC, hCPrincipal, hBC⟩ := + (isPrincipalRV_iff_exists_degreeHomogeneousClass B).mp hBPrincipal + have hBInitial : w.rvInitialFormHom B = DirectSum.of w.Component α C := by + calc + w.rvInitialFormHom B = + ((w.rvEquivHomogeneous B : w.HomogeneousClasses) : w.AssociatedGraded) := by + rw [w.rvEquivHomogeneous_apply, w.coe_rvHomogeneous] + _ = (degreeHomogeneousClass α C : w.AssociatedGraded) := + congrArg Subtype.val hBC + _ = DirectSum.of w.Component α C := + coe_degreeHomogeneousClass α C + have hBHomogeneous : + w.rvInitialFormHom B ∈ w.homogeneousClasses := by + rw [← w.coe_rvHomogeneous] + exact (w.rvHomogeneous B).2 + refine ⟨?_, hBHomogeneous, ?_⟩ + · rw [hBInitial] + intro hzero + apply hC + apply DirectSum.of_injective α + simpa using hzero + · rw [isPrincipalGraded_iff] + intro β + rw [hBInitial] + by_cases hβ : α = β + · subst β + simpa using hCPrincipal + · rw [DirectSum.of_eq_of_ne α β C (Ne.symm hβ)] + exact (isPrincipalDegreeClass_iff β 0).mpr (Or.inl rfl) + · rintro ⟨hx, hxHomogeneous, hxPrincipal⟩ + rw [w.mem_homogeneousClasses_iff] at hxHomogeneous + rcases hxHomogeneous with hzero | ⟨α, C, hCeq⟩ + · exact (hx hzero).elim + have hC : C ≠ 0 := by + intro hC + subst C + exact hx (hCeq.trans (map_zero _)) + let xHomogeneous : w.HomogeneousClasses := + ⟨x, (w.mem_homogeneousClasses_iff x).mpr (Or.inr ⟨α, C, hCeq⟩)⟩ + let B := w.rvEquivHomogeneous.symm xHomogeneous + refine ⟨B, ?_, ?_⟩ + · apply (isPrincipalRV_iff_exists_degreeHomogeneousClass B).mpr + refine ⟨α, C, hC, ?_, ?_⟩ + · rw [isPrincipalGraded_iff] at hxPrincipal + have hα := hxPrincipal α + rw [hCeq, DirectSum.of_eq_same] at hα + exact hα + · change w.rvEquivHomogeneous B = degreeHomogeneousClass α C + apply Subtype.ext + calc + ((w.rvEquivHomogeneous B : w.HomogeneousClasses) : w.AssociatedGraded) = x := by + exact congrArg Subtype.val (w.rvEquivHomogeneous.apply_symm_apply xHomogeneous) + _ = DirectSum.of w.Component α C := hCeq + _ = (degreeHomogeneousClass α C : w.AssociatedGraded) := + (coe_degreeHomogeneousClass α C).symm + · change w.rvInitialFormHom B = x + calc + w.rvInitialFormHom B = + ((w.rvEquivHomogeneous B : w.HomogeneousClasses) : w.AssociatedGraded) := by + rw [w.rvEquivHomogeneous_apply, w.coe_rvHomogeneous] + _ = x := congrArg Subtype.val (w.rvEquivHomogeneous.apply_symm_apply xHomogeneous) + +/-- LM24, Proposition 6.2.1: nonzero factors of a product lying in degree RV also lie in +degree RV. -/ +theorem hahnDegreeRV_factors_of_mul_mem {B C : DegreeGraded K} + (hB : B ≠ 0) (hC : C ≠ 0) + (hBC : B * C ∈ (degreeValuation K).homogeneousClasses) : + B ∈ (degreeValuation K).homogeneousClasses ∧ + C ∈ (degreeValuation K).homogeneousClasses := by + exact (degreeValuation K).mem_homogeneousClasses_of_mul_mem + hB hC hBC + +/-- The `P̂` clause of LM24, Corollary 6.2.2: nonzero factors of a componentwise-principal +product are componentwise principal. -/ +theorem hahnDegreePrincipalGraded_factors_of_mul_mem {B C : DegreeGraded K} + (hB : B ≠ 0) (hC : C ≠ 0) + (hBC : IsPrincipalGraded (B * C)) : + IsPrincipalGraded B ∧ IsPrincipalGraded C := by + have hFactors := factors_mem_principalGradedSubalgebra_of_mul_mem hB hC + ((mem_principalGradedSubalgebra_iff (B * C)).mpr hBC) + exact ⟨(mem_principalGradedSubalgebra_iff B).mp hFactors.1, + (mem_principalGradedSubalgebra_iff C).mp hFactors.2⟩ + +/-- The `P` clause of LM24, Corollary 6.2.2: nonzero factors of a product in the image of the +principal RV classes also lie in that image. -/ +theorem hahnDegreePrincipalRVImage_factors_of_mul_mem {B C : DegreeGraded K} + (hB : B ≠ 0) (hC : C ≠ 0) + (hBC : IsPrincipalRVImage (B * C)) : + IsPrincipalRVImage B ∧ IsPrincipalRVImage C := by + have hBC' := (isPrincipalRVImage_iff (B * C)).mp hBC + have hHomogeneous := hahnDegreeRV_factors_of_mul_mem hB hC hBC'.2.1 + have hPrincipal := hahnDegreePrincipalGraded_factors_of_mul_mem hB hC hBC'.2.2 + exact ⟨(isPrincipalRVImage_iff B).mpr + ⟨hB, hHomogeneous.1, hPrincipal.1⟩, + (isPrincipalRVImage_iff C).mpr + ⟨hC, hHomogeneous.2, hPrincipal.2⟩⟩ + +/-- The first clause of LM24, Corollary 6.2.3: divisibility in degree RV agrees with +divisibility after the canonical embedding into the degree-graded ring. -/ +theorem hahnDegreeRV_dvd_iff_associatedGraded_dvd (B C : HahnDegreeRV K) : + B ∣ C ↔ + (degreeValuation K).rvInitialFormHom B ∣ + (degreeValuation K).rvInitialFormHom C := by + exact (degreeValuation K).rv_dvd_iff_associatedGraded_dvd B C + +/-- The finite-support clause of LM24, Corollary 6.2.3: ambient graded divisibility between +finite-support classes is exactly divisibility in the finite-support Hahn-series ring. -/ +theorem finiteSupportGradedEmbedding_dvd_iff (p q : FiniteSupportRing (K := K)) : + finiteSupportGradedEmbedding K p ∣ finiteSupportGradedEmbedding K q ↔ + p ∣ q := by + let w := degreeValuation K + constructor + · intro hpq + have hpqHomogeneous : + finiteSupportHomogeneousClass p ∣ + finiteSupportHomogeneousClass q := + (w.homogeneous_dvd_iff_associatedGraded_dvd + (finiteSupportHomogeneousClass p) + (finiteSupportHomogeneousClass q)).mpr (by + simpa only [coe_finiteSupportHomogeneousClass] using hpq) + have hqHomogeneous : + finiteSupportHomogeneousClass q = + degreeHomogeneousClass 0 + (degreeFiniteSupportResidueEquiv K q) := by + apply Subtype.ext + rw [coe_finiteSupportHomogeneousClass, coe_degreeHomogeneousClass, + finiteSupportGradedEmbedding_apply] + have hScalar : ∃ C : w.Component 0, + degreeFiniteSupportResidueEquiv K p • C = + degreeFiniteSupportResidueEquiv K q := + (finiteSupportHomogeneousClass_dvd_degreeHomogeneousClass_iff p 0 + (degreeFiniteSupportResidueEquiv K q)).mp (by + rw [← hqHomogeneous] + exact hpqHomogeneous) + obtain ⟨C, hC⟩ := hScalar + let e := degreeFiniteSupportResidueEquiv K + refine ⟨e.symm C, ?_⟩ + apply e.injective + rw [map_mul, e.apply_symm_apply] + simpa only [smul_eq_mul] using hC.symm + · exact map_dvd (finiteSupportGradedEmbedding K) + +/-- LM24, Proposition 6.2.4: an RV class divides a graded element if and only if it divides +every homogeneous component. -/ +theorem hahnDegreeRV_dvd_iff_dvd_components + (B : HahnDegreeRV K) (C : DegreeGraded K) : + (degreeValuation K).rvInitialFormHom B ∣ C ↔ + ∀ α, + (degreeValuation K).rvInitialFormHom B ∣ + DirectSum.of (degreeValuation K).Component α (C α) := by + exact (degreeValuation K).rv_dvd_iff_dvd_components B C + +end + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/InfiniteSupport.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/InfiniteSupport.lean new file mode 100644 index 0000000000..13dc96a195 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/InfiniteSupport.lean @@ -0,0 +1,298 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.NormalizedSeriesMaximalFinite +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.DegreeTermCount +public import Mathlib.Algebra.Group.Irreducible.Defs + +/-! +# Factorisation after removing finite-support divisors + +This module proves the conditional core of LM24, Proposition 5.6.1. A Hahn series with no +nonunit finite-support divisor factors into a nonzero scalar and a finite list of irreducible +series with infinite support. Well-founded induction on degree gives the factorisation, while +additivity of the uncompressed Cantor term count gives the sharp numerical upper bound. + +For an arbitrary nonzero series `b`, division by its normalized maximal finite-support divisor +`p(b)` produces a residual with the required divisor property. The resulting theorem retains +the nonzeroness of the scalar, although the printed proposition does not state that consequence. + +Pairwise greatest-common-divisor existence and the classification of units in the +finite-support ring remain explicit hypotheses. They are not hidden in instances. The coefficient +field has characteristic zero. +-/ + +open scoped HahnSeries NatOrdinal + +universe v + +namespace Berarducci + +public noncomputable section + +variable {K : Type v} [Field K] [CharZero K] + +/-- A Hahn series has only unit finite-support divisors. This is the intrinsic property of the +residual after removing its maximal finite-support divisor. -/ +def HasOnlyUnitFiniteSupportDivisors (b : Series K) : Prop := + ∀ p : FiniteSupportRing (K := K), (p : Series K) ∣ b → IsUnit p + +omit [CharZero K] in +/-- Characterization of having only unit finite-support divisors. -/ +theorem hasOnlyUnitFiniteSupportDivisors_iff (b : Series K) : + HasOnlyUnitFiniteSupportDivisors b ↔ + ∀ p : FiniteSupportRing (K := K), (p : Series K) ∣ b → IsUnit p := + Iff.rfl + +omit [CharZero K] in +/-- Every divisor of a series with only unit finite-support divisors has the same property. -/ +theorem HasOnlyUnitFiniteSupportDivisors.of_dvd + {b c : Series K} (hb : HasOnlyUnitFiniteSupportDivisors b) (hcb : c ∣ b) : + HasOnlyUnitFiniteSupportDivisors c := by + intro p hpc + exact hb p (dvd_trans hpc hcb) + +omit [CharZero K] in +private theorem series_coe_ne_zero {b : Series K} (hb : b ≠ 0) : + (b : K⟦ℝ⟧) ≠ 0 := by + intro hzero + apply hb + exact Subtype.ext hzero + +omit [CharZero K] in +/-- A nonunit series with only unit finite-support divisors has infinite support. -/ +theorem HasOnlyUnitFiniteSupportDivisors.support_infinite_of_not_isUnit + {b : Series K} (hb : HasOnlyUnitFiniteSupportDivisors b) + (hbUnit : ¬IsUnit b) : + (b : K⟦ℝ⟧).support.Infinite := by + by_contra hInfinite + have hFinite : (b : K⟦ℝ⟧).support.Finite := Set.not_infinite.mp hInfinite + let p : FiniteSupportRing (K := K) := ⟨b, by + rw [HahnSeries.Nonpositive.mem_finiteSupportSubring_iff] + exact hFinite⟩ + have hpDvd : (p : Series K) ∣ b := ⟨1, by simp [p]⟩ + have hpUnit : IsUnit p := hb p hpDvd + apply hbUnit + change IsUnit (p : Series K) + exact hpUnit.map + (HahnSeries.Nonpositive.finiteSupportSubring + (G := ℝ) (K := K)).subtype + +/-- A nonzero series with only unit finite-support divisors factors into a nonzero scalar and +irreducible infinite-support series, with the number of factors bounded by the Cantor term count +of its degree. -/ +theorem HasOnlyUnitFiniteSupportDivisors.exists_factorization + (hunits : ∀ p : FiniteSupportRing (K := K), + IsUnit p ↔ ∃ k : K, k ≠ 0 ∧ + p = HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℝ) k) + {b : Series K} (hb : b ≠ 0) + (hbPrimitive : HasOnlyUnitFiniteSupportDivisors b) : + ∃ (k : K) (factors : List (Series K)), + k ≠ 0 ∧ b = HahnSeries.Nonpositive.C k * factors.prod ∧ + (∀ c ∈ factors, + Irreducible c ∧ (c : K⟦ℝ⟧).support.Infinite) ∧ + factors.length ≤ HahnSeries.degreeCantorTermCount (b : K⟦ℝ⟧) := by + classical + let wf : WellFounded (Function.onFun (fun α β : WithBot NatOrdinal ↦ α < β) + (fun c : Series K ↦ (c : K⟦ℝ⟧).degree)) := + wellFounded_lt.onFun + refine wf.induction + (C := fun b ↦ b ≠ 0 → HasOnlyUnitFiniteSupportDivisors b → + ∃ (k : K) (factors : List (Series K)), + k ≠ 0 ∧ b = HahnSeries.Nonpositive.C k * factors.prod ∧ + (∀ c ∈ factors, + Irreducible c ∧ (c : K⟦ℝ⟧).support.Infinite) ∧ + factors.length ≤ + HahnSeries.degreeCantorTermCount (b : K⟦ℝ⟧)) b ?_ hb hbPrimitive + intro b ih hb hbPrimitive + by_cases hbDegree : (b : K⟦ℝ⟧).degree ≤ 0 + · have hbFinite : (b : K⟦ℝ⟧).support.Finite := + HahnSeries.degree_le_zero_iff.mp hbDegree + let p : FiniteSupportRing (K := K) := ⟨b, by + rw [HahnSeries.Nonpositive.mem_finiteSupportSubring_iff] + exact hbFinite⟩ + have hpDvd : (p : Series K) ∣ b := ⟨1, by simp [p]⟩ + obtain ⟨k, hk, hpk⟩ := (hunits p).mp (hbPrimitive p hpDvd) + refine ⟨k, [], hk, ?_, ?_, ?_⟩ + · rw [List.prod_nil, mul_one] + apply Subtype.ext + simpa only [p, HahnSeries.Nonpositive.coe_C, + HahnSeries.Nonpositive.coe_finiteSupportScalarHom] using congrArg + (fun q : FiniteSupportRing (K := K) ↦ + ((q : Series K) : K⟦ℝ⟧)) hpk + · simp + · simp + · have hbDegreePos : 0 < (b : K⟦ℝ⟧).degree := lt_of_not_ge hbDegree + have hbNotUnit : ¬IsUnit b := by + intro hbUnit + exact (not_le_of_gt hbDegreePos) + (HahnSeries.Nonpositive.degree_eq_zero_of_isUnit + HahnSeries.Nonpositive.degree_mul hbUnit).le + rcases irreducible_or_factor hbNotUnit with hbIrreducible | ⟨c, d, hcUnit, hdUnit, hfactor⟩ + · refine ⟨1, [b], one_ne_zero, ?_, ?_, ?_⟩ + · simp + · simp only [List.mem_singleton, forall_eq] + exact ⟨hbIrreducible, + HahnSeries.degree_pos_iff_support_infinite.mp hbDegreePos⟩ + · exact HahnSeries.degreeCantorTermCount_pos_of_degree_pos hbDegreePos + · have hc : c ≠ 0 := by + intro hc + apply hb + rw [hfactor, hc, zero_mul] + have hd : d ≠ 0 := by + intro hd + apply hb + rw [hfactor, hd, mul_zero] + have hcPrimitive := hbPrimitive.of_dvd ⟨d, hfactor⟩ + have hdPrimitive := hbPrimitive.of_dvd ⟨c, by + rw [mul_comm] + exact hfactor⟩ + have hcInfinite := hcPrimitive.support_infinite_of_not_isUnit hcUnit + have hdInfinite := hdPrimitive.support_infinite_of_not_isUnit hdUnit + have hcDegreePos : 0 < (c : K⟦ℝ⟧).degree := + HahnSeries.degree_pos_iff_support_infinite.mpr hcInfinite + have hdDegreePos : 0 < (d : K⟦ℝ⟧).degree := + HahnSeries.degree_pos_iff_support_infinite.mpr hdInfinite + have hcDegreeLt : (c : K⟦ℝ⟧).degree < (b : K⟦ℝ⟧).degree := by + calc + (c : K⟦ℝ⟧).degree < + (c : K⟦ℝ⟧).degree + (d : K⟦ℝ⟧).degree := + calc + (c : K⟦ℝ⟧).degree = + (c : K⟦ℝ⟧).degree + 0 := (add_zero _).symm + _ < (c : K⟦ℝ⟧).degree + (d : K⟦ℝ⟧).degree := + WithBot.add_lt_add_left + (HahnSeries.degree_eq_bot.not.mpr (series_coe_ne_zero hc)) + hdDegreePos + _ = ((c * d : Series K) : K⟦ℝ⟧).degree := + (HahnSeries.Nonpositive.degree_mul c d).symm + _ = (b : K⟦ℝ⟧).degree := congrArg + (fun q : Series K ↦ (q : K⟦ℝ⟧).degree) hfactor.symm + have hdDegreeLt : (d : K⟦ℝ⟧).degree < (b : K⟦ℝ⟧).degree := by + calc + (d : K⟦ℝ⟧).degree < + (c : K⟦ℝ⟧).degree + (d : K⟦ℝ⟧).degree := + calc + (d : K⟦ℝ⟧).degree = + 0 + (d : K⟦ℝ⟧).degree := (zero_add _).symm + _ < (c : K⟦ℝ⟧).degree + (d : K⟦ℝ⟧).degree := + WithBot.add_lt_add_right + (HahnSeries.degree_eq_bot.not.mpr (series_coe_ne_zero hd)) + hcDegreePos + _ = ((c * d : Series K) : K⟦ℝ⟧).degree := + (HahnSeries.Nonpositive.degree_mul c d).symm + _ = (b : K⟦ℝ⟧).degree := congrArg + (fun q : Series K ↦ (q : K⟦ℝ⟧).degree) hfactor.symm + obtain ⟨kc, cs, hkc, hcFactor, hcs, hcsBound⟩ := + ih c hcDegreeLt hc hcPrimitive + obtain ⟨kd, ds, hkd, hdFactor, hds, hdsBound⟩ := + ih d hdDegreeLt hd hdPrimitive + refine ⟨kc * kd, cs ++ ds, mul_ne_zero hkc hkd, ?_, ?_, ?_⟩ + · rw [hfactor, hcFactor, hdFactor, List.prod_append, + map_mul, mul_assoc] + ring + · intro q hq + rw [List.mem_append] at hq + exact hq.elim (hcs q) (hds q) + · rw [List.length_append] + calc + cs.length + ds.length ≤ + HahnSeries.degreeCantorTermCount (c : K⟦ℝ⟧) + + HahnSeries.degreeCantorTermCount (d : K⟦ℝ⟧) := + Nat.add_le_add hcsBound hdsBound + _ = HahnSeries.degreeCantorTermCount ((c * d : Series K) : K⟦ℝ⟧) := by + symm + apply HahnSeries.degreeCantorTermCount_mul + · simpa using HahnSeries.Nonpositive.degree_mul c d + · exact series_coe_ne_zero hc + · exact series_coe_ne_zero hd + _ = HahnSeries.degreeCantorTermCount (b : K⟦ℝ⟧) := by + rw [← hfactor] + +/-- Dividing a nonzero series by its normalized maximal finite-support divisor leaves only unit +finite-support divisors. -/ +theorem hasOnlyUnitFiniteSupportDivisors_residual (hgcd : ∀ p q : FiniteSupportRing (K := K), + ∃ d : FiniteSupportRing (K := K), + ∀ e : FiniteSupportRing (K := K), e ∣ p ∧ e ∣ q ↔ e ∣ d) + {b q : Series K} (hb : b ≠ 0) + (hq : b = + (seriesNormalizedMaximalFiniteSupportDivisor b : Series K) * q) : + HasOnlyUnitFiniteSupportDivisors q := by + let p := seriesNormalizedMaximalFiniteSupportDivisor b + have hpSpec := (isNormalizedSeriesMaximalFiniteSupportDivisor_iff b p).mp + (seriesNormalizedMaximalFiniteSupportDivisor_is_of_exists_gcd hgcd b) + have hpNe : p ≠ 0 := + (seriesNormalizedMaximalFiniteSupportDivisor_isMonic_of_ne_zero hgcd hb).ne_zero + intro r hrq + obtain ⟨s, hs⟩ := hrq + let pr : FiniteSupportRing (K := K) := p * r + have hprDvdB : (pr : Series K) ∣ b := by + refine ⟨s, ?_⟩ + rw [hq, hs] + simp only [pr, p, Subring.coe_mul, mul_assoc] + have hprDvdP : pr ∣ p := (hpSpec.1 pr).mp hprDvdB + obtain ⟨t, ht⟩ := hprDvdP + apply isUnit_iff_exists.mpr + have hrt : r * t = 1 := by + apply mul_left_cancel₀ hpNe + calc + p * (r * t) = (p * r) * t := (mul_assoc _ _ _).symm + _ = p := ht.symm + _ = p * 1 := (mul_one p).symm + exact ⟨t, hrt, by simpa only [mul_comm] using hrt⟩ + +/-- Conditional strengthened form of LM24, Proposition 5.6.1, retaining that the scalar is +nonzero. -/ +theorem exists_series_infinite_support_factorization_of_exists_gcd + (hgcd : ∀ p q : FiniteSupportRing (K := K), + ∃ d : FiniteSupportRing (K := K), + ∀ e : FiniteSupportRing (K := K), e ∣ p ∧ e ∣ q ↔ e ∣ d) + (hunits : ∀ p : FiniteSupportRing (K := K), + IsUnit p ↔ ∃ k : K, k ≠ 0 ∧ + p = HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℝ) k) + {b : Series K} (hb : b ≠ 0) : + ∃ (k : K) (factors : List (Series K)), + k ≠ 0 ∧ + b = HahnSeries.Nonpositive.C k * + (seriesNormalizedMaximalFiniteSupportDivisor b : Series K) * + factors.prod ∧ + (∀ c ∈ factors, + Irreducible c ∧ (c : K⟦ℝ⟧).support.Infinite) ∧ + factors.length ≤ HahnSeries.degreeCantorTermCount (b : K⟦ℝ⟧) := by + let p := seriesNormalizedMaximalFiniteSupportDivisor b + have hpDvd : (p : Series K) ∣ b := + seriesNormalizedMaximalFiniteSupportDivisor_dvd_of_exists_gcd hgcd b + obtain ⟨q, hq⟩ := hpDvd + have hqNe : q ≠ 0 := by + intro hzero + apply hb + rw [hq, hzero, mul_zero] + have hqPrimitive : HasOnlyUnitFiniteSupportDivisors q := + hasOnlyUnitFiniteSupportDivisors_residual hgcd hb hq + obtain ⟨k, factors, hk, hqFactor, hfactors, hbound⟩ := + hqPrimitive.exists_factorization hunits hqNe + refine ⟨k, factors, hk, ?_, hfactors, ?_⟩ + · change b = HahnSeries.Nonpositive.C k * (p : Series K) * factors.prod + rw [hq, hqFactor] + ring + · apply hbound.trans_eq + apply HahnSeries.degreeCantorTermCount_congr + rw [hq, HahnSeries.Nonpositive.degree_mul] + have hpNe : p ≠ 0 := + (seriesNormalizedMaximalFiniteSupportDivisor_isMonic_of_ne_zero hgcd hb).ne_zero + have hpSeriesNe : (p : Series K) ≠ 0 := by + intro hzero + exact hpNe (Subtype.ext hzero) + have hpHahnNe : (p : K⟦ℝ⟧) ≠ 0 := + series_coe_ne_zero hpSeriesNe + rw [HahnSeries.degree_eq_zero.mpr ⟨hpHahnNe, + (HahnSeries.Nonpositive.mem_finiteSupportSubring_iff (p : Series K)).mp p.2⟩, + zero_add] + +end + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/MaximalFinite.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/MaximalFinite.lean new file mode 100644 index 0000000000..5f65416c80 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/MaximalFinite.lean @@ -0,0 +1,574 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Divisibility.MaximalDivisor +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalSubringTensor +public import LeanPool.ConwayRefinement.ConwayRefinement.LinearAlgebra.TensorProduct.Content + +/-! +# Maximal finite-support divisors in the degree-graded ring + +This module constructs the intrinsic associate classes underlying LM24, Proposition 5.4.3, +Corollary 5.4.4, and Proposition 5.4.8. For a homogeneous component or for the full +degree-graded ring, a class is characterized by the equivalence + +`q divides the class ↔ Associates.mk q divides the maximal associate class`. + +The construction transports the basis-independent content of a tensor through the componentwise +and global tensor equivalences. A basis is therefore used only inside the generic existence proof; +it does not occur in any definition in this module. Pairwise gcd existence is an explicit theorem +hypothesis. It is neither installed as a typeclass nor incorporated into the primitive +definitions. + +The paper's representative-valued normalization and its exact statements in the RV monoid are +kept separate from this associate-class core. +-/ + +open scoped DirectSum HahnSeries NatOrdinal TensorProduct + +universe v + +namespace Berarducci + +public noncomputable section + +variable {K : Type v} [Field K] + +/-- Multiplication on the finite-support tensor factor agrees with the residue-ring action on a +fixed component of `RV̂`. -/ +theorem principalComponentTensorEquiv_mulRightFactor + (α : NatOrdinal) (q : FiniteSupportRing (K := K)) + (z : PrincipalComponent K α ⊗[K] FiniteSupportRing (K := K)) : + principalComponentTensorEquiv K α + (TensorProduct.mulRightFactor q z) = + HahnSeries.Nonpositive.degreeFiniteSupportResidueEquiv K q • + principalComponentTensorEquiv K α z := by + induction z using TensorProduct.inductionOn with + | tmul x p => + rw [TensorProduct.mulRightFactor_tmul, + principalComponentTensorEquiv_tmul, + principalComponentTensorEquiv_tmul, map_mul] + exact degreeResidue_smul_smul α _ _ _ + | add x y hx hy => + rw [(TensorProduct.mulRightFactor (K := K) q).map_add, + (principalComponentTensorEquiv K α).map_add, + (principalComponentTensorEquiv K α).map_add, hx, hy] + exact (smul_add + (HahnSeries.Nonpositive.degreeFiniteSupportResidueEquiv K q) + (principalComponentTensorEquiv K α x) + (principalComponentTensorEquiv K α y)).symm + +/-- Multiplication on the finite-support tensor factor agrees with multiplication by the +grade-zero finite-support embedding in the associated graded ring. -/ +theorem principalSubringTensorEquiv_mulRightFactor [CharZero K] (q : FiniteSupportRing (K := K)) + (z : PrincipalSubring K ⊗[K] FiniteSupportRing (K := K)) : + principalSubringTensorEquiv K + (TensorProduct.mulRightFactor q z) = + finiteSupportGradedEmbedding K q * + principalSubringTensorEquiv K z := by + induction z using TensorProduct.inductionOn with + | tmul x p => + rw [TensorProduct.mulRightFactor_tmul, + principalSubringTensorEquiv_tmul, + principalSubringTensorEquiv_tmul, map_mul] + ac_rfl + | add x y hx hy => + calc + principalSubringTensorEquiv K + (TensorProduct.mulRightFactor q (x + y)) = + principalSubringTensorEquiv K + (TensorProduct.mulRightFactor q x + + TensorProduct.mulRightFactor q y) := + congrArg (principalSubringTensorEquiv K) + ((TensorProduct.mulRightFactor (K := K) q).map_add x y) + _ = principalSubringTensorEquiv K + (TensorProduct.mulRightFactor q x) + + principalSubringTensorEquiv K + (TensorProduct.mulRightFactor q y) := + map_add (principalSubringTensorEquiv K) _ _ + _ = finiteSupportGradedEmbedding K q * + principalSubringTensorEquiv K x + + finiteSupportGradedEmbedding K q * + principalSubringTensorEquiv K y := + congrArg₂ (· + ·) hx hy + _ = finiteSupportGradedEmbedding K q * + (principalSubringTensorEquiv K x + + principalSubringTensorEquiv K y) := + (mul_add _ _ _).symm + _ = finiteSupportGradedEmbedding K q * + principalSubringTensorEquiv K (x + y) := + congrArg (finiteSupportGradedEmbedding K q * ·) + (map_add (principalSubringTensorEquiv K) x y).symm + +/-- An associate class records exactly the finite-support divisors of a fixed homogeneous +component of `RV̂`. -/ +def IsLayerMaximalFiniteSupportDivisor (α : NatOrdinal) + (B : (HahnSeries.Nonpositive.degreeValuation K).Component α) + (a : Associates (FiniteSupportRing (K := K))) : Prop := + ∀ q : FiniteSupportRing (K := K), Associates.mk q ≤ a ↔ + ∃ C : (HahnSeries.Nonpositive.degreeValuation K).Component α, + HahnSeries.Nonpositive.degreeFiniteSupportResidueEquiv K q • C = B + +/-- The defining divisibility characterization for a fixed homogeneous component. -/ +theorem isLayerMaximalFiniteSupportDivisor_iff (α : NatOrdinal) + (B : (HahnSeries.Nonpositive.degreeValuation K).Component α) + (a : Associates (FiniteSupportRing (K := K))) : + IsLayerMaximalFiniteSupportDivisor α B a ↔ + ∀ q : FiniteSupportRing (K := K), Associates.mk q ≤ a ↔ + ∃ C : + (HahnSeries.Nonpositive.degreeValuation K).Component α, + HahnSeries.Nonpositive.degreeFiniteSupportResidueEquiv K q • C = B := + Iff.rfl + +/-- An associate class records exactly the divisors of a graded element that arise from the +finite-support subring in grade zero. -/ +def IsGradedMaximalFiniteSupportDivisor (B : DegreeGraded K) + (a : Associates (FiniteSupportRing (K := K))) : Prop := + IsMaximalDivisorAlong + (finiteSupportGradedEmbedding K).toMonoidHom B a + +/-- The defining divisibility characterization for an element of the associated graded ring. -/ +theorem isGradedMaximalFiniteSupportDivisor_iff (B : DegreeGraded K) + (a : Associates (FiniteSupportRing (K := K))) : + IsGradedMaximalFiniteSupportDivisor B a ↔ + ∀ q : FiniteSupportRing (K := K), Associates.mk q ≤ a ↔ + (finiteSupportGradedEmbedding K).toMonoidHom q ∣ B := by + rw [IsGradedMaximalFiniteSupportDivisor, + isMaximalDivisorAlong_iff] + +/-- Representative form of the maximal-divisor characterization used in LM24, +Corollary 5.4.4. -/ +theorem isGradedMaximalFiniteSupportDivisor_mk_iff (B : DegreeGraded K) + (p : FiniteSupportRing (K := K)) : + IsGradedMaximalFiniteSupportDivisor B (Associates.mk p) ↔ + ∀ q : FiniteSupportRing (K := K), + finiteSupportGradedEmbedding K q ∣ B ↔ q ∣ p := by + rw [isGradedMaximalFiniteSupportDivisor_iff] + constructor + · intro h q + constructor + · intro hqB + exact Associates.mk_le_mk_iff_dvd.mp ((h q).mpr hqB) + · intro hqp + exact (h q).mp (Associates.mk_le_mk_iff_dvd.mpr hqp) + · intro h q + constructor + · intro hqp + exact (h q).mpr (Associates.mk_le_mk_iff_dvd.mp hqp) + · intro hqB + exact Associates.mk_le_mk_iff_dvd.mpr ((h q).mp hqB) + +/-- The maximal-divisor predicate on a homogeneous component is the intrinsic tensor-content +predicate transported through the homogeneous-component equivalence. -/ +theorem isContent_principalComponentTensorEquiv_symm_iff (α : NatOrdinal) + (B : (HahnSeries.Nonpositive.degreeValuation K).Component α) + (a : Associates (FiniteSupportRing (K := K))) : + TensorProduct.IsContent + ((principalComponentTensorEquiv K α).symm B) a ↔ + IsLayerMaximalFiniteSupportDivisor α B a := by + rw [TensorProduct.isContent_iff, + isLayerMaximalFiniteSupportDivisor_iff] + constructor + · intro h q + rw [h q] + constructor + · rintro ⟨z, hz⟩ + refine ⟨principalComponentTensorEquiv K α z, ?_⟩ + rw [← principalComponentTensorEquiv_mulRightFactor, + hz, LinearEquiv.apply_symm_apply] + · rintro ⟨C, hC⟩ + refine ⟨(principalComponentTensorEquiv K α).symm C, ?_⟩ + apply (principalComponentTensorEquiv K α).injective + rw [principalComponentTensorEquiv_mulRightFactor, + LinearEquiv.apply_symm_apply, LinearEquiv.apply_symm_apply, hC] + · intro h q + rw [h q] + constructor + · rintro ⟨C, hC⟩ + refine ⟨(principalComponentTensorEquiv K α).symm C, ?_⟩ + apply (principalComponentTensorEquiv K α).injective + rw [principalComponentTensorEquiv_mulRightFactor, + LinearEquiv.apply_symm_apply, LinearEquiv.apply_symm_apply, hC] + · rintro ⟨z, hz⟩ + refine ⟨principalComponentTensorEquiv K α z, ?_⟩ + rw [← principalComponentTensorEquiv_mulRightFactor, + hz, LinearEquiv.apply_symm_apply] + +/-- Multiplying a nonzero principal fixed-degree class by a finite-support series gives a class +whose maximal finite-support divisor is represented by that finite-support series. -/ +theorem isLayerMaximalFiniteSupportDivisor_finiteSupport_mul_principal [CharZero K] + (α : NatOrdinal) (p : FiniteSupportRing (K := K)) (a : Series K) + (ha : HahnSeries.Nonpositive.IsPrincipal a) + (haDegree : (a : K⟦ℝ⟧).degree = (α : WithBot NatOrdinal)) : + IsLayerMaximalFiniteSupportDivisor α + (degreeLayerMk α ((p : Series K) * a) (by + rw [HahnSeries.Nonpositive.degree_mul, haDegree] + exact add_le_of_nonpos_left (HahnSeries.degree_le_zero_iff.mpr + ((HahnSeries.Nonpositive.mem_finiteSupportSubring_iff + (p : Series K)).mp p.2)))) + (Associates.mk p) := by + let C := degreeLayerMk α a haDegree.le + have hCPrincipal : IsPrincipalDegreeClass α C := by + rw [isPrincipalDegreeClass_iff] + exact Or.inr ⟨a, ha, haDegree, rfl⟩ + let x := degreeLayerToPrincipalComponent K α C + have hxImage : principalComponentToHahnDegreeLayer K α x = C := + principalComponentToHahnDegreeLayer_degreeLayerToPrincipalComponent_of_isPrincipal + α C hCPrincipal + have hC : C ≠ 0 := by + intro hzero + have hlt := (degreeLayerMk_eq_zero_iff α a haDegree.le).mp hzero + rw [haDegree] at hlt + exact lt_irrefl _ hlt + have hx : x ≠ 0 := by + intro hzero + apply hC + rw [← hxImage, hzero, map_zero] + have heq : + principalComponentTensorEquiv K α (x ⊗ₜ[K] p) = + degreeLayerMk α ((p : Series K) * a) (by + rw [HahnSeries.Nonpositive.degree_mul, haDegree] + exact add_le_of_nonpos_left (HahnSeries.degree_le_zero_iff.mpr + ((HahnSeries.Nonpositive.mem_finiteSupportSubring_iff + (p : Series K)).mp p.2))) := by + rw [principalComponentTensorEquiv_tmul, hxImage] + exact degreeFiniteSupportResidueEquiv_smul_degreeLayerMk α p a haDegree.le + apply (isContent_principalComponentTensorEquiv_symm_iff α _ (Associates.mk p)).mp + rw [← heq, LinearEquiv.symm_apply_apply] + exact TensorProduct.isContent_tmul_of_ne_zero x hx p + +/-- The graded maximal-divisor predicate is intrinsic tensor content transported through the +global tensor equivalence. -/ +theorem isContent_principalGradedTensorEquiv_symm_iff [CharZero K] (B : DegreeGraded K) + (a : Associates (FiniteSupportRing (K := K))) : + TensorProduct.IsContent + ((principalSubringTensorEquiv K).symm B) a ↔ + IsGradedMaximalFiniteSupportDivisor B a := by + rw [TensorProduct.isContent_iff, + isGradedMaximalFiniteSupportDivisor_iff] + constructor + · intro h q + rw [h q] + constructor + · rintro ⟨z, hz⟩ + refine ⟨principalSubringTensorEquiv K z, ?_⟩ + change B = finiteSupportGradedEmbedding K q * + principalSubringTensorEquiv K z + rw [← principalSubringTensorEquiv_mulRightFactor, + hz, AlgEquiv.apply_symm_apply] + · rintro ⟨C, hC⟩ + change B = finiteSupportGradedEmbedding K q * C at hC + refine ⟨(principalSubringTensorEquiv K).symm C, ?_⟩ + apply (principalSubringTensorEquiv K).injective + rw [principalSubringTensorEquiv_mulRightFactor, + AlgEquiv.apply_symm_apply, AlgEquiv.apply_symm_apply] + exact hC.symm + · intro h q + rw [h q] + constructor + · rintro ⟨C, hC⟩ + change B = finiteSupportGradedEmbedding K q * C at hC + refine ⟨(principalSubringTensorEquiv K).symm C, ?_⟩ + apply (principalSubringTensorEquiv K).injective + rw [principalSubringTensorEquiv_mulRightFactor, + AlgEquiv.apply_symm_apply, AlgEquiv.apply_symm_apply] + exact hC.symm + · rintro ⟨z, hz⟩ + refine ⟨principalSubringTensorEquiv K z, ?_⟩ + change B = finiteSupportGradedEmbedding K q * + principalSubringTensorEquiv K z + rw [← principalSubringTensorEquiv_mulRightFactor, + hz, AlgEquiv.apply_symm_apply] + +/-- A finite-support series, embedded in grade zero, is its own maximal finite-support +divisor. -/ +theorem isGradedMaximalFiniteSupportDivisor_finiteSupport [CharZero K] (p : FiniteSupportRing (K + := K)) : + IsGradedMaximalFiniteSupportDivisor + (finiteSupportGradedEmbedding K p) (Associates.mk p) := by + apply (isContent_principalGradedTensorEquiv_symm_iff _ (Associates.mk p)).mp + rw [← principalSubringTensorEquiv_one_tmul p, + AlgEquiv.symm_apply_apply] + have hOne : (1 : PrincipalSubring K) ≠ 0 := by + intro hzero + have htarget : (1 : DegreeGraded K) = 0 := by + rw [← map_one (principalSubringEmbedding K), + ← map_zero (principalSubringEmbedding K), hzero] + have hfinite : + finiteSupportGradedEmbedding K + (1 : FiniteSupportRing (K := K)) = + finiteSupportGradedEmbedding K 0 := by + calc + finiteSupportGradedEmbedding K + (1 : FiniteSupportRing (K := K)) = 1 := + map_one (finiteSupportGradedEmbedding K) + _ = 0 := htarget + _ = finiteSupportGradedEmbedding K 0 := + (map_zero (finiteSupportGradedEmbedding K)).symm + exact one_ne_zero (finiteSupportGradedEmbedding_injective K hfinite) + exact TensorProduct.isContent_tmul_of_ne_zero + (1 : PrincipalSubring K) hOne p + +/-- Multiplying a nonzero principal fixed-degree class by a finite-support series gives a +homogeneous graded class whose maximal finite-support divisor is represented by that series. -/ +theorem isGradedMaximalFiniteSupportDivisor_finiteSupport_mul_principal [CharZero K] + (α : NatOrdinal) (p : FiniteSupportRing (K := K)) (a : Series K) + (ha : HahnSeries.Nonpositive.IsPrincipal a) + (haDegree : (a : K⟦ℝ⟧).degree = (α : WithBot NatOrdinal)) : + IsGradedMaximalFiniteSupportDivisor + (DirectSum.of + (HahnSeries.Nonpositive.degreeValuation K).Component + α + (degreeLayerMk α ((p : Series K) * a) (by + rw [HahnSeries.Nonpositive.degree_mul, haDegree] + exact add_le_of_nonpos_left (HahnSeries.degree_le_zero_iff.mpr + ((HahnSeries.Nonpositive.mem_finiteSupportSubring_iff + (p : Series K)).mp p.2))))) + (Associates.mk p) := by + let C := degreeLayerMk α a haDegree.le + have hCPrincipal : IsPrincipalDegreeClass α C := by + rw [isPrincipalDegreeClass_iff] + exact Or.inr ⟨a, ha, haDegree, rfl⟩ + let x := degreeLayerToPrincipalComponent K α C + have hxImage : principalComponentToHahnDegreeLayer K α x = C := + principalComponentToHahnDegreeLayer_degreeLayerToPrincipalComponent_of_isPrincipal + α C hCPrincipal + have hC : C ≠ 0 := by + intro hzero + have hlt := (degreeLayerMk_eq_zero_iff α a haDegree.le).mp hzero + rw [haDegree] at hlt + exact lt_irrefl _ hlt + have hx : x ≠ 0 := by + intro hzero + apply hC + rw [← hxImage, hzero, map_zero] + let X : PrincipalSubring K := + DirectSum.of (PrincipalComponent K) α x + have hX : X ≠ 0 := by + intro hzero + apply hx + exact DirectSum.of_injective α (by simpa [X] using hzero) + have heq : + principalSubringTensorEquiv K (X ⊗ₜ[K] p) = + DirectSum.of + (HahnSeries.Nonpositive.degreeValuation K).Component + α + (degreeLayerMk α ((p : Series K) * a) (by + rw [HahnSeries.Nonpositive.degree_mul, haDegree] + exact add_le_of_nonpos_left (HahnSeries.degree_le_zero_iff.mpr + ((HahnSeries.Nonpositive.mem_finiteSupportSubring_iff + (p : Series K)).mp p.2)))) := by + rw [principalSubringTensorEquiv_tmul, show X = + DirectSum.of (PrincipalComponent K) α x by rfl, + principalSubringEmbedding_of, hxImage, mul_comm, + finiteSupportGradedEmbedding_mul_of] + exact congrArg + (DirectSum.of + (HahnSeries.Nonpositive.degreeValuation K).Component + α) + (degreeFiniteSupportResidueEquiv_smul_degreeLayerMk α p a haDegree.le) + apply (isContent_principalGradedTensorEquiv_symm_iff _ (Associates.mk p)).mp + rw [← heq, AlgEquiv.symm_apply_apply] + exact TensorProduct.isContent_tmul_of_ne_zero X hX p + +/-- A fixed homogeneous component has at most one maximal finite-support divisor class. -/ +theorem IsLayerMaximalFiniteSupportDivisor.eq {α : NatOrdinal} + {B : (HahnSeries.Nonpositive.degreeValuation K).Component α} + {a b : Associates (FiniteSupportRing (K := K))} + (ha : IsLayerMaximalFiniteSupportDivisor α B a) + (hb : IsLayerMaximalFiniteSupportDivisor α B b) : a = b := by + induction a using Quotient.inductionOn with + | _ p => + induction b using Quotient.inductionOn with + | _ q => + apply le_antisymm + · exact (hb p).2 ((ha p).1 le_rfl) + · exact (ha q).2 ((hb q).1 le_rfl) + +/-- A graded element has at most one maximal finite-support divisor class. -/ +theorem IsGradedMaximalFiniteSupportDivisor.eq {B : DegreeGraded K} + {a b : Associates (FiniteSupportRing (K := K))} + (ha : IsGradedMaximalFiniteSupportDivisor B a) + (hb : IsGradedMaximalFiniteSupportDivisor B b) : a = b := by + exact IsMaximalDivisorAlong.eq ha hb + +/-- Pairwise gcd existence gives a unique maximal finite-support divisor of every fixed +homogeneous component. -/ +theorem existsUnique_isLayerMaximalFiniteSupportDivisor_of_exists_gcd + (hgcd : ∀ p q : FiniteSupportRing (K := K), + ∃ d : FiniteSupportRing (K := K), + ∀ e : FiniteSupportRing (K := K), + e ∣ p ∧ e ∣ q ↔ e ∣ d) + (α : NatOrdinal) + (B : (HahnSeries.Nonpositive.degreeValuation K).Component α) : + ∃! a : Associates (FiniteSupportRing (K := K)), + IsLayerMaximalFiniteSupportDivisor α B a := by + obtain ⟨a, ha, hunique⟩ := + TensorProduct.existsUnique_isContent_of_exists_gcd hgcd + ((principalComponentTensorEquiv K α).symm B) + refine ⟨a, + (isContent_principalComponentTensorEquiv_symm_iff α B a).mp ha, + ?_⟩ + intro b hb + exact hunique b + ((isContent_principalComponentTensorEquiv_symm_iff α B b).mpr hb) + +/-- A principal fixed-degree class has a maximal finite-support divisor represented by a +constant series. -/ +theorem exists_scalar_isLayerMaximalFiniteSupportDivisor_of_isPrincipal (α : NatOrdinal) + (B : (HahnSeries.Nonpositive.degreeValuation K).Component α) + (hB : IsPrincipalDegreeClass α B) : + ∃ k : K, IsLayerMaximalFiniteSupportDivisor α B + (Associates.mk + (HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℝ) k)) := by + by_cases hB0 : B = 0 + · subst B + refine ⟨0, ?_⟩ + simpa using + (isContent_principalComponentTensorEquiv_symm_iff α 0 0).mp + (by + simpa using + (TensorProduct.isContent_zero (K := K) + (D := FiniteSupportRing (K := K)) + (V := PrincipalComponent K α))) + · let x := degreeLayerToPrincipalComponent K α B + have hxImage : principalComponentToHahnDegreeLayer K α x = B := + principalComponentToHahnDegreeLayer_degreeLayerToPrincipalComponent_of_isPrincipal α B hB + have hx : x ≠ 0 := by + intro hx0 + apply hB0 + rw [← hxImage, hx0, map_zero] + have hinv : (principalComponentTensorEquiv K α).symm B = + x ⊗ₜ[K] (1 : FiniteSupportRing (K := K)) := by + apply (principalComponentTensorEquiv K α).injective + rw [LinearEquiv.apply_symm_apply, principalComponentTensorEquiv_tmul, + map_one, degreeResidue_one_smul, hxImage] + refine ⟨1, ?_⟩ + have hcontent := TensorProduct.isContent_tmul_one_of_ne_zero + (K := K) (D := FiniteSupportRing (K := K)) x hx + rw [← hinv] at hcontent + simpa using + (isContent_principalComponentTensorEquiv_symm_iff α B 1).mp hcontent + +/-- Pairwise gcd existence gives a unique maximal finite-support divisor of every element of the +degree-graded ring. -/ +theorem existsUnique_isGradedMaximalFiniteSupportDivisor_of_exists_gcd [CharZero K] + (hgcd : ∀ p q : FiniteSupportRing (K := K), + ∃ d : FiniteSupportRing (K := K), + ∀ e : FiniteSupportRing (K := K), + e ∣ p ∧ e ∣ q ↔ e ∣ d) + (B : DegreeGraded K) : + ∃! a : Associates (FiniteSupportRing (K := K)), + IsGradedMaximalFiniteSupportDivisor B a := by + obtain ⟨a, ha, hunique⟩ := + TensorProduct.existsUnique_isContent_of_exists_gcd hgcd + ((principalSubringTensorEquiv K).symm B) + refine ⟨a, + (isContent_principalGradedTensorEquiv_symm_iff B a).mp ha, + ?_⟩ + intro b hb + exact hunique b + ((isContent_principalGradedTensorEquiv_symm_iff B b).mpr hb) + +/-- The canonical maximal finite-support divisor class of a homogeneous component. + +The fallback branch is unreachable whenever maximal-divisor existence has been established. -/ +noncomputable def layerMaximalFiniteSupportDivisor (α : NatOrdinal) + (B : (HahnSeries.Nonpositive.degreeValuation K).Component α) : + Associates (FiniteSupportRing (K := K)) := by + classical + exact if h : ∃ a : Associates (FiniteSupportRing (K := K)), + IsLayerMaximalFiniteSupportDivisor α B a then + Classical.choose h + else + 0 + +/-- Any class satisfying the homogeneous-component characterization is the canonical class. -/ +theorem layerMaximalFiniteSupportDivisor_eq_of_is {α : NatOrdinal} + {B : (HahnSeries.Nonpositive.degreeValuation K).Component α} + {a : Associates (FiniteSupportRing (K := K))} + (ha : IsLayerMaximalFiniteSupportDivisor α B a) : + layerMaximalFiniteSupportDivisor α B = a := by + classical + let hex : ∃ b : Associates (FiniteSupportRing (K := K)), + IsLayerMaximalFiniteSupportDivisor α B b := ⟨a, ha⟩ + rw [layerMaximalFiniteSupportDivisor, dite_eq_left hex] + exact (Classical.choose_spec hex).eq ha + +/-- Under pairwise gcd existence, the canonical homogeneous class satisfies its defining +characterization. -/ +theorem layerMaximalFiniteSupportDivisor_is_of_exists_gcd + (hgcd : ∀ p q : FiniteSupportRing (K := K), + ∃ d : FiniteSupportRing (K := K), + ∀ e : FiniteSupportRing (K := K), + e ∣ p ∧ e ∣ q ↔ e ∣ d) + (α : NatOrdinal) + (B : (HahnSeries.Nonpositive.degreeValuation K).Component α) : + IsLayerMaximalFiniteSupportDivisor α B + (layerMaximalFiniteSupportDivisor α B) := by + obtain ⟨a, ha, _⟩ := + existsUnique_isLayerMaximalFiniteSupportDivisor_of_exists_gcd hgcd α B + rw [layerMaximalFiniteSupportDivisor_eq_of_is ha] + exact ha + +/-- The canonical maximal finite-support divisor class of a graded element. + +The fallback branch is unreachable whenever maximal-divisor existence has been established. -/ +noncomputable def gradedMaximalFiniteSupportDivisor (B : DegreeGraded K) : + Associates (FiniteSupportRing (K := K)) := by + classical + exact if h : ∃ a : Associates (FiniteSupportRing (K := K)), + IsGradedMaximalFiniteSupportDivisor B a then + Classical.choose h + else + 0 + +/-- Any class satisfying the graded characterization is the canonical class. -/ +theorem gradedMaximalFiniteSupportDivisor_eq_of_is {B : DegreeGraded K} + {a : Associates (FiniteSupportRing (K := K))} + (ha : IsGradedMaximalFiniteSupportDivisor B a) : + gradedMaximalFiniteSupportDivisor B = a := by + classical + let hex : ∃ b : Associates (FiniteSupportRing (K := K)), + IsGradedMaximalFiniteSupportDivisor B b := ⟨a, ha⟩ + rw [gradedMaximalFiniteSupportDivisor, dite_eq_left hex] + exact (Classical.choose_spec hex).eq ha + +/-- Under pairwise gcd existence, the canonical graded class satisfies its defining +characterization. -/ +theorem gradedMaximalFiniteSupportDivisor_is_of_exists_gcd [CharZero K] + (hgcd : ∀ p q : FiniteSupportRing (K := K), + ∃ d : FiniteSupportRing (K := K), + ∀ e : FiniteSupportRing (K := K), + e ∣ p ∧ e ∣ q ↔ e ∣ d) + (B : DegreeGraded K) : + IsGradedMaximalFiniteSupportDivisor B + (gradedMaximalFiniteSupportDivisor B) := by + obtain ⟨a, ha, _⟩ := + existsUnique_isGradedMaximalFiniteSupportDivisor_of_exists_gcd hgcd B + rw [gradedMaximalFiniteSupportDivisor_eq_of_is ha] + exact ha + +/-- Associate-class form of LM24, Proposition 5.4.8: maximal finite-support divisor classes are +supermultiplicative. -/ +theorem gradedMaximalFiniteSupportDivisor_mul_le_of_exists_gcd [CharZero K] + (hgcd : ∀ p q : FiniteSupportRing (K := K), + ∃ d : FiniteSupportRing (K := K), + ∀ e : FiniteSupportRing (K := K), + e ∣ p ∧ e ∣ q ↔ e ∣ d) + (B C : DegreeGraded K) : + gradedMaximalFiniteSupportDivisor B * + gradedMaximalFiniteSupportDivisor C ≤ + gradedMaximalFiniteSupportDivisor (B * C) := by + exact IsMaximalDivisorAlong.mul_le + (gradedMaximalFiniteSupportDivisor_is_of_exists_gcd hgcd B) + (gradedMaximalFiniteSupportDivisor_is_of_exists_gcd hgcd C) + (gradedMaximalFiniteSupportDivisor_is_of_exists_gcd hgcd (B * C)) + +end + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/MaximalFiniteMultiplicativity.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/MaximalFiniteMultiplicativity.lean new file mode 100644 index 0000000000..d9ce694253 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/MaximalFiniteMultiplicativity.lean @@ -0,0 +1,105 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.NormalizedMaximalFinite + +import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.AssociatedGradedDivisibility + +/-! +# Multiplicativity of normalized maximal finite-support divisors + +This module proves the field-generic reduction underlying LM24, Corollary 6.3.7. If every +finite-support divisor of a product in `RV̂` factors into finite-support divisors of the two +factors, then the normalized maximal finite-support divisor is multiplicative. + +Pairwise greatest-common-divisor existence and the classification of finite-support units remain +explicit hypotheses; the statements module discharges both over the real exponents. +-/ + +open scoped DirectSum HahnSeries NatOrdinal + +universe v + +namespace Berarducci + +public noncomputable section + +open HahnSeries.Nonpositive + +variable {K : Type v} [Field K] [CharZero K] + +/-- The normalized maximal finite-support divisor is multiplicative whenever finite-support +divisors of products admit compatible finite-support factorisations. -/ +theorem gradedNormalizedMaximalFiniteSupportDivisor_mul_of_factorization + (hgcd : ∀ p q : FiniteSupportRing (K := K), + ∃ d : FiniteSupportRing (K := K), + ∀ e : FiniteSupportRing (K := K), e ∣ p ∧ e ∣ q ↔ e ∣ d) + (hunits : ∀ u : FiniteSupportRing (K := K), + IsUnit u ↔ ∃ k : K, k ≠ 0 ∧ + u = finiteSupportScalarHom (G := ℝ) k) + (hfactor : ∀ (p : FiniteSupportRing (K := K)) + (B C : DegreeGraded K), + finiteSupportGradedEmbedding K p ∣ B * C → + ∃ p₁ p₂ : FiniteSupportRing (K := K), + p = p₁ * p₂ ∧ + finiteSupportGradedEmbedding K p₁ ∣ B ∧ + finiteSupportGradedEmbedding K p₂ ∣ C) + (B C : DegreeGraded K) : + gradedNormalizedMaximalFiniteSupportDivisor (B * C) = + gradedNormalizedMaximalFiniteSupportDivisor B * + gradedNormalizedMaximalFiniteSupportDivisor C := by + let pB := gradedNormalizedMaximalFiniteSupportDivisor B + let pC := gradedNormalizedMaximalFiniteSupportDivisor C + have hmaxB := (isNormalizedGradedMaximalFiniteSupportDivisor_iff B _).mp + (gradedNormalizedMaximalFiniteSupportDivisor_is_of_exists_gcd hgcd B) + have hmaxC := (isNormalizedGradedMaximalFiniteSupportDivisor_iff C _).mp + (gradedNormalizedMaximalFiniteSupportDivisor_is_of_exists_gcd hgcd C) + have hmaxBC := (isNormalizedGradedMaximalFiniteSupportDivisor_iff (B * C) _).mp + (gradedNormalizedMaximalFiniteSupportDivisor_is_of_exists_gcd hgcd (B * C)) + apply gradedNormalizedMaximalFiniteSupportDivisor_eq_of_is hgcd hunits + rw [isNormalizedGradedMaximalFiniteSupportDivisor_iff] + constructor + · intro q + constructor + · intro hq + obtain ⟨q₁, q₂, hqFactor, hq₁, hq₂⟩ := hfactor q B C hq + rw [hqFactor] + exact mul_dvd_mul ((hmaxB.1 q₁).mp hq₁) ((hmaxC.1 q₂).mp hq₂) + · intro hq + apply (hmaxBC.1 q).mpr + exact hq.trans + (gradedNormalizedMaximalFiniteSupportDivisor_mul_dvd_of_exists_gcd hgcd B C) + · by_cases hBC : B * C = 0 + · apply Or.inl + refine ⟨hBC, ?_⟩ + change pB * pC = 0 + rcases eq_zero_or_eq_zero_of_mul_eq_zero hBC with hB | hC + · have hpB : pB = 0 := by + rcases hmaxB.2 with h | h + · exact h.2 + · exact (h.1 hB).elim + rw [hpB, zero_mul] + · have hpC : pC = 0 := by + rcases hmaxC.2 with h | h + · exact h.2 + · exact (h.1 hC).elim + rw [hpC, mul_zero] + · apply Or.inr + refine ⟨hBC, ?_⟩ + apply IsMonicFiniteSupport.mul + · apply gradedNormalizedMaximalFiniteSupportDivisor_isMonic_of_ne_zero hgcd + intro hB + apply hBC + rw [hB, zero_mul] + · apply gradedNormalizedMaximalFiniteSupportDivisor_isMonic_of_ne_zero hgcd + intro hC + apply hBC + rw [hC, mul_zero] + +end + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/NormalizedHPart.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/NormalizedHPart.lean new file mode 100644 index 0000000000..d3f73fb7ab --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/NormalizedHPart.lean @@ -0,0 +1,173 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.FiniteSupportConstantTermOne +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.RealSupportSupremum + +import Mathlib.Algebra.GroupWithZero.Divisibility +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Monomial + +/-! +# Normalized finite-support part over an exponent subgroup + +LM24, Lemma 6.5.2 associates to a nonzero finite-support real-exponent series `p` a unique +series `p_H` in `1 + K(H^{< 0})`. The defining property is intrinsic: every normalized +finite-support `H`-series divides `p` after exponent-domain extension exactly when it divides +`p_H` over `H`. + +This file freezes that property and its uniqueness proposition without choosing a factorisation +of `p`. The full existence theorem depends on the Ritt factorisation and greatest-common-divisor +prerequisites used in the paper; no such prerequisite is hidden in the definition. The identity +case is proved completely as a semantic boundary check. +-/ + +open scoped HahnSeries + +universe v + +public noncomputable section + +namespace HahnSeries.Nonpositive + +variable (H : AddSubgroup ℝ) {K : Type v} [Field K] + +/-- The finite-support exponent-domain embedding induced by `H ⊆ ℝ`. -/ +def finiteSupportToReal : + FiniteSupportRing (G := H) (K := K) →+* + FiniteSupportRing (G := ℝ) (K := K) := + mapDomainFiniteSupport H.subtype H.subtype_injective fun _ _ ↦ ⟨fun h ↦ h, fun h ↦ h⟩ + +/-- The underlying nonpositive series of `finiteSupportToReal` is `mapDomainToReal`. -/ +@[simp] +theorem coe_finiteSupportToReal + (p : FiniteSupportRing (G := H) (K := K)) : + ((finiteSupportToReal H p : FiniteSupportRing (G := ℝ) (K := K)) : + Nonpositive ℝ K) = mapDomainToReal H (p : Nonpositive H K) := + by + apply Subtype.ext + rw [finiteSupportToReal, coe_mapDomainFiniteSupport, + coe_mapDomainToReal, coe_mapDomain] + +/-- A normalized finite-support `H`-series is the normalized `H`-part of `p` when it has exactly +the same normalized `H`-divisors as `p` has after exponent-domain extension. -/ +def IsNormalizedHPart + (p : FiniteSupportRing (G := ℝ) (K := K)) + (q : ConstantTermOneFiniteSupport (G := H) (K := K)) : Prop := + ∀ r : ConstantTermOneFiniteSupport (G := H) (K := K), + finiteSupportToReal H + (r : FiniteSupportRing (G := H) (K := K)) ∣ p ↔ + (r : FiniteSupportRing (G := H) (K := K)) ∣ + (q : FiniteSupportRing (G := H) (K := K)) + +/-- Characterization of the normalized `H`-part property by divisibility. -/ +theorem isNormalizedHPart_iff + (p : FiniteSupportRing (G := ℝ) (K := K)) + (q : ConstantTermOneFiniteSupport (G := H) (K := K)) : + IsNormalizedHPart H p q ↔ + ∀ r : ConstantTermOneFiniteSupport (G := H) (K := K), + finiteSupportToReal H + (r : FiniteSupportRing (G := H) (K := K)) ∣ p ↔ + (r : FiniteSupportRing (G := H) (K := K)) ∣ + (q : FiniteSupportRing (G := H) (K := K)) := + Iff.rfl + +/-- Existence and uniqueness of a normalized `H`-part for a finite-support real series. -/ +def HasUniqueNormalizedHPart + (p : FiniteSupportRing (G := ℝ) (K := K)) : Prop := + ∃! q : ConstantTermOneFiniteSupport (G := H) (K := K), + IsNormalizedHPart H p q + +/-- Two normalized `H`-parts of the same finite-support real series are equal. Thus the +uniqueness clause in LM24, Lemma 6.5.2 follows from the intrinsic divisibility property alone. -/ +theorem IsNormalizedHPart.eq + {p : FiniteSupportRing (G := ℝ) (K := K)} + {q q' : ConstantTermOneFiniteSupport (G := H) (K := K)} + (hq : IsNormalizedHPart H p q) (hq' : IsNormalizedHPart H p q') : q = q' := by + have hqDvdQ' : + (q : FiniteSupportRing (G := H) (K := K)) ∣ + (q' : FiniteSupportRing (G := H) (K := K)) := + (hq' q).mp ((hq q).mpr dvd_rfl) + have hq'DvdQ : + (q' : FiniteSupportRing (G := H) (K := K)) ∣ + (q : FiniteSupportRing (G := H) (K := K)) := + (hq q').mp ((hq' q').mpr dvd_rfl) + obtain ⟨u, hu⟩ := associated_of_dvd_dvd hqDvdQ' hq'DvdQ + have huUnit : IsUnit + (((u : FiniteSupportRing (G := H) (K := K)) : Nonpositive H K)) := + u.isUnit.map (finiteSupportSubring (G := H) (K := K)).subtype + have huConstant : constantCoeff + (((u : FiniteSupportRing (G := H) (K := K)) : Nonpositive H K)) = 1 := by + have hconstant := congrArg + (fun r : FiniteSupportRing (G := H) (K := K) ↦ + constantCoeff (r : Nonpositive H K)) hu + simpa only [Subring.coe_mul, map_mul, q.constantCoeff_eq_one, + q'.constantCoeff_eq_one, one_mul] using hconstant + have huOne : (u : FiniteSupportRing (G := H) (K := K)) = 1 := by + apply Subtype.ext + exact eq_one_of_isUnit_of_constantCoeff_eq_one huUnit huConstant + apply Subtype.ext + simpa only [huOne, mul_one] using hu + +/-- For the normalized `H`-part property, existence already implies unique existence. -/ +theorem hasUniqueNormalizedHPart_iff_exists + (p : FiniteSupportRing (G := ℝ) (K := K)) : + HasUniqueNormalizedHPart H p ↔ + ∃ q : ConstantTermOneFiniteSupport (G := H) (K := K), + IsNormalizedHPart H p q := by + constructor + · rintro ⟨q, hq, _⟩ + exact ⟨q, hq⟩ + · rintro ⟨q, hq⟩ + exact ⟨q, hq, fun _ hq' ↦ hq'.eq H hq⟩ + +/-- A normalized series whose real-domain image divides one is itself one. -/ +theorem ConstantTermOneFiniteSupport.eq_one_of_finiteSupportToReal_dvd_one + (r : ConstantTermOneFiniteSupport (G := H) (K := K)) + (hr : finiteSupportToReal H + (r : FiniteSupportRing (G := H) (K := K)) ∣ 1) : r = 1 := by + have hrUnitFinite : IsUnit (finiteSupportToReal H + (r : FiniteSupportRing (G := H) (K := K))) := + isUnit_iff_dvd_one.mpr hr + have hrUnit : IsUnit (mapDomainToReal H + ((r : FiniteSupportRing (G := H) (K := K)) : Nonpositive H K)) := by + rw [← coe_finiteSupportToReal] + exact hrUnitFinite.map + (finiteSupportSubring (G := ℝ) (K := K)).subtype + have hrConstant : constantCoeff (mapDomainToReal H + ((r : FiniteSupportRing (G := H) (K := K)) : Nonpositive H K)) = 1 := by + rw [constantCoeff_mapDomainToReal] + exact r.constantCoeff_eq_one + have hrImageEq : mapDomainToReal H + ((r : FiniteSupportRing (G := H) (K := K)) : Nonpositive H K) = 1 := + eq_one_of_isUnit_of_constantCoeff_eq_one hrUnit hrConstant + apply Subtype.ext + apply Subtype.ext + exact mapDomainToReal_injective H (by simpa using hrImageEq) + +/-- The multiplicative identity is its own normalized `H`-part. -/ +theorem one_isNormalizedHPart : + IsNormalizedHPart H + (1 : FiniteSupportRing (G := ℝ) (K := K)) + (1 : ConstantTermOneFiniteSupport (G := H) (K := K)) := by + intro r + constructor + · intro hr + rw [r.eq_one_of_finiteSupportToReal_dvd_one H hr] + · intro hr + simpa using (finiteSupportToReal H).map_dvd hr + +/-- The identity has a unique normalized `H`-part, namely itself. -/ +theorem existsUnique_normalizedHPart_one : + ∃! q : ConstantTermOneFiniteSupport (G := H) (K := K), + IsNormalizedHPart H + (1 : FiniteSupportRing (G := ℝ) (K := K)) q := by + refine ⟨1, one_isNormalizedHPart H, ?_⟩ + intro q hq + apply q.eq_one_of_finiteSupportToReal_dvd_one H + exact (hq q).mpr (dvd_refl _) + +end HahnSeries.Nonpositive diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/NormalizedHPartMultiplicativity.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/NormalizedHPartMultiplicativity.lean new file mode 100644 index 0000000000..9a9889d9db --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/NormalizedHPartMultiplicativity.lean @@ -0,0 +1,111 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.NormalizedHPart + +/-! +# Multiplication of normalized exponent-subgroup parts + +LM24, Corollary 6.5.4 states that the normalized `H`-part of a product is the product of +the normalized `H`-parts. Its proof uses a specific Ritt-factorisation consequence: a normalized +`H`-divisor of a product of finite-support real series can be split into normalized `H`-divisors +of the two factors. + +This module names that prerequisite explicitly and proves the complete reduction from it. The +prerequisite is neither installed as an instance nor folded into the definition of a normalized +`H`-part. Thus the intrinsic definition and uniqueness theorem remain independent of the later +Ritt and greatest-common-divisor proof. +-/ + +open scoped HahnSeries + +universe v + +public noncomputable section + +namespace HahnSeries.Nonpositive + +variable (H : AddSubgroup ℝ) {K : Type v} [Field K] + +/-- Every normalized finite-support `H`-divisor of a product of finite-support real series splits +as a product of normalized `H`-divisors of the two factors. This is the exact factor-splitting +input used in LM24's proof of Corollary 6.5.4. -/ +def HasNormalizedHDivisorRefinement : Prop := + ∀ (p q : FiniteSupportRing (G := ℝ) (K := K)) + (r : ConstantTermOneFiniteSupport (G := H) (K := K)), + finiteSupportToReal H + (r : FiniteSupportRing (G := H) (K := K)) ∣ p * q → + ∃ r₁ r₂ : ConstantTermOneFiniteSupport (G := H) (K := K), + r = r₁ * r₂ ∧ + finiteSupportToReal H + (r₁ : FiniteSupportRing (G := H) (K := K)) ∣ p ∧ + finiteSupportToReal H + (r₂ : FiniteSupportRing (G := H) (K := K)) ∣ q + +/-- Characterization of normalized `H`-divisor refinement by factor witnesses. -/ +theorem hasNormalizedHDivisorRefinement_iff : + HasNormalizedHDivisorRefinement H (K := K) ↔ + ∀ (p q : FiniteSupportRing (G := ℝ) (K := K)) + (r : ConstantTermOneFiniteSupport (G := H) (K := K)), + finiteSupportToReal H + (r : FiniteSupportRing (G := H) (K := K)) ∣ p * q → + ∃ r₁ r₂ : ConstantTermOneFiniteSupport (G := H) (K := K), + r = r₁ * r₂ ∧ + finiteSupportToReal H + (r₁ : FiniteSupportRing (G := H) (K := K)) ∣ p ∧ + finiteSupportToReal H + (r₂ : FiniteSupportRing (G := H) (K := K)) ∣ q := + Iff.rfl + +/-- The product of two normalized `H`-parts satisfies the normalized-part divisibility +characterization for the product. -/ +theorem isNormalizedHPart_mul + (hrefine : HasNormalizedHDivisorRefinement H (K := K)) + {p q : FiniteSupportRing (G := ℝ) (K := K)} + {pH qH : ConstantTermOneFiniteSupport (G := H) (K := K)} + (hpH : IsNormalizedHPart H p pH) + (hqH : IsNormalizedHPart H q qH) : + IsNormalizedHPart H (p * q) (pH * qH) := by + rw [isNormalizedHPart_iff] + have hpH' := (isNormalizedHPart_iff H p pH).mp hpH + have hqH' := (isNormalizedHPart_iff H q qH).mp hqH + intro r + constructor + · intro hr + obtain ⟨r₁, r₂, rfl, hr₁, hr₂⟩ := hrefine p q r hr + exact mul_dvd_mul (Iff.mp (hpH' r₁) hr₁) (Iff.mp (hqH' r₂) hr₂) + · intro hr + have hpDvd : finiteSupportToReal H + (pH : FiniteSupportRing (G := H) (K := K)) ∣ p := + (hpH' pH).mpr dvd_rfl + have hqDvd : finiteSupportToReal H + (qH : FiniteSupportRing (G := H) (K := K)) ∣ q := + (hqH' qH).mpr dvd_rfl + have hrMapped := (finiteSupportToReal H).map_dvd hr + have hpartsDvd : finiteSupportToReal H + ((pH * qH : ConstantTermOneFiniteSupport (G := H) (K := K)) : + FiniteSupportRing (G := H) (K := K)) ∣ p * q := by + change finiteSupportToReal H + ((pH : FiniteSupportRing (G := H) (K := K)) * + (qH : FiniteSupportRing (G := H) (K := K))) ∣ p * q + rw [map_mul] + exact mul_dvd_mul hpDvd hqDvd + exact hrMapped.trans hpartsDvd + +/-- Relational form of LM24, Corollary 6.5.4: any normalized `H`-part of a product equals the +product of normalized `H`-parts of its factors. -/ +theorem normalizedHPart_mul_eq + (hrefine : HasNormalizedHDivisorRefinement H (K := K)) + {p q : FiniteSupportRing (G := ℝ) (K := K)} + {pH qH pqH : ConstantTermOneFiniteSupport (G := H) (K := K)} + (hpH : IsNormalizedHPart H p pH) + (hqH : IsNormalizedHPart H q qH) + (hpqH : IsNormalizedHPart H (p * q) pqH) : + pqH = pH * qH := + hpqH.eq H (isNormalizedHPart_mul H hrefine hpH hqH) + +end HahnSeries.Nonpositive diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/NormalizedHPartSeries.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/NormalizedHPartSeries.lean new file mode 100644 index 0000000000..5c2a75151f --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/NormalizedHPartSeries.lean @@ -0,0 +1,83 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.NormalizedHPartMultiplicativity +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.NormalizedSeriesMaximalFinite + +/-! +# Normalized exponent-subgroup parts of Hahn-series maximal divisors + +LM24, Corollary 6.5.3 combines two intrinsic divisor characterizations. The real finite-support +series `p(b)` has exactly the finite-support divisors of `b`, while its normalized `H`-part has +exactly its normalized finite-support `H`-divisors. + +The theorem below proves this composition for arbitrary representatives satisfying those two +predicates. It therefore needs no Ritt-factorisation or Berarducci input; the corresponding source +theorem reduces to the two existence results. +-/ + +open scoped HahnSeries + +universe v + +public noncomputable section + +namespace HahnSeries.Nonpositive + +variable (H : AddSubgroup ℝ) {K : Type v} [Field K] + +/-- Relational form of LM24, Corollary 6.5.3: normalized finite-support `H`-divisors of a Hahn +series are exactly the divisors of the normalized `H`-part of its maximal finite-support +divisor. -/ +theorem normalizedHPart_dvd_iff_dvd_series + {b : Nonpositive ℝ K} {p : FiniteSupportRing (G := ℝ) (K := K)} + {pH : ConstantTermOneFiniteSupport (G := H) (K := K)} + (hmax : Berarducci.IsNormalizedSeriesMaximalFiniteSupportDivisor b p) + (hpH : IsNormalizedHPart H p pH) + (q : ConstantTermOneFiniteSupport (G := H) (K := K)) : + mapDomainToReal H + ((q : FiniteSupportRing (G := H) (K := K)) : Nonpositive H K) ∣ b ↔ + (q : FiniteSupportRing (G := H) (K := K)) ∣ + (pH : FiniteSupportRing (G := H) (K := K)) := by + have hmax' := + (Berarducci.isNormalizedSeriesMaximalFiniteSupportDivisor_iff b p).mp hmax + have hpH' := (isNormalizedHPart_iff H p pH).mp hpH + calc + mapDomainToReal H + ((q : FiniteSupportRing (G := H) (K := K)) : Nonpositive H K) ∣ b ↔ + ((finiteSupportToReal H + (q : FiniteSupportRing (G := H) (K := K)) : + FiniteSupportRing (G := ℝ) (K := K)) : Nonpositive ℝ K) ∣ b := by + rw [coe_finiteSupportToReal] + _ ↔ finiteSupportToReal H + (q : FiniteSupportRing (G := H) (K := K)) ∣ p := + hmax'.1 _ + _ ↔ (q : FiniteSupportRing (G := H) (K := K)) ∣ + (pH : FiniteSupportRing (G := H) (K := K)) := hpH' q + +/-- Relational reduction underlying LM24, Corollary 6.5.5: multiplicativity of the real +series-level maximal finite-support divisor and normalized-divisor refinement imply +multiplicativity of its normalized `H`-part. -/ +theorem normalizedHPart_seriesMaximal_mul_eq + (hrefine : HasNormalizedHDivisorRefinement H (K := K)) + {b c : Nonpositive ℝ K} + {bH cH bcH : ConstantTermOneFiniteSupport (G := H) (K := K)} + (hbH : IsNormalizedHPart H + (Berarducci.seriesNormalizedMaximalFiniteSupportDivisor b) bH) + (hcH : IsNormalizedHPart H + (Berarducci.seriesNormalizedMaximalFiniteSupportDivisor c) cH) + (hbcH : IsNormalizedHPart H + (Berarducci.seriesNormalizedMaximalFiniteSupportDivisor (b * c)) bcH) + (hmaxMul : Berarducci.seriesNormalizedMaximalFiniteSupportDivisor (b * c) = + Berarducci.seriesNormalizedMaximalFiniteSupportDivisor b * + Berarducci.seriesNormalizedMaximalFiniteSupportDivisor c) : + bcH = bH * cH := by + apply hbcH.eq H + rw [hmaxMul] + exact isNormalizedHPart_mul H hrefine hbH hcH + +end HahnSeries.Nonpositive diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/NormalizedMaximalFinite.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/NormalizedMaximalFinite.lean new file mode 100644 index 0000000000..8f14513f31 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/NormalizedMaximalFinite.lean @@ -0,0 +1,252 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.MaximalFinite +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.FiniteSupportNormalization + +/-! +# Normalized maximal finite-support divisors + +This module passes from the intrinsic associate class of a maximal finite-support divisor to the +representative normalization used in LM24, Notation 5.4.5. The zero graded element is represented +by zero. For a nonzero graded element, the greatest exponent in the support of the representative +has coefficient `1`. + +The normalization is defined for the canonical associate class without assuming greatest common +divisors or classifying units. Pairwise greatest-common-divisor existence proves that its associate +class is the maximal one. The same hypothesis then gives the representative form of LM24, +Proposition 5.4.8. +-/ + +open scoped DirectSum HahnSeries NatOrdinal + +universe v + +namespace Berarducci + +public noncomputable section + +variable {K : Type v} [Field K] [CharZero K] + +/-- A series is the normalized maximal finite-support divisor of a graded element when it has +exactly the finite-support divisors of that element and satisfies the normalization convention of +LM24, Notation 5.4.5. -/ +def IsNormalizedGradedMaximalFiniteSupportDivisor (B : DegreeGraded K) + (p : FiniteSupportRing (K := K)) : Prop := + (∀ q : FiniteSupportRing (K := K), + finiteSupportGradedEmbedding K q ∣ B ↔ q ∣ p) ∧ + ((B = 0 ∧ p = 0) ∨ + (B ≠ 0 ∧ HahnSeries.Nonpositive.IsMonicFiniteSupport p)) + +omit [CharZero K] in +/-- Characterization of a normalized maximal finite-support divisor by divisibility and its zero +or monic normalization clause. -/ +theorem isNormalizedGradedMaximalFiniteSupportDivisor_iff (B : DegreeGraded K) + (p : FiniteSupportRing (K := K)) : + IsNormalizedGradedMaximalFiniteSupportDivisor B p ↔ + (∀ q : FiniteSupportRing (K := K), + finiteSupportGradedEmbedding K q ∣ B ↔ q ∣ p) ∧ + ((B = 0 ∧ p = 0) ∨ + (B ≠ 0 ∧ HahnSeries.Nonpositive.IsMonicFiniteSupport p)) := + Iff.rfl + +/-- The normalized representative of the maximal finite-support divisor class of a graded +element. -/ +def gradedNormalizedMaximalFiniteSupportDivisor + (B : DegreeGraded K) : FiniteSupportRing (K := K) := + HahnSeries.Nonpositive.normalizedAssociateRepresentative (G := ℝ) + (gradedMaximalFiniteSupportDivisor B) + +omit [CharZero K] in +/-- The normalized maximal finite-support divisor is the canonical normalized representative of +its intrinsic associate class. -/ +theorem gradedNormalizedMaximalFiniteSupportDivisor_eq_normalizedRepresentative + (B : DegreeGraded K) : + gradedNormalizedMaximalFiniteSupportDivisor B = + HahnSeries.Nonpositive.normalizedAssociateRepresentative (G := ℝ) + (gradedMaximalFiniteSupportDivisor B) := + (rfl) + +omit [CharZero K] in +/-- The normalized maximal finite-support divisor satisfies the intrinsic normalization +predicate. -/ +theorem gradedNormalizedMaximalFiniteSupportDivisor_isNormalized + (B : DegreeGraded K) : + HahnSeries.Nonpositive.IsNormalizedAssociateRepresentative + (gradedMaximalFiniteSupportDivisor B) + (gradedNormalizedMaximalFiniteSupportDivisor B) := + HahnSeries.Nonpositive.normalizedAssociateRepresentative_is _ + +omit [CharZero K] in +/-- The associate class of the normalized representative is the intrinsic maximal-divisor +class. -/ +theorem gradedNormalizedMaximalFiniteSupportDivisor_mk (B : DegreeGraded K) : + Associates.mk (gradedNormalizedMaximalFiniteSupportDivisor B) = + gradedMaximalFiniteSupportDivisor B := + HahnSeries.Nonpositive.normalizedAssociateRepresentative_mk _ + +/-- On an embedded finite-support series, the graded normalized divisor is the normalized +representative of that series's own associate class. -/ +theorem gradedNormalizedMaximalFiniteSupportDivisor_finiteSupport (p : FiniteSupportRing (K := K)) : + gradedNormalizedMaximalFiniteSupportDivisor + (finiteSupportGradedEmbedding K p) = + HahnSeries.Nonpositive.normalizedAssociateRepresentative (G := ℝ) + (Associates.mk p) := by + rw [gradedNormalizedMaximalFiniteSupportDivisor, + gradedMaximalFiniteSupportDivisor_eq_of_is + (isGradedMaximalFiniteSupportDivisor_finiteSupport p)] + +/-- Under pairwise greatest-common-divisor existence, the normalized representative has exactly +the finite-support divisors of the graded element. -/ +theorem gradedNormalizedMaximalFiniteSupportDivisor_isMaximal_of_exists_gcd + (hgcd : ∀ p q : FiniteSupportRing (K := K), + ∃ d : FiniteSupportRing (K := K), + ∀ e : FiniteSupportRing (K := K), e ∣ p ∧ e ∣ q ↔ e ∣ d) + (B : DegreeGraded K) : + IsGradedMaximalFiniteSupportDivisor B + (Associates.mk (gradedNormalizedMaximalFiniteSupportDivisor B)) := by + rw [gradedNormalizedMaximalFiniteSupportDivisor_mk] + exact gradedMaximalFiniteSupportDivisor_is_of_exists_gcd hgcd B + +/-- A nonzero graded element has a nonzero maximal finite-support divisor class. -/ +theorem gradedMaximalFiniteSupportDivisor_ne_zero_of_ne_zero + (hgcd : ∀ p q : FiniteSupportRing (K := K), + ∃ d : FiniteSupportRing (K := K), + ∀ e : FiniteSupportRing (K := K), e ∣ p ∧ e ∣ q ↔ e ∣ d) + {B : DegreeGraded K} (hB : B ≠ 0) : + gradedMaximalFiniteSupportDivisor B ≠ 0 := by + intro hclass + have hmax := + gradedMaximalFiniteSupportDivisor_is_of_exists_gcd hgcd B + have hzeroLe : Associates.mk (0 : FiniteSupportRing (K := K)) ≤ + gradedMaximalFiniteSupportDivisor B := by + rw [hclass] + exact le_rfl + have hzeroDvd := + (isGradedMaximalFiniteSupportDivisor_iff B _).mp hmax 0 |>.mp hzeroLe + obtain ⟨D, hD⟩ := hzeroDvd + apply hB + change B = finiteSupportGradedEmbedding K 0 * D at hD + rw [map_zero, zero_mul] at hD + exact hD + +/-- The normalized maximal finite-support divisor of a nonzero graded element is monic. -/ +theorem gradedNormalizedMaximalFiniteSupportDivisor_isMonic_of_ne_zero + (hgcd : ∀ p q : FiniteSupportRing (K := K), + ∃ d : FiniteSupportRing (K := K), + ∀ e : FiniteSupportRing (K := K), e ∣ p ∧ e ∣ q ↔ e ∣ d) + {B : DegreeGraded K} (hB : B ≠ 0) : + HahnSeries.Nonpositive.IsMonicFiniteSupport + (gradedNormalizedMaximalFiniteSupportDivisor B) := by + apply HahnSeries.Nonpositive.normalizedAssociateRepresentative_isMonic_of_ne_zero + exact gradedMaximalFiniteSupportDivisor_ne_zero_of_ne_zero hgcd hB + +/-- Under pairwise greatest-common-divisor existence, the chosen representative satisfies the +source-level normalized maximal-divisor predicate. -/ +theorem gradedNormalizedMaximalFiniteSupportDivisor_is_of_exists_gcd + (hgcd : ∀ p q : FiniteSupportRing (K := K), + ∃ d : FiniteSupportRing (K := K), + ∀ e : FiniteSupportRing (K := K), e ∣ p ∧ e ∣ q ↔ e ∣ d) + (B : DegreeGraded K) : + IsNormalizedGradedMaximalFiniteSupportDivisor B + (gradedNormalizedMaximalFiniteSupportDivisor B) := by + constructor + · exact (isGradedMaximalFiniteSupportDivisor_mk_iff B _).mp + (gradedNormalizedMaximalFiniteSupportDivisor_isMaximal_of_exists_gcd hgcd B) + · by_cases hB : B = 0 + · subst B + apply Or.inl + refine ⟨rfl, ?_⟩ + have hmax := gradedMaximalFiniteSupportDivisor_is_of_exists_gcd hgcd 0 + have hzero : IsGradedMaximalFiniteSupportDivisor (0 : DegreeGraded K) 0 := by + rw [isGradedMaximalFiniteSupportDivisor_iff] + intro q + constructor + · intro _ + exact dvd_zero _ + · intro _ + exact Associates.mk_le_mk_of_dvd (dvd_zero q) + have hclass := IsGradedMaximalFiniteSupportDivisor.eq hmax hzero + rw [gradedNormalizedMaximalFiniteSupportDivisor, hclass, + HahnSeries.Nonpositive.normalizedAssociateRepresentative_zero] + · exact Or.inr ⟨hB, + gradedNormalizedMaximalFiniteSupportDivisor_isMonic_of_ne_zero hgcd hB⟩ + +omit [CharZero K] in +/-- The normalized maximal-divisor predicate determines at most one finite-support series when all +units are nonzero constant series. -/ +theorem IsNormalizedGradedMaximalFiniteSupportDivisor.eq (hunits : ∀ u : FiniteSupportRing (K := K), + IsUnit u ↔ ∃ k : K, k ≠ 0 ∧ + u = HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℝ) k) + {B : DegreeGraded K} + {p q : FiniteSupportRing (K := K)} + (hp : IsNormalizedGradedMaximalFiniteSupportDivisor B p) + (hq : IsNormalizedGradedMaximalFiniteSupportDivisor B q) : + p = q := by + have hpMax := + (isGradedMaximalFiniteSupportDivisor_mk_iff B p).mpr hp.1 + have hqMax := + (isGradedMaximalFiniteSupportDivisor_mk_iff B q).mpr hq.1 + have hclasses : Associates.mk p = Associates.mk q := + IsGradedMaximalFiniteSupportDivisor.eq hpMax hqMax + rcases hp.2 with hpZero | hpNonzero + · rcases hq.2 with hqZero | hqNonzero + · exact hpZero.2.trans hqZero.2.symm + · exact (hqNonzero.1 hpZero.1).elim + · rcases hq.2 with hqZero | hqNonzero + · exact (hpNonzero.1 hqZero.1).elim + · have hpNormalized : + HahnSeries.Nonpositive.IsNormalizedAssociateRepresentative + (Associates.mk p) p := + (HahnSeries.Nonpositive.isNormalizedAssociateRepresentative_iff + (Associates.mk p) p).mpr + (Or.inr ⟨Associates.mk_ne_zero.mpr hpNonzero.2.ne_zero, + rfl, hpNonzero.2⟩) + have hqNormalized : + HahnSeries.Nonpositive.IsNormalizedAssociateRepresentative + (Associates.mk p) q := + (HahnSeries.Nonpositive.isNormalizedAssociateRepresentative_iff + (Associates.mk p) q).mpr + (Or.inr ⟨Associates.mk_ne_zero.mpr hpNonzero.2.ne_zero, + hclasses.symm, hqNonzero.2⟩) + exact hpNormalized.eq hunits hqNormalized + +/-- Any series satisfying the normalized maximal-divisor predicate is the chosen normalized +representative, under pairwise greatest-common-divisor existence and the unit classification. -/ +theorem gradedNormalizedMaximalFiniteSupportDivisor_eq_of_is + (hgcd : ∀ p q : FiniteSupportRing (K := K), + ∃ d : FiniteSupportRing (K := K), + ∀ e : FiniteSupportRing (K := K), e ∣ p ∧ e ∣ q ↔ e ∣ d) + (hunits : ∀ u : FiniteSupportRing (K := K), + IsUnit u ↔ ∃ k : K, k ≠ 0 ∧ + u = HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℝ) k) + {B : DegreeGraded K} + {p : FiniteSupportRing (K := K)} + (hp : IsNormalizedGradedMaximalFiniteSupportDivisor B p) : + gradedNormalizedMaximalFiniteSupportDivisor B = p := by + exact (gradedNormalizedMaximalFiniteSupportDivisor_is_of_exists_gcd hgcd B).eq hunits hp + +/-- Representative form of LM24, Proposition 5.4.8: the product of the normalized maximal +finite-support divisors divides the normalized maximal finite-support divisor of the product. -/ +theorem gradedNormalizedMaximalFiniteSupportDivisor_mul_dvd_of_exists_gcd + (hgcd : ∀ p q : FiniteSupportRing (K := K), + ∃ d : FiniteSupportRing (K := K), + ∀ e : FiniteSupportRing (K := K), e ∣ p ∧ e ∣ q ↔ e ∣ d) + (B C : DegreeGraded K) : + gradedNormalizedMaximalFiniteSupportDivisor B * + gradedNormalizedMaximalFiniteSupportDivisor C ∣ + gradedNormalizedMaximalFiniteSupportDivisor (B * C) := by + apply Associates.mk_le_mk_iff_dvd.mp + rw [← Associates.mk_mul_mk, + gradedNormalizedMaximalFiniteSupportDivisor_mk, + gradedNormalizedMaximalFiniteSupportDivisor_mk, + gradedNormalizedMaximalFiniteSupportDivisor_mk] + exact gradedMaximalFiniteSupportDivisor_mul_le_of_exists_gcd hgcd B C + +end + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/NormalizedSeriesMaximalFinite.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/NormalizedSeriesMaximalFinite.lean new file mode 100644 index 0000000000..7201fd282e --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/NormalizedSeriesMaximalFinite.lean @@ -0,0 +1,267 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.NormalizedMaximalFinite +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.SeriesMaximalFinite +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.FiniteSupportNormalization + +/-! +# Normalized maximal finite-support divisors of Hahn series + +This module passes from the intrinsic associate class of LM24, Proposition 5.5.1 to the +representative `p(b)` fixed by Notation 5.5.2. The representative is zero when `b = 0`; otherwise +its coefficient at the greatest support exponent is `1`. + +The source-level divisibility characterization, the three clauses of Remark 5.5.3, and the +one-sided product divisibility of Proposition 5.5.5 are proved with their exact orientations. Unit +classification and pairwise greatest-common-divisor existence remain explicit hypotheses. +-/ + +open scoped HahnSeries NatOrdinal + +universe v + +namespace Berarducci + +public noncomputable section + +variable {K : Type v} [Field K] [CharZero K] + +/-- A finite-support series is the normalized maximal divisor of a Hahn series when it has +exactly its finite-support divisors and is zero at zero or monic otherwise. -/ +def IsNormalizedSeriesMaximalFiniteSupportDivisor + (b : Series K) (p : FiniteSupportRing (K := K)) : Prop := + (∀ q : FiniteSupportRing (K := K), (q : Series K) ∣ b ↔ q ∣ p) ∧ + ((b = 0 ∧ p = 0) ∨ + (b ≠ 0 ∧ HahnSeries.Nonpositive.IsMonicFiniteSupport p)) + +omit [CharZero K] in +/-- Characterization of a normalized maximal finite-support divisor of a Hahn series. -/ +theorem isNormalizedSeriesMaximalFiniteSupportDivisor_iff + (b : Series K) (p : FiniteSupportRing (K := K)) : + IsNormalizedSeriesMaximalFiniteSupportDivisor b p ↔ + (∀ q : FiniteSupportRing (K := K), (q : Series K) ∣ b ↔ q ∣ p) ∧ + ((b = 0 ∧ p = 0) ∨ + (b ≠ 0 ∧ HahnSeries.Nonpositive.IsMonicFiniteSupport p)) := + Iff.rfl + +/-- The normalized representative of the maximal finite-support divisor class of a Hahn series. +-/ +noncomputable def seriesNormalizedMaximalFiniteSupportDivisor + (b : Series K) : FiniteSupportRing (K := K) := + HahnSeries.Nonpositive.normalizedAssociateRepresentative (G := ℝ) + (seriesMaximalFiniteSupportDivisor b) + +omit [CharZero K] in +/-- The chosen series-level representative is normalized in its associate class. -/ +theorem seriesNormalizedMaximalFiniteSupportDivisor_isNormalized (b : Series K) : + HahnSeries.Nonpositive.IsNormalizedAssociateRepresentative + (seriesMaximalFiniteSupportDivisor b) + (seriesNormalizedMaximalFiniteSupportDivisor b) := + HahnSeries.Nonpositive.normalizedAssociateRepresentative_is _ + +omit [CharZero K] in +/-- The associate class of the normalized representative is the intrinsic maximal-divisor +class. -/ +theorem seriesNormalizedMaximalFiniteSupportDivisor_mk (b : Series K) : + Associates.mk (seriesNormalizedMaximalFiniteSupportDivisor b) = + seriesMaximalFiniteSupportDivisor b := + HahnSeries.Nonpositive.normalizedAssociateRepresentative_mk _ + +/-- On a finite-support input, the series-level normalization coincides with the earlier +graded normalization from LM24, Notation 5.4.5. This includes the zero input. -/ +theorem seriesNormalizedMaximalFiniteSupportDivisor_coe_eq_graded (p : FiniteSupportRing (K := K)) : + seriesNormalizedMaximalFiniteSupportDivisor (p : Series K) = + gradedNormalizedMaximalFiniteSupportDivisor + (finiteSupportGradedEmbedding K p) := by + rw [seriesNormalizedMaximalFiniteSupportDivisor, + seriesMaximalFiniteSupportDivisor_coe, + gradedNormalizedMaximalFiniteSupportDivisor_finiteSupport] + +/-- Under pairwise greatest-common-divisor existence, the normalized representative has exactly +the finite-support divisors of the Hahn series. -/ +theorem seriesNormalizedMaximalFiniteSupportDivisor_isMaximal_of_exists_gcd + (hgcd : ∀ p q : FiniteSupportRing (K := K), + ∃ d : FiniteSupportRing (K := K), + ∀ e : FiniteSupportRing (K := K), e ∣ p ∧ e ∣ q ↔ e ∣ d) + (b : Series K) : + IsSeriesMaximalFiniteSupportDivisor b + (Associates.mk (seriesNormalizedMaximalFiniteSupportDivisor b)) := by + rw [seriesNormalizedMaximalFiniteSupportDivisor_mk] + exact seriesMaximalFiniteSupportDivisor_is_of_exists_gcd hgcd b + +/-- A nonzero Hahn series has a nonzero maximal finite-support divisor class. -/ +theorem seriesMaximalFiniteSupportDivisor_ne_zero_of_ne_zero + (hgcd : ∀ p q : FiniteSupportRing (K := K), + ∃ d : FiniteSupportRing (K := K), + ∀ e : FiniteSupportRing (K := K), e ∣ p ∧ e ∣ q ↔ e ∣ d) + {b : Series K} (hb : b ≠ 0) : + seriesMaximalFiniteSupportDivisor b ≠ 0 := by + intro hclass + have hmax := seriesMaximalFiniteSupportDivisor_is_of_exists_gcd hgcd b + have hzeroLe : Associates.mk (0 : FiniteSupportRing (K := K)) ≤ + seriesMaximalFiniteSupportDivisor b := by + rw [hclass] + exact le_rfl + have hzeroDvd := + (isSeriesMaximalFiniteSupportDivisor_iff b _).mp hmax 0 |>.mp hzeroLe + exact hb (zero_dvd_iff.mp hzeroDvd) + +/-- The normalized maximal finite-support divisor of a nonzero Hahn series is monic. -/ +theorem seriesNormalizedMaximalFiniteSupportDivisor_isMonic_of_ne_zero + (hgcd : ∀ p q : FiniteSupportRing (K := K), + ∃ d : FiniteSupportRing (K := K), + ∀ e : FiniteSupportRing (K := K), e ∣ p ∧ e ∣ q ↔ e ∣ d) + {b : Series K} (hb : b ≠ 0) : + HahnSeries.Nonpositive.IsMonicFiniteSupport + (seriesNormalizedMaximalFiniteSupportDivisor b) := by + apply HahnSeries.Nonpositive.normalizedAssociateRepresentative_isMonic_of_ne_zero + exact seriesMaximalFiniteSupportDivisor_ne_zero_of_ne_zero hgcd hb + +/-- Under pairwise greatest-common-divisor existence, the chosen representative satisfies the +normalized series-level maximal-divisor predicate. -/ +theorem seriesNormalizedMaximalFiniteSupportDivisor_is_of_exists_gcd + (hgcd : ∀ p q : FiniteSupportRing (K := K), + ∃ d : FiniteSupportRing (K := K), + ∀ e : FiniteSupportRing (K := K), e ∣ p ∧ e ∣ q ↔ e ∣ d) + (b : Series K) : + IsNormalizedSeriesMaximalFiniteSupportDivisor b + (seriesNormalizedMaximalFiniteSupportDivisor b) := by + constructor + · exact (isSeriesMaximalFiniteSupportDivisor_mk_iff b _).mp + (seriesNormalizedMaximalFiniteSupportDivisor_isMaximal_of_exists_gcd hgcd b) + · by_cases hb : b = 0 + · subst b + apply Or.inl + refine ⟨rfl, ?_⟩ + have hzero : IsSeriesMaximalFiniteSupportDivisor (0 : Series K) 0 := + IsSeriesMaximalFiniteSupportDivisor.zero + rw [seriesNormalizedMaximalFiniteSupportDivisor, + seriesMaximalFiniteSupportDivisor_eq_of_is hzero, + HahnSeries.Nonpositive.normalizedAssociateRepresentative_zero] + · exact Or.inr ⟨hb, + seriesNormalizedMaximalFiniteSupportDivisor_isMonic_of_ne_zero hgcd hb⟩ + +omit [CharZero K] in +/-- The normalized series-level predicate determines at most one finite-support series when all +units are nonzero constant series. -/ +theorem IsNormalizedSeriesMaximalFiniteSupportDivisor.eq (hunits : ∀ u : FiniteSupportRing (K := K), + IsUnit u ↔ ∃ k : K, k ≠ 0 ∧ + u = HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℝ) k) + {b : Series K} {p q : FiniteSupportRing (K := K)} + (hp : IsNormalizedSeriesMaximalFiniteSupportDivisor b p) + (hq : IsNormalizedSeriesMaximalFiniteSupportDivisor b q) : p = q := by + have hpMax := (isSeriesMaximalFiniteSupportDivisor_mk_iff b p).mpr hp.1 + have hqMax := (isSeriesMaximalFiniteSupportDivisor_mk_iff b q).mpr hq.1 + have hclasses : Associates.mk p = Associates.mk q := hpMax.eq hqMax + rcases hp.2 with hpZero | hpNonzero + · rcases hq.2 with hqZero | hqNonzero + · exact hpZero.2.trans hqZero.2.symm + · exact (hqNonzero.1 hpZero.1).elim + · rcases hq.2 with hqZero | hqNonzero + · exact (hpNonzero.1 hqZero.1).elim + · have hpNormalized : + HahnSeries.Nonpositive.IsNormalizedAssociateRepresentative + (Associates.mk p) p := + (HahnSeries.Nonpositive.isNormalizedAssociateRepresentative_iff + (Associates.mk p) p).mpr + (Or.inr ⟨Associates.mk_ne_zero.mpr hpNonzero.2.ne_zero, + rfl, hpNonzero.2⟩) + have hqNormalized : + HahnSeries.Nonpositive.IsNormalizedAssociateRepresentative + (Associates.mk p) q := + (HahnSeries.Nonpositive.isNormalizedAssociateRepresentative_iff + (Associates.mk p) q).mpr + (Or.inr ⟨Associates.mk_ne_zero.mpr hpNonzero.2.ne_zero, + hclasses.symm, hqNonzero.2⟩) + exact hpNormalized.eq hunits hqNormalized + +/-- Any finite-support series satisfying the normalized predicate is the chosen normalized +representative. -/ +theorem seriesNormalizedMaximalFiniteSupportDivisor_eq_of_is + (hgcd : ∀ p q : FiniteSupportRing (K := K), + ∃ d : FiniteSupportRing (K := K), + ∀ e : FiniteSupportRing (K := K), e ∣ p ∧ e ∣ q ↔ e ∣ d) + (hunits : ∀ u : FiniteSupportRing (K := K), + IsUnit u ↔ ∃ k : K, k ≠ 0 ∧ + u = HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℝ) k) + {b : Series K} {p : FiniteSupportRing (K := K)} + (hp : IsNormalizedSeriesMaximalFiniteSupportDivisor b p) : + seriesNormalizedMaximalFiniteSupportDivisor b = p := by + exact (seriesNormalizedMaximalFiniteSupportDivisor_is_of_exists_gcd hgcd b).eq hunits hp + +/-- The product of the normalized maximal finite-support divisors divides the normalized maximal +finite-support divisor of the product. -/ +theorem seriesNormalizedMaximalFiniteSupportDivisor_mul_dvd_of_exists_gcd + (hgcd : ∀ p q : FiniteSupportRing (K := K), + ∃ d : FiniteSupportRing (K := K), + ∀ e : FiniteSupportRing (K := K), e ∣ p ∧ e ∣ q ↔ e ∣ d) + (b c : Series K) : + seriesNormalizedMaximalFiniteSupportDivisor b * + seriesNormalizedMaximalFiniteSupportDivisor c ∣ + seriesNormalizedMaximalFiniteSupportDivisor (b * c) := by + apply Associates.mk_le_mk_iff_dvd.mp + rw [← Associates.mk_mul_mk, + seriesNormalizedMaximalFiniteSupportDivisor_mk, + seriesNormalizedMaximalFiniteSupportDivisor_mk, + seriesNormalizedMaximalFiniteSupportDivisor_mk] + exact seriesMaximalFiniteSupportDivisor_mul_le_of_exists_gcd hgcd b c + +/-- The normalized maximal finite-support divisor embeds as a divisor of the Hahn series. -/ +theorem seriesNormalizedMaximalFiniteSupportDivisor_dvd_of_exists_gcd + (hgcd : ∀ p q : FiniteSupportRing (K := K), + ∃ d : FiniteSupportRing (K := K), + ∀ e : FiniteSupportRing (K := K), e ∣ p ∧ e ∣ q ↔ e ∣ d) + (b : Series K) : + (seriesNormalizedMaximalFiniteSupportDivisor b : Series K) ∣ b := by + have h := seriesNormalizedMaximalFiniteSupportDivisor_is_of_exists_gcd hgcd b + exact (h.1 (seriesNormalizedMaximalFiniteSupportDivisor b)).mpr dvd_rfl + +/-- The normalized maximal finite-support divisor of zero is zero. -/ +theorem seriesNormalizedMaximalFiniteSupportDivisor_zero_of_exists_gcd + (hgcd : ∀ p q : FiniteSupportRing (K := K), + ∃ d : FiniteSupportRing (K := K), + ∀ e : FiniteSupportRing (K := K), e ∣ p ∧ e ∣ q ↔ e ∣ d) : + seriesNormalizedMaximalFiniteSupportDivisor (0 : Series K) = 0 := by + have h := seriesNormalizedMaximalFiniteSupportDivisor_is_of_exists_gcd hgcd (0 : Series K) + rcases h.2 with hzero | hnonzero + · exact hzero.2 + · exact (hnonzero.1 rfl).elim + +/-- The normalized maximal divisor of a finite-support series is a nonzero scalar multiple of +that series. -/ +theorem exists_scalar_seriesNormalizedMaximalFiniteSupportDivisor_coe + (hunits : ∀ u : FiniteSupportRing (K := K), + IsUnit u ↔ ∃ k : K, k ≠ 0 ∧ + u = HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℝ) k) + (p : FiniteSupportRing (K := K)) : + ∃ k : K, k ≠ 0 ∧ + seriesNormalizedMaximalFiniteSupportDivisor (p : Series K) = + HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℝ) k * p := by + have hclasses : Associates.mk p = + Associates.mk (seriesNormalizedMaximalFiniteSupportDivisor (p : Series K)) := by + rw [seriesNormalizedMaximalFiniteSupportDivisor_mk, + seriesMaximalFiniteSupportDivisor_coe] + exact HahnSeries.Nonpositive.exists_nonzero_scalar_mul_of_mk_eq_mk + hunits hclasses + +/-- The normalized maximal finite-support divisor of a principal Hahn series is one. -/ +theorem seriesNormalizedMaximalFiniteSupportDivisor_eq_one_of_isPrincipal + (hunits : ∀ u : FiniteSupportRing (K := K), + IsUnit u ↔ ∃ k : K, k ≠ 0 ∧ + u = HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℝ) k) + {b : Series K} (hb : HahnSeries.Nonpositive.IsPrincipal b) : + seriesNormalizedMaximalFiniteSupportDivisor b = 1 := by + have hclass := seriesMaximalFiniteSupportDivisor_eq_one_of_isPrincipal hb + apply HahnSeries.Nonpositive.normalizedAssociateRepresentative_eq_of_is hunits + rw [HahnSeries.Nonpositive.isNormalizedAssociateRepresentative_iff, hclass] + exact Or.inr ⟨one_ne_zero, Associates.mk_one, + HahnSeries.Nonpositive.isMonicFiniteSupport_one⟩ + +end + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/PreSchreier.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/PreSchreier.lean new file mode 100644 index 0000000000..6c67f26c6a --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/PreSchreier.lean @@ -0,0 +1,67 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.FiniteSupportFactorUniqueness +public import Mathlib.Algebra.GroupWithZero.Divisibility + +/-! +# Pre-Schreier reduction from LM24 factorisation + +This module proves the factorisation-theoretic reduction used in LM24, Corollary 6.4.2. If every +finite-support factor is primal, every irreducible infinite-support factor is prime, and every +nonzero series has the factorisation supplied by Theorem 6.4.1, then the full Hahn-series ring is +a decomposition monoid, equivalently a pre-Schreier domain in the terminology of the paper. +-/ + +open scoped HahnSeries + +universe v + +namespace Berarducci + +public noncomputable section + +variable {K : Type v} [Field K] + +/-- A product list of prime elements is primal. -/ +theorem list_prod_isPrimal_of_prime + (factors : List (Series K)) + (hfactors : ∀ c ∈ factors, Prime c) : + IsPrimal factors.prod := by + induction factors with + | nil => simpa using isUnit_one.isPrimal + | cons c factors ih => + rw [List.prod_cons] + exact (hfactors c (by simp)).isPrimal.mul + (ih (fun d hd ↦ hfactors d (by simp [hd]))) + +/-- Factorisation into a primal finite-support factor and prime infinite-support factors makes +every series primal. -/ +theorem decompositionMonoid_of_infiniteSupportFactorization + (hfinitePrimal : ∀ p : FiniteSupportRing (K := K), IsPrimal (p : Series K)) + (hfactorization : ∀ b : Series K, b ≠ 0 → + ∃ (p : FiniteSupportRing (K := K)) (factors : List (Series K)), + IsInfiniteSupportIrreducibleFactorization b p factors) + (hinfinitePrime : ∀ c : Series K, + Irreducible c → (c : K⟦ℝ⟧).support.Infinite → Prime c) : + DecompositionMonoid (Series K) := by + constructor + intro b + by_cases hb : b = 0 + · subst b + exact isPrimal_zero + · obtain ⟨p, factors, hfactorization⟩ := hfactorization b hb + have hfactorization' := + (isInfiniteSupportIrreducibleFactorization_iff b p factors).mp hfactorization + rw [hfactorization'.1] + exact (hfinitePrimal p).mul + (list_prod_isPrimal_of_prime factors fun c hc ↦ + hinfinitePrime c (hfactorization'.2 c hc).1 (hfactorization'.2 c hc).2) + +end + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/PrincipalMaximalFinite.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/PrincipalMaximalFinite.lean new file mode 100644 index 0000000000..77e79a077d --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/PrincipalMaximalFinite.lean @@ -0,0 +1,194 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.NormalizedMaximalFinite +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.RVMaximalFinite + +import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.AssociatedGradedDivisibility +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.GradedDivisibility + +/-! +# Maximal finite-support divisors and principal factors + +This module proves the field-generic cores of LM24, Lemmas 6.3.1--6.3.2. Multiplication by a +nonzero element of `P̂` is injective. Under the intrinsic tensor +decomposition, it acts only on the principal tensor factor, so it preserves tensor content and +hence the maximal finite-support divisor. + +The RV result is obtained from the full graded result through the canonical RV embedding. +Finite-support greatest-common-divisor existence remains an explicit hypothesis; the coefficient +field has characteristic zero. +-/ + +open scoped DirectSum HahnSeries NatOrdinal TensorProduct + +universe v + +namespace Berarducci + +public noncomputable section + +open HahnSeries.Nonpositive + +variable {K : Type v} [Field K] [CharZero K] + +private theorem principalSubringMulLeft_injective {c : PrincipalSubring K} (hc : c ≠ 0) : + Function.Injective (LinearMap.mulLeft K c) := by + intro x y hxy + change c * x = c * y at hxy + apply principalSubringEmbedding_injective K + have hcImage : principalSubringEmbedding K c ≠ 0 := by + intro hzero + apply hc + exact principalSubringEmbedding_injective K + (hzero.trans (map_zero (principalSubringEmbedding K)).symm) + apply mul_left_cancel₀ hcImage + simpa only [map_mul] using + congrArg (principalSubringEmbedding K) hxy + +private theorem principalSubringTensorEquiv_mulLeft_rTensor (c : PrincipalSubring K) + (z : PrincipalSubring K ⊗[K] FiniteSupportRing (K := K)) : + principalSubringTensorEquiv K + ((LinearMap.mulLeft K c).rTensor (FiniteSupportRing (K := K)) z) = + principalSubringEmbedding K c * + principalSubringTensorEquiv K z := by + induction z using TensorProduct.inductionOn with + | tmul x p => + rw [LinearMap.rTensor_tmul, + principalSubringTensorEquiv_tmul, + principalSubringTensorEquiv_tmul] + change principalSubringEmbedding K (c * x) * + finiteSupportGradedEmbedding K p = _ + rw [map_mul] + exact mul_assoc _ _ _ + | add x y hx hy => simp [map_add, hx, hy, mul_add] + +/-- Multiplication by a nonzero componentwise-principal graded element preserves the intrinsic +maximal finite-support divisor predicate. -/ +theorem isGradedMaximalFiniteSupportDivisor_mul_principal_iff (B : DegreeGraded K) + {C : DegreeGraded K} + (hC : IsPrincipalGraded C) (hC0 : C ≠ 0) + (a : Associates (FiniteSupportRing (K := K))) : + IsGradedMaximalFiniteSupportDivisor (B * C) a ↔ + IsGradedMaximalFiniteSupportDivisor B a := by + rw [isPrincipalGraded_iff] at hC + let c := rvProjection K C + have hc : principalSubringEmbedding K c = C := by + apply DirectSum.ext + intro α + rw [principalSubringEmbedding_apply, rvProjection_apply] + exact + principalComponentToHahnDegreeLayer_degreeLayerToPrincipalComponent_of_isPrincipal + α (C α) (hC α) + have hc0 : c ≠ 0 := by + intro hzero + apply hC0 + rw [← hc, hzero, map_zero] + let e := principalSubringTensorEquiv K + let z := e.symm B + let f := LinearMap.mulLeft K c + have hef : e (f.rTensor (FiniteSupportRing (K := K)) z) = B * C := by + calc + e (f.rTensor (FiniteSupportRing (K := K)) z) = + principalSubringEmbedding K c * e z := by + exact principalSubringTensorEquiv_mulLeft_rTensor c z + _ = C * B := by rw [hc, e.apply_symm_apply] + _ = B * C := mul_comm _ _ + have hpreimage : + e.symm (B * C) = f.rTensor (FiniteSupportRing (K := K)) z := by + apply e.injective + rw [e.apply_symm_apply, hef] + rw [← isContent_principalGradedTensorEquiv_symm_iff (B * C) a, + ← isContent_principalGradedTensorEquiv_symm_iff B a, + hpreimage] + exact TensorProduct.isContent_rTensor_iff_of_injective + f (principalSubringMulLeft_injective hc0) z a + +/-- Multiplication by a nonzero componentwise-principal graded element preserves the canonical +maximal finite-support divisor class, assuming pairwise greatest-common-divisor existence. -/ +theorem gradedMaximalFiniteSupportDivisor_mul_principal_eq_of_exists_gcd + (hgcd : ∀ p q : FiniteSupportRing (K := K), + ∃ d : FiniteSupportRing (K := K), + ∀ e : FiniteSupportRing (K := K), e ∣ p ∧ e ∣ q ↔ e ∣ d) + (B : DegreeGraded K) + {C : DegreeGraded K} + (hC : IsPrincipalGraded C) (hC0 : C ≠ 0) : + gradedMaximalFiniteSupportDivisor (B * C) = + gradedMaximalFiniteSupportDivisor B := by + exact IsGradedMaximalFiniteSupportDivisor.eq + (gradedMaximalFiniteSupportDivisor_is_of_exists_gcd hgcd (B * C)) + ((isGradedMaximalFiniteSupportDivisor_mul_principal_iff B hC hC0 _).mpr + (gradedMaximalFiniteSupportDivisor_is_of_exists_gcd hgcd B)) + +/-- Multiplication by a nonzero componentwise-principal graded element preserves the normalized +maximal finite-support divisor, assuming pairwise greatest-common-divisor existence. This is the +field-generic core of LM24, Lemma 6.3.2. -/ +theorem gradedNormalizedMaximalFiniteSupportDivisor_mul_principal_eq_of_exists_gcd + (hgcd : ∀ p q : FiniteSupportRing (K := K), + ∃ d : FiniteSupportRing (K := K), + ∀ e : FiniteSupportRing (K := K), e ∣ p ∧ e ∣ q ↔ e ∣ d) + (B : DegreeGraded K) + {C : DegreeGraded K} + (hC : IsPrincipalGraded C) (hC0 : C ≠ 0) : + gradedNormalizedMaximalFiniteSupportDivisor (B * C) = + gradedNormalizedMaximalFiniteSupportDivisor B := by + rw [gradedNormalizedMaximalFiniteSupportDivisor_eq_normalizedRepresentative, + gradedNormalizedMaximalFiniteSupportDivisor_eq_normalizedRepresentative, + gradedMaximalFiniteSupportDivisor_mul_principal_eq_of_exists_gcd hgcd B hC hC0] + +/-- Multiplication by a nonzero componentwise-principal graded element neither creates nor +destroys divisibility by an embedded finite-support series. -/ +theorem finiteSupportGradedEmbedding_dvd_mul_principal_iff_of_exists_gcd + (hgcd : ∀ p q : FiniteSupportRing (K := K), + ∃ d : FiniteSupportRing (K := K), + ∀ e : FiniteSupportRing (K := K), e ∣ p ∧ e ∣ q ↔ e ∣ d) + (p : FiniteSupportRing (K := K)) + (B : DegreeGraded K) + {C : DegreeGraded K} + (hC : IsPrincipalGraded C) (hC0 : C ≠ 0) : + finiteSupportGradedEmbedding K p ∣ B * C ↔ + finiteSupportGradedEmbedding K p ∣ B := by + have hmaxBC := + gradedNormalizedMaximalFiniteSupportDivisor_is_of_exists_gcd hgcd (B * C) + have hmaxB := + gradedNormalizedMaximalFiniteSupportDivisor_is_of_exists_gcd hgcd B + have hmaxBC' := + (isNormalizedGradedMaximalFiniteSupportDivisor_iff _ _).mp hmaxBC + have hmaxB' := + (isNormalizedGradedMaximalFiniteSupportDivisor_iff _ _).mp hmaxB + rw [hmaxBC'.1 p, hmaxB'.1 p, + gradedNormalizedMaximalFiniteSupportDivisor_mul_principal_eq_of_exists_gcd hgcd B hC hC0] + +/-- Multiplication by a nonzero principal RV class preserves the normalized maximal +finite-support divisor of its canonical graded image. This is the field-generic core of LM24, +Lemma 6.3.1. -/ +theorem gradedNormalizedMaximalFiniteSupportDivisor_rv_mul_principal_eq_of_exists_gcd + (hgcd : ∀ p q : FiniteSupportRing (K := K), + ∃ d : FiniteSupportRing (K := K), + ∀ e : FiniteSupportRing (K := K), e ∣ p ∧ e ∣ q ↔ e ∣ d) + (B : HahnDegreeRV K) {C : HahnDegreeRV K} + (hC : IsPrincipalRV C) (hC0 : C ≠ 0) : + gradedNormalizedMaximalFiniteSupportDivisor + ((degreeValuation K).rvInitialFormHom (B * C)) = + gradedNormalizedMaximalFiniteSupportDivisor + ((degreeValuation K).rvInitialFormHom B) := by + let w := degreeValuation K + have hCImage := isPrincipalRVImage_initialForm C hC + have hCPrincipal := (isPrincipalRVImage_iff (w.rvInitialFormHom C)).mp + hCImage |>.2.2 + have hCImage0 : w.rvInitialFormHom C ≠ 0 := by + intro hzero + apply hC0 + apply w.rvInitialFormHom_injective + simpa using hzero + rw [map_mul] + exact gradedNormalizedMaximalFiniteSupportDivisor_mul_principal_eq_of_exists_gcd hgcd + (w.rvInitialFormHom B) hCPrincipal hCImage0 + +end + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/PrincipalSubringLocalization.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/PrincipalSubringLocalization.lean new file mode 100644 index 0000000000..3c94a3350c --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/PrincipalSubringLocalization.lean @@ -0,0 +1,69 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalSubringLocalization + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.PrincipalMaximalFinite + +/-! +# Finite-support divisibility and principal graded localization + +The localization of `RV̂` at the nonzero elements of `P̂` does not create new divisibility +relations by finite-support series. For the nontrivial direction, clear a principal denominator +and then use the field-generic core of LM24, Lemma 6.3.2, to remove that denominator. + +This is the precise localization step used in the proof of LM24, Corollary 6.3.6. +-/ + +open scoped HahnSeries + +universe v + +namespace Berarducci + +public noncomputable section + +open HahnSeries.Nonpositive + +variable {K : Type v} [Field K] [CharZero K] + +/-- Divisibility by an embedded finite-support series is reflected by localization at nonzero +principal graded factors. -/ +theorem principalSubringLocalizationMap_finiteSupport_dvd_iff_of_exists_gcd + (hgcd : ∀ p q : FiniteSupportRing (K := K), + ∃ d : FiniteSupportRing (K := K), + ∀ e : FiniteSupportRing (K := K), e ∣ p ∧ e ∣ q ↔ e ∣ d) + (p : FiniteSupportRing (K := K)) + (B : DegreeGraded K) : + principalSubringFractionScalarExtension K p ∣ + principalSubringLocalizationMap K B ↔ + finiteSupportGradedEmbedding K p ∣ B := by + constructor + · intro hp + obtain ⟨X, d, hd, hclear⟩ := + principalSubringLocalization_exists_finiteSupport_dvd_mul_principal hp + have hdivPrincipal : + finiteSupportGradedEmbedding K p ∣ + B * principalSubringEmbedding K d := + ⟨X, hclear⟩ + have hdPrincipal : + IsPrincipalGraded + (principalSubringEmbedding K d) := + principalSubringEmbedding_isPrincipal d + have hdImage : principalSubringEmbedding K d ≠ 0 := by + intro hzero + apply hd + apply principalSubringEmbedding_injective K + simpa using hzero + exact + (finiteSupportGradedEmbedding_dvd_mul_principal_iff_of_exists_gcd hgcd p B hdPrincipal + hdImage).mp hdivPrincipal + · exact principalSubringLocalizationMap_finiteSupport_dvd + +end + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/PrincipalSubringPrimality.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/PrincipalSubringPrimality.lean new file mode 100644 index 0000000000..6063d3be41 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/PrincipalSubringPrimality.lean @@ -0,0 +1,91 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalSubringFiniteSupport +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalSubringTensor + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.PrincipalSubringLocalization + +/-! +# Primality of finite-support elements in the degree-graded ring + +This module proves the field-generic core of LM24, Corollary 6.3.6. A factorisation supplied in +the localization of `RV̂` is scalar-redistributed to the original coefficient field. Clearing its +two principal denominators and applying LM24, Lemma 6.3.2, then recovers divisibility in `RV̂`. + +The stronger theorem retains both factors as elements of the finite-support ring. Primality of the +embedded element is derived from that witness theorem. +-/ + +open scoped HahnSeries + +universe v + +namespace Berarducci + +public noncomputable section + +open HahnSeries.Nonpositive + +variable {K : Type v} [Field K] [CharZero K] + +/-- A finite-support divisor of a product in `RV̂` factors into finite-support divisors of the +two factors, assuming scalar redistribution and pairwise greatest-common-divisor existence over +both coefficient fields. -/ +theorem finiteSupportGradedEmbedding_exists_factor_dvd_of_scalarRedistribution + (hgcdK : ∀ p q : FiniteSupportRing (K := K), + ∃ d : FiniteSupportRing (K := K), + ∀ e : FiniteSupportRing (K := K), e ∣ p ∧ e ∣ q ↔ e ∣ d) + (hgcdL : ∀ p q : PrincipalSubringFractionFiniteSupportRing K, + ∃ d : PrincipalSubringFractionFiniteSupportRing K, + ∀ e : PrincipalSubringFractionFiniteSupportRing K, + e ∣ p ∧ e ∣ q ↔ e ∣ d) + (hredistribute : PrincipalSubringFractionScalarRedistribution K) + (p : FiniteSupportRing (K := K)) + (B C : DegreeGraded K) + (hp : finiteSupportGradedEmbedding K p ∣ B * C) : + ∃ p₁ p₂ : FiniteSupportRing (K := K), + p = p₁ * p₂ ∧ + finiteSupportGradedEmbedding K p₁ ∣ B ∧ + finiteSupportGradedEmbedding K p₂ ∣ C := by + have hpLocalized := + principalSubringLocalizationMap_finiteSupport_dvd_mul hp + obtain ⟨p₁, p₂, hpFactors, hp₁, hp₂⟩ := + principalSubringFractionScalarExtension_exists_factor_dvd_of_scalarRedistribution hredistribute + hgcdL p + (principalSubringLocalizationMap K B) + (principalSubringLocalizationMap K C) hpLocalized + refine ⟨p₁, p₂, hpFactors, ?_, ?_⟩ + · exact + (principalSubringLocalizationMap_finiteSupport_dvd_iff_of_exists_gcd hgcdK p₁ B).mp hp₁ + · exact + (principalSubringLocalizationMap_finiteSupport_dvd_iff_of_exists_gcd hgcdK p₂ C).mp hp₂ + +/-- Every embedded finite-support element is primal in `RV̂` under the same explicit +prerequisites. -/ +theorem finiteSupportGradedEmbedding_isPrimal_of_scalarRedistribution + (hgcdK : ∀ p q : FiniteSupportRing (K := K), + ∃ d : FiniteSupportRing (K := K), + ∀ e : FiniteSupportRing (K := K), e ∣ p ∧ e ∣ q ↔ e ∣ d) + (hgcdL : ∀ p q : PrincipalSubringFractionFiniteSupportRing K, + ∃ d : PrincipalSubringFractionFiniteSupportRing K, + ∀ e : PrincipalSubringFractionFiniteSupportRing K, + e ∣ p ∧ e ∣ q ↔ e ∣ d) + (hredistribute : PrincipalSubringFractionScalarRedistribution K) + (p : FiniteSupportRing (K := K)) : + IsPrimal (finiteSupportGradedEmbedding K p) := by + intro B C hp + obtain ⟨p₁, p₂, hpFactors, hp₁, hp₂⟩ := + finiteSupportGradedEmbedding_exists_factor_dvd_of_scalarRedistribution hgcdK hgcdL + hredistribute p B C hp + refine ⟨finiteSupportGradedEmbedding K p₁, + finiteSupportGradedEmbedding K p₂, hp₁, hp₂, ?_⟩ + rw [hpFactors, map_mul] + +end + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/RVGradedMaximalFinite.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/RVGradedMaximalFinite.lean new file mode 100644 index 0000000000..54c741f540 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/RVGradedMaximalFinite.lean @@ -0,0 +1,79 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.MaximalFinite +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.RVMaximalFinite + +import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.AssociatedGradedDivisibility + +/-! +# Maximal finite-support divisors under the RV-to-graded embedding + +The canonical multiplicative embedding of degree RV into the associated graded ring preserves +and reflects divisibility. Consequently it also preserves the intrinsic maximal finite-support +divisor class. +-/ + +open scoped HahnSeries + +universe v + +namespace Berarducci + +public noncomputable section + +open HahnSeries.Nonpositive + +variable {K : Type v} [Field K] [CharZero K] + +/-- A maximal finite-support divisor class of an RV element is equivalently a maximal +finite-support divisor class of its canonical image in the associated graded ring. -/ +theorem isRVMaximalFiniteSupportDivisor_iff_isGradedMaximalFiniteSupportDivisor (B : HahnDegreeRV K) + (a : Associates (FiniteSupportRing (K := K))) : + IsRVMaximalFiniteSupportDivisor B a ↔ + IsGradedMaximalFiniteSupportDivisor + ((degreeValuation K).rvInitialFormHom B) a := by + let w := degreeValuation K + rw [isRVMaximalFiniteSupportDivisor_iff, + isGradedMaximalFiniteSupportDivisor_iff] + constructor <;> intro h q + · rw [h q] + have htransport := + w.rv_dvd_iff_associatedGraded_dvd (finiteSupportRVEmbedding K q) B + have hfinite : + w.rvInitialFormHom (finiteSupportRVEmbedding K q) = + finiteSupportGradedEmbedding K q := by + calc + w.rvInitialFormHom (finiteSupportRVEmbedding K q) = + ((w.rvEquivHomogeneous (finiteSupportRVEmbedding K q) : + w.HomogeneousClasses) : w.AssociatedGraded) := by + rw [w.rvEquivHomogeneous_apply, w.coe_rvHomogeneous] + _ = finiteSupportGradedEmbedding K q := by + simpa only [w] using + coe_rvEquivHomogeneous_finiteSupportRVEmbedding q + rw [hfinite] at htransport + exact htransport + · rw [h q] + have htransport := + w.rv_dvd_iff_associatedGraded_dvd (finiteSupportRVEmbedding K q) B + have hfinite : + w.rvInitialFormHom (finiteSupportRVEmbedding K q) = + finiteSupportGradedEmbedding K q := by + calc + w.rvInitialFormHom (finiteSupportRVEmbedding K q) = + ((w.rvEquivHomogeneous (finiteSupportRVEmbedding K q) : + w.HomogeneousClasses) : w.AssociatedGraded) := by + rw [w.rvEquivHomogeneous_apply, w.coe_rvHomogeneous] + _ = finiteSupportGradedEmbedding K q := by + simpa only [w] using + coe_rvEquivHomogeneous_finiteSupportRVEmbedding q + rw [hfinite] at htransport + exact htransport.symm + +end + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/RVMaximalFinite.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/RVMaximalFinite.lean new file mode 100644 index 0000000000..9e636bba43 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/RVMaximalFinite.lean @@ -0,0 +1,576 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Divisibility.MaximalDivisor +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalSubringTensor + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.MaximalFinite + +/-! +# Maximal finite-support divisors in RV + +This module works with the actual multiplicative RV quotient attached to Hahn-series degree. It +defines the finite-support embedding into RV and proves that divisibility in RV agrees with the +fixed-component divisibility used by the tensor-content construction. + +Consequently every RV class has a unique intrinsic maximal finite-support divisor in +`Associates K(ℝ^{≤ 0})`, assuming only pairwise gcd existence in the finite-support ring. This +is the associate-class form of LM24, Proposition 5.4.3. In particular, the source statement is +not silently replaced by divisibility in the full associated graded ring. +-/ + +open scoped DirectSum HahnSeries NatOrdinal + +universe v + +namespace Berarducci + +public noncomputable section + +open HahnSeries.Nonpositive + +variable {K : Type v} [Field K] + +/-- A fixed component, regarded as an element of the monoid of homogeneous graded classes. -/ +def degreeHomogeneousClass (α : NatOrdinal) + (B : (HahnSeries.Nonpositive.degreeValuation K).Component α) : + (HahnSeries.Nonpositive.degreeValuation K).HomogeneousClasses := + ⟨DirectSum.of + (HahnSeries.Nonpositive.degreeValuation K).Component α B, + (MaxAddDegree.mem_homogeneousClasses_iff + (HahnSeries.Nonpositive.degreeValuation K) _).mpr + (Or.inr ⟨α, B, rfl⟩)⟩ + +/-- The underlying graded element of a fixed homogeneous class. -/ +@[simp] +theorem coe_degreeHomogeneousClass (α : NatOrdinal) + (B : (HahnSeries.Nonpositive.degreeValuation K).Component α) : + (degreeHomogeneousClass α B : DegreeGraded K) = + DirectSum.of + (HahnSeries.Nonpositive.degreeValuation K).Component α B := + (rfl) + +variable [CharZero K] + +private theorem directSum_index_eq_of_of_eq {ι : Type*} [DecidableEq ι] + {A : ι → Type*} [∀ i, AddCommMonoid (A i)] + {i j : ι} {x : A i} {y : A j} + (hx : x ≠ 0) (h : DirectSum.of A i x = DirectSum.of A j y) : i = j := by + by_contra hij + have hvalue := congrArg (fun z : DirectSum ι A ↦ z i) h + rw [DirectSum.of_eq_same, + DirectSum.of_eq_of_ne j i y hij] at hvalue + exact hx hvalue + +variable (K) in +/-- The RV monoid attached to the multiplicative Hahn-series degree valuation. -/ +abbrev HahnDegreeRV := + (HahnSeries.Nonpositive.degreeValuation K).RV + +variable (K) in +/-- The finite-support ring embeds multiplicatively into degree RV. -/ +def finiteSupportRVEmbedding : + FiniteSupportRing (K := K) →*₀ HahnDegreeRV K where + toFun p := + (HahnSeries.Nonpositive.degreeValuation K).rv (p : Series K) + map_one' := map_one _ + map_mul' p q := by + change (HahnSeries.Nonpositive.degreeValuation K).rv + ((p : Series K) * (q : Series K)) = _ + rw [map_mul] + map_zero' := + (HahnSeries.Nonpositive.degreeValuation K).rv_zero + +/-- The finite-support RV embedding is the RV quotient map on the underlying Hahn series. -/ +@[simp] +theorem finiteSupportRVEmbedding_apply (p : FiniteSupportRing (K := K)) : + finiteSupportRVEmbedding K p = + (HahnSeries.Nonpositive.degreeValuation K).rv (p : Series K) := + (rfl) + +/-- Under the RV/homogeneous equivalence, the finite-support RV embedding agrees with the +grade-zero embedding into the associated graded ring. -/ +theorem coe_rvEquivHomogeneous_finiteSupportRVEmbedding (p : FiniteSupportRing (K := K)) : + (((HahnSeries.Nonpositive.degreeValuation K).rvEquivHomogeneous + (finiteSupportRVEmbedding K p) : + (HahnSeries.Nonpositive.degreeValuation K).HomogeneousClasses) : + DegreeGraded K) = + finiteSupportGradedEmbedding K p := by + rw [finiteSupportRVEmbedding_apply] + rw [coe_rvEquivHomogeneous_rv_eq_residueRingHom_finiteSupportResidueEquiv + (w := HahnSeries.Nonpositive.degreeValuation K) + (HahnSeries.Nonpositive.degreeValuation_apply) p] + rw [(HahnSeries.Nonpositive.degreeValuation K).residueRingHom_apply, + finiteSupportGradedEmbedding_apply, + degreeFiniteSupportResidueEquiv_apply, + finiteSupportResidueEquiv_apply] + +variable (K) in +/-- The finite-support embedding into degree RV is injective. -/ +theorem finiteSupportRVEmbedding_injective : + Function.Injective (finiteSupportRVEmbedding K) := by + intro p q hpq + apply finiteSupportGradedEmbedding_injective K + rw [← coe_rvEquivHomogeneous_finiteSupportRVEmbedding p, + ← coe_rvEquivHomogeneous_finiteSupportRVEmbedding q, + hpq] + +/-- The homogeneous graded class corresponding to the RV class of a finite-support series. -/ +def finiteSupportHomogeneousClass (p : FiniteSupportRing (K := K)) : + (HahnSeries.Nonpositive.degreeValuation K).HomogeneousClasses := + (HahnSeries.Nonpositive.degreeValuation K).rvHomogeneous + (finiteSupportRVEmbedding K p) + +/-- Evaluation of the finite-support homogeneous class. -/ +@[simp] +theorem finiteSupportHomogeneousClass_apply (p : FiniteSupportRing (K := K)) : + finiteSupportHomogeneousClass p = + (HahnSeries.Nonpositive.degreeValuation K).rvHomogeneous + (finiteSupportRVEmbedding K p) := + (rfl) + +/-- The finite-support homogeneous class has the expected grade-zero image. -/ +theorem coe_finiteSupportHomogeneousClass (p : FiniteSupportRing (K := K)) : + (finiteSupportHomogeneousClass p : + DegreeGraded K) = + finiteSupportGradedEmbedding K p := + by + rw [finiteSupportHomogeneousClass_apply, + ← (HahnSeries.Nonpositive.degreeValuation K).rvEquivHomogeneous_apply] + exact coe_rvEquivHomogeneous_finiteSupportRVEmbedding p + +/-- Multiplication of a finite-support homogeneous class with a fixed homogeneous class is the +degree-zero residue action on that component. -/ +theorem finiteSupportHomogeneousClass_mul_degreeHomogeneousClass + (q : FiniteSupportRing (K := K)) (α : NatOrdinal) + (C : (HahnSeries.Nonpositive.degreeValuation K).Component α) : + finiteSupportHomogeneousClass q * degreeHomogeneousClass α C = + degreeHomogeneousClass α + (HahnSeries.Nonpositive.degreeFiniteSupportResidueEquiv K q • C) := by + apply Subtype.ext + rw [Submonoid.coe_mul, + coe_finiteSupportHomogeneousClass, + coe_degreeHomogeneousClass, + coe_degreeHomogeneousClass] + exact finiteSupportGradedEmbedding_mul_of q α C + +/-- The RV class of a series of exact degree `α` corresponds to its class in the degree-`α` +homogeneous component. -/ +theorem rvEquivHomogeneous_rv_eq_degreeHomogeneousClass (α : NatOrdinal) (p : Series K) + (hpDegree : (p : K⟦ℝ⟧).degree = (α : WithBot NatOrdinal)) : + (HahnSeries.Nonpositive.degreeValuation K).rvEquivHomogeneous + ((HahnSeries.Nonpositive.degreeValuation K).rv p) = + degreeHomogeneousClass α + (degreeLayerMk α p hpDegree.le) := by + let w := HahnSeries.Nonpositive.degreeValuation K + let pLE : w.filtrationLE α := + ⟨p, (w.mem_filtrationLE_iff α p).mpr (by + rw [HahnSeries.Nonpositive.degreeValuation_apply, hpDegree])⟩ + have hpComponent : w.componentMk α pLE ≠ 0 := by + intro hzero + have hlt := (w.componentMk_eq_zero_iff α pLE).mp hzero + rw [HahnSeries.Nonpositive.degreeValuation_apply, hpDegree] at hlt + exact lt_irrefl _ hlt + apply Subtype.ext + rw [w.rvEquivHomogeneous_apply, w.coe_rvHomogeneous, w.rvInitialFormHom_rv] + calc + w.initialForm p = w.homogeneousMk α pLE := + w.initialForm_eq_homogeneousMk_of_componentMk_ne_zero α pLE hpComponent + _ = DirectSum.of w.Component α (w.componentMk α pLE) := + w.homogeneousMk_apply α pLE + _ = DirectSum.of w.Component α (degreeLayerMk α p hpDegree.le) := by + apply congrArg (DirectSum.of w.Component α) + exact (degreeLayerMk_eq_componentMk α p hpDegree.le).symm + +/-- LM24, Definition 5.2.1: an RV class is principal when it has a principal Hahn-series +representative. Zero is deliberately excluded because principal series are nonzero. -/ +def IsPrincipalRV (B : HahnDegreeRV K) : Prop := + ∃ p : Series K, HahnSeries.Nonpositive.IsPrincipal p ∧ + B = (HahnSeries.Nonpositive.degreeValuation K).rv p + +/-- Characterization of a principal RV class by a principal representative. -/ +theorem isPrincipalRV_iff (B : HahnDegreeRV K) : + IsPrincipalRV B ↔ + ∃ p : Series K, HahnSeries.Nonpositive.IsPrincipal p ∧ + B = (HahnSeries.Nonpositive.degreeValuation K).rv p := + Iff.rfl + +/-- An RV class is principal in the sense of LM24, Definition 5.2.1 exactly when its homogeneous +image is a nonzero principal vector in one degree component. -/ +theorem isPrincipalRV_iff_exists_degreeHomogeneousClass (B : HahnDegreeRV K) : + IsPrincipalRV B ↔ + ∃ (α : NatOrdinal) + (C : (HahnSeries.Nonpositive.degreeValuation K).Component α), + C ≠ 0 ∧ IsPrincipalDegreeClass α C ∧ + (HahnSeries.Nonpositive.degreeValuation K).rvEquivHomogeneous B = + degreeHomogeneousClass α C := by + let w := HahnSeries.Nonpositive.degreeValuation K + constructor + · rintro ⟨p, hp, rfl⟩ + have hpDegreeNe : (p : K⟦ℝ⟧).degree ≠ ⊥ := by + intro hbot + exact hp.ne_zero (Subtype.ext (HahnSeries.degree_eq_bot.mp hbot)) + let α := (p : K⟦ℝ⟧).degree.unbot hpDegreeNe + have hpDegree : (p : K⟦ℝ⟧).degree = (α : WithBot NatOrdinal) := + (WithBot.coe_unbot _ hpDegreeNe).symm + let C := degreeLayerMk α p hpDegree.le + have hC : C ≠ 0 := by + intro hzero + have hlt := (degreeLayerMk_eq_zero_iff α p hpDegree.le).mp hzero + rw [hpDegree] at hlt + exact lt_irrefl _ hlt + refine ⟨α, C, hC, + (isPrincipalDegreeClass_iff α C).mpr + (Or.inr ⟨p, hp, hpDegree, rfl⟩), ?_⟩ + exact rvEquivHomogeneous_rv_eq_degreeHomogeneousClass α p hpDegree + · rintro ⟨α, C, hC, hCPrincipal, hB⟩ + rcases (isPrincipalDegreeClass_iff α C).mp hCPrincipal with + hCzero | ⟨p, hp, hpDegree, hCp⟩ + · exact (hC hCzero).elim + · refine ⟨p, hp, ?_⟩ + apply w.rvEquivHomogeneous.injective + calc + w.rvEquivHomogeneous B = degreeHomogeneousClass α C := hB + _ = degreeHomogeneousClass α + (degreeLayerMk α p hpDegree.le) := + congrArg (degreeHomogeneousClass α) hCp + _ = w.rvEquivHomogeneous (w.rv p) := + (rvEquivHomogeneous_rv_eq_degreeHomogeneousClass α p hpDegree).symm + +/-- Divisibility of a fixed homogeneous class by a finite-support class is exactly scalar +divisibility in that fixed component. -/ +theorem finiteSupportHomogeneousClass_dvd_degreeHomogeneousClass_iff + (q : FiniteSupportRing (K := K)) (α : NatOrdinal) + (B : (HahnSeries.Nonpositive.degreeValuation K).Component α) : + finiteSupportHomogeneousClass q ∣ + degreeHomogeneousClass α B ↔ + ∃ C : + (HahnSeries.Nonpositive.degreeValuation K).Component α, + HahnSeries.Nonpositive.degreeFiniteSupportResidueEquiv K q • C = B := by + by_cases hB : B = 0 + · subst B + constructor + · intro _ + refine ⟨0, ?_⟩ + let w := HahnSeries.Nonpositive.degreeValuation K + apply DirectSum.of_injective (β := w.Component) α + rw [DirectSum.of_zero_smul, map_zero, mul_zero] + · rintro ⟨C, hC⟩ + refine ⟨degreeHomogeneousClass α C, ?_⟩ + apply Subtype.ext + change DirectSum.of + (HahnSeries.Nonpositive.degreeValuation K).Component + α 0 = + (finiteSupportHomogeneousClass q : + DegreeGraded K) * + (degreeHomogeneousClass α C : DegreeGraded K) + rw [coe_finiteSupportHomogeneousClass, + finiteSupportGradedEmbedding_apply, + coe_degreeHomogeneousClass, + ← DirectSum.of_zero_smul, hC, map_zero] + · constructor + · rintro ⟨H, hH⟩ + have hHCoe := congrArg Subtype.val hH + have hHmem := + (MaxAddDegree.mem_homogeneousClasses_iff + (HahnSeries.Nonpositive.degreeValuation K) + (H : DegreeGraded K)).mp H.2 + rcases hHmem with hzero | ⟨β, C, hC⟩ + · have hOfZero : DirectSum.of + (HahnSeries.Nonpositive.degreeValuation K).Component + α B = 0 := by + change DirectSum.of + (HahnSeries.Nonpositive.degreeValuation K).Component + α B = + (finiteSupportHomogeneousClass q : + DegreeGraded K) * + (H : DegreeGraded K) at hHCoe + simpa [hzero] using hHCoe + apply (hB ?_).elim + apply DirectSum.of_injective α + simpa using hOfZero + · have hHrepr : H = degreeHomogeneousClass β C := + Subtype.ext hC + subst H + change DirectSum.of + (HahnSeries.Nonpositive.degreeValuation K).Component + α B = + (finiteSupportHomogeneousClass q : + DegreeGraded K) * + (degreeHomogeneousClass β C : DegreeGraded K) + at hHCoe + rw [coe_finiteSupportHomogeneousClass, + coe_degreeHomogeneousClass, + finiteSupportGradedEmbedding_mul_of] at hHCoe + have hαβ : α = β := directSum_index_eq_of_of_eq hB hHCoe + subst β + exact ⟨C, ((DirectSum.of_injective α) hHCoe).symm⟩ + · rintro ⟨C, hC⟩ + refine ⟨degreeHomogeneousClass α C, ?_⟩ + rw [finiteSupportHomogeneousClass_mul_degreeHomogeneousClass, hC] + +/-- Divisibility is preserved and reflected by the multiplicative equivalence from RV to +homogeneous graded classes. -/ +theorem finiteSupportRVEmbedding_dvd_iff_homogeneous + (q : FiniteSupportRing (K := K)) (B : HahnDegreeRV K) : + finiteSupportRVEmbedding K q ∣ B ↔ + finiteSupportHomogeneousClass q ∣ + (HahnSeries.Nonpositive.degreeValuation K).rvEquivHomogeneous B := by + let e := + (HahnSeries.Nonpositive.degreeValuation K).rvEquivHomogeneous + constructor + · rintro ⟨C, hC⟩ + refine ⟨(HahnSeries.Nonpositive.degreeValuation K).rvHomogeneous C, + ?_⟩ + apply Subtype.ext + rw [(HahnSeries.Nonpositive.degreeValuation K).rvEquivHomogeneous_apply, + (HahnSeries.Nonpositive.degreeValuation K).coe_rvHomogeneous] + change + (HahnSeries.Nonpositive.degreeValuation K).rvInitialFormHom B = + (finiteSupportHomogeneousClass q : DegreeGraded K) * + ((HahnSeries.Nonpositive.degreeValuation K).rvHomogeneous C : + DegreeGraded K) + rw [finiteSupportHomogeneousClass_apply, + (HahnSeries.Nonpositive.degreeValuation K).coe_rvHomogeneous + (finiteSupportRVEmbedding K q), + (HahnSeries.Nonpositive.degreeValuation K).coe_rvHomogeneous C] + rw [← (HahnSeries.Nonpositive.degreeValuation K).rvInitialFormHom.map_mul, hC] + · rintro ⟨H, hH⟩ + refine ⟨e.symm H, ?_⟩ + apply (HahnSeries.Nonpositive.degreeValuation K).rvHomogeneous_injective + have hsymm : + (HahnSeries.Nonpositive.degreeValuation K).rvHomogeneous + (e.symm H) = H := by + rw [← (HahnSeries.Nonpositive.degreeValuation K).rvEquivHomogeneous_apply, e.apply_symm_apply] + apply Subtype.ext + have hHCoe := congrArg Subtype.val hH + rw [(HahnSeries.Nonpositive.degreeValuation K).rvEquivHomogeneous_apply, + (HahnSeries.Nonpositive.degreeValuation K).coe_rvHomogeneous] at hHCoe + change + (HahnSeries.Nonpositive.degreeValuation K).rvInitialFormHom B = + (finiteSupportHomogeneousClass q : DegreeGraded K) * + (H : DegreeGraded K) at hHCoe + rw [finiteSupportHomogeneousClass_apply, + (HahnSeries.Nonpositive.degreeValuation K).coe_rvHomogeneous + (finiteSupportRVEmbedding K q)] at hHCoe + rw [(HahnSeries.Nonpositive.degreeValuation K).coe_rvHomogeneous B, + (HahnSeries.Nonpositive.degreeValuation K).coe_rvHomogeneous + (finiteSupportRVEmbedding K q * e.symm H)] + change + (HahnSeries.Nonpositive.degreeValuation K).rvInitialFormHom B = + (HahnSeries.Nonpositive.degreeValuation K).rvInitialFormHom + (finiteSupportRVEmbedding K q * e.symm H) + rw [(HahnSeries.Nonpositive.degreeValuation K).rvInitialFormHom.map_mul] + have hsymmCoe := congrArg Subtype.val hsymm + rw [(HahnSeries.Nonpositive.degreeValuation K).coe_rvHomogeneous (e.symm H)] at hsymmCoe + change + (HahnSeries.Nonpositive.degreeValuation K).rvInitialFormHom + (e.symm H) = (H : DegreeGraded K) at hsymmCoe + rw [hsymmCoe] + exact hHCoe + +/-- An associate class records exactly the finite-support divisors of an RV class. This is the +intrinsic predicate underlying LM24, Proposition 5.4.3. -/ +def IsRVMaximalFiniteSupportDivisor (B : HahnDegreeRV K) + (a : Associates (FiniteSupportRing (K := K))) : Prop := + IsMaximalDivisorAlong + (finiteSupportRVEmbedding K).toMonoidHom B a + +/-- The defining divisibility characterization for a maximal finite-support divisor in RV. -/ +theorem isRVMaximalFiniteSupportDivisor_iff (B : HahnDegreeRV K) + (a : Associates (FiniteSupportRing (K := K))) : + IsRVMaximalFiniteSupportDivisor B a ↔ + ∀ q : FiniteSupportRing (K := K), Associates.mk q ≤ a ↔ + (finiteSupportRVEmbedding K).toMonoidHom q ∣ B := by + rw [IsRVMaximalFiniteSupportDivisor, + isMaximalDivisorAlong_iff] + +/-- Representative form of the maximal-divisor characterization used in LM24, +Proposition 5.4.3. -/ +theorem isRVMaximalFiniteSupportDivisor_mk_iff + (B : HahnDegreeRV K) (p : FiniteSupportRing (K := K)) : + IsRVMaximalFiniteSupportDivisor B (Associates.mk p) ↔ + ∀ q : FiniteSupportRing (K := K), + finiteSupportRVEmbedding K q ∣ B ↔ q ∣ p := by + rw [isRVMaximalFiniteSupportDivisor_iff] + constructor + · intro h q + constructor + · intro hqB + exact Associates.mk_le_mk_iff_dvd.mp ((h q).mpr hqB) + · intro hqp + exact (h q).mp (Associates.mk_le_mk_iff_dvd.mpr hqp) + · intro h q + constructor + · intro hqp + exact (h q).mpr (Associates.mk_le_mk_iff_dvd.mp hqp) + · intro hqB + exact Associates.mk_le_mk_iff_dvd.mpr ((h q).mp hqB) + +/-- An RV class has at most one maximal finite-support divisor class. -/ +theorem IsRVMaximalFiniteSupportDivisor.eq {B : HahnDegreeRV K} + {a b : Associates (FiniteSupportRing (K := K))} + (ha : IsRVMaximalFiniteSupportDivisor B a) + (hb : IsRVMaximalFiniteSupportDivisor B b) : a = b := by + exact IsMaximalDivisorAlong.eq ha hb + +/-- Pairwise gcd existence gives a unique maximal finite-support divisor class for every RV +class. -/ +theorem existsUnique_isRVMaximalFiniteSupportDivisor_of_exists_gcd + (hgcd : ∀ p q : FiniteSupportRing (K := K), + ∃ d : FiniteSupportRing (K := K), + ∀ e : FiniteSupportRing (K := K), e ∣ p ∧ e ∣ q ↔ e ∣ d) + (B : HahnDegreeRV K) : + ∃! a : Associates (FiniteSupportRing (K := K)), + IsRVMaximalFiniteSupportDivisor B a := by + let w := HahnSeries.Nonpositive.degreeValuation K + let e := w.rvEquivHomogeneous + by_cases hB : B = 0 + · subst B + refine ⟨0, ?_, ?_⟩ + · exact IsMaximalDivisorAlong.zero + (finiteSupportRVEmbedding K).toMonoidHom + · intro a ha + exact IsRVMaximalFiniteSupportDivisor.eq ha + (IsMaximalDivisorAlong.zero + (finiteSupportRVEmbedding K).toMonoidHom) + · have hEB : e B ≠ 0 := by + intro hzero + apply hB + apply e.injective + rw [w.rvEquivHomogeneous_zero] + exact hzero + have hEBmem := (w.mem_homogeneousClasses_iff (e B : w.AssociatedGraded)).mp (e B).2 + rcases hEBmem with hzero | ⟨α, C, hC⟩ + · exact (hEB (Subtype.ext hzero)).elim + · obtain ⟨a, ha, hunique⟩ := + existsUnique_isLayerMaximalFiniteSupportDivisor_of_exists_gcd hgcd α C + have hEBrepr : e B = degreeHomogeneousClass α C := + Subtype.ext hC + refine ⟨a, ?_, ?_⟩ + · apply (isRVMaximalFiniteSupportDivisor_iff B a).mpr + intro q + change Associates.mk q ≤ a ↔ finiteSupportRVEmbedding K q ∣ B + rw [finiteSupportRVEmbedding_dvd_iff_homogeneous, + hEBrepr, + finiteSupportHomogeneousClass_dvd_degreeHomogeneousClass_iff] + exact (isLayerMaximalFiniteSupportDivisor_iff α C a).mp ha q + · intro b hb + apply hunique b + apply (isLayerMaximalFiniteSupportDivisor_iff α C b).mpr + intro q + rw [← finiteSupportHomogeneousClass_dvd_degreeHomogeneousClass_iff, + ← hEBrepr, + ← finiteSupportRVEmbedding_dvd_iff_homogeneous] + exact (isRVMaximalFiniteSupportDivisor_iff B b).mp hb q + +/-- If `a` is principal of degree `α` and `p` is a nonzero finite-support series, then the +RV class of `p * a` has maximal finite-support divisor class represented by `p`. -/ +theorem isRVMaximalFiniteSupportDivisor_finiteSupport_mul_principal + (α : NatOrdinal) (p : FiniteSupportRing (K := K)) (hp : p ≠ 0) + (a : Series K) (ha : HahnSeries.Nonpositive.IsPrincipal a) + (haDegree : (a : K⟦ℝ⟧).degree = (α : WithBot NatOrdinal)) : + IsRVMaximalFiniteSupportDivisor + ((HahnSeries.Nonpositive.degreeValuation K).rv + ((p : Series K) * a)) + (Associates.mk p) := by + have hpHahn : (p : K⟦ℝ⟧) ≠ 0 := by + intro hzero + apply hp + exact Subtype.ext (Subtype.ext hzero) + have hpDegree : (p : K⟦ℝ⟧).degree = 0 := by + rw [HahnSeries.degree_eq_zero] + exact ⟨hpHahn, + (HahnSeries.Nonpositive.mem_finiteSupportSubring_iff + (p : Series K)).mp p.2⟩ + have hprodDegree : (((p : Series K) * a : Series K) : K⟦ℝ⟧).degree = + (α : WithBot NatOrdinal) := by + rw [HahnSeries.Nonpositive.degree_mul, hpDegree, haDegree, zero_add] + have hLayer := + isLayerMaximalFiniteSupportDivisor_finiteSupport_mul_principal α p a ha haDegree + apply (isRVMaximalFiniteSupportDivisor_iff _ (Associates.mk p)).mpr + intro q + change Associates.mk q ≤ Associates.mk p ↔ + finiteSupportRVEmbedding K q ∣ + (HahnSeries.Nonpositive.degreeValuation K).rv + ((p : Series K) * a) + rw [finiteSupportRVEmbedding_dvd_iff_homogeneous, + rvEquivHomogeneous_rv_eq_degreeHomogeneousClass α _ hprodDegree, + finiteSupportHomogeneousClass_dvd_degreeHomogeneousClass_iff] + exact (isLayerMaximalFiniteSupportDivisor_iff α _ _).mp hLayer q + +/-- A principal RV class has a maximal finite-support divisor represented by a constant series, +as in the final clause of LM24, Proposition 5.4.3. -/ +theorem exists_scalar_isRVMaximalFiniteSupportDivisor_of_isPrincipal + (B : HahnDegreeRV K) (hB : IsPrincipalRV B) : + ∃ k : K, IsRVMaximalFiniteSupportDivisor B + (Associates.mk + (HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℝ) k)) := by + obtain ⟨α, C, _, hCPrincipal, hBCoe⟩ := + (isPrincipalRV_iff_exists_degreeHomogeneousClass B).mp hB + obtain ⟨k, hk⟩ := + exists_scalar_isLayerMaximalFiniteSupportDivisor_of_isPrincipal α C hCPrincipal + refine ⟨k, (isRVMaximalFiniteSupportDivisor_iff B _).mpr ?_⟩ + intro q + change Associates.mk q ≤ Associates.mk + (HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℝ) k) ↔ + finiteSupportRVEmbedding K q ∣ B + rw [finiteSupportRVEmbedding_dvd_iff_homogeneous, + hBCoe, + finiteSupportHomogeneousClass_dvd_degreeHomogeneousClass_iff] + exact (isLayerMaximalFiniteSupportDivisor_iff α C _).mp hk q + +/-- The canonical maximal finite-support divisor class of an RV element. + +The fallback branch is unreachable whenever maximal-divisor existence has been established. -/ +noncomputable def rvMaximalFiniteSupportDivisor (B : HahnDegreeRV K) : + Associates (FiniteSupportRing (K := K)) := by + classical + exact if h : ∃ a : Associates (FiniteSupportRing (K := K)), + IsRVMaximalFiniteSupportDivisor B a then + Classical.choose h + else + 0 + +/-- Any class satisfying the RV characterization is the canonical class. -/ +theorem rvMaximalFiniteSupportDivisor_eq_of_is {B : HahnDegreeRV K} + {a : Associates (FiniteSupportRing (K := K))} + (ha : IsRVMaximalFiniteSupportDivisor B a) : + rvMaximalFiniteSupportDivisor B = a := by + classical + let hex : ∃ b : Associates (FiniteSupportRing (K := K)), + IsRVMaximalFiniteSupportDivisor B b := ⟨a, ha⟩ + rw [rvMaximalFiniteSupportDivisor, dite_eq_left hex] + exact (Classical.choose_spec hex).eq ha + +/-- Under pairwise gcd existence, the canonical RV class satisfies its defining +characterization. -/ +theorem rvMaximalFiniteSupportDivisor_is_of_exists_gcd (hgcd : ∀ p q : FiniteSupportRing (K := K), + ∃ d : FiniteSupportRing (K := K), + ∀ e : FiniteSupportRing (K := K), e ∣ p ∧ e ∣ q ↔ e ∣ d) + (B : HahnDegreeRV K) : + IsRVMaximalFiniteSupportDivisor B + (rvMaximalFiniteSupportDivisor B) := by + obtain ⟨a, ha, _⟩ := + existsUnique_isRVMaximalFiniteSupportDivisor_of_exists_gcd hgcd B + rw [rvMaximalFiniteSupportDivisor_eq_of_is ha] + exact ha + +/-- For a principal RV class, the canonical maximal finite-support divisor is represented by a +constant series. -/ +theorem exists_scalar_rvMaximalFiniteSupportDivisor_of_isPrincipal + (B : HahnDegreeRV K) (hB : IsPrincipalRV B) : + ∃ k : K, rvMaximalFiniteSupportDivisor B = + Associates.mk + (HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℝ) k) := by + obtain ⟨k, hk⟩ := + exists_scalar_isRVMaximalFiniteSupportDivisor_of_isPrincipal B hB + exact ⟨k, rvMaximalFiniteSupportDivisor_eq_of_is hk⟩ + +end + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Random.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Random.lean new file mode 100644 index 0000000000..5de520ae4c --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Random.lean @@ -0,0 +1,25 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Random.ClassIrreducible +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Random.CoefficientRandom +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Random.GradedIrreducible +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Random.HereditaryIndependence +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Random.IndependenceWindow +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Random.MainTheorem +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Random.NonPrincipalIrreducible +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Random.NormalFormBlocks +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Random.PrincipalIrreducible +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Random.Random +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Random.RandomBlocks +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Random.ReducibleSpan +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Random.SuccessorStep +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Random.SupportRandom +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Random.TruncationIndependence + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Random/ClassIrreducible.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Random/ClassIrreducible.lean new file mode 100644 index 0000000000..283e3b4eb9 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Random/ClassIrreducible.lean @@ -0,0 +1,94 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Random.SuccessorStep +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Random.PrincipalIrreducible +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Statements.OrdinalValueDegree + +import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.AssociatedGradedDivisibility + +/-! +# Irreducible classes in $\widehat{\mathrm P}$ + +Fornasiero, Lavi, L'Innocente and Mantova, *Irreducibility in generalized power series* (2024), +Corollary 4.5, first clause, for `α = n < ω`: if `b ∈ P_n` is hereditarily `rv_J`-independent, +then `rv(b)` is irreducible. The class `rv(b)` is `rv_J(b) ∈ P_n ⊆ P̂`, and the statement is +irreducibility in `P̂`. + +The argument is the one of the source's proof: a factorisation `rv_J(b) = X · Y` in `P̂` has +homogeneous factors, because `P̂` is a graded domain (Berarducci, Theorem 9.7); if both factors +have positive grade, `rv_J(b)` lies in the span `D_n` of such products, which `(*)_n` excludes +for a hereditarily `rv_J`-independent `b`; and a nonzero class of grade zero is a unit. +-/ + +open scoped DirectSum HahnSeries NatOrdinal + +universe v + +public noncomputable section + +namespace FLLM24 + +open Berarducci + +variable {K : Type v} [Field K] [CharZero K] + +/-- A nonzero class of positive grade `n` outside `D_n` is irreducible in `P̂`. -/ +theorem irreducible_of_notMem_decomposableSpan {n : NatOrdinal} (hn : 0 < n) + {x : PrincipalComponent K n} (hx : x ≠ 0) + (hmem : DirectSum.of (PrincipalComponent K) n x ∉ decomposableSpan K n) : + Irreducible (DirectSum.of (PrincipalComponent K) n x) := by + refine ⟨not_isUnit_of_grade_ne_zero hn.ne' x, fun A C hAC ↦ ?_⟩ + have hne : DirectSum.of (PrincipalComponent K) n x ≠ 0 := fun h ↦ + hx (DirectSum.of_injective n (by rw [h, map_zero])) + have hA : A ≠ 0 := fun h ↦ hne (by rw [hAC, h, zero_mul]) + have hC : C ≠ 0 := fun h ↦ hne (by rw [hAC, h, mul_zero]) + have hhom : A * C ∈ (ordinalValueDegreeValuation K).homogeneousClasses := by + rw [← hAC, MaxAddDegree.mem_homogeneousClasses_iff] + exact Or.inr ⟨n, x, rfl⟩ + obtain ⟨hAhom, hChom⟩ := + (ordinalValueDegreeValuation K).mem_homogeneousClasses_of_mul_mem hA hC hhom + rcases (MaxAddDegree.mem_homogeneousClasses_iff _ A).mp hAhom with rfl | ⟨β, y, rfl⟩ + · exact absurd rfl hA + rcases (MaxAddDegree.mem_homogeneousClasses_iff _ C).mp hChom with rfl | ⟨γ, z, rfl⟩ + · exact absurd rfl hC + have hy : y ≠ 0 := fun h ↦ hA (by rw [h, map_zero]) + have hz : z ≠ 0 := fun h ↦ hC (by rw [h, map_zero]) + -- The product of the homogeneous factors sits in grade `β + γ`, which must be `n`. + have hgrade : n = β + γ := by + by_contra hne' + have hcomp := congrArg (fun w : PrincipalSubring K ↦ w (β + γ)) hAC + simp only [DirectSum.of_mul_of, DirectSum.of_eq_of_ne _ _ _ (Ne.symm hne'), + DirectSum.of_eq_same] at hcomp + exact MaxAddDegree.componentMul_ne_zero (ordinalValueDegreeValuation K) y z hy hz hcomp.symm + rcases eq_or_ne β 0 with hβ | hβ + · subst hβ + exact Or.inl (isUnit_of_grade_zero y hy) + rcases eq_or_ne γ 0 with hγ | hγ + · subst hγ + exact Or.inr (isUnit_of_grade_zero z hz) + exfalso + apply hmem + rw [hAC, hgrade] + exact of_mul_of_mem_decomposableSpan (pos_iff_ne_zero.mpr hβ) (pos_iff_ne_zero.mpr hγ) y z + +/-- FLLM24, Corollary 4.5 (first clause) for `α = n ≥ 1`: the class `rv_J(b)` of a hereditarily +`rv_J`-independent series of ordinal-value degree `n` is irreducible in `P̂`. -/ +theorem irreducible_rvJ_of_hereditarilyRVIndependent {n : ℕ} (hn : 1 ≤ n) {b : Series K} + (hb : HereditarilyRVIndependent n (fun _ : Unit ↦ b)) : Irreducible (rvJ b) := by + have hval : ordinalValue b = ω^ (n : NatOrdinal) := hb.ordinalValue_eq () + have hmem := rvJ_notMem_decomposableSpan (independentModuloDecomposable_of_pos hn) hb + have hcut : ordinalValue b < ω^ ((n : NatOrdinal) + 1) := by + rw [hval]; exact NatOrdinal.wpow_lt_wpow.mpr (lt_add_one _) + rw [rvJ_eq_gradeClass hval, gradeClass_of_lt hcut] at hmem ⊢ + refine irreducible_of_notMem_decomposableSpan (Nat.cast_pos.mpr hn) ?_ hmem + rw [Ne, principalComponentMk_eq_zero_iff, hval] + exact lt_irrefl _ + +end FLLM24 + +end diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Random/CoefficientRandom.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Random/CoefficientRandom.lean new file mode 100644 index 0000000000..aa66fd1a44 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Random/CoefficientRandom.lean @@ -0,0 +1,179 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Random.Random +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Random.TruncationIndependence +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Random.IndependenceWindow +public import LeanPool.ConwayRefinement.ConwayRefinement.LinearAlgebra.AlgebraicIndependentDet +public import LeanPool.ConwayRefinement.ConwayRefinement.Order.DifferenceAvoidance + +import Mathlib.LinearAlgebra.Matrix.ToLinearEquiv + +/-! +# Algebraically independent coefficients give hereditary `rv_J`-independence + +Fornasiero, Lavi, L'Innocente and Mantova, *Irreducibility in generalized power series* (2024), +Proposition 3.4 and Corollary 3.5: if the coefficients of `b_1, …, b_n` are algebraically +independent over `ℚ` and `deg_J(b_i) = α ≥ 1`, then `rv_J(b_1), …, rv_J(b_n)` are linearly +independent, and `Q(b_1, …, b_n)` holds. + +The source's proof of Proposition 3.4 picks exponents `γ_1, …, γ_n` in `supp(u_1)` and forms +the matrix `A[i, j] = u_{j, γ_i}`, whose determinant vanishes because `A v = 0` for the +coefficient vector `v ≠ 0` of the relation; it concludes that "the elements of `A` are not +algebraically independent". Two points are completed here. The entries `u_{j, γ_i}` must be +distinct members of the coefficient family, so the `γ_i` have to be chosen in the supports of +all the `u_j` at once; and Corollary 3.5 applies Proposition 3.4 to families of translated +truncations `b_i^{|γ_{i,j}}`, whose joint coefficient family is not algebraically independent, +since one coefficient of `b_i` reappears in several truncations. Both are met by a single +argument for families of translated truncations `c_k = b_{j(k)}^{|γ(k)}` at distinct pairs: the +exponents `x_q`, one in the support of each `c_q` near zero and outside the support of the +relation, are chosen so that no difference `x_q - x_{q'}` equals a difference `γ(k) - γ(k')`. +Then the entries `c_k(x_q) = b_{j(k)}(γ(k) + x_q)` are zero or pairwise distinct coefficients, the +diagonal entries are nonzero, and the determinant is a nonzero polynomial in the coefficients, +being `1` when the diagonal variables are set to `1` and the others to `0`. +-/ + +open scoped HahnSeries NatOrdinal + +universe v + +public noncomputable section + +namespace FLLM24 + +open Berarducci HahnSeries.Nonpositive + +variable {K : Type v} [Field K] [CharZero K] + +/-- FLLM24, Proposition 3.4 in the form needed for Corollary 3.5: the translated truncations at +distinct pairs of a family with algebraically independent coefficients, when of a common positive +degree, have linearly independent classes. -/ +theorem IsMutuallyCoefficientRandom.truncationsIndependent {ι : Type} {b : ι → Series K} + (hb : IsMutuallyCoefficientRandom b) : TruncationsIndependent K b := by + refine TruncationsIndependent.of fun d hd κ _ j γ hinj hγ hval ↦ ?_ + classical + cases nonempty_fintype κ + set c : κ → Series K := fun k ↦ translatedTruncation (b (j k) : K⟦ℝ⟧) (γ k) with hc + rw [linearIndependent_iff'] + intro s g hsum k₀ hk₀ + by_contra hg₀ + -- Restrict to the support `P` of the coefficients. + set P := s.filter (fun k ↦ g k ≠ 0) with hP + have hk₀P : k₀ ∈ P := Finset.mem_filter.mpr ⟨hk₀, hg₀⟩ + have hgP : ∀ k ∈ P, g k ≠ 0 := fun k hk ↦ (Finset.mem_filter.mp hk).2 + have hrelP : ∑ k ∈ P, g k • rvJ (c k) = 0 := by + rw [hP, Finset.sum_filter_of_ne] + · exact hsum + · intro k _ hk hgk + exact hk (by rw [hgk, zero_smul]) + have hrel' : ∑ k : P, g k • rvJ (c k) = 0 := by + rw [Finset.sum_coe_sort P (fun k ↦ g k • rvJ (c k))] + exact hrelP + -- The relation has ordinal value below `ω^d`. + set R : Series K := ∑ k : P, (HahnSeries.Nonpositive.C : K →+* Series K) (g k) * c k with hR + have hRlt : ordinalValue R < ω^ (d : NatOrdinal) := + ordinalValue_sum_C_mul_lt_of_sum_smul_rvJ_eq_zero (fun k : P ↦ hval k) (fun k : P ↦ g k) + hrel' + have hd' : (0 : NatOrdinal) < d := Nat.cast_pos.mpr hd + -- A common window `(η, 0)` in which every `c k` has infinitely many support points outside + -- the support of `R`. + have hwin : ∀ k : P, ∃ η₀ < (0 : ℝ), ∀ η, η₀ < η → η < 0 → + ((((c k : Series K) : K⟦ℝ⟧).support ∩ Set.Ioo η 0) \ (R : K⟦ℝ⟧).support).Infinite := + fun k ↦ exists_forall_infinite_support_diff hd' (hval k) hRlt + choose η₀ hη₀ hwin using hwin + have hPne : (Finset.univ : Finset P).Nonempty := ⟨⟨k₀, hk₀P⟩, Finset.mem_univ _⟩ + set η := (Finset.univ.sup' hPne η₀) / 2 with hη + have hηneg : η < 0 := by + have : Finset.univ.sup' hPne η₀ < 0 := by + obtain ⟨k, -, hk⟩ := Finset.exists_mem_eq_sup' hPne η₀ + rw [hk]; exact hη₀ k + rw [hη]; linarith + have hηgt : ∀ k : P, η₀ k < η := fun k ↦ by + have h1 : η₀ k ≤ Finset.univ.sup' hPne η₀ := Finset.le_sup' η₀ (Finset.mem_univ k) + have h2 : Finset.univ.sup' hPne η₀ < 0 := by linarith [hηneg] + rw [hη]; linarith + set E : P → Set ℝ := fun k ↦ (((c k : Series K) : K⟦ℝ⟧).support ∩ Set.Ioo η 0) \ + (R : K⟦ℝ⟧).support with hE + have hEinf : ∀ k : P, (E k).Infinite := fun k ↦ hwin k η (hηgt k) hηneg + -- Exponents with differences avoiding the differences of the `γ k`. + set D : Finset ℝ := (Finset.univ : Finset (P × P)).image fun p ↦ γ p.1 - γ p.2 with hD + obtain ⟨x, hxE, hxD⟩ := exists_forall_mem_forall_sub_notMem (Finset.univ : Finset P) E hEinf D + have hxE' : ∀ q : P, x q ∈ E q := fun q ↦ hxE q (Finset.mem_univ q) + have hxneg : ∀ q : P, x q < 0 := fun q ↦ (hxE' q).1.2.2 + have hxR : ∀ q : P, ((R : Series K) : K⟦ℝ⟧).coeff (x q) = 0 := fun q ↦ by + have := (hxE' q).2 + rwa [HahnSeries.mem_support, not_ne_iff] at this + have hxc : ∀ q : P, ((c q : Series K) : K⟦ℝ⟧).coeff (x q) ≠ 0 := fun q ↦ (hxE' q).1.1 + -- The matrix of coefficients. + have hcoeff : ∀ (q k : P), ((c k : Series K) : K⟦ℝ⟧).coeff (x q) = + ((b (j k) : Series K) : K⟦ℝ⟧).coeff (γ k + x q) := fun q k ↦ by + rw [hc, coeff_translatedTruncation, ite_eq_left (hxneg q).le] + let M : Matrix P P K := Matrix.of fun q k ↦ ((c k : Series K) : K⟦ℝ⟧).coeff (x q) + have hMg : M.mulVec (fun k : P ↦ g k) = 0 := by + funext q + rw [Matrix.mulVec, Pi.zero_apply, ← hxR q, hR, coeff_sum_C_mul] + simp only [dotProduct, Matrix.of_apply, M] + exact Finset.sum_congr rfl fun k _ ↦ mul_comm _ _ + have hgne : (fun k : P ↦ g k) ≠ 0 := by + intro h + exact hgP k₀ hk₀P (congrFun h ⟨k₀, hk₀P⟩) + have hdet : M.det = 0 := Matrix.exists_mulVec_eq_zero_iff.mp ⟨_, hgne, hMg⟩ + -- The pattern of variables. + let v : P → P → Option (coefficientIndex b) := fun q k ↦ + if h : (j k, γ k + x q) ∈ coefficientIndex b then some ⟨(j k, γ k + x q), h⟩ else none + have hM : ∀ q k, M q k = (v q k).elim 0 (fun p : coefficientIndex b ↦ + ((b p.1.1 : Series K) : K⟦ℝ⟧).coeff p.1.2) := by + intro q k + simp only [M, Matrix.of_apply, v] + rw [hcoeff q k] + by_cases h : (j k, γ k + x q) ∈ coefficientIndex b + · rw [dite_eq_left h] + rfl + · rw [dite_eq_right h, Option.elim] + rw [mem_coefficientIndex_iff, not_ne_iff] at h + exact h + have hdiag : ∀ q, (v q q).isSome := by + intro q + have h : (j q, γ q + x q) ∈ coefficientIndex b := by + rw [mem_coefficientIndex_iff] + rw [← hcoeff q q] + exact hxc q + simp only [v, dite_eq_left h, Option.isSome_some] + have hdistinct : ∀ q k q' k' w, v q k = some w → v q' k' = some w → q = q' ∧ k = k' := by + intro q k q' k' w h1 h2 + have hpair : (j k, γ k + x q) = (j k', γ k' + x q') := by + by_cases hk : (j k, γ k + x q) ∈ coefficientIndex b + · by_cases hk' : (j k', γ k' + x q') ∈ coefficientIndex b + · simp only [v, dite_eq_left hk, dite_eq_left hk', Option.some.injEq] at h1 h2 + exact congrArg Subtype.val (h1.trans h2.symm) + · simp [v, dite_eq_right hk'] at h2 + · simp [v, dite_eq_right hk] at h1 + have hj : j k = j k' := congrArg Prod.fst hpair + have hγ' : γ k + x q = γ k' + x q' := congrArg Prod.snd hpair + by_cases hqq : q = q' + · subst hqq + have hγk : γ k = γ k' := add_right_cancel hγ' + exact ⟨rfl, Subtype.ext (hinj (Prod.ext hj hγk))⟩ + · exfalso + apply hxD q (Finset.mem_univ q) q' (Finset.mem_univ q') hqq + refine Finset.mem_image.mpr ⟨(k', k), Finset.mem_univ _, ?_⟩ + linarith + exact Matrix.det_ne_zero_of_algebraicIndependent hb.algebraicIndependent v M hM hdiag + hdistinct hdet + +/-- FLLM24, Corollary 3.5 for finite degrees: a finite family of series with algebraically +independent coefficients and ordinal value `ω^n`, `n ≥ 1`, is hereditarily +`rv_J`-independent. -/ +theorem IsMutuallyCoefficientRandom.hereditarilyRVIndependent {ι : Type} [Finite ι] + {b : ι → Series K} (hb : IsMutuallyCoefficientRandom b) {n : ℕ} (hn : 1 ≤ n) + (hval : ∀ i, ordinalValue (b i) = ω^ (n : NatOrdinal)) : + HereditarilyRVIndependent n b := + hb.truncationsIndependent.hereditarilyRVIndependent_self hn hval + +end FLLM24 + +end diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Random/GradedIrreducible.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Random/GradedIrreducible.lean new file mode 100644 index 0000000000..3fc64b7f1c --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Random/GradedIrreducible.lean @@ -0,0 +1,506 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalSubringTensor +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Statements.PrincipalSubringPrimality +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Degree.Statements.DegreeValuation +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Monomial +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.FiniteSupportUnit + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Random.ReducibleSpan + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Random.PrincipalIrreducible +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Degree.SupportSupremumMultiplicativity +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalComponentDegree +import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.AssociatedGradedDivisibility +import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.DegreeSum +import Mathlib.LinearAlgebra.Basis.VectorSpace +import Mathlib.RingTheory.TensorProduct.Basic + +/-! +# Block forms in the degree-graded ring + +Fornasiero, Lavi, L'Innocente and Mantova, *Irreducibility in generalized power series* (2024), +Proposition 3.2, proves irreducibility of `b = ∑ b_i t^{γ_i} + r` from that of `rv(b_m)` by +working in the degree-graded ring `RV̂` of LM24: the initial form of `b` is +`t^{γ_m} · B` with `B = ∑ rv(b_i) t^{γ_i - γ_m}`, and a factorisation of `b` gives one of `B` +after the monomial `t^{γ_m}` has been split between the factors. This module carries out the +graded part of the argument. + +`RV̂ ≅ P̂ ⊗_K K(ℝ^{≤0})` (LM24, Proposition 6.1.2). A *block form* is an element +`∑ᵢ X_i · t^{δ_i}` with `X_i ∈ P_n` linearly independent, `δ_i ≤ 0`, one `δ_m = 0` and all other +`δ_i < 0`; its image under the graded projection `RV̂ → P̂` is `X_m`. If `X_m` is irreducible in +`P̂`, the block form is irreducible in `RV̂`: a factorisation `B = A C` has homogeneous factors, +the projection of one factor is a unit of `P̂`, so that factor has grade zero and is a +finite-support series `p`; the coordinate functional extracting the coefficient of `X_m` is +`K(ℝ^{≤0})`-linear and sends `B` to `t^{δ_m} = 1`, whence `p` is a unit. The source words this +step as "`p(B) = 1` implies `p(A) = 1`" and "`deg_J(a_i) = 0` for every `i`". + +Finite-support series are primal in `RV̂` (LM24, Corollary 6.3.6), and the divisors of a monomial +in `K(ℝ^{≤0})` are monomials. Hence in any factorisation `A C = t^γ · B` one factor is a monomial +`k t^x`; and a series whose initial form is the image of a finite-support series is that series. +-/ + +open scoped DirectSum HahnSeries NatOrdinal TensorProduct + +universe v + +public noncomputable section + +namespace FLLM24 + +open Berarducci HahnSeries.Nonpositive + +variable {K : Type v} [Field K] + +/-! ### Monomials and units -/ + +/-- A factor of a nonzero monomial of `K((ℝ^{≤0}))` is a monomial: the order and the support +supremum of a product are both additive (Berarducci, Corollary 9.8 for the supremum), and they +agree on a monomial, so they agree on each factor. -/ +theorem isMonomial_of_mul_eq_single [CharZero K] {p q : Series K} {γ : ℝ} {k : K} (hk : k ≠ 0) + (hγ : γ ≤ 0) (h : p * q = single γ k hγ) : IsMonomial p := by + have hsingle : single γ k hγ ≠ 0 := by + intro hzero + have hcoeff := congrArg (fun x : Series K ↦ (x : K⟦ℝ⟧).coeff γ) hzero + exact hk (by simpa [coe_single] using hcoeff) + have hp : p ≠ 0 := fun hp ↦ hsingle (by rw [← h, hp, zero_mul]) + have hq : q ≠ 0 := fun hq ↦ hsingle (by rw [← h, hq, mul_zero]) + have hp' : (p : K⟦ℝ⟧) ≠ 0 := fun h' ↦ hp (Subtype.ext h') + have hq' : (q : K⟦ℝ⟧) ≠ 0 := fun h' ↦ hq (Subtype.ext h') + -- The supremum of the support is additive. + have hsup : sSup (p : K⟦ℝ⟧).support + sSup (q : K⟦ℝ⟧).support = γ := by + have h1 := supportSup_mul p q + rw [h, supportSup_single hk hγ, supportSup_of_ne hp, supportSup_of_ne hq, ← WithBot.coe_add] + at h1 + exact WithBot.coe_inj.mp h1.symm + -- The order is additive. + have horder : (p : K⟦ℝ⟧).order + (q : K⟦ℝ⟧).order = γ := by + have h1 := congrArg (fun x : Series K ↦ (x : K⟦ℝ⟧).order) h + simp only [Subring.coe_mul, coe_single] at h1 + rw [HahnSeries.order_mul hp' hq', HahnSeries.order_single hk] at h1 + exact h1 + have hpmem : (p : K⟦ℝ⟧).order ∈ (p : K⟦ℝ⟧).support := + HahnSeries.coeff_order_eq_zero.not.mpr hp' + have hqmem : (q : K⟦ℝ⟧).order ∈ (q : K⟦ℝ⟧).support := + HahnSeries.coeff_order_eq_zero.not.mpr hq' + have hple : (p : K⟦ℝ⟧).order ≤ sSup (p : K⟦ℝ⟧).support := + le_csSup (bddAbove_support p) hpmem + have hqle : (q : K⟦ℝ⟧).order ≤ sSup (q : K⟦ℝ⟧).support := + le_csSup (bddAbove_support q) hqmem + have hpeq : (p : K⟦ℝ⟧).order = sSup (p : K⟦ℝ⟧).support := by linarith + rw [isMonomial_iff_support_eq_singleton] + refine ⟨(p : K⟦ℝ⟧).order, Set.Subset.antisymm (fun y hy ↦ ?_) (fun y hy ↦ ?_)⟩ + · have h1 : (p : K⟦ℝ⟧).order ≤ y := HahnSeries.order_le_of_coeff_ne_zero hy + have h2 : y ≤ (p : K⟦ℝ⟧).order := by + rw [hpeq] + exact le_csSup (bddAbove_support p) hy + exact Set.mem_singleton_iff.mpr (le_antisymm h2 h1) + · rw [Set.mem_singleton_iff] at hy + rw [hy] + exact hpmem + +/-- Every element of grade zero in `RV̂` is the image of a finite-support series. -/ +theorem exists_finiteSupportGradedEmbedding_eq_of + (y : (degreeValuation K).Component 0) : + ∃ p : Berarducci.FiniteSupportRing (K := K), + finiteSupportGradedEmbedding K p = DirectSum.of (degreeValuation K).Component 0 y := by + refine ⟨(degreeFiniteSupportResidueEquiv K).symm y, ?_⟩ + rw [finiteSupportGradedEmbedding_apply, RingEquiv.apply_symm_apply] + +/-- A nonzero factor of a nonzero homogeneous element of `RV̂` is homogeneous, with grades +adding up to the grade of the product. -/ +theorem exists_of_eq_of_mul_eq_of [CharZero K] {n : NatOrdinal} + {Y : (degreeValuation K).Component n} (hY : Y ≠ 0) {A C : DegreeGraded K} + (hAC : A * C = DirectSum.of (degreeValuation K).Component n Y) : + ∃ (a c : NatOrdinal) (A₀ : (degreeValuation K).Component a) + (C₀ : (degreeValuation K).Component c), A₀ ≠ 0 ∧ C₀ ≠ 0 ∧ a + c = n ∧ + A = DirectSum.of (degreeValuation K).Component a A₀ ∧ + C = DirectSum.of (degreeValuation K).Component c C₀ := by + have hne : DirectSum.of (degreeValuation K).Component n Y ≠ 0 := fun h ↦ + hY (DirectSum.of_injective n (by rw [h, map_zero])) + have hA : A ≠ 0 := fun h ↦ hne (by rw [← hAC, h, zero_mul]) + have hC : C ≠ 0 := fun h ↦ hne (by rw [← hAC, h, mul_zero]) + have hhom : A * C ∈ (degreeValuation K).homogeneousClasses := by + rw [hAC, MaxAddDegree.mem_homogeneousClasses_iff] + exact Or.inr ⟨n, Y, rfl⟩ + obtain ⟨hAhom, hChom⟩ := (degreeValuation K).mem_homogeneousClasses_of_mul_mem hA hC hhom + rcases (MaxAddDegree.mem_homogeneousClasses_iff _ A).mp hAhom with rfl | ⟨a, A₀, rfl⟩ + · exact absurd rfl hA + rcases (MaxAddDegree.mem_homogeneousClasses_iff _ C).mp hChom with rfl | ⟨c, C₀, rfl⟩ + · exact absurd rfl hC + have hA₀ : A₀ ≠ 0 := fun h ↦ hA (by rw [h, map_zero]) + have hC₀ : C₀ ≠ 0 := fun h ↦ hC (by rw [h, map_zero]) + refine ⟨a, c, A₀, C₀, hA₀, hC₀, ?_, rfl, rfl⟩ + by_contra hne' + have hcomp := congrArg (fun w : DegreeGraded K ↦ w (a + c)) hAC + simp only [DirectSum.of_mul_of, DirectSum.of_eq_of_ne _ _ _ hne', DirectSum.of_eq_same] at hcomp + exact MaxAddDegree.componentMul_ne_zero (degreeValuation K) A₀ C₀ hA₀ hC₀ hcomp + +/-- The units of `RV̂` are the nonzero scalars: a unit is homogeneous of grade zero, hence a +finite-support series, and the units of `K(ℝ^{≤0})` are `K^×`. -/ +theorem exists_algebraMap_eq_of_isUnit [CharZero K] {A : DegreeGraded K} (hA : IsUnit A) : + ∃ k : K, k ≠ 0 ∧ A = algebraMap K (DegreeGraded K) k := by + obtain ⟨A', hAA'⟩ := hA.exists_right_inv + have hone : A * A' = DirectSum.of (degreeValuation K).Component 0 + (degreeValuation K).componentOne := by + rw [hAA'] + exact DirectSum.one_def _ + have hone_ne : (degreeValuation K).componentOne ≠ 0 := by + rw [MaxAddDegree.componentOne_eq_componentMk, Ne, MaxAddDegree.componentMk_eq_zero_iff, + (degreeValuation K).map_one_eq_zero_of_isSeparated (degreeValuation_isSeparated K)] + exact lt_irrefl _ + obtain ⟨a, c, A₀, C₀, -, -, hac, rfl, rfl⟩ := exists_of_eq_of_mul_eq_of hone_ne hone + obtain ⟨ha, hc⟩ := NatOrdinal.add_eq_zero_iff.mp hac + subst ha hc + obtain ⟨p, hp⟩ := exists_finiteSupportGradedEmbedding_eq_of A₀ + obtain ⟨q, hq⟩ := exists_finiteSupportGradedEmbedding_eq_of C₀ + rw [← hp, ← hq, ← map_mul, ← map_one (finiteSupportGradedEmbedding K)] at hAA' + have hpq : p * q = 1 := finiteSupportGradedEmbedding_injective K hAA' + obtain ⟨k, hk, hpk⟩ := (isUnit_finiteSupport_iff_exists_scalar p).mp + (isUnit_iff_exists_inv.mpr ⟨q, hpq⟩) + refine ⟨k, hk, ?_⟩ + rw [← hp, hpk, + show finiteSupportScalarHom (G := ℝ) k = + algebraMap K (Berarducci.FiniteSupportRing (K := K)) k from rfl] + exact (finiteSupportGradedEmbedding K).commutes k + +/-! ### The coordinate functional -/ + +/-- A linearly independent family in a vector space admits, for each index `m`, a linear +functional equal to `1` at the `m`-th vector and `0` at the others. -/ +theorem _root_.LinearIndependent.exists_dual_apply_eq {V : Type*} [AddCommGroup V] [Module K V] + {ι : Type*} [DecidableEq ι] {v : ι → V} (hv : LinearIndependent K v) (m : ι) : + ∃ φ : V →ₗ[K] K, ∀ i, φ (v i) = if i = m then 1 else 0 := by + obtain ⟨φ, hφ⟩ := LinearMap.exists_extend ((Finsupp.lapply m) ∘ₗ hv.repr) + refine ⟨φ, fun i ↦ ?_⟩ + have h := congrArg (fun f : Submodule.span K (Set.range v) →ₗ[K] K ↦ + f ⟨v i, Submodule.subset_span (Set.mem_range_self i)⟩) hφ + simp only [LinearMap.comp_apply, Submodule.subtype_apply] at h + rw [h, hv.repr_eq_single i ⟨v i, Submodule.subset_span (Set.mem_range_self i)⟩ rfl, + Finsupp.lapply_apply, Finsupp.single_apply] + +variable (K) in +/-- The `K(ℝ^{≤0})`-coordinate of `RV̂ ≅ P̂ ⊗ K(ℝ^{≤0})` along a linear functional +`φ : P̂ → K`: the composite `RV̂ ≃ P̂ ⊗ K(ℝ^{≤0}) → K ⊗ K(ℝ^{≤0}) ≃ K(ℝ^{≤0})`. -/ +def coordinate [CharZero K] (φ : PrincipalSubring K →ₗ[K] K) : + DegreeGraded K →ₗ[K] Berarducci.FiniteSupportRing (K := K) := + (TensorProduct.lid K (Berarducci.FiniteSupportRing (K := K))).toLinearMap ∘ₗ + TensorProduct.map φ LinearMap.id ∘ₗ (principalSubringTensorEquiv K).symm.toLinearMap + +theorem coordinate_tmul [CharZero K] (φ : PrincipalSubring K →ₗ[K] K) (x : PrincipalSubring K) + (p : Berarducci.FiniteSupportRing (K := K)) : + coordinate K φ + (principalSubringEmbedding K x * finiteSupportGradedEmbedding K p) = + φ x • p := by + rw [coordinate, LinearMap.comp_apply, LinearMap.comp_apply, AlgEquiv.toLinearMap_apply, + ← principalSubringTensorEquiv_tmul, AlgEquiv.symm_apply_apply, TensorProduct.map_tmul, + LinearMap.id_apply, LinearEquiv.coe_toLinearMap, TensorProduct.lid_tmul] + +/-- The coordinate functional is `K(ℝ^{≤0})`-linear for the grade-zero action. -/ +theorem coordinate_finiteSupportGradedEmbedding_mul [CharZero K] (φ : PrincipalSubring K →ₗ[K] K) + (p : Berarducci.FiniteSupportRing (K := K)) (z : DegreeGraded K) : + coordinate K φ (finiteSupportGradedEmbedding K p * z) = p * coordinate K φ z := by + obtain ⟨t, rfl⟩ := (principalSubringTensorEquiv K).surjective z + rw [← principalSubringTensorEquiv_one_tmul, ← map_mul] + induction t using TensorProduct.inductionOn with + | tmul x q => + rw [Algebra.TensorProduct.tmul_mul_tmul, one_mul, principalSubringTensorEquiv_tmul, + principalSubringTensorEquiv_tmul, coordinate_tmul, coordinate_tmul, mul_smul_comm] + | add t₁ t₂ h₁ h₂ => + simp only [mul_add, map_add, h₁, h₂] + +/-! ### The graded projection on finite-support series -/ + +/-- The graded projection `RV̂ → P̂` sends the image of a finite-support series `p` to the class +of `p` in grade zero of `P̂`, which is its constant coefficient. -/ +theorem rvProjection_finiteSupportGradedEmbedding + (p : Berarducci.FiniteSupportRing (K := K)) : + rvProjection K (finiteSupportGradedEmbedding K p) = gradeClass 0 (p : Series K) := by + have hcut : ordinalValue (p : Series K) < ω^ ((0 : NatOrdinal) + 1) := by + rw [← ordinalValueDegree_le_coe_iff] + refine (ordinalValueDegree_le_degree _).trans ?_ + rw [WithBot.coe_zero, HahnSeries.degree_le_zero_iff] + exact (mem_finiteSupportSubring_iff (p : Series K)).mp p.2 + rw [finiteSupportGradedEmbedding_eq_homogeneousMk, MaxAddDegree.homogeneousMk_apply, + rvProjection_of, degreeLayerToPrincipalComponent_componentMk, + gradeClass_eq_homogeneousMk hcut, MaxAddDegree.homogeneousMk_apply] + exact congrArg _ (congrArg _ (Subtype.ext (coe_finiteSupportFiltrationRepresentative p))) + +/-- The graded projection kills the image of a strictly negative monomial. -/ +theorem rvProjection_finiteSupportMonomial_of_neg + {g : exponentMonoid ℝ} (hg : (g : ℝ) < 0) : + rvProjection K (finiteSupportGradedEmbedding K (finiteSupportMonomial g)) = 0 := by + rw [rvProjection_finiteSupportGradedEmbedding] + apply gradeClass_eq_zero_of_lt + have heq : ((finiteSupportMonomial (K := K) g : Berarducci.FiniteSupportRing (K := K)) : + Series K) = single (g : ℝ) 1 g.2 := + Subtype.ext ((coe_finiteSupportMonomial g).trans (coe_single _ _ _).symm) + rw [heq, ordinalValue_of_mem_negativeMonomialIdeal (single_one_mem_negativeMonomialIdeal hg), + NatOrdinal.wpow_zero] + exact zero_lt_one + +/-- The graded projection sends the image of `t^0 = 1` to `1`. -/ +theorem rvProjection_finiteSupportMonomial_zero : + rvProjection K (finiteSupportGradedEmbedding K + (finiteSupportMonomial (K := K) (0 : exponentMonoid ℝ))) = 1 := by + have h1 : finiteSupportMonomial (K := K) (0 : exponentMonoid ℝ) = 1 := by + apply Subtype.ext + apply Subtype.ext + rw [coe_finiteSupportMonomial] + exact HahnSeries.single_zero_one + rw [h1, map_one, map_one] + +/-! ### Block forms -/ + +variable (K) in +/-- The block form `∑ᵢ rv_J(X_i) · t^{δ_i}` in `RV̂`, for classes `X_i ∈ P̂` and exponents +`δ_i ≤ 0`. -/ +def blockForm [CharZero K] {ι : Type*} [Fintype ι] (X : ι → PrincipalSubring K) + (δ : ι → exponentMonoid ℝ) : DegreeGraded K := + ∑ i, principalSubringEmbedding K (X i) * + finiteSupportGradedEmbedding K (finiteSupportMonomial (δ i)) + +theorem blockForm_def [CharZero K] {ι : Type*} [Fintype ι] (X : ι → PrincipalSubring K) + (δ : ι → exponentMonoid ℝ) : + blockForm K X δ = ∑ i, principalSubringEmbedding K (X i) * + finiteSupportGradedEmbedding K (finiteSupportMonomial (δ i)) := + (rfl) + +/-- The graded projection of a block form with a single exponent `δ_m = 0` is `X_m`. -/ +theorem rvProjection_blockForm [CharZero K] {ι : Type*} [Fintype ι] + (X : ι → PrincipalSubring K) (δ : ι → exponentMonoid ℝ) (m : ι) (hm : δ m = 0) + (hδ : ∀ i, δ i = 0 → i = m) : + rvProjection K (blockForm K X δ) = X m := by + classical + rw [blockForm_def, map_sum] + rw [Finset.sum_eq_single m] + · rw [map_mul, rvProjection_principalGradedEmbedding, hm, + rvProjection_finiteSupportMonomial_zero, mul_one] + · intro i _ hi + have hneg : ((δ i : exponentMonoid ℝ) : ℝ) < 0 := by + rcases lt_or_eq_of_le (show ((δ i : exponentMonoid ℝ) : ℝ) ≤ 0 from (δ i).2) with h | h + · exact h + · exact absurd (hδ i (Subtype.ext h)) hi + rw [map_mul, rvProjection_finiteSupportMonomial_of_neg hneg, mul_zero] + · intro h + exact absurd (Finset.mem_univ m) h + +/-- The block form is homogeneous of grade `n` when its classes lie in `P_n`. -/ +theorem blockForm_eq_of [CharZero K] {n : NatOrdinal} {ι : Type*} [Fintype ι] + (x : ι → PrincipalComponent K n) (δ : ι → exponentMonoid ℝ) : + blockForm K (fun i ↦ DirectSum.of (PrincipalComponent K) n (x i)) δ = + DirectSum.of (degreeValuation K).Component n + (∑ i, degreeFiniteSupportResidueEquiv K (finiteSupportMonomial (δ i)) • + principalComponentToHahnDegreeLayer K n (x i)) := by + rw [blockForm_def, map_sum] + refine Finset.sum_congr rfl fun i _ ↦ ?_ + rw [mul_comm, principalSubringEmbedding_of, finiteSupportGradedEmbedding_mul_of] + +/-- The coordinate of a block form along a functional with `φ(X_i) = δ_{im}` is `t^{δ_m}`. -/ +theorem coordinate_blockForm [CharZero K] {ι : Type*} [Fintype ι] [DecidableEq ι] + (X : ι → PrincipalSubring K) (δ : ι → exponentMonoid ℝ) (m : ι) (φ : PrincipalSubring K →ₗ[K] K) + (hφ : ∀ i, φ (X i) = if i = m then 1 else 0) : + coordinate K φ (blockForm K X δ) = finiteSupportMonomial (δ m) := by + classical + rw [blockForm_def, map_sum] + rw [Finset.sum_eq_single m] + · rw [coordinate_tmul, hφ, ite_eq_left rfl, one_smul] + · intro i _ hi + rw [coordinate_tmul, hφ, ite_eq_right hi, zero_smul] + · intro h + exact absurd (Finset.mem_univ m) h + +/-- FLLM24, proof of Proposition 3.2: a block form `∑ᵢ X_i t^{δ_i}` in `RV̂` with `X_i ∈ P_n` +linearly independent, `δ_m = 0` the only zero exponent and `X_m` irreducible in `P̂` is +irreducible in `RV̂`. -/ +theorem irreducible_blockForm [CharZero K] {n : NatOrdinal} {ι : Type*} [Fintype ι] + (x : ι → PrincipalComponent K n) + (hli : LinearIndependent K (fun i ↦ DirectSum.of (PrincipalComponent K) n (x i))) + (δ : ι → exponentMonoid ℝ) (m : ι) (hm : δ m = 0) (hδ : ∀ i, δ i = 0 → i = m) + (hirr : Irreducible (DirectSum.of (PrincipalComponent K) n (x m))) : + Irreducible (blockForm K (fun i ↦ DirectSum.of (PrincipalComponent K) n (x i)) δ) := by + classical + set B := blockForm K (fun i ↦ DirectSum.of (PrincipalComponent K) n (x i)) δ with hB + have hproj : rvProjection K B = DirectSum.of (PrincipalComponent K) n (x m) := + rvProjection_blockForm _ δ m hm hδ + obtain ⟨φ, hφ⟩ := hli.exists_dual_apply_eq m + -- A factor whose projection is a unit is itself a unit. + have key : ∀ A C : DegreeGraded K, B = A * C → IsUnit (rvProjection K A) → + IsUnit A := by + intro A C hAC hunit + have hY : (∑ i, degreeFiniteSupportResidueEquiv K (finiteSupportMonomial (δ i)) • + principalComponentToHahnDegreeLayer K n (x i)) ≠ 0 := by + intro hzero + have hBzero : B = 0 := by rw [hB, blockForm_eq_of, hzero, map_zero] + rw [hBzero, map_zero] at hproj + exact hirr.ne_zero hproj.symm + have hAC' : A * C = DirectSum.of (degreeValuation K).Component n + (∑ i, degreeFiniteSupportResidueEquiv K (finiteSupportMonomial (δ i)) • + principalComponentToHahnDegreeLayer K n (x i)) := by + rw [← hAC, hB, blockForm_eq_of] + obtain ⟨a, c, A₀, C₀, hA₀, -, -, rfl, rfl⟩ := exists_of_eq_of_mul_eq_of hY hAC' + -- The unit projection forces grade zero. + have ha : a = 0 := by + by_contra ha + rw [rvProjection_of] at hunit + exact not_isUnit_of_grade_ne_zero ha _ hunit + subst ha + obtain ⟨p, hp⟩ := exists_finiteSupportGradedEmbedding_eq_of A₀ + rw [← hp] at hAC ⊢ + -- The coordinate along `φ` shows that `p` divides `1`. + have hcoord := congrArg (coordinate K φ) hAC + rw [coordinate_blockForm _ δ m φ hφ, coordinate_finiteSupportGradedEmbedding_mul, hm] at hcoord + have hone : finiteSupportMonomial (K := K) (0 : exponentMonoid ℝ) = 1 := by + apply Subtype.ext + apply Subtype.ext + rw [coe_finiteSupportMonomial] + exact HahnSeries.single_zero_one + rw [hone] at hcoord + have hunit : IsUnit p := + ⟨Units.mkOfMulEqOne p _ hcoord.symm, Units.val_mkOfMulEqOne hcoord.symm⟩ + exact hunit.map (finiteSupportGradedEmbedding K) + refine ⟨fun hunit ↦ hirr.not_isUnit (hproj ▸ hunit.map (rvProjection K)), + fun A C hAC ↦ ?_⟩ + have hprod : rvProjection K A * rvProjection K C = + DirectSum.of (PrincipalComponent K) n (x m) := by + rw [← map_mul, ← hAC, hproj] + rcases hirr.isUnit_or_isUnit hprod.symm with hA | hC + · exact Or.inl (key A C hAC hA) + · exact Or.inr (key C A (by rw [hAC, mul_comm]) hC) + +/-- FLLM24, proof of Proposition 3.2, the monomial step: if `A · C = t^γ · B` with `B` an +irreducible block form, then one of `A`, `C` is the image of a monomial `k t^x` of +`K(ℝ^{≤0})`. Finite-support series are primal in `RV̂` (LM24, Corollary 6.3.6), so `t^γ` +splits as `p₁ p₂` with `p₁ ∣ A` and `p₂ ∣ C`; the `p_i` are monomials, and cancelling them +leaves a factorisation of `B`. -/ +theorem exists_isMonomial_factor_of_mul_eq [CharZero K] {n : NatOrdinal} + {ι : Type*} [Fintype ι] (x : ι → PrincipalComponent K n) + (hli : LinearIndependent K (fun i ↦ DirectSum.of (PrincipalComponent K) n (x i))) + (δ : ι → exponentMonoid ℝ) (m : ι) (hm : δ m = 0) (hδ : ∀ i, δ i = 0 → i = m) + (hirr : Irreducible (DirectSum.of (PrincipalComponent K) n (x m))) + (γ : exponentMonoid ℝ) {A C : DegreeGraded K} + (hAC : A * C = finiteSupportGradedEmbedding K (finiteSupportMonomial γ) * + blockForm K (fun i ↦ DirectSum.of (PrincipalComponent K) n (x i)) δ) : + ∃ p : Berarducci.FiniteSupportRing (K := K), IsMonomial (p : Series K) ∧ + (A = finiteSupportGradedEmbedding K p ∨ C = finiteSupportGradedEmbedding K p) := by + set B := blockForm K (fun i ↦ DirectSum.of (PrincipalComponent K) n (x i)) δ with hB + have hBirr : Irreducible B := irreducible_blockForm x hli δ m hm hδ hirr + have hdvd : finiteSupportGradedEmbedding K (finiteSupportMonomial γ) ∣ A * C := + ⟨B, hAC⟩ + obtain ⟨a₁, a₂, ⟨A', hA'⟩, ⟨C', hC'⟩, hsplit⟩ := + finiteSupportGradedEmbedding_isPrimal (finiteSupportMonomial γ) hdvd + -- The two factors of `t^γ` are monomials. + have hres_ne : degreeFiniteSupportResidueEquiv K (finiteSupportMonomial (K := K) γ) ≠ 0 := by + intro h + have h1 : finiteSupportMonomial (K := K) γ = 0 := + (degreeFiniteSupportResidueEquiv K).injective (by rw [h, map_zero]) + have h2 := congrArg + (fun q : Berarducci.FiniteSupportRing (K := K) ↦ ((q : Series K) : K⟦ℝ⟧).coeff γ) h1 + simp [coe_finiteSupportMonomial] at h2 + have hsplit' : a₁ * a₂ = DirectSum.of (degreeValuation K).Component 0 + (degreeFiniteSupportResidueEquiv K (finiteSupportMonomial γ)) := by + rw [← hsplit, finiteSupportGradedEmbedding_apply] + obtain ⟨a, c, A₀, C₀, -, -, hac, rfl, rfl⟩ := exists_of_eq_of_mul_eq_of hres_ne hsplit' + obtain ⟨ha, hc⟩ := NatOrdinal.add_eq_zero_iff.mp hac + subst ha hc + obtain ⟨p₁, hp₁⟩ := exists_finiteSupportGradedEmbedding_eq_of A₀ + obtain ⟨p₂, hp₂⟩ := exists_finiteSupportGradedEmbedding_eq_of C₀ + rw [← hp₁, ← hp₂, ← map_mul] at hsplit + have hp₁p₂ : p₁ * p₂ = finiteSupportMonomial γ := + finiteSupportGradedEmbedding_injective K hsplit.symm + have hγ0 : ((γ : exponentMonoid ℝ) : ℝ) ≤ 0 := γ.2 + have hp₁p₂' : (p₁ : Series K) * (p₂ : Series K) = single (γ : ℝ) (1 : K) hγ0 := by + have h1 := congrArg Subtype.val hp₁p₂ + rw [Subring.coe_mul] at h1 + rw [h1] + exact Subtype.ext ((coe_finiteSupportMonomial γ).trans (coe_single _ _ _).symm) + have hmono₁ : IsMonomial (p₁ : Series K) := isMonomial_of_mul_eq_single one_ne_zero hγ0 hp₁p₂' + have hmono₂ : IsMonomial (p₂ : Series K) := + isMonomial_of_mul_eq_single one_ne_zero hγ0 (by rw [mul_comm]; exact hp₁p₂') + -- Cancel `t^γ` to obtain a factorisation of `B`. + have hγne : finiteSupportGradedEmbedding K (finiteSupportMonomial (K := K) γ) ≠ 0 := by + rw [finiteSupportGradedEmbedding_apply] + intro h + exact hres_ne (DirectSum.of_injective 0 (by rw [h, map_zero])) + have hBeq : B = A' * C' := by + apply mul_left_cancel₀ hγne + rw [← hAC, hA', hC', ← hp₁, ← hp₂, hsplit, map_mul] + ring + rcases hBirr.isUnit_or_isUnit hBeq with hA'u | hC'u + · obtain ⟨k, hk, hk'⟩ := exists_algebraMap_eq_of_isUnit hA'u + refine ⟨p₁ * algebraMap K _ k, ?_, Or.inl ?_⟩ + · obtain ⟨g, l, hg, hl, hp₁eq⟩ := isMonomial_iff.mp hmono₁ + refine isMonomial_iff.mpr ⟨g, l * k, hg, mul_ne_zero hl hk, ?_⟩ + rw [Subring.coe_mul, + show ((algebraMap K (Berarducci.FiniteSupportRing (K := K)) k : + Berarducci.FiniteSupportRing (K := K)) : Series K) = HahnSeries.Nonpositive.C k from + congrArg Subtype.val (show algebraMap K (Berarducci.FiniteSupportRing (K := K)) k = + finiteSupportScalarHom k from rfl) |>.trans + (Subtype.ext ((coe_finiteSupportScalarHom k).trans + (HahnSeries.Nonpositive.coe_C k).symm)), + hp₁eq] + apply Subtype.ext + simp only [Subring.coe_mul, coe_single, HahnSeries.Nonpositive.coe_C, HahnSeries.C_apply, + HahnSeries.single_mul_single, add_zero] + · rw [hA', ← hp₁, hk', map_mul, (finiteSupportGradedEmbedding K).commutes] + · obtain ⟨k, hk, hk'⟩ := exists_algebraMap_eq_of_isUnit hC'u + refine ⟨p₂ * algebraMap K _ k, ?_, Or.inr ?_⟩ + · obtain ⟨g, l, hg, hl, hp₂eq⟩ := isMonomial_iff.mp hmono₂ + refine isMonomial_iff.mpr ⟨g, l * k, hg, mul_ne_zero hl hk, ?_⟩ + rw [Subring.coe_mul, + show ((algebraMap K (Berarducci.FiniteSupportRing (K := K)) k : + Berarducci.FiniteSupportRing (K := K)) : Series K) = HahnSeries.Nonpositive.C k from + congrArg Subtype.val (show algebraMap K (Berarducci.FiniteSupportRing (K := K)) k = + finiteSupportScalarHom k from rfl) |>.trans + (Subtype.ext ((coe_finiteSupportScalarHom k).trans + (HahnSeries.Nonpositive.coe_C k).symm)), + hp₂eq] + apply Subtype.ext + simp only [Subring.coe_mul, coe_single, HahnSeries.Nonpositive.coe_C, HahnSeries.C_apply, + HahnSeries.single_mul_single, add_zero] + · rw [hC', ← hp₂, hk', map_mul, (finiteSupportGradedEmbedding K).commutes] + +/-! ### Back to series -/ + +/-- A series whose initial form is the image of a nonzero finite-support series `p` is `p`. -/ +theorem eq_of_initialForm_eq_finiteSupportGradedEmbedding [CharZero K] {a : Series K} + {p : Berarducci.FiniteSupportRing (K := K)} (hp : p ≠ 0) + (h : (degreeValuation K).initialForm a = finiteSupportGradedEmbedding K p) : + a = (p : Series K) := by + have hp' : (p : Series K) ≠ 0 := fun h' ↦ hp (Subtype.ext h') + have hdeg0 : degreeValuation K (p : Series K) = 0 := degreeValuation_finiteSupport_eq_zero p hp + -- `a` has degree zero, because its initial form lives in grade zero. + have ha0 : degreeValuation K a = 0 := by + have hne : (degreeValuation K).initialForm a ≠ 0 := by + rw [h, finiteSupportGradedEmbedding_eq_initialForm] + exact (degreeValuation K).initialForm_ne_zero_of_ne_zero (degreeValuation_isSeparated K) hp' + have hbot : degreeValuation K a ≠ ⊥ := fun hbot ↦ hne + ((degreeValuation K).initialForm_eq_zero_of_eq_bot hbot) + obtain ⟨d, hd⟩ := WithBot.ne_bot_iff_exists.mp hbot + by_contra hd0 + have hcomp := congrArg (fun z : DegreeGraded K ↦ z d) h + rw [finiteSupportGradedEmbedding_eq_initialForm, MaxAddDegree.initialForm_apply, + MaxAddDegree.initialForm_apply, dite_eq_left hd.symm, dite_eq_right (by + rw [hdeg0] + intro h0 + exact hd0 (by rw [← hd, ← h0]))] at hcomp + exact ((degreeValuation K).componentMk_eq_zero_iff d _).not.mpr + (by rw [← hd]; exact lt_irrefl _) hcomp + -- Hence `a` has finite support and its image in `RV̂` is its initial form. + have hafin : a ∈ (finiteSupportSubring : Subring (Series K)) := by + rw [mem_finiteSupportSubring_iff] + rw [degreeValuation_apply] at ha0 + exact (HahnSeries.degree_eq_zero.mp ha0).2 + have ha : finiteSupportGradedEmbedding K ⟨a, hafin⟩ = finiteSupportGradedEmbedding K p := by + rw [finiteSupportGradedEmbedding_eq_initialForm] + exact h + exact congrArg Subtype.val (finiteSupportGradedEmbedding_injective K ha) + +end FLLM24 + +end diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Random/HereditaryIndependence.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Random/HereditaryIndependence.lean new file mode 100644 index 0000000000..1342c00654 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Random/HereditaryIndependence.lean @@ -0,0 +1,174 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalSubring +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Truncation +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.DegreeInitialForm + +import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.DegreeSum + +/-! +# Hereditary `rv_J`-independence at finite ordinal-value degrees + +Fornasiero, Lavi, L'Innocente and Mantova, *Irreducibility in generalized power series* (2024), +§ 3, define by recursion on `deg_J(b_1)` when series `b_1, …, b_n` of a common ordinal-value degree +are *hereditarily `rv_J`-independent*, written `Q(b_1, …, b_n)`: + +1. the classes `rv_J(b_1), …, rv_J(b_n)` are `K`-linearly independent; +2. when `deg_J(b_1) ≠ deg_J^p(b_1)`, there is `δ < 0` such that for every degree `α` with + `deg_J^r(b_1) ≤ α < deg_J(b_1)` and all exponents `γ_{i,j} ≥ δ`, distinct for fixed `i`, with + `deg_J(b_i^{|γ_{i,j}}) = α`, the family of translated truncations `b_i^{|γ_{i,j}}` is again + hereditarily `rv_J`-independent. + +This module records the definition for finite ordinal-value degrees `n < ω`, the case of the +finite-degree irreducibility theorem. For `deg_J(b) = n ≥ 1` one has `v_J(b) = ω^n = ω^(n-1) · ω`, +so `deg_J^p(b) = 1` and `deg_J^r(b) = n - 1`: the second clause applies exactly when `n ≥ 2`, and +the degrees `α` it ranges over reduce to the single value `n - 1`. The class `rv_J(b)` is the +initial form of `b` in `P̂ = ⊕ P_α` for the ordinal-value degree. + +Families are indexed by an arbitrary type in `Type`; the families of translated truncations in +the second clause are indexed by a finite type `κ` together with maps `j : κ → ι` and +`γ : κ → ℝ`, the requirement "`γ_{i,j} ≠ γ_{i,j'}` whenever `j ≠ j'`" being injectivity of +`k ↦ (j k, γ k)`. Translated truncations are taken at exponents `γ ≤ 0`, the domain of +Definition 2.4; at `γ = 0` the truncation is the series itself, whose degree excludes it from the +second clause. +-/ + +open scoped HahnSeries NatOrdinal + +universe v + +public noncomputable section + +namespace FLLM24 + +open Berarducci + +variable {K : Type v} [Field K] + +/-- The class `rv_J(b)` of FLLM24, Definition 2.15: the initial form of `b` in Berarducci's +ring `P̂` for the ordinal-value degree `deg_J`, which is zero exactly on `J`. -/ +def rvJ (b : Series K) : PrincipalSubring K := + (ordinalValueDegreeValuation K).initialForm b + +theorem rvJ_eq_initialForm (b : Series K) : + rvJ b = (ordinalValueDegreeValuation K).initialForm b := + (rfl) + +/-- At ordinal value `ω^α`, the class `rv_J(b)` is the homogeneous class of `b` in grade `α`. -/ +theorem rvJ_eq_homogeneousMk {b : Series K} {α : NatOrdinal} (hb : ordinalValue b = ω^ α) : + rvJ b = (ordinalValueDegreeValuation K).homogeneousMk α + ⟨b, (mem_ordinalValueDegreeValuation_filtrationLE_iff b α).mpr + (hb ▸ NatOrdinal.wpow_lt_wpow.mpr (Order.lt_add_one_iff.mpr le_rfl))⟩ := by + rw [rvJ_eq_initialForm] + symm + apply MaxAddDegree.homogeneousMk_eq_initialForm_of_degree_eq + rw [ordinalValueDegreeValuation_apply, ordinalValueDegree_eq_coe_iff] + exact hb + +/-- `rv_J(b)` vanishes exactly on `J`. -/ +theorem rvJ_eq_zero_iff (b : Series K) : + rvJ b = 0 ↔ b ∈ HahnSeries.Nonpositive.negativeMonomialIdeal K := by + rw [rvJ_eq_initialForm, MaxAddDegree.initialForm_eq_zero_iff, + ordinalValueDegreeValuation_eq_bot_iff] + +/-- FLLM24, § 3, at a finite ordinal-value degree `n`: the series `b i` have `v_J(b i) = ω^n`, +their classes `rv_J(b i)` are `K`-linearly independent, and, when `n ≥ 2`, there is `δ < 0` +such that every finite family of translated truncations `(b (j k))^{|γ k}` at distinct pairs +`(j k, γ k)` with `δ ≤ γ k ≤ 0` and `v_J((b (j k))^{|γ k}) = ω^(n-1)` is hereditarily +`rv_J`-independent at degree `n - 1`. -/ +def HereditarilyRVIndependent : ℕ → {ι : Type} → (ι → Series K) → Prop + | 0, _, b => + (∀ i, ordinalValue (b i) = ω^ ((0 : ℕ) : NatOrdinal)) ∧ + LinearIndependent K (fun i ↦ rvJ (b i)) + | n + 1, ι, b => + (∀ i, ordinalValue (b i) = ω^ ((n + 1 : ℕ) : NatOrdinal)) ∧ + LinearIndependent K (fun i ↦ rvJ (b i)) ∧ + (1 ≤ n → ∃ δ : ℝ, δ < 0 ∧ + ∀ (κ : Type) [Finite κ] (j : κ → ι) (γ : κ → ℝ), + Function.Injective (fun k ↦ (j k, γ k)) → + (∀ k, δ ≤ γ k) → (∀ k, γ k ≤ 0) → + (∀ k, ordinalValue (translatedTruncation (b (j k) : K⟦ℝ⟧) (γ k)) = + ω^ (n : NatOrdinal)) → + HereditarilyRVIndependent n + (fun k ↦ translatedTruncation (b (j k) : K⟦ℝ⟧) (γ k))) + +namespace HereditarilyRVIndependent + +variable {ι : Type} {b : ι → Series K} + +/-- Every member of a hereditarily `rv_J`-independent family at degree `n` has ordinal value +`ω^n`. -/ +theorem ordinalValue_eq {n : ℕ} (h : HereditarilyRVIndependent n b) (i : ι) : + ordinalValue (b i) = ω^ (n : NatOrdinal) := by + cases n with + | zero => exact h.1 i + | succ n => exact h.1 i + +/-- Axiom 1 of FLLM24, § 3: the classes `rv_J(b i)` are `K`-linearly independent. -/ +theorem linearIndependent {n : ℕ} (h : HereditarilyRVIndependent n b) : + LinearIndependent K (fun i ↦ rvJ (b i)) := by + cases n with + | zero => exact h.2 + | succ n => exact h.2.1 + +/-- Axiom 2 of FLLM24, § 3, at degree `n + 1 ≥ 2`: some threshold `δ < 0` makes every finite +family of translated truncations at distinct pairs above `δ` and of ordinal value `ω^n` +hereditarily `rv_J`-independent at degree `n`. -/ +theorem truncations {n : ℕ} (hn : 1 ≤ n) (h : HereditarilyRVIndependent (n + 1) b) : + ∃ δ : ℝ, δ < 0 ∧ + ∀ (κ : Type) [Finite κ] (j : κ → ι) (γ : κ → ℝ), + Function.Injective (fun k ↦ (j k, γ k)) → + (∀ k, δ ≤ γ k) → (∀ k, γ k ≤ 0) → + (∀ k, ordinalValue (translatedTruncation (b (j k) : K⟦ℝ⟧) (γ k)) = + ω^ (n : NatOrdinal)) → + HereditarilyRVIndependent n (fun k ↦ translatedTruncation (b (j k) : K⟦ℝ⟧) (γ k)) := + h.2.2 hn + +/-- The constructor for degree `n + 1`: the two axioms, the second required when `n ≥ 1`. -/ +theorem of_succ {n : ℕ} + (hvalue : ∀ i, ordinalValue (b i) = ω^ ((n + 1 : ℕ) : NatOrdinal)) + (hindep : LinearIndependent K (fun i ↦ rvJ (b i))) + (htrunc : 1 ≤ n → ∃ δ : ℝ, δ < 0 ∧ + ∀ (κ : Type) [Finite κ] (j : κ → ι) (γ : κ → ℝ), + Function.Injective (fun k ↦ (j k, γ k)) → + (∀ k, δ ≤ γ k) → (∀ k, γ k ≤ 0) → + (∀ k, ordinalValue (translatedTruncation (b (j k) : K⟦ℝ⟧) (γ k)) = + ω^ (n : NatOrdinal)) → + HereditarilyRVIndependent n (fun k ↦ translatedTruncation (b (j k) : K⟦ℝ⟧) (γ k))) : + HereditarilyRVIndependent (n + 1) b := + ⟨hvalue, hindep, htrunc⟩ + +/-- At degree one only Axiom 1 is required: `deg_J^p(b) = 1 = deg_J(b)`. -/ +theorem of_one (hvalue : ∀ i, ordinalValue (b i) = ω^ ((1 : ℕ) : NatOrdinal)) + (hindep : LinearIndependent K (fun i ↦ rvJ (b i))) : + HereditarilyRVIndependent 1 b := + ⟨hvalue, hindep, fun h ↦ absurd h (by decide)⟩ + +/-- Hereditary `rv_J`-independence passes to subfamilies. -/ +theorem comp_injective {n : ℕ} (h : HereditarilyRVIndependent n b) {ι' : Type} (f : ι' → ι) + (hf : Function.Injective f) : + HereditarilyRVIndependent n (b ∘ f) := by + induction n generalizing ι with + | zero => + exact ⟨fun i ↦ h.1 (f i), h.2.comp f hf⟩ + | succ n ih => + refine ⟨fun i ↦ h.1 (f i), h.2.1.comp f hf, fun hn ↦ ?_⟩ + obtain ⟨δ, hδ, hδfam⟩ := h.2.2 hn + refine ⟨δ, hδ, fun κ _ j γ hinj hδγ hγ hvalue ↦ ?_⟩ + have hinj' : Function.Injective (fun k ↦ (f (j k), γ k)) := by + intro k k' hkk' + have h1 : f (j k) = f (j k') := congrArg Prod.fst hkk' + have h2 : γ k = γ k' := congrArg Prod.snd hkk' + exact hinj (Prod.ext (hf h1) h2) + exact hδfam κ (fun k ↦ f (j k)) γ hinj' hδγ hγ hvalue + +end HereditarilyRVIndependent + +end FLLM24 + +end diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Random/IndependenceWindow.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Random/IndependenceWindow.lean new file mode 100644 index 0000000000..7add9d5043 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Random/IndependenceWindow.lean @@ -0,0 +1,154 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Random.ReducibleSpan +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.StableInterval + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.NonpositiveCoefficientMap +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValueImage +import Mathlib.Tactic.Linarith + +/-! +# The support of a vanishing relation among classes + +Fornasiero, Lavi, L'Innocente and Mantova, *Irreducibility in generalized power series* (2024), +Propositions 3.4 and 3.6, both start from a relation `∑ k_i rv_J(b_i) = 0`, that is +`r := ∑ k_i b_i ∈ J_{deg_J(b_1)}`, and compare the supports of the `b_i` with that of `r` near +zero: the support of each `b_i` in `(η, 0)` has order type `v_J(b_i)`, while that of `r` has +order type at most `v_J(r) < v_J(b_i)`, so each `b_i` has infinitely many support points in +`(η, 0)` outside the support of `r`. This module proves these two facts and the coefficient +formula for `r`; the two propositions then differ only in how they exploit such a point. +-/ + +open scoped HahnSeries NatOrdinal + +universe v + +public noncomputable section + +namespace FLLM24 + +open Berarducci HahnSeries.Nonpositive + +variable {K : Type v} [Field K] + +/-- A vanishing `K`-linear relation among the classes `rv_J(c k)` of series of a common ordinal +value `ω^d` puts the corresponding combination of the `c k` into `J_{ω^d}`. -/ +theorem ordinalValue_sum_C_mul_lt_of_sum_smul_rvJ_eq_zero {κ : Type*} [Fintype κ] + {c : κ → Series K} {d : NatOrdinal} (hc : ∀ k, ordinalValue (c k) = ω^ d) (g : κ → K) + (hrel : ∑ k, g k • rvJ (c k) = 0) : + ordinalValue (∑ k, (HahnSeries.Nonpositive.C : K →+* Series K) (g k) * c k) < ω^ d := by + have hcut : ∀ k ∈ (Finset.univ : Finset κ), ordinalValue (c k) < ω^ (d + 1) := fun k _ ↦ by + rw [hc k]; exact NatOrdinal.wpow_lt_wpow.mpr (lt_add_one d) + have hCcut : ∀ k ∈ (Finset.univ : Finset κ), + ordinalValue ((HahnSeries.Nonpositive.C : K →+* Series K) (g k) * c k) < ω^ (d + 1) := + fun k hk ↦ by + simpa only [zero_add] using + ordinalValue_mul_lt_wpow_add_one (ordinalValue_C_lt_wpow_one (g k)) (hcut k hk) + rw [← gradeClass_eq_zero_iff (ordinalValue_sum_lt_wpow_add_one _ _ hCcut), + gradeClass_sum _ _ hCcut, ← hrel] + exact Finset.sum_congr rfl fun k hk ↦ by + rw [gradeClass_C_mul (g k) (hcut k hk), rvJ_eq_gradeClass (hc k)] + +/-- The coefficient of a `K`-linear combination of series. -/ +theorem coeff_sum_C_mul {κ : Type*} [Fintype κ] (c : κ → Series K) (g : κ → K) (x : ℝ) : + (((∑ k, (HahnSeries.Nonpositive.C : K →+* Series K) (g k) * c k : Series K)) : + K⟦ℝ⟧).coeff x = ∑ k, g k * ((c k : Series K) : K⟦ℝ⟧).coeff x := by + rw [AddSubmonoidClass.coe_finsetSum, HahnSeries.coeff_sum] + refine Finset.sum_congr rfl fun k _ ↦ ?_ + rw [Subring.coe_mul, HahnSeries.Nonpositive.coe_C, HahnSeries.C_mul_eq_smul, + HahnSeries.coeff_smul, smul_eq_mul] + +/-- Near zero, the support of a series in `(η, 0)` has order type at most its ordinal value: +equality holds on a stable tail when `1 < v_J`, and the support is empty in `(η, 0)` when the +series lies in `J + K`. -/ +theorem exists_forall_orderType_negativeSupportTail_le (r : Series K) : + ∃ η₀ < (0 : ℝ), ∀ η, η₀ < η → η < 0 → + NatOrdinal.of ((r : K⟦ℝ⟧).isPWO_support.mono + (negativeSupportTail_subset_support r η)).orderType ≤ ordinalValue r := by + by_cases hone : 1 < ordinalValue r + · obtain ⟨η₀, hη₀, h⟩ := + exists_forall_later_negativeSupportTail_orderType_eq_ordinalValue r hone + refine ⟨η₀, hη₀, fun η hη₀η hη ↦ ?_⟩ + rw [h η hη₀η hη, NatOrdinal.of_val] + · have hnear : r ∈ nearConstantSubgroup K := not_not.mp (mt one_lt_ordinalValue_iff.mpr hone) + have hJ := mem_nearConstantSubgroup_iff_sub_C_constantCoeff_mem.mp hnear + set j := r - HahnSeries.Nonpositive.C (HahnSeries.Nonpositive.constantCoeff r) with hj + -- Every nonzero support point of `r` lies in the support of `j`, which is bounded below + -- zero. + have hsupp : (j : K⟦ℝ⟧).support = (r : K⟦ℝ⟧).support \ {0} := support_sub_C_constantCoeff r + obtain ⟨η₀, hη₀, hbound⟩ : ∃ η₀ < (0 : ℝ), ∀ x ∈ (j : K⟦ℝ⟧).support, x ≤ η₀ := by + rcases eq_or_ne j 0 with hj0 | hj0 + · exact ⟨-1, by norm_num, fun x hx ↦ by + rw [hj0] at hx + simp at hx⟩ + · have hlt := mem_negativeMonomialIdeal_iff_supportSup_lt_zero.mp hJ + rw [supportSup_of_ne hj0] at hlt + exact ⟨sSup (j : K⟦ℝ⟧).support, WithBot.coe_lt_coe.mp hlt, + fun x hx ↦ le_csSup (bddAbove_support j) hx⟩ + refine ⟨η₀, hη₀, fun η hη₀η hη ↦ ?_⟩ + have hempty : negativeSupportTail r η = ∅ := by + ext x + simp only [Set.mem_empty_iff_false, iff_false] + intro hx + obtain ⟨hxsupp, hηx, hx0⟩ := mem_negativeSupportTail_iff.mp hx + have hxj : x ∈ (j : K⟦ℝ⟧).support := by + rw [hsupp]; exact ⟨hxsupp, hx0.ne⟩ + exact absurd (hbound x hxj) (not_le.mpr (by linarith)) + rw [(Set.IsPWO.orderType_eq_zero _).mpr hempty] + simp + +/-- FLLM24, proofs of Propositions 3.4 and 3.6: if `v_J(c) = ω^d > 1` and `v_J(r) < ω^d`, then +on every interval `(η, 0)` close to zero the support of `c` has infinitely many points outside +the support of `r`. -/ +theorem exists_forall_infinite_support_diff {c r : Series K} {d : NatOrdinal} (hd : 0 < d) + (hc : ordinalValue c = ω^ d) (hr : ordinalValue r < ω^ d) : + ∃ η₀ < (0 : ℝ), ∀ η, η₀ < η → η < 0 → + (((c : K⟦ℝ⟧).support ∩ Set.Ioo η 0) \ (r : K⟦ℝ⟧).support).Infinite := by + have hone : 1 < ordinalValue c := by + rw [hc, ← NatOrdinal.wpow_zero] + exact NatOrdinal.wpow_lt_wpow.mpr hd + obtain ⟨η₁, hη₁, hstable⟩ := + exists_forall_later_negativeSupportTail_orderType_eq_ordinalValue c hone + obtain ⟨η₂, hη₂, hbound⟩ := exists_forall_orderType_negativeSupportTail_le r + refine ⟨max η₁ η₂, max_lt hη₁ hη₂, fun η hη₀η hη hfin ↦ ?_⟩ + have hη₁η : η₁ < η := (le_max_left _ _).trans_lt hη₀η + have hη₂η : η₂ < η := (le_max_right _ _).trans_lt hη₀η + -- The tail of `c` is covered by the tail of `r` and a finite set. + set E := ((c : K⟦ℝ⟧).support ∩ Set.Ioo η 0) \ (r : K⟦ℝ⟧).support with hE + have hcover : negativeSupportTail c η ⊆ negativeSupportTail r η ∪ E := by + intro x hx + obtain ⟨hxc, hηx, hx0⟩ := mem_negativeSupportTail_iff.mp hx + by_cases hxr : x ∈ (r : K⟦ℝ⟧).support + · exact Or.inl (mem_negativeSupportTail_iff.mpr ⟨hxr, hηx, hx0⟩) + · exact Or.inr ⟨⟨hxc, hηx, hx0⟩, hxr⟩ + have hcPWO := (c : K⟦ℝ⟧).isPWO_support.mono (negativeSupportTail_subset_support c η) + have hrPWO := (r : K⟦ℝ⟧).isPWO_support.mono (negativeSupportTail_subset_support r η) + have hEPWO : E.IsPWO := hfin.isPWO + have hle := Set.IsPWO.orderType_mono hcPWO (hrPWO.union hEPWO) hcover + have hunion := Set.IsPWO.orderType_union_le_naturalAdd hrPWO hEPWO + have hEfin : NatOrdinal.of hEPWO.orderType < ω^ d := by + have h1 : hEPWO.orderType < Ordinal.omega0 := (hEPWO.finite_iff_orderType_lt_omega).mp hfin + have h2 : NatOrdinal.of hEPWO.orderType < ω^ (1 : NatOrdinal) := by + rw [NatOrdinal.wpow_def, NatOrdinal.of.lt_iff_lt] + simpa using h1 + exact h2.trans_le (NatOrdinal.wpow_le_wpow.mpr (Order.one_le_iff_pos.mpr hd)) + have hrlt : NatOrdinal.of hrPWO.orderType < ω^ d := (hbound η hη₂η hη).trans_lt hr + have hsum : NatOrdinal.of hrPWO.orderType + NatOrdinal.of hEPWO.orderType < ω^ d := + NatOrdinal.add_lt_wpow hrlt hEfin + have hcval : NatOrdinal.of hcPWO.orderType = ω^ d := by + rw [hstable η hη₁η hη, NatOrdinal.of_val, hc] + have : NatOrdinal.of hcPWO.orderType ≤ NatOrdinal.of hrPWO.orderType + + NatOrdinal.of hEPWO.orderType := by + rw [← NatOrdinal.val.le_iff_le, NatOrdinal.val_of] + exact hle.trans hunion + rw [hcval] at this + exact absurd this (not_le.mpr hsum) + +end FLLM24 + +end diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Random/MainTheorem.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Random/MainTheorem.lean new file mode 100644 index 0000000000..50d8652979 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Random/MainTheorem.lean @@ -0,0 +1,99 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Random.RandomBlocks + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.PrincipalAddition +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalComponentDegree + +/-! +# Irreducibility of random series of finite degree + +Fornasiero, Lavi, L'Innocente and Mantova, *Irreducibility in generalized power series* (2024), +Theorem 1.8 for `α = n < ω`, and Corollary 1.5. + +Theorem 1.8: let `b ∈ K((ℝ^{≤0}))` with `sup(b) = 0` and `ot(b) = m ω^n + β`, `m ≥ 1`, +`β < ω^n`. If `b` is random, then `b` is irreducible, and so is `b + r` for every `r` with +`ot(r) < ω^n` and `sup(b + r) = 0`. The proof is the one of the source, Corollary 4.13 for +`α = n`: the normal form of `b` gives `b = ∑ᵢ bᵢ t^{γᵢ} + r'` with `b₁, …, bₘ ∈ P_n` and +`deg(r') < n`; randomness of `b` makes the blocks mutually random, hence hereditarily +`rv_J`-independent; and Proposition 3.2 applies to `b + r = ∑ᵢ bᵢ t^{γᵢ} + (r' + r)`. + +Corollary 1.5: a random principal series of degree `n ≥ 1` is irreducible, the case `m = 1`, +`β = 0`, `r = 0`. The source states Corollary 1.5 for every `n ∈ ℕ`; at `n = 0` a principal +series is a nonzero constant, a unit, and the statement is false as printed, so the corollary is +stated here for `n ≥ 1`. +-/ + +open scoped HahnSeries NatOrdinal + +universe v + +public noncomputable section + +namespace FLLM24 + +open Berarducci HahnSeries HahnSeries.Nonpositive + +variable {K : Type v} [Field K] [CharZero K] + +/-- FLLM24, Theorem 1.8 for `α = n ≥ 1`, the perturbed form: if `b` is random with +`ot(b) = ω^n · m + β`, `m ≥ 1`, `β < ω^n`, then `b + r` is irreducible for every `r` with +`ot(r) < ω^n` and `sup(b + r) = 0`. -/ +theorem irreducible_add_of_isRandom {n m : ℕ} (hn : 1 ≤ n) (hm : 1 ≤ m) {β : Ordinal} + (hβ : β < Ordinal.omega0 ^ (n : Ordinal)) {b : Series K} (hb : IsRandom b) + (hot : (b : K⟦ℝ⟧).supportOrderType = Ordinal.omega0 ^ (n : Ordinal) * m + β) + {r : Series K} (hr : (r : K⟦ℝ⟧).supportOrderType < Ordinal.omega0 ^ (n : Ordinal)) + (hsup : supportSup (b + r) = 0) : + Irreducible (b + r) := by + obtain ⟨d⟩ := exists_blockDecomposition hn hβ hot + have hQ : HereditarilyRVIndependent n d.block := d.hereditarilyRVIndependent_block hn hb + have : Nonempty (Fin m) := ⟨⟨0, hm⟩⟩ + obtain ⟨i₀, hi₀⟩ := Finite.exists_max d.exponent + have hr' : ((d.rest + r : Series K) : K⟦ℝ⟧).degree < + ((n : NatOrdinal) : WithBot NatOrdinal) := by + have hrdeg : (r : K⟦ℝ⟧).degree < ((n : NatOrdinal) : WithBot NatOrdinal) := by + rw [degree_lt_coe_iff_supportOrderType_lt_wpow, NatOrdinal.val_wpow, NatOrdinal.val_natCast] + exact hr + rw [Subring.coe_add] + exact (HahnSeries.degree_add_le _ _).trans_lt (max_lt d.rest_degree hrdeg) + have heq : b + r = blockSum d.block d.exponent d.exponent_nonpos (d.rest + r) := by + rw [blockSum_def, ← add_assoc, ← blockSum_def, ← d.eq_blockSum] + rw [heq] at hsup ⊢ + exact irreducible_blockSum hn d.block_isPrincipal hQ d.exponent_nonpos + d.exponent_strictMono.injective i₀ hi₀ hr' hsup + +/-- FLLM24, Theorem 1.8 for `α = n ≥ 1`: a random series `b` with `sup(b) = 0` and +`ot(b) = ω^n · m + β`, `m ≥ 1`, `β < ω^n`, is irreducible. -/ +theorem irreducible_of_isRandom {n m : ℕ} (hn : 1 ≤ n) (hm : 1 ≤ m) {β : Ordinal} + (hβ : β < Ordinal.omega0 ^ (n : Ordinal)) {b : Series K} (hb : IsRandom b) + (hsup : supportSup b = 0) + (hot : (b : K⟦ℝ⟧).supportOrderType = Ordinal.omega0 ^ (n : Ordinal) * m + β) : + Irreducible b := by + have h := irreducible_add_of_isRandom hn hm hβ hb hot (r := 0) + (by + rw [ZeroMemClass.coe_zero, supportOrderType_zero] + exact Ordinal.opow_pos _ Ordinal.omega0_pos) + (by rw [add_zero]; exact hsup) + rwa [add_zero] at h + +/-- FLLM24, Corollary 1.5 for `n ≥ 1`: a random principal series of degree `n` is +irreducible. -/ +theorem irreducible_of_isRandom_of_isPrincipal {n : ℕ} (hn : 1 ≤ n) {b : Series K} + (hb : IsRandom b) (hp : IsPrincipal b) + (hdeg : (b : K⟦ℝ⟧).degree = ((n : NatOrdinal) : WithBot NatOrdinal)) : + Irreducible b := by + have hot : (b : K⟦ℝ⟧).supportOrderType = Ordinal.omega0 ^ (n : Ordinal) * (1 : ℕ) + 0 := by + rw [Nat.cast_one, mul_one, add_zero] + have h := hp.supportOrderType_eq_wpow_of_degree_eq hdeg + rw [h, NatOrdinal.val_wpow, NatOrdinal.val_natCast] + exact irreducible_of_isRandom hn le_rfl (Ordinal.opow_pos _ Ordinal.omega0_pos) hb + hp.supportSup_eq_zero hot + +end FLLM24 + +end diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Random/NonPrincipalIrreducible.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Random/NonPrincipalIrreducible.lean new file mode 100644 index 0000000000..3e85c4b6a3 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Random/NonPrincipalIrreducible.lean @@ -0,0 +1,266 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Random.ClassIrreducible +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Random.GradedIrreducible +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.NormalForm + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalComponentDegree +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalComponentTensor +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Degree.Statements.Degree +import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.DegreeSum +import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.DegreeInitialForm + +/-! +# Irreducibility of non-principal series of finite degree + +Fornasiero, Lavi, L'Innocente and Mantova, *Irreducibility in generalized power series* (2024), +Proposition 3.2, for `α = n < ω`: let `b = ∑ᵢ bᵢ t^{γᵢ} + r` with `b₁, …, bₘ ∈ P_n`, +`γ₁ < ⋯ < γₘ ≤ 0`, `deg(r) < n`, `sup(b) = 0`, and `Q(b₁, …, bₘ)`. Then `b` is irreducible. + +The source reduces to LM24, Lemma 7.1.1 (`b` is irreducible when `rv(b)/p(rv(b))` is +irreducible and `p(b) = 1`) and Lemma 3.1 (`p(b) = 1`). The proof here keeps its shape but does +not pass through the maximal finite-support divisor: the initial form of `b` in the +degree-graded ring `RV̂` is `t^{γₘ} · B` for the block form `B = ∑ᵢ rv_J(bᵢ) t^{γᵢ - γₘ}`, which +is irreducible by `ConwayRefinement.HahnSeries.Factorization.Random.GradedIrreducible` because +`rv_J(bₘ)` is irreducible in `P̂` (Corollary 4.5, from `Q(bₘ)`); a factorisation `b = a c` +gives `in(a) in(c) = t^{γₘ} B`, so +one factor, say `a`, has initial form a monomial `k t^x`, hence `a = k t^x`; and `x < 0` is +impossible because `sup(b) = 0`, while `x = 0` makes `a` a unit. The hypothesis `sup(b) = 0` is +exactly what the source uses to pass from `p(b) ∣ t^{γₘ}` to `p(b) = 1`. + +The source's "`a ∈ J + K` without loss of generality" is the step `deg_J(a) = 0` obtained from +the irreducibility of `rv(bₘ)`; the step "`deg_J(aᵢ) = 0` for every `i`, hence `a ∈ K(ℝ^{≤0})`" +is the coordinate-functional argument of the graded module. +-/ + +open scoped DirectSum HahnSeries NatOrdinal + +universe v + +public noncomputable section + +namespace FLLM24 + +open Berarducci HahnSeries.Nonpositive + +variable {K : Type v} [Field K] + +/-- The series `∑ᵢ bᵢ t^{γᵢ} + r` of FLLM24, Proposition 3.2. -/ +def blockSum {ι : Type*} [Fintype ι] (b : ι → Series K) (γ : ι → ℝ) (hγ : ∀ i, γ i ≤ 0) + (r : Series K) : Series K := + ∑ i, b i * single (γ i) (1 : K) (hγ i) + r + +theorem blockSum_def {ι : Type*} [Fintype ι] (b : ι → Series K) (γ : ι → ℝ) (hγ : ∀ i, γ i ≤ 0) + (r : Series K) : + blockSum b γ hγ r = ∑ i, b i * single (γ i) (1 : K) (hγ i) + r := + (rfl) + +/-- The monomial `t^γ` as a finite-support series, for `γ ≤ 0`. -/ +private theorem coe_monomial (γ : ℝ) (hγ : γ ≤ 0) : + ((finiteSupportMonomial (K := K) (⟨γ, hγ⟩ : exponentMonoid ℝ) : + Berarducci.FiniteSupportRing (K := K)) : Series K) = single γ (1 : K) hγ := + Subtype.ext ((coe_finiteSupportMonomial _).trans (coe_single _ _ _).symm) + +variable [CharZero K] + +omit [CharZero K] in +/-- The image of a finite-support series in `RV̂` is its class in grade zero, for any proof of +membership in the weak filtration at zero. -/ +private theorem finiteSupportGradedEmbedding_eq_homogeneousMk' + (p : Berarducci.FiniteSupportRing (K := K)) + (h : (p : Series K) ∈ (degreeValuation K).filtrationLE 0) : + finiteSupportGradedEmbedding K p = (degreeValuation K).homogeneousMk 0 ⟨(p : Series K), h⟩ := by + rw [finiteSupportGradedEmbedding_eq_homogeneousMk] + exact congrArg _ (Subtype.ext (coe_finiteSupportFiltrationRepresentative p)) + +/-- The image of a principal series `p` of degree `n` in `RV̂` through `P̂`: its degree-initial +form is the image of its class `rv_J(p)`. -/ +private theorem principalSubringEmbedding_rvJ_of_isPrincipal {n : NatOrdinal} {p : Series K} + (hp : IsPrincipal p) (hpDegree : (p : K⟦ℝ⟧).degree = (n : WithBot NatOrdinal)) : + principalSubringEmbedding K (rvJ p) = (degreeValuation K).initialForm p := by + have hval : ordinalValue p = ω^ n := ordinalValue_eq_wpow_of_isPrincipal hp hpDegree + have hcut : ordinalValue p < ω^ (n + 1) := by + rw [hval]; exact NatOrdinal.wpow_lt_wpow.mpr (lt_add_one n) + rw [rvJ_eq_gradeClass hval, gradeClass_of_lt hcut, principalSubringEmbedding_of, + principalComponentToHahnDegreeLayer_mk n p hp hpDegree hcut, degreeLayerMk_eq_componentMk, + ← MaxAddDegree.homogeneousMk_apply] + apply MaxAddDegree.homogeneousMk_eq_initialForm_of_degree_eq + rw [degreeValuation_apply, hpDegree] + +/-- FLLM24, Proposition 3.2, for `α = n ≥ 1`: if `b₁, …, bₘ ∈ P_n` are hereditarily +`rv_J`-independent, `γ₁, …, γₘ ≤ 0` are distinct with maximum `γₘ`, `deg(r) < n`, and +`b = ∑ᵢ bᵢ t^{γᵢ} + r` has `sup(b) = 0`, then `b` is irreducible in `K((ℝ^{≤0}))`. -/ +theorem irreducible_blockSum {n : ℕ} (hn : 1 ≤ n) {ι : Type} [Fintype ι] + {b : ι → Series K} (hb : ∀ i, IsPrincipal (b i)) (hQ : HereditarilyRVIndependent n b) + {γ : ι → ℝ} (hγ : ∀ i, γ i ≤ 0) (hinj : Function.Injective γ) (m : ι) + (hm : ∀ i, γ i ≤ γ m) {r : Series K} (hr : (r : K⟦ℝ⟧).degree < ((n : NatOrdinal) : WithBot + NatOrdinal)) (hsup : supportSup (blockSum b γ hγ r) = 0) : + Irreducible (blockSum b γ hγ r) := by + classical + set B := blockSum b γ hγ r with hBdef + have hval : ∀ i, ordinalValue (b i) = ω^ (n : NatOrdinal) := hQ.ordinalValue_eq + have hdeg : ∀ i, ((b i : Series K) : K⟦ℝ⟧).degree = ((n : NatOrdinal) : WithBot NatOrdinal) := + fun i ↦ by + rw [← ordinalValueDegree_eq_degree_of_isPrincipal (hb i), ordinalValueDegree_eq_coe_iff] + exact hval i + have hcut : ∀ i, ordinalValue (b i) < ω^ ((n : NatOrdinal) + 1) := fun i ↦ by + rw [hval i]; exact NatOrdinal.wpow_lt_wpow.mpr (lt_add_one _) + -- The classes and the exponents of the block form. + let x : ι → PrincipalComponent K (n : NatOrdinal) := + fun i ↦ principalComponentMk _ (b i) (hcut i) + have hx : ∀ i, + rvJ (b i) = DirectSum.of (PrincipalComponent K) (n : NatOrdinal) (x i) := fun i ↦ by + rw [rvJ_eq_gradeClass (hval i), gradeClass_of_lt (hcut i)] + have hli : LinearIndependent K + (fun i ↦ DirectSum.of (PrincipalComponent K) (n : NatOrdinal) (x i)) := by + simpa only [hx] using hQ.linearIndependent + let δ : ι → exponentMonoid ℝ := fun i ↦ ⟨γ i - γ m, sub_nonpos.mpr (hm i)⟩ + have hδm : δ m = 0 := Subtype.ext (sub_self (γ m)) + have hδ : ∀ i, δ i = 0 → i = m := fun i hi ↦ hinj (sub_eq_zero.mp (congrArg Subtype.val hi)) + let γm : exponentMonoid ℝ := ⟨γ m, hγ m⟩ + have hirr : Irreducible (DirectSum.of (PrincipalComponent K) (n : NatOrdinal) (x m)) := by + rw [← hx] + exact irreducible_rvJ_of_hereditarilyRVIndependent hn + (hQ.comp_injective (fun _ : Unit ↦ m) fun _ _ _ ↦ rfl) + set Bform := blockForm K (fun i ↦ DirectSum.of (PrincipalComponent K) (n : NatOrdinal) (x i)) δ + with hBform + -- The degree-`n` class of `B` is `t^{γₘ} · Bform`. + have hle : ∀ i, ((b i * single (γ i) (1 : K) (hγ i) : Series K) : K⟦ℝ⟧).degree ≤ + ((n : NatOrdinal) : WithBot NatOrdinal) := fun i ↦ by + rw [degree_mul, hdeg i] + have h0 : ((single (γ i) (1 : K) (hγ i) : Series K) : K⟦ℝ⟧).degree ≤ 0 := by + rw [HahnSeries.degree_le_zero_iff, coe_single] + exact (Set.finite_singleton (γ i)).subset HahnSeries.support_single_subset + calc ((n : NatOrdinal) : WithBot NatOrdinal) + ((single (γ i) (1 : K) (hγ i) : Series K) : + K⟦ℝ⟧).degree ≤ (n : NatOrdinal) + (0 : WithBot NatOrdinal) := add_le_add le_rfl h0 + _ = (n : NatOrdinal) := add_zero _ + have hsum_le : degreeValuation K (∑ i, b i * single (γ i) (1 : K) (hγ i)) ≤ + ((n : NatOrdinal) : WithBot NatOrdinal) := + MaxAddDegree.map_sum_le_of_forall_le _ _ _ _ fun i _ ↦ by + rw [degreeValuation_apply]; exact hle i + have hBmem : B ∈ (degreeValuation K).filtrationLE (n : NatOrdinal) := by + rw [MaxAddDegree.mem_filtrationLE_iff, hBdef, blockSum_def] + exact ((degreeValuation K).map_add_le_max _ _).trans (max_le hsum_le (by + rw [degreeValuation_apply]; exact hr.le)) + have hclass : (degreeValuation K).homogeneousMk (n : NatOrdinal) ⟨B, hBmem⟩ = + finiteSupportGradedEmbedding K (finiteSupportMonomial γm) * Bform := by + have hsum_mem : ∑ i, b i * single (γ i) (1 : K) (hγ i) ∈ + (degreeValuation K).filtrationLE (n : NatOrdinal) := + (MaxAddDegree.mem_filtrationLE_iff _ _ _).mpr hsum_le + have hr_mem : r ∈ (degreeValuation K).filtrationLE (n : NatOrdinal) := by + rw [MaxAddDegree.mem_filtrationLE_iff, degreeValuation_apply]; exact hr.le + have hsplit : (degreeValuation K).homogeneousMk (n : NatOrdinal) ⟨B, hBmem⟩ = + (degreeValuation K).homogeneousMk (n : NatOrdinal) ⟨_, hsum_mem⟩ + + (degreeValuation K).homogeneousMk (n : NatOrdinal) ⟨r, hr_mem⟩ := by + rw [← map_add]; rfl + have hr_zero : (degreeValuation K).homogeneousMk (n : NatOrdinal) ⟨r, hr_mem⟩ = 0 := + (degreeValuation K).homogeneousMk_eq_zero_of_degree_lt hr_mem + (by rw [degreeValuation_apply]; exact hr) + rw [hsplit, hr_zero, add_zero, MaxAddDegree.homogeneousMk_finsetSum _ _ _ + (fun i _ ↦ (MaxAddDegree.mem_filtrationLE_iff _ _ _).mpr + (by rw [degreeValuation_apply]; exact hle i)), hBform, blockForm_def, Finset.mul_sum, + ← Finset.sum_attach Finset.univ] + refine Finset.sum_congr rfl fun i _ ↦ ?_ + -- Each term is `in(bᵢ) · t^{γᵢ}` with `t^{γᵢ} = t^{γₘ} t^{γᵢ - γₘ}`. + have hbi_mem : b i ∈ (degreeValuation K).filtrationLE (n : NatOrdinal) := by + rw [MaxAddDegree.mem_filtrationLE_iff, degreeValuation_apply, hdeg i] + have hti_mem : ((finiteSupportMonomial (K := K) (⟨γ i, hγ i⟩ : exponentMonoid ℝ) : + Berarducci.FiniteSupportRing (K := K)) : Series K) ∈ + (degreeValuation K).filtrationLE 0 := by + rw [MaxAddDegree.mem_filtrationLE_iff, degreeValuation_apply, WithBot.coe_zero, + HahnSeries.degree_le_zero_iff] + exact (mem_finiteSupportSubring_iff _).mp (finiteSupportMonomial _).2 + have hbi_form : (degreeValuation K).homogeneousMk (n : NatOrdinal) ⟨b i, hbi_mem⟩ = + principalSubringEmbedding K + (DirectSum.of (PrincipalComponent K) (n : NatOrdinal) (x i)) := by + rw [← hx i, principalSubringEmbedding_rvJ_of_isPrincipal (hb i) (hdeg i)] + exact (degreeValuation K).homogeneousMk_eq_initialForm_of_degree_eq hbi_mem + (by rw [degreeValuation_apply, hdeg i]) + rw [(degreeValuation K).homogeneousMk_mul_of_coe_eq (add_zero (n : NatOrdinal)).symm + ⟨b i, hbi_mem⟩ ⟨_, hti_mem⟩ _ (by + change b i * single (γ i) (1 : K) (hγ i) = b i * _ + rw [coe_monomial]), + ← finiteSupportGradedEmbedding_eq_homogeneousMk' _ hti_mem, hbi_form, + show (⟨γ i, hγ i⟩ : exponentMonoid ℝ) = + ⟨(γm : ℝ) + ((δ i : exponentMonoid ℝ) : ℝ), (exponentMonoid ℝ).add_mem γm.2 (δ i).2⟩ from + Subtype.ext (by change γ i = γ m + (γ i - γ m); ring), + ← finiteSupportMonomial_mul, map_mul] + ring + -- The block form and the monomial are nonzero, so `B` has degree exactly `n`. + have hBform_ne : Bform ≠ 0 := by + intro h + have hproj := rvProjection_blockForm + (fun i ↦ DirectSum.of (PrincipalComponent K) (n : NatOrdinal) (x i)) δ m hδm hδ + rw [← hBform, h, map_zero] at hproj + exact hirr.ne_zero hproj.symm + have hγm_ne : finiteSupportGradedEmbedding K (finiteSupportMonomial (K := K) γm) ≠ 0 := by + intro h + rw [← map_zero (finiteSupportGradedEmbedding K)] at h + have h1 := finiteSupportGradedEmbedding_injective K h + have h2 := congrArg (fun q : Berarducci.FiniteSupportRing (K := K) ↦ + ((q : Series K) : K⟦ℝ⟧).coeff (γ m)) h1 + simp only [coe_finiteSupportMonomial, ZeroMemClass.coe_zero, HahnSeries.coeff_zero] at h2 + rw [show ((γm : exponentMonoid ℝ) : ℝ) = γ m from rfl, HahnSeries.coeff_single_same] at h2 + exact one_ne_zero h2 + have hBclass_ne : (degreeValuation K).homogeneousMk (n : NatOrdinal) ⟨B, hBmem⟩ ≠ 0 := by + rw [hclass]; exact mul_ne_zero hγm_ne hBform_ne + have hBdeg : degreeValuation K B = ((n : NatOrdinal) : WithBot NatOrdinal) := by + have hle' : degreeValuation K B ≤ (n : NatOrdinal) := + (MaxAddDegree.mem_filtrationLE_iff _ _ _).mp hBmem + rcases hle'.lt_or_eq with hlt | heq + · exact absurd ((degreeValuation K).homogeneousMk_eq_zero_iff _ _ |>.mpr hlt) hBclass_ne + · exact heq + have hinit : (degreeValuation K).initialForm B = + finiteSupportGradedEmbedding K (finiteSupportMonomial γm) * Bform := by + rw [← hclass] + exact ((degreeValuation K).homogeneousMk_eq_initialForm_of_degree_eq hBmem hBdeg).symm + -- `B` is not a unit: the units are the constants, of degree zero. + refine ⟨fun hunit ↦ ?_, fun a c hac ↦ ?_⟩ + · have hconst := eq_C_constantCoeff_of_isUnit hunit + have h0 : degreeValuation K B ≤ 0 := by + rw [hconst, degreeValuation_apply] + exact degree_C_le_zero _ + rw [hBdeg] at h0 + exact absurd (WithBot.coe_le_coe.mp h0) (not_le.mpr (Nat.cast_pos.mpr hn)) + -- A factorisation: one factor has a monomial initial form, hence is a monomial. + have hprod : (degreeValuation K).initialForm a * (degreeValuation K).initialForm c = + finiteSupportGradedEmbedding K (finiteSupportMonomial γm) * Bform := by + rw [← MaxAddDegree.initialForm_mul, ← hac, hinit] + obtain ⟨p, hp, hpa⟩ := exists_isMonomial_factor_of_mul_eq x hli δ m hδm hδ hirr γm hprod + have hp0 : p ≠ 0 := by + intro h + obtain ⟨g, l, hg, hl, hpeq⟩ := isMonomial_iff.mp hp + rw [h] at hpeq + have hcoeff := congrArg (fun q : Series K ↦ (q : K⟦ℝ⟧).coeff g) hpeq + exact hl (by simpa [coe_single] using hcoeff.symm) + -- A monomial factor of `B` is a unit, because `sup(B) = 0`. + have hunit_of : ∀ a' : Series K, a' = (p : Series K) → a' ∣ B → IsUnit a' := by + intro a' ha' hdvd + obtain ⟨g, l, hg, hl, hpeq⟩ := isMonomial_iff.mp hp + rw [ha', hpeq] + rcases hg.lt_or_eq with hneg | hzero + · exfalso + have hJ : B ∈ negativeMonomialIdeal K := by + have hmem : single g l hg ∈ negativeMonomialIdeal K := by + rw [mem_negativeMonomialIdeal_iff_supportSup_lt_zero, supportSup_single hl hg] + exact WithBot.coe_lt_coe.mpr hneg + rw [ha', hpeq] at hdvd + exact Ideal.mem_of_dvd _ hdvd hmem + rw [mem_negativeMonomialIdeal_iff_supportSup_lt_zero, hsup] at hJ + exact lt_irrefl _ hJ + · subst hzero + exact (isUnit_single_iff hl le_rfl).mpr rfl + rcases hpa with ha | hc + · exact Or.inl (hunit_of a (eq_of_initialForm_eq_finiteSupportGradedEmbedding hp0 ha) + (Dvd.intro c hac.symm)) + · exact Or.inr (hunit_of c (eq_of_initialForm_eq_finiteSupportGradedEmbedding hp0 hc) + (Dvd.intro_left a hac.symm)) + +end FLLM24 + +end diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Random/NormalFormBlocks.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Random/NormalFormBlocks.lean new file mode 100644 index 0000000000..a0d8a7c0e5 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Random/NormalFormBlocks.lean @@ -0,0 +1,323 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Random.NonPrincipalIrreducible +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.NormalForm + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.SeparatedSupport +import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.AdditivelyPrincipal +import Mathlib.SetTheory.Ordinal.Principal +import Mathlib.Topology.Order.Monotone + +/-! +# The block decomposition of a series of order type `ω^n · m + β` + +Fornasiero, Lavi, L'Innocente and Mantova, *Irreducibility in generalized power series* (2024), +Theorem 1.8, treat a series `b` with `sup(b) = 0` and `ot(b) = m ω^α + β`, `β < ω^α`, through +its normal form (LM24, Definition 3.3.6 and Proposition 3.3.7, recalled as Definition 2.1): +`b = ∑ᵢ bᵢ t^{γᵢ} + r` with `b₁, …, bₘ ∈ P_α`, `γ₁ < ⋯ < γₘ ≤ 0` and `deg(r) < α`. The source +does not spell out this reading of the normal form; it is carried out here for `α = n < ω`. + +The normal form lists principal terms `bᵢ t^{γᵢ}` with supports in strictly increasing +position and order types forming the Cantor normal form of `ot(b)`. When +`ot(b) = ω^n · m + β` with `β < ω^n`, the first `m` terms have order type `ω^n` and the remaining +ones order types below `ω^n`; the latter sum to `r`. The exponents of the first `m` terms are +strictly increasing: two consecutive terms of order type `ω^n ≥ ω` cannot share their support +supremum, since the upper one would then be a single monomial. + +The decomposition records, besides the identity `b = ∑ᵢ bᵢ t^{γᵢ} + r`, the position of the +supports: the support of each block `bᵢ t^{γᵢ}` lies strictly below that of the later blocks and +of `r`. These are the facts used to transfer randomness from `b` to `b₁, …, bₘ`. +-/ + +open scoped HahnSeries NatOrdinal + +universe v + +public noncomputable section + +namespace FLLM24 + +open Berarducci HahnSeries HahnSeries.Nonpositive + +variable {K : Type v} [Field K] + +/-- The block decomposition `b = ∑ᵢ bᵢ t^{γᵢ} + r` of a series of order type `ω^n · m + β`, +`β < ω^n`: `m` principal blocks of degree `n` at strictly increasing exponents `γᵢ ≤ 0`, a rest +of degree below `n`, and the supports of the blocks lying in increasing position below the +support of the rest. -/ +structure BlockDecomposition (b : Series K) (n m : ℕ) where + /-- The principal blocks `b₁, …, bₘ`. -/ + block : Fin m → Series K + /-- The exponents `γ₁ < ⋯ < γₘ`. -/ + exponent : Fin m → ℝ + /-- The rest `r`. -/ + rest : Series K + /-- Each block is principal. -/ + block_isPrincipal : ∀ i, IsPrincipal (block i) + /-- Each block has degree `n`. -/ + block_degree : ∀ i, ((block i : Series K) : K⟦ℝ⟧).degree = ((n : NatOrdinal) : WithBot NatOrdinal) + /-- The exponents are nonpositive. -/ + exponent_nonpos : ∀ i, exponent i ≤ 0 + /-- The exponents are strictly increasing. -/ + exponent_strictMono : StrictMono exponent + /-- The rest has degree below `n`. -/ + rest_degree : (rest : K⟦ℝ⟧).degree < ((n : NatOrdinal) : WithBot NatOrdinal) + /-- `b = ∑ᵢ bᵢ t^{γᵢ} + r`. -/ + eq_blockSum : b = blockSum block exponent exponent_nonpos rest + /-- The support of an earlier block lies strictly below the support of a later block. -/ + piece_lt_piece : ∀ i j, i < j → + ∀ x ∈ ((block i * single (exponent i) (1 : K) (exponent_nonpos i) : Series K) : K⟦ℝ⟧).support, + ∀ y ∈ ((block j * single (exponent j) (1 : K) (exponent_nonpos j) : Series K) : K⟦ℝ⟧).support, + x < y + /-- The support of every block lies strictly below the support of the rest. -/ + piece_lt_rest : ∀ i, + ∀ x ∈ ((block i * single (exponent i) (1 : K) (exponent_nonpos i) : Series K) : K⟦ℝ⟧).support, + ∀ y ∈ (rest : K⟦ℝ⟧).support, x < y + +namespace BlockDecomposition + +variable {b : Series K} {n m : ℕ} (d : BlockDecomposition b n m) + +/-- The `i`-th block in position, `bᵢ t^{γᵢ}`. -/ +def piece (i : Fin m) : Series K := + d.block i * single (d.exponent i) (1 : K) (d.exponent_nonpos i) + +theorem piece_def (i : Fin m) : + d.piece i = d.block i * single (d.exponent i) (1 : K) (d.exponent_nonpos i) := + (rfl) + +theorem coe_piece (i : Fin m) : + ((d.piece i : Series K) : K⟦ℝ⟧) = translate (d.exponent i) (d.block i : K⟦ℝ⟧) := by + rw [piece_def, Subring.coe_mul, coe_single, mul_single_one_eq_translate] + +theorem eq_sum_piece_add_rest : b = ∑ i, d.piece i + d.rest := + d.eq_blockSum.trans (blockSum_def _ _ _ _) + +/-- The support of an earlier piece lies strictly below the support of a later piece. -/ +theorem piece_support_lt {i j : Fin m} (hij : i < j) {x y : ℝ} + (hx : x ∈ ((d.piece i : Series K) : K⟦ℝ⟧).support) + (hy : y ∈ ((d.piece j : Series K) : K⟦ℝ⟧).support) : x < y := + d.piece_lt_piece i j hij x hx y hy + +/-- The support of every piece lies strictly below the support of the rest. -/ +theorem piece_support_lt_rest (i : Fin m) {x y : ℝ} + (hx : x ∈ ((d.piece i : Series K) : K⟦ℝ⟧).support) (hy : y ∈ (d.rest : K⟦ℝ⟧).support) : + x < y := + d.piece_lt_rest i x hx y hy + +end BlockDecomposition + +/-- Every element of a list of ordinals is at most the ordinary sum of the list. -/ +private theorem le_list_sum_of_mem {l : List Ordinal} {a : Ordinal} (ha : a ∈ l) : a ≤ l.sum := by + induction l with + | nil => exact absurd ha (List.not_mem_nil) + | cons c l ih => + rw [List.sum_cons] + rcases List.mem_cons.mp ha with rfl | ha + · exact le_self_add + · exact (ih ha).trans le_add_self + +/-- The Cantor terms of `ω^n · m + β` for `β < ω^n`: `m` copies of `ω^n` followed by the Cantor +terms of `β`. -/ +theorem additivePrincipalTerms_omega0_opow_mul_add {n m : ℕ} {β : Ordinal} + (hβ : β < Ordinal.omega0 ^ (n : Ordinal)) : + (Ordinal.omega0 ^ (n : Ordinal) * m + β).additivePrincipalTerms = + List.replicate m (Ordinal.omega0 ^ (n : Ordinal)) ++ β.additivePrincipalTerms := by + symm + apply Ordinal.additivePrincipalTerms_unique + · rw [List.sum_append, List.sum_replicate, Ordinal.nsmul_eq_mul, + Ordinal.additivePrincipalTerms_sum] + · intro a ha + rcases List.mem_append.mp ha with ha | ha + · rw [List.eq_of_mem_replicate ha] + exact Ordinal.isAdditivelyPrincipal_omega0_opow _ + · exact Ordinal.isAdditivelyPrincipal_of_mem_additivePrincipalTerms ha + · rw [List.sortedGE_iff_pairwise, List.pairwise_append] + refine ⟨?_, List.sortedGE_iff_pairwise.mp (Ordinal.additivePrincipalTerms_sortedGE β), + fun a ha c hc ↦ ?_⟩ + · rw [List.pairwise_iff_forall_sublist] + intro a c hsub + have ha := List.eq_of_mem_replicate (hsub.subset (List.mem_cons_self ..)) + have hc := List.eq_of_mem_replicate (hsub.subset (List.mem_cons_of_mem _ + (List.mem_cons_self ..))) + rw [ha, hc] + · rw [List.eq_of_mem_replicate ha] + exact ((le_list_sum_of_mem hc).trans_eq (Ordinal.additivePrincipalTerms_sum β)).trans hβ.le + +/-- A Hahn series whose support has order type `ω^n` with `n ≥ 1` is not a monomial: its +support is not contained in a singleton. -/ +private theorem not_subset_singleton_of_supportOrderType_eq {n : ℕ} (hn : 1 ≤ n) {x : K⟦ℝ⟧} + (hx : x.supportOrderType = Ordinal.omega0 ^ (n : Ordinal)) (g : ℝ) : + ¬ x.support ⊆ {g} := by + intro hsub + have hle : x.supportOrderType ≤ (HahnSeries.single g (1 : K)).supportOrderType := + supportOrderType_mono (by rw [HahnSeries.support_single_of_ne one_ne_zero]; exact hsub) + rw [supportOrderType_single one_ne_zero, hx] at hle + have hlt : (1 : Ordinal) < Ordinal.omega0 ^ (n : Ordinal) := + Ordinal.one_lt_omega0.trans_le (by + calc Ordinal.omega0 = Ordinal.omega0 ^ (1 : Ordinal) := (Ordinal.opow_one _).symm + _ ≤ Ordinal.omega0 ^ (n : Ordinal) := + Ordinal.opow_le_opow_right Ordinal.omega0_pos (by exact_mod_cast hn)) + exact absurd hle (not_le.mpr hlt) + +/-- LM24, Proposition 3.3.7, read at order type `ω^n · m + β` with `β < ω^n` and `n ≥ 1`: the +normal form of `b` is a block decomposition with `m` blocks of degree `n`. -/ +theorem exists_blockDecomposition {b : Series K} {n m : ℕ} (hn : 1 ≤ n) {β : Ordinal} + (hβ : β < Ordinal.omega0 ^ (n : Ordinal)) + (hot : (b : K⟦ℝ⟧).supportOrderType = Ordinal.omega0 ^ (n : Ordinal) * m + β) : + Nonempty (BlockDecomposition b n m) := by + classical + obtain ⟨terms, hterms⟩ := exists_isNormalForm b + obtain ⟨hsum, -, hprinc, -, hpair⟩ := isNormalForm_iff.mp hterms + set L : List K⟦ℝ⟧ := terms.map NormalForm.Term.series with hL + have htypes : L.map supportOrderType = + List.replicate m (Ordinal.omega0 ^ (n : Ordinal)) ++ β.additivePrincipalTerms := by + rw [hterms.isWeakNormalForm.supportOrderTypes_eq_additivePrincipalTerms, hot, + additivePrincipalTerms_omega0_opow_mul_add hβ] + have hlen : m ≤ L.length := by + have := congrArg List.length htypes + rw [List.length_map, List.length_append, List.length_replicate] at this + omega + have hlenT : m ≤ terms.length := by rwa [hL, List.length_map] at hlen + -- The first `m` series have order type `ω^n`; the remaining ones have smaller order type. + have htake : (L.take m).map supportOrderType = + List.replicate m (Ordinal.omega0 ^ (n : Ordinal)) := by + rw [List.map_take, htypes, List.take_left' (List.length_replicate ..)] + have hdrop : (L.drop m).map supportOrderType = β.additivePrincipalTerms := by + rw [List.map_drop, htypes, List.drop_left' (List.length_replicate ..)] + have hot_take : ∀ y ∈ L.take m, y.supportOrderType = Ordinal.omega0 ^ (n : Ordinal) := + fun y hy ↦ List.eq_of_mem_replicate (htake ▸ List.mem_map_of_mem hy) + have hot_drop : ∀ y ∈ L.drop m, y.supportOrderType < Ordinal.omega0 ^ (n : Ordinal) := by + intro y hy + have hmem : y.supportOrderType ∈ β.additivePrincipalTerms := hdrop ▸ List.mem_map_of_mem hy + exact ((le_list_sum_of_mem hmem).trans_eq (Ordinal.additivePrincipalTerms_sum β)).trans_lt hβ + -- The terms of the first `m` blocks. + have hltT : ∀ i : Fin m, i.1 < terms.length := fun i ↦ lt_of_lt_of_le i.2 hlenT + have hltL : ∀ i : Fin m, i.1 < L.length := fun i ↦ lt_of_lt_of_le i.2 hlen + let tm : Fin m → NormalForm.Term K := fun i ↦ terms[i.1]'(hltT i) + have htm_mem : ∀ i, tm i ∈ terms := fun i ↦ List.getElem_mem _ + have hLget : ∀ i : Fin m, L[i.1]'(hltL i) = (tm i).series := fun i ↦ by + simp only [hL, List.getElem_map, tm] + have hseries_mem : ∀ i, (tm i).series ∈ L.take m := by + intro i + rw [← hLget i, + ← List.getElem_take (h := (by rw [List.length_take]; exact lt_min i.2 (hltL i)))] + exact List.getElem_mem _ + have hprinc' : ∀ i, IsPrincipal (tm i).coefficient := fun i ↦ hprinc _ (htm_mem i) + have hot_tm : ∀ i, ((tm i).coefficient : K⟦ℝ⟧).supportOrderType = + Ordinal.omega0 ^ (n : Ordinal) := fun i ↦ by + rw [← supportOrderType_translate (tm i).exponent, ← NormalForm.Term.series_eq_translate] + exact hot_take _ (hseries_mem i) + have hexp : ∀ i, (tm i).exponent = sSup (tm i).series.support := fun i ↦ + (NormalForm.Term.csSup_support_series (tm i) (hprinc' i)).symm + have hseries_ne : ∀ i, (tm i).series ≠ 0 := fun i ↦ + NormalForm.Term.series_ne_zero (hprinc' i) + have hsub_b : ∀ i, (tm i).series.support ⊆ (b : K⟦ℝ⟧).support := fun i ↦ by + rw [← hsum] + exact support_subset_list_sum_of_mem hpair (List.mem_map_of_mem (htm_mem i)) + -- Pairwise position of the series. + have hlenL : (L.take m).length = m := by + rw [List.length_take]; exact min_eq_left hlen + have hbelow : ∀ i j, i < j → SupportBelow (tm i).series (tm j).series := by + intro i j hij + rw [← hLget i, ← hLget j] + have h := List.pairwise_iff_get.mp hpair ⟨i.1, hltL i⟩ ⟨j.1, hltL j⟩ (by simpa using hij) + simpa only [List.get_eq_getElem] using h + have hpairAll : (L.take m ++ L.drop m).Pairwise SupportBelow := by + rw [List.take_append_drop]; exact hpair + have hbelow_drop : ∀ i, SupportBelow (tm i).series (L.drop m).sum := by + intro i + apply supportBelow_list_sum + intro y hy + exact (List.pairwise_append.mp hpairAll).2.2 _ (hseries_mem i) y hy + -- The exponents. + have hexp_nonpos : ∀ i, (tm i).exponent ≤ 0 := fun i ↦ by + rw [hexp i] + exact csSup_le (support_nonempty_iff.mpr (hseries_ne i)) + fun x hx ↦ HahnSeries.Nonpositive.support_subset b (hsub_b i hx) + have hexp_mono : StrictMono fun i ↦ (tm i).exponent := by + intro i j hij + have hbel := hbelow i j hij + have hle : (tm i).exponent ≤ (tm j).exponent := by + rw [hexp i, hexp j] + exact csSup_support_le_of_supportBelow (hseries_ne i) (hseries_ne j) + (NormalForm.Term.bddAbove_support _) hbel + refine lt_of_le_of_ne hle fun heq ↦ ?_ + apply not_subset_singleton_of_supportOrderType_eq hn (hot_take _ (hseries_mem j)) + (tm j).exponent + intro y hy + have hy_le : y ≤ (tm j).exponent := by + rw [hexp j]; exact le_csSup (NormalForm.Term.bddAbove_support _) hy + have hy_ge : (tm i).exponent ≤ y := by + rw [hexp i] + exact csSup_le (support_nonempty_iff.mpr (hseries_ne i)) fun x hx ↦ (hbel.lt hx hy).le + have heq' : (tm i).exponent = (tm j).exponent := heq + exact Set.mem_singleton_iff.mpr (le_antisymm hy_le (heq' ▸ hy_ge)) + -- The sum of the first `m` series and the rest. + have hsum_take : ∑ i, (tm i).series = (L.take m).sum := by + have hofFn : List.ofFn (fun i : Fin m ↦ (tm i).series) = L.take m := by + apply List.ext_getElem + · rw [List.length_ofFn, hlenL] + · intro i h₁ h₂ + have hi : i < m := by simpa using h₁ + rw [List.getElem_ofFn, ← hLget ⟨i, hi⟩, List.getElem_take] + rw [← hofFn, List.sum_ofFn] + have hsplit : L.sum = (L.take m).sum + (L.drop m).sum := by + have h := List.sum_append (l₁ := L.take m) (l₂ := L.drop m) + rwa [List.take_append_drop] at h + have hrest : (b : K⟦ℝ⟧) - ∑ i, (tm i).series = (L.drop m).sum := by + rw [hsum_take, ← hsum, hsplit] + abel + have hbelowSum : SupportBelow (L.take m).sum (L.drop m).sum := by + apply list_sum_supportBelow + intro x hx + apply supportBelow_list_sum + intro y hy + exact (List.pairwise_append.mp hpairAll).2.2 x hx y hy + have hdropsub : (L.drop m).sum.support ⊆ (b : K⟦ℝ⟧).support := by + rw [← hsum, hsplit, support_add_eq_union_of_supportBelow _ _ hbelowSum] + exact Set.subset_union_right + have hrest_mem : (b : K⟦ℝ⟧) - ∑ i, (tm i).series ∈ nonpositiveSubring ℝ K := by + rw [mem_nonpositiveSubring] + intro y hy + rw [hrest] at hy + exact HahnSeries.Nonpositive.support_subset b (hdropsub hy) + let rest : Series K := ⟨_, hrest_mem⟩ + have hcoe_rest : (rest : K⟦ℝ⟧) = (L.drop m).sum := hrest + have hpairDrop : (L.drop m).Pairwise SupportBelow := hpair.sublist (List.drop_sublist m L) + have hpiece : ∀ i, ((((tm i).coefficient * single (tm i).exponent (1 : K) (hexp_nonpos i)) : + Series K) : K⟦ℝ⟧) = (tm i).series := fun i ↦ by + rw [Subring.coe_mul, coe_single, mul_single_one_eq_translate, + NormalForm.Term.series_eq_translate] + -- Assemble the decomposition. + refine ⟨⟨fun i ↦ (tm i).coefficient, fun i ↦ (tm i).exponent, rest, hprinc', ?_, hexp_nonpos, + hexp_mono, ?_, ?_, ?_, ?_⟩⟩ + · intro i + rw [degree_eq_cantorDegree, hot_tm i, ← NatOrdinal.cantorDegree_of, ← NatOrdinal.val_natCast, + ← NatOrdinal.wpow_def, NatOrdinal.cantorDegree_wpow] + · rw [hcoe_rest, degree_lt_coe_iff_supportOrderType_lt_wpow, supportOrderType_list_sum hpairDrop, + NatOrdinal.val_wpow, NatOrdinal.val_natCast] + exact (Ordinal.isAdditivelyPrincipal_omega0_opow _).list_sum_lt fun a ha ↦ by + obtain ⟨y, hy, rfl⟩ := List.mem_map.mp ha + exact hot_drop y hy + · apply Subtype.ext + rw [blockSum_def, Subring.coe_add, AddSubmonoidClass.coe_finsetSum] + simp only [hpiece] + change (b : K⟦ℝ⟧) = ∑ i, (tm i).series + ((b : K⟦ℝ⟧) - ∑ i, (tm i).series) + abel + · intro i j hij x hx y hy + rw [hpiece] at hx hy + exact (hbelow i j hij).lt hx hy + · intro i x hx y hy + rw [hpiece] at hx + rw [hcoe_rest] at hy + exact (hbelow_drop i).lt hx hy + +end FLLM24 + +end diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Random/PrincipalIrreducible.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Random/PrincipalIrreducible.lean new file mode 100644 index 0000000000..ea1101f060 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Random/PrincipalIrreducible.lean @@ -0,0 +1,100 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.DirectSum.HomogeneousPrime +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.LeastTerm +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalSubring +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.AssociatedGradedValuation + +import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.DegreeAssociatedGradedDomain +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Statements.OrdinalValueDegree + +/-! +# Irreducibility at a power of `ω` + +Fornasiero, Lavi, L'Innocente and Mantova, *Irreducibility of generalised power series* (2024), +§ 1, deduce from Berarducci's `P_α · P_β ⊆ P_{α ⊕ β}` that every principal series of order type +`ω ^ (ω ^ α)` is irreducible, because there are no nonzero `β, γ` with `β ⊕ γ = ω ^ α`. This +module is that deduction, carried out on the graded ring rather than on series. + +Their statement is the stronger one: it concludes irreducibility in `K((ℝ^{≤ 0}))` itself, where +this concludes it for the class in `P̂`. LM24, Theorem E is stronger again, covering order type +`ω ^ (ω ^ α) +̂ β` for every `β < ω ^ (ω ^ α)` and every `α`, not only the additively principal +grades. Nothing here is new; the point of formalizing it is that the grade-splitting argument is +general, and lives in `ConwayRefinement.Algebra.DirectSum.HomogeneousPrime` next to the +primality lift it is the easy counterpart of. +-/ + +open scoped DirectSum NatOrdinal + +universe v + +public noncomputable section + +namespace FLLM24 + +open Berarducci + +variable {K : Type v} [Field K] + +theorem not_isUnit_of_grade_ne_zero {alpha : NatOrdinal} (halpha : alpha ≠ 0) + (X : PrincipalComponent K alpha) : + ¬ IsUnit (DirectSum.of (PrincipalComponent K) alpha X) := by + intro hunit + obtain ⟨y, hy⟩ := hunit.exists_right_inv + have hzero : (DirectSum.of (PrincipalComponent K) alpha X * y) 0 = 0 := by + apply DirectSum.of_mul_apply_eq_zero_of_not_exists + rintro ⟨j, hj⟩ + exact halpha (NatOrdinal.add_eq_zero_iff.mp hj).1 + rw [hy] at hzero + apply (one_ne_zero : (1 : PrincipalSubring K) ≠ 0) + rw [DirectSum.one_def] at hzero ⊢ + simp only [DirectSum.of_apply, dite_eq_left] at hzero + rw [show (GradedMonoid.GOne.one : PrincipalComponent K 0) = 0 by simpa using hzero, map_zero] + +/-- A nonzero class of grade zero is a unit: grade zero is the scalar field. -/ +theorem isUnit_of_grade_zero (u : PrincipalComponent K 0) (hu : u ≠ 0) : + IsUnit (DirectSum.of (PrincipalComponent K) 0 u) := by + obtain ⟨c, rfl⟩ := principalComponentScalarHom_surjective K u + have hc : c ≠ 0 := by + intro hzero + exact hu (by rw [hzero, map_zero]) + have heq : DirectSum.of (PrincipalComponent K) 0 (principalComponentScalarHom K c) = + algebraMap K (PrincipalSubring K) c := rfl + rw [heq] + exact (isUnit_iff_ne_zero.mpr hc).map (algebraMap K (PrincipalSubring K)) + +variable [CharZero K] in +/-- FLLM24, § 1: a nonzero homogeneous class at a power of `ω` is irreducible, here in `P̂`: the +products of nonzero homogeneous classes are nonzero because the ordinal value is multiplicative +(Berarducci, Theorem 9.7). -/ +theorem irreducible_of_isAdditivelyPrincipal + {alpha : NatOrdinal} (halpha : Ordinal.IsAdditivelyPrincipal alpha.val) + (X : PrincipalComponent K alpha) (hX : X ≠ 0) : + Irreducible (DirectSum.of (PrincipalComponent K) alpha X) := by + have halphaNe : alpha ≠ 0 := by + obtain ⟨e, he⟩ := Ordinal.isAdditivelyPrincipal_iff.mp halpha + intro hzero + rw [hzero] at he + exact Ordinal.opow_ne_zero e Ordinal.omega0_ne_zero (by simpa using he.symm) + refine DirectSum.irreducible_of_homogeneous_of_grade_not_split + (PrincipalComponent K) X + (fun u v hu hv ↦ MaxAddDegree.componentMul_ne_zero + (ordinalValueDegreeValuation K) u v hu hv) + (fun _ ↦ zero_le) isUnit_of_grade_zero + (fun j k hjk ↦ ?_) ?_ (not_isUnit_of_grade_ne_zero halphaNe X) + · rcases eq_or_ne j 0 with h | h + · exact Or.inl h + · rcases eq_or_ne k 0 with h' | h' + · exact Or.inr h' + · exact absurd hjk (NatOrdinal.add_ne_of_isAdditivelyPrincipal halpha h h') + · intro hzero + exact hX (DirectSum.of_injective alpha (by rw [hzero, map_zero])) + +end FLLM24 + +end diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Random/Random.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Random/Random.lean new file mode 100644 index 0000000000..c6bf1d0945 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Random/Random.lean @@ -0,0 +1,150 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Germ +public import Mathlib.RingTheory.AlgebraicIndependent.Defs +public import Mathlib.Algebra.Algebra.Rat +public import Mathlib.Topology.MetricSpace.Pseudo.Defs +public import Mathlib.LinearAlgebra.LinearIndependent.Defs + +/-! +# Random series + +Fornasiero, Lavi, L'Innocente and Mantova, *Irreducibility in generalized power series* (2024), +Definition 1.3: a series `b = ∑ b_γ t^γ ∈ K((ℝ^{≤0}))` is *random* if the set +`cl(supp b) ∖ {0}` is `ℚ`-linearly independent in `ℝ`, or the family of coefficients +`⟨b_γ : γ ∈ supp b⟩` is algebraically independent over `ℚ`. Section 3 extends this to finitely +many series: `b_1, …, b_m` are *mutually random* if the closures of their supports meet pairwise +only in `{0}` and the union of the sets `cl(supp b_i) ∖ {0}` is `ℚ`-linearly independent, or +the joint family of all their coefficients is algebraically independent over `ℚ`. + +The coefficient field has characteristic zero, so it is a `ℚ`-algebra through Mathlib's +`DivisionRing.toRatAlgebra`; algebraic independence is Mathlib's `AlgebraicIndependent ℚ`. +The two clauses are recorded as separate predicates, `IsSupportRandom` and +`IsCoefficientRandom`, and `IsRandom` is their disjunction, so that the theorems proved from +each clause can be stated for that clause alone. +-/ + +open scoped HahnSeries + +universe v + +public noncomputable section + +namespace FLLM24 + +open Berarducci + +variable {K : Type v} [Field K] + +/-- The set `cl(supp b) ∖ {0}` of FLLM24, Definition 1.3. -/ +def supportClosure (b : Series K) : Set ℝ := + closure (b : K⟦ℝ⟧).support \ {0} + +theorem mem_supportClosure_iff (b : Series K) (x : ℝ) : + x ∈ supportClosure b ↔ x ∈ closure (b : K⟦ℝ⟧).support ∧ x ≠ 0 := + (Iff.rfl) + +/-- The first clause of FLLM24, Definition 1.3: the closure of the support of `b`, with zero +removed, is a `ℚ`-linearly independent subset of `ℝ`. -/ +def IsSupportRandom (b : Series K) : Prop := + LinearIndependent ℚ (fun x : supportClosure b ↦ (x : ℝ)) + +theorem IsSupportRandom.linearIndependent {b : Series K} (h : IsSupportRandom b) : + LinearIndependent ℚ (fun x : supportClosure b ↦ (x : ℝ)) := + h + +theorem IsSupportRandom.of {b : Series K} + (h : LinearIndependent ℚ (fun x : supportClosure b ↦ (x : ℝ))) : IsSupportRandom b := + h + +variable [CharZero K] in +/-- The second clause of FLLM24, Definition 1.3: the coefficients `⟨b_γ : γ ∈ supp b⟩` are +algebraically independent over `ℚ`. -/ +def IsCoefficientRandom (b : Series K) : Prop := + AlgebraicIndependent ℚ (fun γ : (b : K⟦ℝ⟧).support ↦ (b : K⟦ℝ⟧).coeff γ) + +variable [CharZero K] in +theorem IsCoefficientRandom.algebraicIndependent {b : Series K} (h : IsCoefficientRandom b) : + AlgebraicIndependent ℚ (fun γ : (b : K⟦ℝ⟧).support ↦ (b : K⟦ℝ⟧).coeff γ) := + h + +variable [CharZero K] in +theorem IsCoefficientRandom.of {b : Series K} + (h : AlgebraicIndependent ℚ (fun γ : (b : K⟦ℝ⟧).support ↦ (b : K⟦ℝ⟧).coeff γ)) : + IsCoefficientRandom b := + h + +variable [CharZero K] in +/-- FLLM24, Definition 1.3: a series is random if its support closure (without zero) is +`ℚ`-linearly independent or its coefficients are algebraically independent over `ℚ`. -/ +def IsRandom (b : Series K) : Prop := + IsSupportRandom b ∨ IsCoefficientRandom b + +variable [CharZero K] in +theorem isRandom_iff (b : Series K) : + IsRandom b ↔ IsSupportRandom b ∨ IsCoefficientRandom b := + (Iff.rfl) + +/-- The set `⋃ᵢ cl(supp bᵢ) ∖ {0}` of a family of series. -/ +def supportClosureUnion {ι : Type*} (b : ι → Series K) : Set ℝ := + (⋃ i, closure ((b i : K⟦ℝ⟧)).support) \ {0} + +theorem mem_supportClosureUnion_iff {ι : Type*} (b : ι → Series K) (x : ℝ) : + x ∈ supportClosureUnion b ↔ (∃ i, x ∈ closure ((b i : K⟦ℝ⟧)).support) ∧ x ≠ 0 := by + simp [supportClosureUnion] + +/-- The support clause of mutual randomness, FLLM24, § 3: the closures of the supports meet +pairwise only in `{0}`, and their union with zero removed is `ℚ`-linearly independent. -/ +structure IsMutuallySupportRandom {ι : Type*} (b : ι → Series K) : Prop where + /-- `cl(supp bᵢ) ∩ cl(supp bⱼ) ⊆ {0}` for `i ≠ j`. -/ + closure_inter_subset : ∀ i j, i ≠ j → + closure ((b i : K⟦ℝ⟧)).support ∩ closure ((b j : K⟦ℝ⟧)).support ⊆ {0} + /-- `⋃ᵢ cl(supp bᵢ) ∖ {0}` is `ℚ`-linearly independent. -/ + linearIndependent : LinearIndependent ℚ (fun x : supportClosureUnion b ↦ (x : ℝ)) + +/-- The index set of the joint coefficient family of a family of series: the pairs `(i, γ)` with +`γ ∈ supp bᵢ`. -/ +def coefficientIndex {ι : Type*} (b : ι → Series K) : Set (ι × ℝ) := + {p | p.2 ∈ ((b p.1 : K⟦ℝ⟧)).support} + +theorem mem_coefficientIndex_iff {ι : Type*} (b : ι → Series K) (p : ι × ℝ) : + p ∈ coefficientIndex b ↔ ((b p.1 : K⟦ℝ⟧)).coeff p.2 ≠ 0 := + (Iff.rfl) + +variable [CharZero K] in +/-- The coefficient clause of mutual randomness, FLLM24, § 3: the joint family +`⟨b_{iγ} : i, γ ∈ supp bᵢ⟩` is algebraically independent over `ℚ`. -/ +def IsMutuallyCoefficientRandom {ι : Type*} (b : ι → Series K) : Prop := + AlgebraicIndependent ℚ (fun p : coefficientIndex b ↦ ((b p.1.1 : K⟦ℝ⟧)).coeff p.1.2) + +variable [CharZero K] in +theorem IsMutuallyCoefficientRandom.algebraicIndependent {ι : Type*} {b : ι → Series K} + (h : IsMutuallyCoefficientRandom b) : + AlgebraicIndependent ℚ (fun p : coefficientIndex b ↦ ((b p.1.1 : K⟦ℝ⟧)).coeff p.1.2) := + h + +variable [CharZero K] in +theorem IsMutuallyCoefficientRandom.of {ι : Type*} {b : ι → Series K} + (h : AlgebraicIndependent ℚ (fun p : coefficientIndex b ↦ ((b p.1.1 : K⟦ℝ⟧)).coeff p.1.2)) : + IsMutuallyCoefficientRandom b := + h + +variable [CharZero K] in +/-- FLLM24, § 3: `b₁, …, bₘ` are mutually random if they satisfy the support clause or the +coefficient clause. -/ +def IsMutuallyRandom {ι : Type*} (b : ι → Series K) : Prop := + IsMutuallySupportRandom b ∨ IsMutuallyCoefficientRandom b + +variable [CharZero K] in +theorem isMutuallyRandom_iff {ι : Type*} (b : ι → Series K) : + IsMutuallyRandom b ↔ IsMutuallySupportRandom b ∨ IsMutuallyCoefficientRandom b := + (Iff.rfl) + +end FLLM24 + +end diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Random/RandomBlocks.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Random/RandomBlocks.lean new file mode 100644 index 0000000000..944cb74e14 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Random/RandomBlocks.lean @@ -0,0 +1,325 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Random.NormalFormBlocks +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Random.Random +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Random.CoefficientRandom +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Random.SupportRandom +public import LeanPool.ConwayRefinement.ConwayRefinement.LinearAlgebra.IndicatorFinsupp + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalComponentDegree +import Mathlib.Topology.Algebra.Group.Basic +import Mathlib.Topology.Order.Monotone + +/-! +# Randomness of a series passes to its blocks + +Fornasiero, Lavi, L'Innocente and Mantova, *Irreducibility in generalized power series* (2024), +Theorem 1.8, apply Proposition 3.2 to the blocks `b₁, …, bₘ` of a random series +`b = ∑ᵢ bᵢ t^{γᵢ} + r`, which requires `Q(b₁, …, bₘ)`, hence the mutual randomness of the +blocks. The source does not write this step; it is carried out here. + +Coefficient clause: every coefficient of a block is a coefficient of `b`, since the blocks +`bᵢ t^{γᵢ}` occupy disjoint parts of the support of `b`; the joint coefficient family of the +blocks is a subfamily of the coefficient family of `b`, indexed injectively. + +Support clause: `cl(supp bᵢ) = cl(supp (bᵢ t^{γᵢ})) - γᵢ`, and `γᵢ ∈ cl(supp b)`. Two distinct +blocks cannot share a nonzero point `z` of their support closures, for `z + γᵢ`, `z + γⱼ`, +`γᵢ`, `γⱼ` would then satisfy a `ℚ`-relation in `cl(supp b) ∖ {0}` forcing `γᵢ = γⱼ`. A vanishing +`ℚ`-combination of elements `z` of `⋃ᵢ cl(supp bᵢ) ∖ {0}` lifts to the free module on +`cl(supp b) ∖ {0}` as a combination of `e(z + γ_{i(z)}) - e(γ_{i(z)})`; evaluated at the +smallest point `z₀ + γ_{i(z₀)}` occurring, only the coefficient of `z₀` survives, because +`γ_{i(z)} > z + γ_{i(z)}` for every `z`, and `z ↦ z + γ_{i(z)}` is injective. +-/ + +open scoped HahnSeries NatOrdinal + +universe v + +public noncomputable section + +namespace FLLM24 + +open Berarducci HahnSeries HahnSeries.Nonpositive + +variable {K : Type v} [Field K] + +namespace BlockDecomposition + +variable {b : Series K} {n m : ℕ} (d : BlockDecomposition b n m) + +/-! ### Supports of the pieces -/ + +/-- The supports of two distinct pieces are disjoint. -/ +theorem piece_disjoint {i j : Fin m} (hij : i ≠ j) {x : ℝ} + (hx : x ∈ ((d.piece i : Series K) : K⟦ℝ⟧).support) : + x ∉ ((d.piece j : Series K) : K⟦ℝ⟧).support := by + intro hx' + rcases lt_or_gt_of_ne hij with h | h + · exact lt_irrefl x (d.piece_support_lt h hx hx') + · exact lt_irrefl x (d.piece_support_lt h hx' hx) + +/-- The coefficient of `b` at a support point of the `i`-th piece is the coefficient of that +piece. -/ +theorem coeff_eq_coeff_piece (i : Fin m) {x : ℝ} + (hx : x ∈ ((d.piece i : Series K) : K⟦ℝ⟧).support) : + (b : K⟦ℝ⟧).coeff x = ((d.piece i : Series K) : K⟦ℝ⟧).coeff x := by + classical + have hsum := congrArg (fun c : Series K ↦ (c : K⟦ℝ⟧).coeff x) d.eq_sum_piece_add_rest + simp only [Subring.coe_add, AddSubmonoidClass.coe_finsetSum, HahnSeries.coeff_add, + HahnSeries.coeff_sum] at hsum + rw [hsum, Finset.sum_eq_single i] + · have hrest : ((d.rest : Series K) : K⟦ℝ⟧).coeff x = 0 := by + by_contra hne + exact lt_irrefl x (d.piece_support_lt_rest i hx hne) + rw [hrest, add_zero] + · intro j _ hji + by_contra hne + exact d.piece_disjoint hji.symm hx hne + · intro h + exact absurd (Finset.mem_univ i) h + +/-- The support of each piece is contained in the support of `b`. -/ +theorem support_piece_subset (i : Fin m) : + ((d.piece i : Series K) : K⟦ℝ⟧).support ⊆ (b : K⟦ℝ⟧).support := by + intro x hx + rw [HahnSeries.mem_support, d.coeff_eq_coeff_piece i hx] + exact hx + +/-- The coefficient of a block is the coefficient of its piece at the translated exponent. -/ +theorem coeff_block (i : Fin m) (y : ℝ) : + ((d.block i : Series K) : K⟦ℝ⟧).coeff y = + ((d.piece i : Series K) : K⟦ℝ⟧).coeff (d.exponent i + y) := by + rw [d.coe_piece, coeff_translate, add_sub_cancel_left] + +/-- The support of a piece is the translate of the support of its block. -/ +theorem support_piece (i : Fin m) : + ((d.piece i : Series K) : K⟦ℝ⟧).support = (d.exponent i + ·) '' ((d.block i : Series K) : + K⟦ℝ⟧).support := by + rw [d.coe_piece, support_translate] + +/-- The closure of the support of a piece is the translate of the closure of the support of its +block. -/ +theorem closure_support_piece (i : Fin m) : + closure ((d.piece i : Series K) : K⟦ℝ⟧).support = + (d.exponent i + ·) '' closure ((d.block i : Series K) : K⟦ℝ⟧).support := by + rw [d.support_piece] + exact ((Homeomorph.addLeft (d.exponent i)).image_closure _).symm + +/-- The exponent of a block lies in the closure of the support of its piece. -/ +theorem exponent_mem_closure (i : Fin m) : + d.exponent i ∈ closure ((d.piece i : Series K) : K⟦ℝ⟧).support := by + rw [d.closure_support_piece] + refine ⟨0, ?_, add_zero _⟩ + have hsup := (d.block_isPrincipal i).supportSup_eq_zero + rw [supportSup_of_ne (d.block_isPrincipal i).ne_zero] at hsup + have h0 : sSup ((d.block i : Series K) : K⟦ℝ⟧).support = 0 := WithBot.coe_inj.mp hsup + rw [← h0] + exact csSup_mem_closure (support_nonempty_iff.mpr (by + intro h; exact (d.block_isPrincipal i).ne_zero (Subtype.ext h))) (bddAbove_support _) + +/-- Points of the closure of a later piece are at least the exponent of an earlier block. -/ +theorem exponent_le_of_mem_closure_piece {i j : Fin m} (hij : i < j) {y : ℝ} + (hy : y ∈ closure ((d.piece j : Series K) : K⟦ℝ⟧).support) : d.exponent i ≤ y := by + have hsub : ((d.piece j : Series K) : K⟦ℝ⟧).support ⊆ Set.Ici (d.exponent i) := by + intro y' hy' + have hbound : ((d.piece i : Series K) : K⟦ℝ⟧).support ⊆ Set.Iic y' := + fun x hx ↦ (d.piece_support_lt hij hx hy').le + exact closure_minimal hbound isClosed_Iic (d.exponent_mem_closure i) + exact closure_minimal hsub isClosed_Ici hy + +/-- Points of the closure of the support of a block are nonpositive. -/ +theorem nonpos_of_mem_closure_block (i : Fin m) {z : ℝ} + (hz : z ∈ closure ((d.block i : Series K) : K⟦ℝ⟧).support) : z ≤ 0 := + closure_minimal (support_subset (d.block i)) isClosed_Iic hz + +/-- A point of the closure of the support of a block, translated by the exponent, lies in the +closure of the support of `b`. -/ +theorem add_mem_closure_support (i : Fin m) {z : ℝ} + (hz : z ∈ closure ((d.block i : Series K) : K⟦ℝ⟧).support) : + d.exponent i + z ∈ closure (b : K⟦ℝ⟧).support := by + apply closure_mono (d.support_piece_subset i) + rw [d.closure_support_piece] + exact ⟨z, hz, rfl⟩ + +/-- Two distinct blocks have no common nonzero point in their support closures translated into +position: `γᵢ + z = γⱼ + z'` with `z, z' ≠ 0` forces `i = j`. -/ +theorem eq_of_exponent_add_eq {i j : Fin m} {z z' : ℝ} + (hz : z ∈ closure ((d.block i : Series K) : K⟦ℝ⟧).support) + (hz' : z' ∈ closure ((d.block j : Series K) : K⟦ℝ⟧).support) (hz0 : z ≠ 0) (hz0' : z' ≠ 0) + (h : d.exponent i + z = d.exponent j + z') : i = j := by + by_contra hij + rcases lt_or_gt_of_ne hij with hlt | hlt + · have hmem : d.exponent j + z' ∈ closure ((d.piece j : Series K) : K⟦ℝ⟧).support := by + rw [d.closure_support_piece]; exact ⟨z', hz', rfl⟩ + have hge := d.exponent_le_of_mem_closure_piece hlt hmem + have hzneg : z < 0 := lt_of_le_of_ne (d.nonpos_of_mem_closure_block i hz) hz0 + linarith + · have hmem : d.exponent i + z ∈ closure ((d.piece i : Series K) : K⟦ℝ⟧).support := by + rw [d.closure_support_piece]; exact ⟨z, hz, rfl⟩ + have hge := d.exponent_le_of_mem_closure_piece hlt hmem + have hzneg : z' < 0 := lt_of_le_of_ne (d.nonpos_of_mem_closure_block j hz') hz0' + linarith + +/-! ### The coefficient clause -/ + +/-- The blocks of a series with algebraically independent coefficients have jointly +algebraically independent coefficients. -/ +theorem isMutuallyCoefficientRandom_block [CharZero K] (hb : IsCoefficientRandom b) : + IsMutuallyCoefficientRandom d.block := by + apply IsMutuallyCoefficientRandom.of + have hpiece : ∀ p : coefficientIndex d.block, + d.exponent p.1.1 + p.1.2 ∈ ((d.piece p.1.1 : Series K) : K⟦ℝ⟧).support := by + intro p + rw [HahnSeries.mem_support, ← d.coeff_block] + exact (mem_coefficientIndex_iff d.block p.1).mp p.2 + have hcoeff : ∀ p : coefficientIndex d.block, + ((d.block p.1.1 : Series K) : K⟦ℝ⟧).coeff p.1.2 = + (b : K⟦ℝ⟧).coeff (d.exponent p.1.1 + p.1.2) := fun p ↦ by + rw [d.coeff_eq_coeff_piece _ (hpiece p), d.coeff_block] + let f : coefficientIndex d.block → (b : K⟦ℝ⟧).support := fun p ↦ + ⟨d.exponent p.1.1 + p.1.2, by + rw [HahnSeries.mem_support, ← hcoeff p] + exact (mem_coefficientIndex_iff d.block p.1).mp p.2⟩ + have hf : Function.Injective f := by + intro p q hpq + have h : d.exponent p.1.1 + p.1.2 = d.exponent q.1.1 + q.1.2 := congrArg Subtype.val hpq + have hij : p.1.1 = q.1.1 := by + by_contra hne + exact d.piece_disjoint hne (hpiece p) (h ▸ hpiece q) + apply Subtype.ext + apply Prod.ext hij + rw [hij] at h + exact add_left_cancel h + have := hb.algebraicIndependent.comp f hf + convert this using 1 + funext p + exact hcoeff p + +/-! ### The support clause -/ + +/-- The blocks of a series with `ℚ`-linearly independent support closure satisfy the support +clause of mutual randomness. -/ +theorem isMutuallySupportRandom_block (hb : IsSupportRandom b) : + IsMutuallySupportRandom d.block := by + classical + set L := supportClosure b with hL + set T := Finsupp.linearCombination ℚ (fun z : L ↦ (z : ℝ)) with hT + have hinjL : Function.Injective T := + linearIndependent_iff_injective_finsuppLinearCombination.mp hb.linearIndependent + -- Translated closure points and exponents as elements of `L`. + have hmemL : ∀ (i : Fin m) {z : ℝ}, z ∈ closure ((d.block i : Series K) : K⟦ℝ⟧).support → + z ≠ 0 → d.exponent i + z ∈ L := by + intro i z hz hz0 + refine (mem_supportClosure_iff b _).mpr ⟨d.add_mem_closure_support i hz, ?_⟩ + have hzneg : z < 0 := lt_of_le_of_ne (d.nonpos_of_mem_closure_block i hz) hz0 + linarith [d.exponent_nonpos i] + have hγcomb : ∀ i : Fin m, T (L.indicatorFinsupp ℚ (d.exponent i)) = d.exponent i := by + intro i + rcases eq_or_ne (d.exponent i) 0 with h0 | h0 + · rw [h0]; exact L.linearCombination_indicatorFinsupp_zero ℚ + · exact L.linearCombination_indicatorFinsupp_of_mem ℚ ((mem_supportClosure_iff b _).mpr + ⟨closure_mono (d.support_piece_subset i) (d.exponent_mem_closure i), h0⟩) + refine ⟨fun i j hij z hz ↦ ?_, ?_⟩ + · -- A common nonzero point of two support closures gives a relation in `L`. + obtain ⟨hzi, hzj⟩ := hz + by_contra hz0' + have hz0 : z ≠ 0 := fun h ↦ hz0' (Set.mem_singleton_iff.mpr h) + have hxL := hmemL i hzi hz0 + have hx'L := hmemL j hzj hz0 + have hrel : L.indicatorFinsupp ℚ (d.exponent i + z) + L.indicatorFinsupp ℚ (d.exponent j) = + L.indicatorFinsupp ℚ (d.exponent j + z) + L.indicatorFinsupp ℚ (d.exponent i) := by + apply hinjL + rw [map_add, map_add, L.linearCombination_indicatorFinsupp_of_mem ℚ hxL, + L.linearCombination_indicatorFinsupp_of_mem ℚ hx'L, hγcomb, hγcomb] + ring + have hpos : 0 < (L.indicatorFinsupp ℚ (d.exponent i + z) + + L.indicatorFinsupp ℚ (d.exponent j)) ⟨_, hxL⟩ := by + rw [Finsupp.add_apply, L.indicatorFinsupp_apply_self hxL] + linarith [L.indicatorFinsupp_apply_nonneg (R := ℚ) (d.exponent j) ⟨_, hxL⟩] + rw [hrel, Finsupp.add_apply] at hpos + have hγi : L.indicatorFinsupp ℚ (d.exponent i) ⟨_, hxL⟩ = 0 := by + apply L.indicatorFinsupp_apply_of_ne + intro heq + exact hz0 (by simp only at heq; linarith) + rw [hγi, add_zero] at hpos + have heq : d.exponent i + z = d.exponent j + z := by + by_contra hne + rw [L.indicatorFinsupp_apply_of_ne _ _ hne] at hpos + exact lt_irrefl _ hpos + exact hij (d.exponent_strictMono.injective (add_right_cancel heq)) + · -- A vanishing combination of the translated points, tested at the smallest point. + rw [linearIndependent_iff'] + intro s g hsum z₀ hz₀ + by_contra hg₀ + set S := s.filter (fun z ↦ g z ≠ 0) with hS + have hz₀S : z₀ ∈ S := Finset.mem_filter.mpr ⟨hz₀, hg₀⟩ + have hgS : ∀ z ∈ S, g z ≠ 0 := fun z hz ↦ (Finset.mem_filter.mp hz).2 + have hidx : ∀ z : supportClosureUnion d.block, + ∃ i, (z : ℝ) ∈ closure ((d.block i : Series K) : K⟦ℝ⟧).support := fun z ↦ + ((mem_supportClosureUnion_iff d.block z).mp z.2).1 + choose idx hidx using hidx + have hzne : ∀ z : supportClosureUnion d.block, (z : ℝ) ≠ 0 := fun z ↦ + ((mem_supportClosureUnion_iff d.block z).mp z.2).2 + have hzneg : ∀ z : supportClosureUnion d.block, (z : ℝ) < 0 := fun z ↦ + lt_of_le_of_ne (d.nonpos_of_mem_closure_block (idx z) (hidx z)) (hzne z) + set ψ : supportClosureUnion d.block → ℝ := fun z ↦ d.exponent (idx z) + z with hψ + have hψL : ∀ z, ψ z ∈ L := fun z ↦ hmemL (idx z) (hidx z) (hzne z) + have hψinj : Function.Injective ψ := by + intro z z' h + have hij := d.eq_of_exponent_add_eq (hidx z) (hidx z') (hzne z) (hzne z') h + apply Subtype.ext + simp only [hψ] at h + rw [hij] at h + exact add_left_cancel h + have hψlt : ∀ z, ψ z < d.exponent (idx z) := fun z ↦ by + simp only [hψ]; linarith [hzneg z] + obtain ⟨z₁, hz₁S, hmin⟩ := S.exists_min_image ψ ⟨z₀, hz₀S⟩ + have hz₁s : z₁ ∈ s := (Finset.mem_filter.mp hz₁S).1 + -- The lifted relation in the free module on `L`. + set F : L →₀ ℚ := ∑ z ∈ s, g z • + (L.indicatorFinsupp ℚ (ψ z) - L.indicatorFinsupp ℚ (d.exponent (idx z))) with hF + have hTF : T F = 0 := by + rw [hF, map_sum, ← hsum] + refine Finset.sum_congr rfl fun z _ ↦ ?_ + rw [map_smul, map_sub, L.linearCombination_indicatorFinsupp_of_mem ℚ (hψL z), hγcomb] + simp only [hψ, add_sub_cancel_left] + have hF0 : F = 0 := hinjL (by rw [hTF, map_zero]) + have hval := congrArg (fun f : L →₀ ℚ ↦ f ⟨ψ z₁, hψL z₁⟩) hF0 + simp only [hF, Finsupp.finsetSum_apply, Finsupp.smul_apply, Finsupp.sub_apply, + Finsupp.zero_apply, smul_eq_mul] at hval + rw [Finset.sum_eq_single z₁] at hval + · rw [L.indicatorFinsupp_apply_self (hψL z₁), + L.indicatorFinsupp_apply_of_ne _ _ (hψlt z₁).ne, sub_zero, mul_one] at hval + exact hgS z₁ hz₁S hval + · intro z hz hne + by_cases hgz : g z = 0 + · rw [hgz, zero_mul] + · have hzS : z ∈ S := Finset.mem_filter.mpr ⟨hz, hgz⟩ + rw [L.indicatorFinsupp_apply_of_ne _ _ (fun h ↦ hne (hψinj h).symm), + L.indicatorFinsupp_apply_of_ne _ _ ((hmin z hzS).trans_lt (hψlt z)).ne, sub_zero, + mul_zero] + · intro h + exact absurd hz₁s h + +/-! ### Hereditary `rv_J`-independence of the blocks -/ + +/-- The blocks of a random series of order type `ω^n · m + β` are hereditarily +`rv_J`-independent at degree `n ≥ 1`. -/ +theorem hereditarilyRVIndependent_block [CharZero K] (hn : 1 ≤ n) (hb : IsRandom b) : + HereditarilyRVIndependent n d.block := by + have hval : ∀ i, ordinalValue (d.block i) = ω^ (n : NatOrdinal) := fun i ↦ + ordinalValue_eq_wpow_of_isPrincipal (d.block_isPrincipal i) (d.block_degree i) + rcases (isRandom_iff b).mp hb with hsupp | hcoeff + · exact (d.isMutuallySupportRandom_block hsupp).hereditarilyRVIndependent hn hval + · exact (d.isMutuallyCoefficientRandom_block hcoeff).hereditarilyRVIndependent hn hval + +end BlockDecomposition + +end FLLM24 + +end diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Random/ReducibleSpan.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Random/ReducibleSpan.lean new file mode 100644 index 0000000000..1e3e7f6aa5 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Random/ReducibleSpan.lean @@ -0,0 +1,313 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Random.HereditaryIndependence +public import Mathlib.LinearAlgebra.Quotient.Basic + +import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.DegreeSum +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValueImage +import Mathlib.LinearAlgebra.Finsupp.LinearCombination +import Mathlib.LinearAlgebra.LinearIndependent.Basic + +/-! +# The space of reducible classes and the property `(*)_α` + +Fornasiero, Lavi, L'Innocente and Mantova, *Irreducibility in generalized power series* (2024), +Definition 4.1, let `R_α` be the set of products `bc` of two principal series not in `K` with +`deg_J(bc) = α`, and `A_α := J_α + Span_K(R_α)`. Property `(*)_α` says: whenever `b_1, …, b_n` +in `P_α` are hereditarily `rv_J`-independent, they are `K`-linearly independent over `A_α`. + +This module states `(*)_α` in `P̂`. The class map `rv_J` sends +`J_{ω^(α+1)}` onto the homogeneous component `P_α` with kernel `J_α = J_{ω^α}`, and it sends +`R_α` onto the +products of two homogeneous classes of positive grades `β, γ` with `β + γ = α`. Hence, for series +in `J_{ω^(α+1)}`, membership in `A_α` is the same as membership of the grade-`α` class in + +`D_α := Span_K { X · Y : X ∈ P_β, Y ∈ P_γ, β, γ > 0, β + γ = α }`, + +and `K`-linear independence over `A_α` is linear independence of the classes modulo `D_α`. Two +repairs of the printed statement are built in. First, `(*)_α` quantifies over all series of +ordinal-value degree `α`, not only the principal ones: the inductive step of the source applies +`(*)_α` to translated truncations, which need not be principal. Second, the classes are compared +modulo `D_α` rather than the series modulo `A_α`; this is the same condition for series of degree +`α`, and it is the form in which the induction is carried out. + +The total map `gradeClass α` sends a series of `J_{ω^(α+1)}` to its class in grade `α` and every +other series to zero; it is the map `rv_J^α : J_{α+1} → RV_J^α` of the source extended by zero. +-/ + +open scoped DirectSum HahnSeries NatOrdinal + +universe v + +public noncomputable section + +namespace FLLM24 + +open Berarducci + +variable {K : Type v} [Field K] + +/-! ### The class of a series in a fixed grade -/ + +/-- The class of `c` in grade `α` of `P̂`: the image of `c ∈ J_{ω^(α+1)}` in +`P_α = J_{ω^(α+1)} / J_{ω^α}`, and zero when `c ∉ J_{ω^(α+1)}`. -/ +def gradeClass (α : NatOrdinal) (c : Series K) : PrincipalSubring K := + if h : ordinalValue c < ω^ (α + 1) then + DirectSum.of (PrincipalComponent K) α (principalComponentMk α c h) + else + 0 + +theorem gradeClass_of_lt {α : NatOrdinal} {c : Series K} (h : ordinalValue c < ω^ (α + 1)) : + gradeClass α c = DirectSum.of (PrincipalComponent K) α (principalComponentMk α c h) := by + rw [gradeClass, dite_eq_left h] + +theorem gradeClass_eq_homogeneousMk {α : NatOrdinal} {c : Series K} + (h : ordinalValue c < ω^ (α + 1)) : + gradeClass α c = (ordinalValueDegreeValuation K).homogeneousMk α + ⟨c, (mem_ordinalValueDegreeValuation_filtrationLE_iff c α).mpr h⟩ := by + rw [gradeClass_of_lt h, principalComponentMk_eq_componentMk, MaxAddDegree.homogeneousMk_apply] + +/-- A series of ordinal value below `ω^α` has zero class in grade `α`. -/ +theorem gradeClass_eq_zero_of_lt {α : NatOrdinal} {c : Series K} (h : ordinalValue c < ω^ α) : + gradeClass α c = 0 := by + have h' : ordinalValue c < ω^ (α + 1) := + h.trans (NatOrdinal.wpow_lt_wpow.mpr (lt_add_one α)) + rw [gradeClass_of_lt h', (principalComponentMk_eq_zero_iff α c h').mpr h, map_zero] + +/-- For `c ∈ J_{ω^(α+1)}`, the class of `c` in grade `α` vanishes exactly when `c ∈ J_{ω^α}`. -/ +theorem gradeClass_eq_zero_iff {α : NatOrdinal} {c : Series K} (h : ordinalValue c < ω^ (α + 1)) : + gradeClass α c = 0 ↔ ordinalValue c < ω^ α := by + rw [gradeClass_of_lt h] + constructor + · intro hzero + exact (principalComponentMk_eq_zero_iff α c h).mp + (DirectSum.of_injective α (by simpa using hzero)) + · intro hlt + rw [(principalComponentMk_eq_zero_iff α c h).mpr hlt, map_zero] + +/-- At ordinal value exactly `ω^α`, the grade-`α` class is `rv_J`. -/ +theorem rvJ_eq_gradeClass {α : NatOrdinal} {c : Series K} (h : ordinalValue c = ω^ α) : + rvJ c = gradeClass α c := by + rw [rvJ_eq_homogeneousMk h, + gradeClass_eq_homogeneousMk (h ▸ NatOrdinal.wpow_lt_wpow.mpr (lt_add_one α))] + +/-- At ordinal value exactly `ω^α`, the class `rv_J(c)` is nonzero. -/ +theorem rvJ_ne_zero_of_eq {α : NatOrdinal} {c : Series K} (h : ordinalValue c = ω^ α) : + rvJ c ≠ 0 := by + rw [rvJ_eq_gradeClass h, Ne, gradeClass_eq_zero_iff (h ▸ NatOrdinal.wpow_lt_wpow.mpr + (lt_add_one α)), h] + exact lt_irrefl _ + +/-- For `c ∈ J_{ω^(α+1)}` the grade-`α` class is nonzero exactly when `v_J(c) = ω^α`. -/ +theorem ordinalValue_eq_of_gradeClass_ne_zero {α : NatOrdinal} {c : Series K} + (h : ordinalValue c < ω^ (α + 1)) (hne : gradeClass α c ≠ 0) : + ordinalValue c = ω^ α := by + have hnot : ¬ ordinalValue c < ω^ α := fun hlt ↦ hne (gradeClass_eq_zero_of_lt hlt) + rcases ordinalValue_eq_zero_or_isAdditivelyPrincipal c with hzero | hprin + · exact absurd (hzero ▸ NatOrdinal.wpow_pos α) hnot + · have hxi := Ordinal.natOrdinal_of_eq_wpow_log hprin + rw [NatOrdinal.of_val] at hxi + rw [hxi] at hnot h ⊢ + congr 1 + exact le_antisymm (Order.lt_add_one_iff.mp (NatOrdinal.wpow_lt_wpow.mp h)) + (le_of_not_gt fun hlt ↦ hnot (NatOrdinal.wpow_lt_wpow.mpr hlt)) + +/-- A series of `J_{ω^(α+1)}` has ordinal value `ω^α` or lies in `J_{ω^α}`. -/ +theorem ordinalValue_eq_or_lt_of_lt_wpow_add_one {α : NatOrdinal} {c : Series K} + (h : ordinalValue c < ω^ (α + 1)) : + ordinalValue c = ω^ α ∨ ordinalValue c < ω^ α := by + by_cases hne : gradeClass α c = 0 + · exact Or.inr ((gradeClass_eq_zero_iff h).mp hne) + · exact Or.inl (ordinalValue_eq_of_gradeClass_ne_zero h hne) + +/-- The grade-`α` class is additive on `J_{ω^(α+1)}`. -/ +theorem gradeClass_add {α : NatOrdinal} {b c : Series K} + (hb : ordinalValue b < ω^ (α + 1)) (hc : ordinalValue c < ω^ (α + 1)) : + gradeClass α (b + c) = gradeClass α b + gradeClass α c := by + have hbc : ordinalValue (b + c) < ω^ (α + 1) := + (ordinalValue_add_le_max b c).trans_lt (max_lt hb hc) + rw [gradeClass_eq_homogeneousMk hb, gradeClass_eq_homogeneousMk hc, + gradeClass_eq_homogeneousMk hbc, ← map_add] + rfl + +/-- The grade-`α` class of a constant multiple is the scalar multiple of the class. -/ +theorem gradeClass_C_mul {α : NatOrdinal} (k : K) {c : Series K} + (hc : ordinalValue c < ω^ (α + 1)) : + gradeClass α ((HahnSeries.Nonpositive.C : K →+* Series K) k * c) = k • gradeClass α c := by + have hkc : ordinalValue ((HahnSeries.Nonpositive.C : K →+* Series K) k * c) < ω^ (α + 1) := by + simpa only [zero_add] using + ordinalValue_mul_lt_wpow_add_one (ordinalValue_C_lt_wpow_one k) hc + rw [gradeClass_of_lt hkc, gradeClass_of_lt hc, ← DirectSum.of_smul, smul_principalComponentMk] + +/-- A finite sum of series of `J_{ω^(α+1)}` lies in `J_{ω^(α+1)}`. -/ +theorem ordinalValue_sum_lt_wpow_add_one {α : NatOrdinal} {ι : Type*} (s : Finset ι) + (f : ι → Series K) (hf : ∀ i ∈ s, ordinalValue (f i) < ω^ (α + 1)) : + ordinalValue (∑ i ∈ s, f i) < ω^ (α + 1) := by + rw [← ordinalValueDegree_le_coe_iff, ← ordinalValueDegreeValuation_apply] + refine MaxAddDegree.map_sum_le_of_forall_le (ordinalValueDegreeValuation K) s f _ + fun i hi ↦ ?_ + rw [ordinalValueDegreeValuation_apply, ordinalValueDegree_le_coe_iff] + exact hf i hi + +/-- The grade-`α` class of a finite sum of series in `J_{ω^(α+1)}`. -/ +theorem gradeClass_sum {α : NatOrdinal} {ι : Type*} (s : Finset ι) (f : ι → Series K) + (hf : ∀ i ∈ s, ordinalValue (f i) < ω^ (α + 1)) : + gradeClass α (∑ i ∈ s, f i) = ∑ i ∈ s, gradeClass α (f i) := by + classical + induction s using Finset.induction_on with + | empty => + rw [Finset.sum_empty, Finset.sum_empty] + exact gradeClass_eq_zero_of_lt (by rw [ordinalValue_zero]; exact NatOrdinal.wpow_pos α) + | insert a s ha ih => + have hsum : ordinalValue (∑ i ∈ s, f i) < ω^ (α + 1) := + ordinalValue_sum_lt_wpow_add_one s f fun i hi ↦ hf i (Finset.mem_insert_of_mem hi) + rw [Finset.sum_insert ha, Finset.sum_insert ha, + gradeClass_add (hf a (Finset.mem_insert_self a s)) hsum, + ih fun i hi ↦ hf i (Finset.mem_insert_of_mem hi)] + +/-- The grade-`α` class of a difference of series in `J_{ω^(α+1)}`. -/ +theorem gradeClass_sub {α : NatOrdinal} {b c : Series K} + (hb : ordinalValue b < ω^ (α + 1)) (hc : ordinalValue c < ω^ (α + 1)) : + gradeClass α (b - c) = gradeClass α b - gradeClass α c := by + have hbc : ordinalValue (b - c) < ω^ (α + 1) := by + rw [sub_eq_add_neg] + exact (ordinalValue_add_le_max b (-c)).trans_lt (max_lt hb (by rwa [ordinalValue_neg])) + rw [eq_sub_iff_add_eq, ← gradeClass_add hbc hc, sub_add_cancel] + +/-- The grade-`(α + β)` class of a product is the product of the grade classes. -/ +theorem gradeClass_mul {α β : NatOrdinal} {b c : Series K} + (hb : ordinalValue b < ω^ (α + 1)) (hc : ordinalValue c < ω^ (β + 1)) : + gradeClass (α + β) (b * c) = gradeClass α b * gradeClass β c := by + rw [gradeClass_of_lt (ordinalValue_mul_lt_wpow_add_one hb hc), gradeClass_of_lt hb, + gradeClass_of_lt hc, ← principalComponentMul_mk, principalComponentMul_eq_componentMul, + DirectSum.of_mul_of] + rfl + +/-- Series of `J_{ω^(α+1)}` congruent modulo `J_{ω^α}` have the same grade-`α` class. -/ +theorem gradeClass_eq_of_sub_lt {α : NatOrdinal} {b c : Series K} + (hb : ordinalValue b < ω^ (α + 1)) (hc : ordinalValue c < ω^ (α + 1)) + (h : ordinalValue (b - c) < ω^ α) : + gradeClass α b = gradeClass α c := by + rw [gradeClass_of_lt hb, gradeClass_of_lt hc, (principalComponentMk_eq_iff α b c hb hc).mpr h] + +/-- The grade-`α` class lives in grade `α`: it is the inclusion of its `α`-component. -/ +theorem gradeClass_eq_of_apply (α : NatOrdinal) (c : Series K) : + gradeClass α c = DirectSum.of (PrincipalComponent K) α (gradeClass α c α) := by + by_cases h : ordinalValue c < ω^ (α + 1) + · rw [gradeClass_of_lt h, DirectSum.of_eq_same] + · rw [gradeClass, dite_eq_right h, DirectSum.zero_apply, map_zero] + +/-! ### The reducible span -/ + +variable (K) in +/-- FLLM24, Definition 4.1, in `P̂`: the `K`-span `D_α` of the products of two homogeneous +classes of positive grades `β, γ` with `β + γ = α`. It is the image `rv_J(R_α)`'s span, and +`c ∈ J_{ω^(α+1)}` lies in `A_α = J_α + Span_K(R_α)` exactly when its grade-`α` class lies in +`D_α`. -/ +def decomposableSpan (α : NatOrdinal) : Submodule K (PrincipalSubring K) := + Submodule.span K + {z | ∃ (β γ : NatOrdinal) (x : PrincipalComponent K β) (y : PrincipalComponent K γ), + 0 < β ∧ 0 < γ ∧ β + γ = α ∧ + z = DirectSum.of (PrincipalComponent K) β x * + DirectSum.of (PrincipalComponent K) γ y} + +theorem of_mul_of_mem_decomposableSpan {β γ : NatOrdinal} (hβ : 0 < β) (hγ : 0 < γ) + (x : PrincipalComponent K β) (y : PrincipalComponent K γ) : + DirectSum.of (PrincipalComponent K) β x * DirectSum.of (PrincipalComponent K) γ y ∈ + decomposableSpan K (β + γ) := + Submodule.subset_span ⟨β, γ, x, y, hβ, hγ, rfl, rfl⟩ + +/-- The grade class of a product of series of positive degrees `β, γ` lies in `D_{β+γ}`. -/ +theorem gradeClass_mul_mem_decomposableSpan {β γ : NatOrdinal} (hβ : 0 < β) (hγ : 0 < γ) + {b c : Series K} (hb : ordinalValue b < ω^ (β + 1)) (hc : ordinalValue c < ω^ (γ + 1)) : + gradeClass (β + γ) (b * c) ∈ decomposableSpan K (β + γ) := by + rw [gradeClass_mul hb hc, gradeClass_of_lt hb, gradeClass_of_lt hc] + exact of_mul_of_mem_decomposableSpan hβ hγ _ _ + +/-- Every element of `D_α` is a finite combination of grade-`α` classes of products `u v` of +series of positive ordinal-value degrees `β, γ` with `β + γ = α`. -/ +theorem exists_sum_of_mem_decomposableSpan {α : NatOrdinal} {z : PrincipalSubring K} + (hz : z ∈ decomposableSpan K α) : + ∃ (m : ℕ) (μ : Fin m → K) (β γ : Fin m → NatOrdinal) (u w : Fin m → Series K), + (∀ k, 0 < β k ∧ 0 < γ k ∧ β k + γ k = α ∧ + ordinalValue (u k) < ω^ (β k + 1) ∧ ordinalValue (w k) < ω^ (γ k + 1)) ∧ + z = ∑ k, μ k • gradeClass α (u k * w k) := by + rw [decomposableSpan, Submodule.mem_span_set'] at hz + obtain ⟨m, μ, g, hsum⟩ := hz + have hrep : ∀ k : Fin m, ∃ (β γ : NatOrdinal) (u w : Series K), + 0 < β ∧ 0 < γ ∧ β + γ = α ∧ ordinalValue u < ω^ (β + 1) ∧ ordinalValue w < ω^ (γ + 1) ∧ + (g k : PrincipalSubring K) = gradeClass α (u * w) := by + intro k + obtain ⟨β, γ, x, y, hβ, hγ, hβγ, hz⟩ := (g k).2 + obtain ⟨u, hu, rfl⟩ := exists_principalComponentMk β x + obtain ⟨w, hw, rfl⟩ := exists_principalComponentMk γ y + refine ⟨β, γ, u, w, hβ, hγ, hβγ, hu, hw, ?_⟩ + rw [hz, ← gradeClass_of_lt hu, ← gradeClass_of_lt hw, ← gradeClass_mul hu hw, hβγ] + choose β γ u w hβ hγ hβγ hu hw hg using hrep + refine ⟨m, μ, β, γ, u, w, fun k ↦ ⟨hβ k, hγ k, hβγ k, hu k, hw k⟩, ?_⟩ + rw [← hsum] + exact Finset.sum_congr rfl fun k _ ↦ by rw [hg k] + +/-- No product of two positive grades is `1`: `D_1 = 0`, FLLM24, Remark 4.2. -/ +theorem decomposableSpan_one : decomposableSpan K 1 = ⊥ := by + rw [decomposableSpan, Submodule.span_eq_bot] + rintro z ⟨β, γ, x, y, hβ, hγ, hβγ, rfl⟩ + exfalso + have h1 : (1 : NatOrdinal) ≤ β := Order.one_le_iff_pos.mpr hβ + have h2 : (1 : NatOrdinal) ≤ γ := Order.one_le_iff_pos.mpr hγ + have h12 : (1 : NatOrdinal) + 1 ≤ β + γ := add_le_add h1 h2 + rw [hβγ] at h12 + exact absurd h12 (not_le.mpr (lt_add_one 1)) + +/-! ### The property `(*)_α` -/ + +variable (K) in +/-- FLLM24, § 4, property `(*)_α` at a finite degree `n`: every hereditarily `rv_J`-independent +family `b` of series with `v_J(b i) = ω^n` has classes `rv_J(b i)` that are `K`-linearly +independent modulo `D_n`, which is the source's "`K`-linearly independent over `A_n`". -/ +def IndependentModuloDecomposable (n : ℕ) : Prop := + ∀ {ι : Type} (b : ι → Series K), HereditarilyRVIndependent n b → + LinearIndependent K (fun i ↦ (decomposableSpan K (n : NatOrdinal)).mkQ (rvJ (b i))) + +/-- Introduction rule for `(*)_n`. -/ +theorem IndependentModuloDecomposable.of {n : ℕ} + (h : ∀ {ι : Type} (b : ι → Series K), HereditarilyRVIndependent n b → + LinearIndependent K (fun i ↦ (decomposableSpan K (n : NatOrdinal)).mkQ (rvJ (b i)))) : + IndependentModuloDecomposable K n := + h + +/-- Elimination rule for `(*)_n`. -/ +theorem IndependentModuloDecomposable.linearIndependent {n : ℕ} + (h : IndependentModuloDecomposable K n) {ι : Type} {b : ι → Series K} + (hb : HereditarilyRVIndependent n b) : + LinearIndependent K (fun i ↦ (decomposableSpan K (n : NatOrdinal)).mkQ (rvJ (b i))) := + h b hb + +/-- FLLM24, Proposition 4.3, for `β = 0`: `(*)_1` holds, because `A_1 = J_1` and hereditary +`rv_J`-independence at degree `1` is linear independence of the classes. -/ +theorem independentModuloDecomposable_one : IndependentModuloDecomposable K 1 := by + intro ι b hb + have hlin := hb.linearIndependent + refine hlin.map' (decomposableSpan K ((1 : ℕ) : NatOrdinal)).mkQ ?_ + rw [Submodule.ker_mkQ, Nat.cast_one, decomposableSpan_one] + +/-- Under `(*)_n`, the class of a single hereditarily `rv_J`-independent series of degree `n` +lies outside `D_n`. -/ +theorem rvJ_notMem_decomposableSpan {n : ℕ} (hstar : IndependentModuloDecomposable K n) + {b : Series K} (hb : HereditarilyRVIndependent n (fun _ : Unit ↦ b)) : + rvJ b ∉ decomposableSpan K (n : NatOrdinal) := by + intro hmem + have hlin := hstar (fun _ : Unit ↦ b) hb + have hne := hlin.ne_zero () + apply hne + rw [Submodule.mkQ_apply, Submodule.Quotient.mk_eq_zero] + exact hmem + +end FLLM24 + +end diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Random/SuccessorStep.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Random/SuccessorStep.lean new file mode 100644 index 0000000000..e35fe76d16 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Random/SuccessorStep.lean @@ -0,0 +1,550 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Random.ReducibleSpan +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.LeibnizRemainder +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.ResidualPoint +public import LeanPool.ConwayRefinement.ConwayRefinement.LinearAlgebra.FiniteSpanRelation + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.ResidualPointCofinality +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValueImage +import Mathlib.Order.ConditionallyCompleteLattice.Finset +import Mathlib.Topology.Instances.Real.Lemmas + +/-! +# The successor step `(*)_α ⇒ (*)_{α+1}` and `(*)_n` for finite `n` + +Fornasiero, Lavi, L'Innocente and Mantova, *Irreducibility in generalized power series* (2024), +Proposition 4.4, and Corollary 4.5 for `α = n < ω` (Remark 4.6). + +Suppose `b = ∑ λ_j b_j ∈ A_{n+1}` with `Q(b_1, …, b_m)` and `λ ≠ 0`; write +`b = ∑ μ_k p_k q_k + r` with `p_k, q_k` of positive degrees `β_k + γ_k = n + 1` and +`r ∈ J_{n+1}`. For `γ < 0` close to zero, Berarducci's Leibniz rule (Proposition 2.10) gives +`b^{|γ} ≡ ∑ μ_k (p_k^{|γ} q_k + p_k q_k^{|γ})` modulo `J_n`, and each term `p_k^{|γ} q_k` lies in +`K q_k + A_n`: its class is `k · rv_J(q_k)` when `p_k^{|γ} ∈ J + K`, and a product of two classes +of positive grades otherwise. So the classes of the `b^{|γ}` lie, modulo `D_n`, in the span of +`2m` fixed vectors. The residual points of `b` are cofinal at zero (Berarducci, Lemma 6.8), so +`2m + 1` of them close to zero give a nontrivial relation `∑ δ_i b^{|γ_i} ∈ A_n`. Expanding +`b^{|γ_i} = ∑ λ_j b_j^{|γ_i}` and discarding the truncations of degree below `n`, Axiom 2 of +`Q(b_1, …, b_m)` makes the remaining truncations hereditarily `rv_J`-independent at degree `n`, +so `(*)_n` forces every coefficient `δ_i λ_j` with `deg_J(b_j^{|γ_i}) = n` to vanish; since each +residual point `γ_i` has some `j` with `λ_j ≠ 0` and `deg_J(b_j^{|γ_i}) = n`, this contradicts +`δ ≠ 0`. + +The source applies `(*)_n` to the translated truncations `b_j^{|γ_i}`, which are not principal +in general; `(*)_n` is therefore stated here for all series of degree `n`, as explained in +`ConwayRefinement.HahnSeries.Factorization.Random.ReducibleSpan`. The representatives `p_k, q_k` +of the classes generating `D_{n+1}` need not be principal either: the Leibniz rule is available +for every series of the relevant ordinal-value cuts. +-/ + +open Filter Topology +open scoped DirectSum HahnSeries NatOrdinal + +universe v + +public noncomputable section + +namespace FLLM24 + +open Berarducci + +variable {K : Type v} [Field K] + +/-- A positive natural ordinal bounded by a natural number has positive constant coefficient. -/ +theorem _root_.NatOrdinal.constantCoeff_pos_of_pos_of_le_natCast {β : NatOrdinal} {m : ℕ} + (hpos : 0 < β) (hle : β ≤ m) : 0 < β.constantCoeff := by + obtain ⟨k, rfl⟩ := NatOrdinal.lt_omega0.mp (hle.trans_lt (NatOrdinal.natCast_lt_omega0 m)) + rw [NatOrdinal.constantCoeff_natCast] + exact Nat.cast_pos.mp hpos + +/-- Translated truncation of a `K`-linear combination of series. -/ +theorem translatedTruncation_sum_C_mul {ι : Type*} (s : Finset ι) (g : ι → K) (b : ι → Series K) + (γ : ℝ) : + translatedTruncation ((∑ i ∈ s, (HahnSeries.Nonpositive.C : K →+* Series K) (g i) * b i : + Series K) : K⟦ℝ⟧) γ = + ∑ i ∈ s, (HahnSeries.Nonpositive.C : K →+* Series K) (g i) * + translatedTruncation (b i : K⟦ℝ⟧) γ := by + rw [← translatedTruncationAddMonoidHom_apply, AddSubmonoidClass.coe_finsetSum, map_sum] + refine Finset.sum_congr rfl fun i _ ↦ ?_ + rw [translatedTruncationAddMonoidHom_apply, Subring.coe_mul, HahnSeries.Nonpositive.coe_C, + translatedTruncation_C_mul] + +/-- FLLM24, proof of Proposition 4.4: if `deg_J(p) = β ≥ 1`, `deg_J(q) = γ ≥ 1` and +`(β - 1) + γ = n`, then for `γ' < 0` close to zero the grade-`n` class of `p^{|γ'} q` lies in +`K · rv_J(q) + D_n`: when `p^{|γ'} ∈ J + K` it is a scalar multiple of the class of `q`, and +otherwise it is a product of two classes of positive grades. -/ +theorem eventually_gradeClass_translatedTruncation_mul_mem {n : ℕ} {β γ : NatOrdinal} + (hβ : 0 < β.constantCoeff) (hγ : 0 < γ) (hsum : β.removeNat 1 + γ = n) + {p q : Series K} (hp : ordinalValue p < ω^ (β + 1)) (hq : ordinalValue q < ω^ (γ + 1)) : + ∀ᶠ γ' in 𝓝[<] (0 : ℝ), + gradeClass (n : NatOrdinal) (translatedTruncation (p : K⟦ℝ⟧) γ' * q) ∈ + (K ∙ gradeClass (n : NatOrdinal) q) ⊔ decomposableSpan K (n : NatOrdinal) := by + have hβ' : β.removeNat 1 + 1 = β := by + simpa using NatOrdinal.removeNat_add_natCast hβ + have hdrop := eventually_ordinalValue_translatedTruncation_lt_wpow_of_ordinalValue_lt_wpow_add_one + β p hp + filter_upwards [hdrop] with γ' hγ' + set w := translatedTruncation (p : K⟦ℝ⟧) γ' with hw + rw [← hβ'] at hγ' + rcases eq_or_ne (β.removeNat 1) 0 with hzero | hpos + · -- `w ∈ J + K`: the class of `w q` is a scalar multiple of the class of `q`. + rw [hzero, zero_add] at hsum hγ' + rw [← hsum] + have hwNear : w ∈ nearConstantSubgroup K := by + by_contra hnot + have hlt := one_lt_ordinalValue_iff.mpr hnot + rcases ordinalValue_eq_or_lt_of_lt_wpow_add_one + (α := 0) (by rwa [zero_add]) with hone | hzero' + · rw [NatOrdinal.wpow_zero] at hone + exact absurd hone hlt.ne' + · rw [NatOrdinal.wpow_zero] at hzero' + exact absurd (hzero'.trans hlt) (lt_irrefl _) + obtain ⟨j, hj, k, hjk⟩ := mem_nearConstantSubgroup_iff.mp hwNear + have hjq : gradeClass γ (j * q) = 0 := by + apply gradeClass_eq_zero_of_lt + rw [ordinalValue_of_mem_negativeMonomialIdeal (Ideal.mul_mem_right q _ hj)] + exact NatOrdinal.wpow_pos γ + have hjqcut : ordinalValue (j * q) < ω^ (γ + 1) := by + rw [ordinalValue_of_mem_negativeMonomialIdeal (Ideal.mul_mem_right q _ hj)] + exact NatOrdinal.wpow_pos _ + have hkq : ordinalValue ((HahnSeries.Nonpositive.C : K →+* Series K) k * q) < ω^ (γ + 1) := by + simpa only [zero_add] using + ordinalValue_mul_lt_wpow_add_one (ordinalValue_C_lt_wpow_one k) hq + rw [← hjk, add_mul, gradeClass_add hjqcut hkq, hjq, zero_add, gradeClass_C_mul k hq] + exact Submodule.mem_sup_left (Submodule.mem_span_singleton.mpr ⟨k, rfl⟩) + · -- `w` has positive degree `β - 1`: the class of `w q` is decomposable. + have hmem := gradeClass_mul_mem_decomposableSpan (pos_iff_ne_zero.mpr hpos) hγ hγ' hq + rw [hsum] at hmem + exact Submodule.mem_sup_right hmem + +/-- Berarducci, Lemma 6.8, as used in FLLM24, Proposition 4.4: a series of ordinal value +`ω^(α+1)` has, in every interval `(η, 0)`, as many residual points as desired; at a residual +point the translated truncation has ordinal value `ω^α`. -/ +theorem exists_finset_residualPoints {α : NatOrdinal} {b : Series K} + (hb : ordinalValue b = ω^ (α + 1)) {η : ℝ} (hη : η < 0) (N : ℕ) : + ∃ Γ : Finset ℝ, Γ.card = N ∧ + ∀ γ ∈ Γ, η < γ ∧ γ < 0 ∧ ordinalValue (translatedTruncation (b : K⟦ℝ⟧) γ) = ω^ α := by + have hone : 1 < ordinalValue b := by + rw [hb] + calc (1 : NatOrdinal) = ω^ (0 : NatOrdinal) := NatOrdinal.wpow_zero.symm + _ < ω^ (α + 1) := NatOrdinal.wpow_lt_wpow.mpr + (lt_of_lt_of_le (lt_add_one (0 : NatOrdinal)) + (add_le_add (bot_le : (0 : NatOrdinal) ≤ α) le_rfl)) + let b' : SeriesWithOrdinalValueAboveOne K := ⟨b, hone⟩ + have hres : b'.residualValue = ω^ α := by + have hcoeff : 0 < (α + 1).constantCoeff := by + have h := NatOrdinal.constantCoeff_add_natCast α 1 + rw [Nat.cast_one] at h + rw [h] + exact Nat.succ_pos _ + rw [b'.residualValue_eq_wpow_removeNat_of_ordinalValue_eq_wpow (α + 1) hcoeff hb] + congr 1 + have h := NatOrdinal.removeNat_add_natCast (a := α + 1) (n := 1) (by + have h := NatOrdinal.constantCoeff_add_natCast α 1 + rw [Nat.cast_one] at h + rw [h]; exact Nat.le_add_left 1 _) + rw [Nat.cast_one] at h + exact add_right_cancel h + have hLUB := residualPointSet_isLUB_zero b' + -- Residual points in `(η, 0)` form an infinite set. + have hinf : (residualPointSet b' ∩ Set.Ioo η 0).Infinite := by + intro hfin + let S := residualPointSet b' ∩ Set.Ioo η 0 ∪ {η} + have hSfin : S.Finite := hfin.union (Set.finite_singleton η) + have hSne : S.Nonempty := ⟨η, Set.mem_union_right _ rfl⟩ + have hmem := hSne.csSup_mem hSfin + have hneg : sSup S < 0 := by + rcases hmem with hmem | hmem + · exact hmem.2.2 + · rw [Set.mem_singleton_iff] at hmem + rw [hmem]; exact hη + have hηle : η ≤ sSup S := le_csSup hSfin.bddAbove (Set.mem_union_right _ rfl) + obtain ⟨c, hc, hlt, hc0⟩ := hLUB.exists_between' (zero_not_mem_residualPointSet b') hneg + have hcS : c ∈ S := Set.mem_union_left _ ⟨hc, hηle.trans_lt hlt, hc0⟩ + exact absurd (le_csSup hSfin.bddAbove hcS) (not_le.mpr hlt) + obtain ⟨Γ, hΓ, hcard⟩ := hinf.exists_subset_card_eq N + refine ⟨Γ, hcard, fun γ hγ ↦ ?_⟩ + have hγ' := hΓ hγ + refine ⟨hγ'.2.1, hγ'.2.2, ?_⟩ + rw [← hres] + exact (mem_residualPointSet_iff.mp hγ'.1).2 + +/-- The quotient map by `D` sends `(K · v) + D` into `K · (v mod D)`. -/ +private theorem mkQ_mem_span_singleton_of_mem_sup {V : Type*} [AddCommGroup V] [Module K V] + {D : Submodule K V} {x v : V} (h : x ∈ (K ∙ v) ⊔ D) : D.mkQ x ∈ K ∙ D.mkQ v := by + obtain ⟨y, hy, z, hz, rfl⟩ := Submodule.mem_sup.mp h + obtain ⟨c, rfl⟩ := Submodule.mem_span_singleton.mp hy + have hz0 : D.mkQ z = 0 := by + rw [Submodule.mkQ_apply, Submodule.Quotient.mk_eq_zero] + exact hz + rw [map_add, map_smul, hz0, add_zero] + exact Submodule.mem_span_singleton.mpr ⟨c, rfl⟩ + +/-- Uniform truncation, Leibniz and decomposable-span estimates near zero. -/ +private theorem eventually_successor_decomposition_estimates + {ι : Type*} {n m : ℕ} (β γ : Fin m → NatOrdinal) (u w : Fin m → Series K) + (b : ι → Series K) (T : Finset ι) (r : Series K) + (hk : ∀ k, 0 < β k ∧ 0 < γ k ∧ β k + γ k = (n : NatOrdinal) + 1 ∧ + ordinalValue (u k) < ω^ (β k + 1) ∧ ordinalValue (w k) < ω^ (γ k + 1)) + (hβc : ∀ k, 0 < (β k).constantCoeff) (hγc : ∀ k, 0 < (γ k).constantCoeff) + (hβγ : ∀ k, (β k).removeNat 1 + γ k = n) + (hγβ : ∀ k, (γ k).removeNat 1 + β k = n) + (huw : ∀ k, ordinalValue (u k * w k) < ω^ ((n : NatOrdinal) + 1 + 1)) + (hrlt : ordinalValue r < ω^ ((n : NatOrdinal) + 1)) + (hcut : ∀ i, ordinalValue (b i) < ω^ ((n : NatOrdinal) + 1 + 1)) : ∀ᶠ γ' in 𝓝[<] (0 : ℝ), + (∀ k, ordinalValue (translatedTruncation ((u k * w k : Series K) : K⟦ℝ⟧) γ' - + translatedTruncation (u k : K⟦ℝ⟧) γ' * w k - u k * translatedTruncation (w k : K⟦ℝ⟧) γ') + < ω^ (n : NatOrdinal)) ∧ + (∀ k, gradeClass (n : NatOrdinal) (translatedTruncation (u k : K⟦ℝ⟧) γ' * w k) ∈ + (K ∙ gradeClass (n : NatOrdinal) (w k)) ⊔ decomposableSpan K (n : NatOrdinal)) ∧ + (∀ k, gradeClass (n : NatOrdinal) (translatedTruncation (w k : K⟦ℝ⟧) γ' * u k) ∈ + (K ∙ gradeClass (n : NatOrdinal) (u k)) ⊔ decomposableSpan K (n : NatOrdinal)) ∧ + (∀ k, ordinalValue (translatedTruncation (u k : K⟦ℝ⟧) γ') < ω^ (β k)) ∧ + (∀ k, ordinalValue (translatedTruncation (w k : K⟦ℝ⟧) γ') < ω^ (γ k)) ∧ + (∀ k, ordinalValue (translatedTruncation ((u k * w k : Series K) : K⟦ℝ⟧) γ') < + ω^ ((n : NatOrdinal) + 1)) ∧ + ordinalValue (translatedTruncation (r : K⟦ℝ⟧) γ') < ω^ (n : NatOrdinal) ∧ + (∀ i ∈ T, ordinalValue (translatedTruncation (b i : K⟦ℝ⟧) γ') < + ω^ ((n : NatOrdinal) + 1)) := by + classical + refine Filter.Eventually.and (Filter.eventually_all.mpr fun k ↦ ?_) + (Filter.Eventually.and (Filter.eventually_all.mpr fun k ↦ ?_) + (Filter.Eventually.and (Filter.eventually_all.mpr fun k ↦ ?_) + (Filter.Eventually.and (Filter.eventually_all.mpr fun k ↦ ?_) + (Filter.Eventually.and (Filter.eventually_all.mpr fun k ↦ ?_) + (Filter.Eventually.and (Filter.eventually_all.mpr fun k ↦ ?_) + (Filter.Eventually.and ?_ ((Filter.eventually_all_finset T).mpr fun i _ ↦ ?_))))))) + · have h := eventually_ordinalValue_leibnizRemainder_lt (hβc k) (u k) (w k) + (hk k).2.2.2.1 (hk k).2.2.2.2 + rwa [hβγ k] at h + · exact eventually_gradeClass_translatedTruncation_mul_mem (hβc k) (hk k).2.1 (hβγ k) + (hk k).2.2.2.1 (hk k).2.2.2.2 + · exact eventually_gradeClass_translatedTruncation_mul_mem (hγc k) (hk k).1 (hγβ k) + (hk k).2.2.2.2 (hk k).2.2.2.1 + · exact eventually_ordinalValue_translatedTruncation_lt_wpow_of_ordinalValue_lt_wpow_add_one + (β k) (u k) (hk k).2.2.2.1 + · exact eventually_ordinalValue_translatedTruncation_lt_wpow_of_ordinalValue_lt_wpow_add_one + (γ k) (w k) (hk k).2.2.2.2 + · exact eventually_ordinalValue_translatedTruncation_lt_wpow_of_ordinalValue_lt_wpow_add_one + ((n : NatOrdinal) + 1) (u k * w k) (huw k) + · exact eventually_ordinalValue_translatedTruncation_lt_wpow_of_ordinalValue_lt_wpow_add_one + (n : NatOrdinal) r hrlt + · exact eventually_ordinalValue_translatedTruncation_lt_wpow_of_ordinalValue_lt_wpow_add_one + ((n : NatOrdinal) + 1) (b i) (hcut i) + +/-- The grade of a translated polynomial sum is the sum of its Leibniz contributions. -/ +private theorem gradeClass_translatedTruncation_sum_products + {n m : ℕ} (μ : Fin m → K) (u w : Fin m → Series K) (B r : Series K) (γ' : ℝ) + (hBPr : B = (∑ k, (HahnSeries.Nonpositive.C : K →+* Series K) (μ k) * + (u k * w k)) + r) + (hE1 : ∀ k, ordinalValue (translatedTruncation ((u k * w k : Series K) : K⟦ℝ⟧) γ' - + translatedTruncation (u k : K⟦ℝ⟧) γ' * w k - + u k * translatedTruncation (w k : K⟦ℝ⟧) γ') < ω^ (n : NatOrdinal)) + (hYcut : ∀ k, ordinalValue (translatedTruncation (u k : K⟦ℝ⟧) γ' * w k) < + ω^ ((n : NatOrdinal) + 1)) + (hZcut : ∀ k, ordinalValue (translatedTruncation (w k : K⟦ℝ⟧) γ' * u k) < + ω^ ((n : NatOrdinal) + 1)) + (hE4 : ∀ k, ordinalValue (translatedTruncation ((u k * w k : Series K) : K⟦ℝ⟧) γ') < + ω^ ((n : NatOrdinal) + 1)) + (hE5 : ordinalValue (translatedTruncation (r : K⟦ℝ⟧) γ') < ω^ (n : NatOrdinal)) : + gradeClass (n : NatOrdinal) (translatedTruncation (B : K⟦ℝ⟧) γ') = + ∑ k, μ k • (gradeClass (n : NatOrdinal) (translatedTruncation (u k : K⟦ℝ⟧) γ' * w k) + + gradeClass (n : NatOrdinal) (translatedTruncation (w k : K⟦ℝ⟧) γ' * u k)) := by + classical + let P : Series K := ∑ k, (HahnSeries.Nonpositive.C : K →+* Series K) (μ k) * (u k * w k) + have hCtrunc : ∀ k ∈ (Finset.univ : Finset (Fin m)), + ordinalValue ((HahnSeries.Nonpositive.C : K →+* Series K) (μ k) * + translatedTruncation ((u k * w k : Series K) : K⟦ℝ⟧) γ') < ω^ ((n : NatOrdinal) + 1) := + fun k _ ↦ by + simpa only [zero_add] using + ordinalValue_mul_lt_wpow_add_one (ordinalValue_C_lt_wpow_one (μ k)) (hE4 k) + have hPtrunc : ordinalValue (translatedTruncation (P : K⟦ℝ⟧) γ') < ω^ ((n : NatOrdinal) + 1) := by + dsimp only [P] + rw [translatedTruncation_sum_C_mul] + exact ordinalValue_sum_lt_wpow_add_one _ _ hCtrunc + have hrtrunc : ordinalValue (translatedTruncation (r : K⟦ℝ⟧) γ') < ω^ ((n : NatOrdinal) + 1) := + hE5.trans (NatOrdinal.wpow_lt_wpow.mpr (lt_add_one _)) + rw [hBPr, Subring.coe_add, translatedTruncation_add, gradeClass_add hPtrunc hrtrunc, + gradeClass_eq_zero_of_lt hE5, add_zero, translatedTruncation_sum_C_mul, + gradeClass_sum _ _ hCtrunc] + refine Finset.sum_congr rfl fun k _ ↦ ?_ + rw [gradeClass_C_mul (μ k) (hE4 k)] + congr 1 + rw [← gradeClass_add (hYcut k) (hZcut k)] + apply gradeClass_eq_of_sub_lt (hE4 k) + ((ordinalValue_add_le_max _ _).trans_lt (max_lt (hYcut k) (hZcut k))) + rw [mul_comm (translatedTruncation (w k : K⟦ℝ⟧) γ') (u k), ← sub_sub] + exact hE1 k + +open Classical in +/-- A truncation relation descends to the terms of exact degree after lower-degree terms vanish. -/ +private theorem rvJ_sum_filter_of_truncation_relation + {ι : Type*} {n : ℕ} (T : Finset ι) (b : ι → Series K) (g : ι → K) (B : Series K) + (Γ : Finset ℝ) (sΓ : Finset Γ) (δ : Γ → K) + (hBtrunc : ∀ γ' ∈ Γ, + gradeClass (n : NatOrdinal) (translatedTruncation (B : K⟦ℝ⟧) γ') = + ∑ i ∈ T, g i • gradeClass (n : NatOrdinal) (translatedTruncation (b i : K⟦ℝ⟧) γ')) + (hcutT : ∀ γ' ∈ sΓ, ∀ i ∈ T, + ordinalValue (translatedTruncation (b i : K⟦ℝ⟧) γ') < ω^ ((n : NatOrdinal) + 1)) + (hδmem : ∑ γ' ∈ sΓ, δ γ' • gradeClass (n : NatOrdinal) + (translatedTruncation (B : K⟦ℝ⟧) γ') ∈ decomposableSpan K (n : NatOrdinal)) : + ∑ p ∈ (sΓ ×ˢ T).filter (fun p : Γ × ι ↦ + ordinalValue (translatedTruncation (b p.2 : K⟦ℝ⟧) p.1) = ω^ (n : NatOrdinal)), + (δ p.1 * g p.2) • rvJ (translatedTruncation (b p.2 : K⟦ℝ⟧) p.1) ∈ + decomposableSpan K (n : NatOrdinal) := by + classical + have hexpand : ∑ γ' ∈ sΓ, δ γ' • gradeClass (n : NatOrdinal) + (translatedTruncation (B : K⟦ℝ⟧) γ') = + ∑ p ∈ sΓ ×ˢ T, (δ p.1 * g p.2) • + gradeClass (n : NatOrdinal) (translatedTruncation (b p.2 : K⟦ℝ⟧) p.1) := by + rw [Finset.sum_product] + refine Finset.sum_congr rfl fun γ' _ ↦ ?_ + rw [hBtrunc γ' γ'.2, Finset.smul_sum] + exact Finset.sum_congr rfl fun i _ ↦ by rw [smul_smul] + rw [hexpand, ← Finset.sum_filter_add_sum_filter_not (sΓ ×ˢ T) (fun p : Γ × ι ↦ + ordinalValue (translatedTruncation (b p.2 : K⟦ℝ⟧) p.1) = ω^ (n : NatOrdinal))] at hδmem + have hzero : ∑ p ∈ (sΓ ×ˢ T).filter (fun p : Γ × ι ↦ + ¬ ordinalValue (translatedTruncation (b p.2 : K⟦ℝ⟧) p.1) = ω^ (n : NatOrdinal)), + (δ p.1 * g p.2) • gradeClass (n : NatOrdinal) (translatedTruncation (b p.2 : K⟦ℝ⟧) p.1) + = 0 := by + refine Finset.sum_eq_zero fun p hp ↦ ?_ + obtain ⟨hp, hne⟩ := Finset.mem_filter.mp hp + obtain ⟨hγ', hi⟩ := Finset.mem_product.mp hp + rcases ordinalValue_eq_or_lt_of_lt_wpow_add_one (hcutT p.1 hγ' p.2 hi) with heq | hlt + · exact absurd heq hne + · rw [gradeClass_eq_zero_of_lt hlt, smul_zero] + rw [hzero, add_zero] at hδmem + convert hδmem using 2 with p hp + rw [rvJ_eq_gradeClass (Finset.mem_filter.mp hp).2] + +/-- FLLM24, Proposition 4.4, at finite degrees: `(*)_n` implies `(*)_{n+1}` for `n ≥ 1`. -/ +theorem independentModuloDecomposable_succ {n : ℕ} (hn : 1 ≤ n) + (hstar : IndependentModuloDecomposable K n) : + IndependentModuloDecomposable K (n + 1) := by + classical + refine IndependentModuloDecomposable.of fun {ι} b hQ ↦ ?_ + rw [Nat.cast_succ, linearIndependent_iff'] + intro s g hsum i₀ hi₀ + by_contra hg₀ + set N : NatOrdinal := (n : NatOrdinal) + 1 with hN + have hNcast : ((n + 1 : ℕ) : NatOrdinal) = N := Nat.cast_succ n + have hval : ∀ i, ordinalValue (b i) = ω^ N := fun i ↦ by + rw [← hNcast]; exact hQ.ordinalValue_eq i + have hcut : ∀ i, ordinalValue (b i) < ω^ (N + 1) := fun i ↦ by + rw [hval i]; exact NatOrdinal.wpow_lt_wpow.mpr (lt_add_one N) + -- The support `T` of the coefficients `g` inside `s`. + set T := s.filter (fun i ↦ g i ≠ 0) with hT + have hi₀T : i₀ ∈ T := Finset.mem_filter.mpr ⟨hi₀, hg₀⟩ + have hgT : ∀ i ∈ T, g i ≠ 0 := fun i hi ↦ (Finset.mem_filter.mp hi).2 + have hsumT : ∑ i ∈ T, g i • (decomposableSpan K N).mkQ (rvJ (b i)) = 0 := by + rw [hT, Finset.sum_filter_of_ne] + · exact hsum + · intro x _ hx hgx + exact hx (by rw [hgx, zero_smul]) + have hrel : ∑ i ∈ T, g i • rvJ (b i) ∈ decomposableSpan K N := by + rw [← Submodule.Quotient.mk_eq_zero, ← Submodule.mkQ_apply, map_sum] + simpa only [map_smul] using hsumT + -- The series `B = ∑ g i • b i` has ordinal value `ω^N` and class in `D_N`. + set B : Series K := ∑ i ∈ T, (HahnSeries.Nonpositive.C : K →+* Series K) (g i) * b i with hB + have hCcut : ∀ i ∈ T, + ordinalValue ((HahnSeries.Nonpositive.C : K →+* Series K) (g i) * b i) < ω^ (N + 1) := + fun i _ ↦ by + simpa only [zero_add] using + ordinalValue_mul_lt_wpow_add_one (ordinalValue_C_lt_wpow_one (g i)) (hcut i) + have hBcut : ordinalValue B < ω^ (N + 1) := ordinalValue_sum_lt_wpow_add_one T _ hCcut + have hBclass : gradeClass N B = ∑ i ∈ T, g i • rvJ (b i) := by + rw [hB, gradeClass_sum T _ hCcut] + exact Finset.sum_congr rfl fun i _ ↦ by + rw [gradeClass_C_mul (g i) (hcut i), rvJ_eq_gradeClass (hval i)] + have hBne : gradeClass N B ≠ 0 := by + intro hzero + rw [hBclass] at hzero + exact hg₀ (linearIndependent_iff'.mp hQ.linearIndependent T g hzero i₀ hi₀T) + have hBval : ordinalValue B = ω^ N := ordinalValue_eq_of_gradeClass_ne_zero hBcut hBne + -- The decomposition `B = ∑ μ_k u_k w_k + r` with `r ∈ J_N`. + have hBmem : gradeClass N B ∈ decomposableSpan K N := by rw [hBclass]; exact hrel + obtain ⟨m, μ, β, γ, u, w, hk, hdecomp⟩ := exists_sum_of_mem_decomposableSpan hBmem + have hNle : ∀ k, β k ≤ ((n + 1 : ℕ) : NatOrdinal) ∧ γ k ≤ ((n + 1 : ℕ) : NatOrdinal) := by + intro k + rw [hNcast, ← (hk k).2.2.1] + exact ⟨NatOrdinal.le_add_right, NatOrdinal.le_add_left⟩ + have hβc : ∀ k, 0 < (β k).constantCoeff := fun k ↦ + NatOrdinal.constantCoeff_pos_of_pos_of_le_natCast (hk k).1 (hNle k).1 + have hγc : ∀ k, 0 < (γ k).constantCoeff := fun k ↦ + NatOrdinal.constantCoeff_pos_of_pos_of_le_natCast (hk k).2.1 (hNle k).2 + have hβγ : ∀ k, (β k).removeNat 1 + γ k = n := by + intro k + have h1 : (β k).removeNat 1 + 1 = β k := by + simpa using NatOrdinal.removeNat_add_natCast (hβc k) + apply add_right_cancel (b := (1 : NatOrdinal)) + rw [add_right_comm, h1, (hk k).2.2.1] + have hγβ : ∀ k, (γ k).removeNat 1 + β k = n := by + intro k + have h1 : (γ k).removeNat 1 + 1 = γ k := by + simpa using NatOrdinal.removeNat_add_natCast (hγc k) + apply add_right_cancel (b := (1 : NatOrdinal)) + rw [add_right_comm, h1, add_comm, (hk k).2.2.1] + have huw : ∀ k, ordinalValue (u k * w k) < ω^ (N + 1) := fun k ↦ by + have h := ordinalValue_mul_lt_wpow_add_one (hk k).2.2.2.1 (hk k).2.2.2.2 + rwa [(hk k).2.2.1] at h + have hCuw : ∀ k ∈ (Finset.univ : Finset (Fin m)), + ordinalValue ((HahnSeries.Nonpositive.C : K →+* Series K) (μ k) * (u k * w k)) < + ω^ (N + 1) := fun k _ ↦ by + simpa only [zero_add] using + ordinalValue_mul_lt_wpow_add_one (ordinalValue_C_lt_wpow_one (μ k)) (huw k) + set P : Series K := + ∑ k, (HahnSeries.Nonpositive.C : K →+* Series K) (μ k) * (u k * w k) with hP + have hPcut : ordinalValue P < ω^ (N + 1) := ordinalValue_sum_lt_wpow_add_one _ _ hCuw + have hPclass : gradeClass N P = ∑ k, μ k • gradeClass N (u k * w k) := by + rw [hP, gradeClass_sum _ _ hCuw] + exact Finset.sum_congr rfl fun k _ ↦ gradeClass_C_mul (μ k) (huw k) + set r : Series K := B - P with hr + have hrlt : ordinalValue r < ω^ N := by + rw [← gradeClass_eq_zero_iff (by + rw [hr, sub_eq_add_neg] + exact (ordinalValue_add_le_max B (-P)).trans_lt + (max_lt hBcut (by rwa [ordinalValue_neg]))), hr, gradeClass_sub hBcut hPcut, hPclass, + ← hdecomp, sub_self] + have hBPr : B = P + r := by rw [hr]; abel + -- The eventual statements near zero. + have hev := eventually_successor_decomposition_estimates β γ u w b T r hk + hβc hγc hβγ hγβ huw hrlt hcut + obtain ⟨η, hη, hη'⟩ := eventually_nhdsLT_iff_exists.mp hev + obtain ⟨δQ, hδQ, hQ2⟩ := hQ.truncations hn + -- Residual points of `B` above both thresholds. + obtain ⟨Γ, hΓcard, hΓ⟩ := + exists_finset_residualPoints (α := (n : NatOrdinal)) hBval (max_lt hη hδQ) (2 * m + 1) + set π := (decomposableSpan K (n : NatOrdinal)).mkQ with hπ + -- For a residual point `γ'`, the class of `B^{|γ'}` expands along `T` and along the + -- Leibniz rule. + have hBtrunc : ∀ γ' ∈ Γ, + gradeClass (n : NatOrdinal) (translatedTruncation (B : K⟦ℝ⟧) γ') = + ∑ i ∈ T, g i • gradeClass (n : NatOrdinal) (translatedTruncation (b i : K⟦ℝ⟧) γ') := by + intro γ' hγ' + obtain ⟨hηγ, hγ0, -⟩ := hΓ γ' hγ' + have hE := hη' γ' ((le_max_left η δQ).trans_lt hηγ) hγ0 + rw [hB, translatedTruncation_sum_C_mul, gradeClass_sum] + · exact Finset.sum_congr rfl fun i hi ↦ gradeClass_C_mul (g i) (hE.2.2.2.2.2.2.2 i hi) + · intro i hi + simpa only [zero_add] using ordinalValue_mul_lt_wpow_add_one + (ordinalValue_C_lt_wpow_one (g i)) (hE.2.2.2.2.2.2.2 i hi) + have hBleib : ∀ γ' ∈ Γ, + gradeClass (n : NatOrdinal) (translatedTruncation (B : K⟦ℝ⟧) γ') = + ∑ k, μ k • (gradeClass (n : NatOrdinal) (translatedTruncation (u k : K⟦ℝ⟧) γ' * w k) + + gradeClass (n : NatOrdinal) (translatedTruncation (w k : K⟦ℝ⟧) γ' * u k)) := by + intro γ' hγ' + obtain ⟨hηγ, hγ0, -⟩ := hΓ γ' hγ' + obtain ⟨hE1, -, -, hE8, hE9, hE4, hE5, -⟩ := hη' γ' ((le_max_left η δQ).trans_lt hηγ) hγ0 + have hYcut : ∀ k, + ordinalValue (translatedTruncation (u k : K⟦ℝ⟧) γ' * w k) < ω^ N := fun k ↦ by + have h1 : ordinalValue (translatedTruncation (u k : K⟦ℝ⟧) γ') < + ω^ ((β k).removeNat 1 + 1) := by + rw [show (β k).removeNat 1 + 1 = β k by + simpa using NatOrdinal.removeNat_add_natCast (hβc k)] + exact hE8 k + have h := ordinalValue_mul_lt_wpow_add_one h1 (hk k).2.2.2.2 + rwa [hβγ k] at h + have hZcut : ∀ k, + ordinalValue (translatedTruncation (w k : K⟦ℝ⟧) γ' * u k) < ω^ N := fun k ↦ by + have h1 : ordinalValue (translatedTruncation (w k : K⟦ℝ⟧) γ') < + ω^ ((γ k).removeNat 1 + 1) := by + rw [show (γ k).removeNat 1 + 1 = γ k by + simpa using NatOrdinal.removeNat_add_natCast (hγc k)] + exact hE9 k + have h := ordinalValue_mul_lt_wpow_add_one h1 (hk k).2.2.2.1 + rwa [hγβ k] at h + exact gradeClass_translatedTruncation_sum_products μ u w B r γ' hBPr + hE1 hYcut hZcut hE4 hE5 + -- The classes of the `B^{|γ'}`, modulo `D_n`, lie in the span of `2m` vectors. + let gens : Fin m ⊕ Fin m → PrincipalSubring K ⧸ decomposableSpan K (n : NatOrdinal) := + Sum.elim (fun k ↦ π (gradeClass (n : NatOrdinal) (u k))) + (fun k ↦ π (gradeClass (n : NatOrdinal) (w k))) + have hspan : ∀ γ' : Γ, + π (gradeClass (n : NatOrdinal) (translatedTruncation (B : K⟦ℝ⟧) γ')) ∈ + Submodule.span K (Set.range gens) := by + intro γ' + obtain ⟨hηγ, hγ0, -⟩ := hΓ γ' γ'.2 + obtain ⟨-, hE2, hE3, -⟩ := hη' γ' ((le_max_left η δQ).trans_lt hηγ) hγ0 + rw [hBleib γ' γ'.2, map_sum] + refine Submodule.sum_mem _ fun k _ ↦ ?_ + rw [map_smul, map_add] + refine Submodule.smul_mem _ _ (Submodule.add_mem _ ?_ ?_) + · refine Submodule.span_mono ?_ (mkQ_mem_span_singleton_of_mem_sup (hE2 k)) + exact Set.singleton_subset_iff.mpr ⟨Sum.inr k, rfl⟩ + · refine Submodule.span_mono ?_ (mkQ_mem_span_singleton_of_mem_sup (hE3 k)) + exact Set.singleton_subset_iff.mpr ⟨Sum.inl k, rfl⟩ + have hcard : Fintype.card (Fin m ⊕ Fin m) < Fintype.card Γ := by + rw [Fintype.card_sum, Fintype.card_fin, Fintype.card_coe, hΓcard] + omega + obtain ⟨sΓ, δ, hδrel, γ₀, hγ₀, hδ₀⟩ := + Module.exists_nontrivial_relation_of_mem_span_range gens + (fun γ' : Γ ↦ π (gradeClass (n : NatOrdinal) (translatedTruncation (B : K⟦ℝ⟧) γ'))) + hspan hcard + -- The relation, expanded along `T` and restricted to the truncations of degree `n`. + have hδmem : ∑ γ' ∈ sΓ, δ γ' • gradeClass (n : NatOrdinal) + (translatedTruncation (B : K⟦ℝ⟧) γ') ∈ decomposableSpan K (n : NatOrdinal) := by + rw [← Submodule.Quotient.mk_eq_zero, ← Submodule.mkQ_apply, map_sum] + simpa only [map_smul] using hδrel + have hcutT : ∀ γ' ∈ sΓ, ∀ i ∈ T, + ordinalValue (translatedTruncation (b i : K⟦ℝ⟧) γ') < ω^ ((n : NatOrdinal) + 1) := by + intro γ' _ i hi + obtain ⟨hηγ, hγ0, -⟩ := hΓ γ' γ'.2 + exact (hη' γ' ((le_max_left η δQ).trans_lt hηγ) hγ0).2.2.2.2.2.2.2 i hi + set S₁ := (sΓ ×ˢ T).filter (fun p : Γ × ι ↦ + ordinalValue (translatedTruncation (b p.2 : K⟦ℝ⟧) p.1) = ω^ (n : NatOrdinal)) with hS₁ + have hrelS₁ := rvJ_sum_filter_of_truncation_relation T b g B Γ sΓ δ hBtrunc hcutT hδmem + -- Axiom 2 makes the surviving truncations hereditarily `rv_J`-independent at degree `n`. + have hQS₁ : HereditarilyRVIndependent n + (fun p : S₁ ↦ translatedTruncation (b p.1.2 : K⟦ℝ⟧) (p.1.1 : ℝ)) := by + refine hQ2 S₁ (fun p ↦ p.1.2) (fun p ↦ (p.1.1 : ℝ)) ?_ ?_ ?_ ?_ + · intro p q hpq + have h1 : p.1.2 = q.1.2 := congrArg Prod.fst hpq + have h2 : (p.1.1 : ℝ) = (q.1.1 : ℝ) := congrArg Prod.snd hpq + exact Subtype.ext (Prod.ext (Subtype.ext h2) h1) + · intro p + obtain ⟨hηγ, -, -⟩ := hΓ p.1.1 p.1.1.2 + exact ((le_max_right η δQ).trans_lt hηγ).le + · intro p + exact (hΓ p.1.1 p.1.1.2).2.1.le + · intro p + exact (Finset.mem_filter.mp p.2).2 + have hlin := hstar.linearIndependent hQS₁ + rw [Fintype.linearIndependent_iff] at hlin + have hcoeff : ∀ p : S₁, δ p.1.1 * g p.1.2 = 0 := by + refine hlin (fun p ↦ δ p.1.1 * g p.1.2) ?_ + rw [← Submodule.Quotient.mk_eq_zero, ← Submodule.mkQ_apply, map_sum] at hrelS₁ + rw [← Finset.sum_coe_sort S₁] at hrelS₁ + simpa only [map_smul] using hrelS₁ + -- At the residual point `γ₀` some `b i^{|γ₀}` with `g i ≠ 0` has degree `n`. + have hBγ₀ : gradeClass (n : NatOrdinal) (translatedTruncation (B : K⟦ℝ⟧) γ₀) ≠ 0 := by + have hres := (hΓ γ₀ γ₀.2).2.2 + rw [← rvJ_eq_gradeClass hres] + exact rvJ_ne_zero_of_eq hres + rw [hBtrunc γ₀ γ₀.2] at hBγ₀ + obtain ⟨i, hi, hne⟩ := Finset.exists_ne_zero_of_sum_ne_zero hBγ₀ + have hgc : gradeClass (n : NatOrdinal) (translatedTruncation (b i : K⟦ℝ⟧) γ₀) ≠ 0 := + fun h ↦ hne (by rw [h, smul_zero]) + have hdeg : ordinalValue (translatedTruncation (b i : K⟦ℝ⟧) γ₀) = ω^ (n : NatOrdinal) := + ordinalValue_eq_of_gradeClass_ne_zero (hcutT γ₀ hγ₀ i hi) hgc + have hpS₁ : (γ₀, i) ∈ S₁ := Finset.mem_filter.mpr ⟨Finset.mem_product.mpr ⟨hγ₀, hi⟩, hdeg⟩ + exact mul_ne_zero hδ₀ (hgT i hi) (hcoeff ⟨(γ₀, i), hpS₁⟩) + +/-- FLLM24, Corollary 4.5 for `α = n < ω` (Remark 4.6): `(*)_n` holds for every `n ≥ 1`, by +induction from Proposition 4.3 through Proposition 4.4. -/ +theorem independentModuloDecomposable_of_pos {n : ℕ} (hn : 1 ≤ n) : + IndependentModuloDecomposable K n := by + induction n with + | zero => exact absurd hn (by decide) + | succ n ih => + rcases Nat.eq_zero_or_pos n with rfl | hpos + · exact independentModuloDecomposable_one + · exact independentModuloDecomposable_succ hpos (ih hpos) + +end FLLM24 + +end diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Random/SupportRandom.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Random/SupportRandom.lean new file mode 100644 index 0000000000..6ddfe75851 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Random/SupportRandom.lean @@ -0,0 +1,176 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Random.Random +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Random.TruncationIndependence +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Random.IndependenceWindow +public import LeanPool.ConwayRefinement.ConwayRefinement.LinearAlgebra.IndicatorFinsupp + +/-! +# Independent support closures give hereditary `rv_J`-independence + +Fornasiero, Lavi, L'Innocente and Mantova, *Irreducibility in generalized power series* (2024), +Proposition 3.6: if `deg_J(b_i) = α > 0`, the closures of the supports of the `b_i` meet pairwise +only in `{0}`, and the union of these closures with `0` removed is `ℚ`-linearly independent, then +`Q(b_1, …, b_n)` holds. + +As in the source, a vanishing relation `∑ k_p c_p ∈ J_α` among translated truncations +`c_p = b_{i(p)}^{|γ_p}` at distinct pairs is tested at a support point `x < 0` of one `c_p` near +zero outside the support of the relation; the coefficient at `x` must cancel against another +`c_{p'}`, giving `β - γ_p = x = β' - γ_{p'}` with `β ∈ supp b_{i(p)}`, `β' ∈ supp b_{i(p')}`. The +`ℚ`-relation `β + γ_{p'} = β' + γ_p` among elements of the independent set (each `γ` lies in the +closure of the corresponding support, or is `0`) forces `β = β'` and `γ_p = γ_{p'}`, since +`β = γ_p` would give `x = 0`; then `β ≠ 0` lies in two support closures, so `i(p) = i(p')`, and +the pairs coincide. The source states Axiom 2 for the family itself and assumes principality +"for simplicity"; the argument here covers the truncation families directly, which is what +Axiom 2 needs at every depth. +-/ + +open scoped HahnSeries NatOrdinal + +universe v + +public noncomputable section + +namespace FLLM24 + +open Berarducci HahnSeries.Nonpositive + +variable {K : Type v} [Field K] + +/-- A translated truncation outside `J` is taken at a point of the closure of the support. -/ +private theorem mem_closure_support_of_ordinalValue_ne_zero {b : Series K} {γ : ℝ} + (h : ordinalValue (translatedTruncation (b : K⟦ℝ⟧) γ) ≠ 0) : + γ ∈ closure (b : K⟦ℝ⟧).support := by + by_contra hγ + exact h (ordinalValue_of_mem_negativeMonomialIdeal + (translatedTruncation_mem_negativeMonomialIdeal_of_not_mem_closure_support hγ)) + +/-- FLLM24, Proposition 3.6 in the form needed for Axiom 2: under the support clause of mutual +randomness, the translated truncations at distinct pairs of a common positive degree have +linearly independent classes. -/ +theorem IsMutuallySupportRandom.truncationsIndependent {ι : Type} {b : ι → Series K} + (hb : IsMutuallySupportRandom b) : TruncationsIndependent K b := by + refine TruncationsIndependent.of fun d hd κ _ j γ hinj hγ hval ↦ ?_ + classical + cases nonempty_fintype κ + set c : κ → Series K := fun k ↦ translatedTruncation (b (j k) : K⟦ℝ⟧) (γ k) with hc + rw [linearIndependent_iff'] + intro s g hsum k₀ hk₀ + by_contra hg₀ + set P := s.filter (fun k ↦ g k ≠ 0) with hP + have hk₀P : k₀ ∈ P := Finset.mem_filter.mpr ⟨hk₀, hg₀⟩ + have hgP : ∀ k ∈ P, g k ≠ 0 := fun k hk ↦ (Finset.mem_filter.mp hk).2 + have hrelP : ∑ k ∈ P, g k • rvJ (c k) = 0 := by + rw [hP, Finset.sum_filter_of_ne] + · exact hsum + · intro k _ hk hgk + exact hk (by rw [hgk, zero_smul]) + have hrel' : ∑ k : P, g k • rvJ (c k) = 0 := by + rw [Finset.sum_coe_sort P (fun k ↦ g k • rvJ (c k))] + exact hrelP + set R : Series K := ∑ k : P, (HahnSeries.Nonpositive.C : K →+* Series K) (g k) * c k with hR + have hRlt : ordinalValue R < ω^ (d : NatOrdinal) := + ordinalValue_sum_C_mul_lt_of_sum_smul_rvJ_eq_zero (fun k : P ↦ hval k) (fun k : P ↦ g k) + hrel' + have hd' : (0 : NatOrdinal) < d := Nat.cast_pos.mpr hd + -- A support point of `c k₀` near zero outside the support of `R`. + obtain ⟨η₀, hη₀, hwin⟩ := exists_forall_infinite_support_diff hd' (hval k₀) hRlt + obtain ⟨x, ⟨hxc, -, hx0⟩, hxR⟩ := (hwin (η₀ / 2) (by linarith) (by linarith)).nonempty + rw [HahnSeries.mem_support, not_ne_iff] at hxR + -- The coefficient of `R` at `x` vanishes, so another `c k₁` contributes at `x`. + have hcoeff : ∀ k : κ, ((c k : Series K) : K⟦ℝ⟧).coeff x = + ((b (j k) : Series K) : K⟦ℝ⟧).coeff (γ k + x) := fun k ↦ by + rw [hc, coeff_translatedTruncation, ite_eq_left hx0.le] + obtain ⟨k₁, hk₁P, hk₁ne, hk₁c⟩ : ∃ k₁ ∈ P, k₁ ≠ k₀ ∧ ((c k₁ : Series K) : K⟦ℝ⟧).coeff x ≠ 0 := by + by_contra hnone + push Not at hnone + have hsum' : ((R : Series K) : K⟦ℝ⟧).coeff x = g k₀ * ((c k₀ : Series K) : K⟦ℝ⟧).coeff x := by + rw [hR, coeff_sum_C_mul] + rw [Finset.sum_eq_single ⟨k₀, hk₀P⟩] + · intro k _ hk + have hkne : (k : κ) ≠ k₀ := fun h ↦ hk (Subtype.ext h) + rw [hnone k k.2 hkne, mul_zero] + · intro h + exact absurd (Finset.mem_univ _) h + rw [hxR] at hsum' + exact mul_ne_zero (hgP k₀ hk₀P) hxc hsum'.symm + -- The two support points and the linear relation between them. + set β := γ k₀ + x with hβ + set β' := γ k₁ + x with hβ' + have hβsupp : β ∈ ((b (j k₀) : Series K) : K⟦ℝ⟧).support := by + rw [HahnSeries.mem_support, ← hcoeff k₀]; exact hxc + have hβ'supp : β' ∈ ((b (j k₁) : Series K) : K⟦ℝ⟧).support := by + rw [HahnSeries.mem_support, ← hcoeff k₁]; exact hk₁c + have hβneg : β < 0 := by linarith [hγ k₀] + have hβ'neg : β' < 0 := by linarith [hγ k₁] + set L := supportClosureUnion b with hL + have hβL : β ∈ L := (mem_supportClosureUnion_iff b β).mpr + ⟨⟨j k₀, subset_closure hβsupp⟩, hβneg.ne⟩ + have hβ'L : β' ∈ L := (mem_supportClosureUnion_iff b β').mpr + ⟨⟨j k₁, subset_closure hβ'supp⟩, hβ'neg.ne⟩ + have hγcl : ∀ k, γ k ∈ closure ((b (j k) : Series K) : K⟦ℝ⟧).support := fun k ↦ + mem_closure_support_of_ordinalValue_ne_zero (by rw [hval k]; exact (NatOrdinal.wpow_pos _).ne') + have hγL : ∀ k, γ k ∈ L ∨ γ k = 0 := fun k ↦ by + rcases eq_or_ne (γ k) 0 with h | h + · exact Or.inr h + · exact Or.inl ((mem_supportClosureUnion_iff b (γ k)).mpr ⟨⟨j k, hγcl k⟩, h⟩) + -- Injectivity of the linear combination over the independent set `L`. + have hinjL : Function.Injective (Finsupp.linearCombination ℚ (fun z : L ↦ (z : ℝ))) := + linearIndependent_iff_injective_finsuppLinearCombination.mp hb.linearIndependent + have hcomb : ∀ k, Finsupp.linearCombination ℚ (fun z : L ↦ (z : ℝ)) + (L.indicatorFinsupp ℚ (γ k)) = γ k := fun k ↦ by + rcases hγL k with h | h + · exact L.linearCombination_indicatorFinsupp_of_mem ℚ h + · rw [h]; exact L.linearCombination_indicatorFinsupp_zero ℚ + have hrelation : L.indicatorFinsupp ℚ β + L.indicatorFinsupp ℚ (γ k₁) = + L.indicatorFinsupp ℚ β' + L.indicatorFinsupp ℚ (γ k₀) := by + apply hinjL + rw [map_add, map_add, L.linearCombination_indicatorFinsupp_of_mem ℚ hβL, + L.linearCombination_indicatorFinsupp_of_mem ℚ hβ'L, hcomb k₁, hcomb k₀, hβ, hβ'] + ring + -- Evaluate at `β`: the right side must be nonzero there. + have hpos : 0 < (L.indicatorFinsupp ℚ β + L.indicatorFinsupp ℚ (γ k₁)) ⟨β, hβL⟩ := by + rw [Finsupp.add_apply, L.indicatorFinsupp_apply_self hβL] + linarith [L.indicatorFinsupp_apply_nonneg (R := ℚ) (γ k₁) ⟨β, hβL⟩] + rw [hrelation, Finsupp.add_apply] at hpos + have hγ₀ : L.indicatorFinsupp ℚ (γ k₀) ⟨β, hβL⟩ = 0 := by + apply L.indicatorFinsupp_apply_of_ne + intro heq + have : x = 0 := by simp only at heq; linarith + exact hx0.ne this + rw [hγ₀, add_zero] at hpos + have hββ' : β = β' := by + by_contra hne + rw [L.indicatorFinsupp_apply_of_ne β' ⟨β, hβL⟩ hne] at hpos + exact lt_irrefl _ hpos + -- Hence the exponents agree and the support closures meet at `β ≠ 0`. + have hγeq : γ k₁ = γ k₀ := by + have h := hrelation + rw [hββ', add_comm (L.indicatorFinsupp ℚ β'), add_comm (L.indicatorFinsupp ℚ β')] at h + have h' := add_right_cancel h + have := congrArg (Finsupp.linearCombination ℚ (fun z : L ↦ (z : ℝ))) h' + rwa [hcomb k₁, hcomb k₀] at this + have hj : j k₀ = j k₁ := by + by_contra hne + have hmem : β ∈ closure ((b (j k₀) : Series K) : K⟦ℝ⟧).support ∩ + closure ((b (j k₁) : Series K) : K⟦ℝ⟧).support := + ⟨subset_closure hβsupp, hββ' ▸ subset_closure hβ'supp⟩ + exact hβneg.ne (hb.closure_inter_subset _ _ hne hmem) + exact hk₁ne (hinj (Prod.ext hj.symm hγeq)) + +/-- FLLM24, Proposition 3.6 for finite degrees: a finite family satisfying the support clause of +mutual randomness, of ordinal value `ω^n` with `n ≥ 1`, is hereditarily `rv_J`-independent. -/ +theorem IsMutuallySupportRandom.hereditarilyRVIndependent {ι : Type} [Finite ι] + {b : ι → Series K} (hb : IsMutuallySupportRandom b) {n : ℕ} (hn : 1 ≤ n) + (hval : ∀ i, ordinalValue (b i) = ω^ (n : NatOrdinal)) : + HereditarilyRVIndependent n b := + hb.truncationsIndependent.hereditarilyRVIndependent_self hn hval + +end FLLM24 + +end diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Random/TruncationIndependence.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Random/TruncationIndependence.lean new file mode 100644 index 0000000000..1dcdddb0ad --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Random/TruncationIndependence.lean @@ -0,0 +1,167 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Random.HereditaryIndependence + +import Mathlib.Data.Finset.Lattice.Fold +import Mathlib.Data.Finset.Max + +/-! +# Hereditary `rv_J`-independence from the independence of truncations + +Fornasiero, Lavi, L'Innocente and Mantova, *Irreducibility in generalized power series* (2024), +Corollary 3.5 and Proposition 3.6, derive `Q(b_1, …, b_n)` from a randomness hypothesis by +verifying Axiom 1 for the family and for all families of translated truncations that Axiom 2 +produces, the hypothesis being inherited by the truncations. This module isolates the +induction: if every finite family of translated truncations `(b_{j(k)})^{|γ(k)}` at distinct +pairs `(j(k), γ(k))` of a common positive degree `d` has linearly independent classes, then every +such family is hereditarily `rv_J`-independent. + +The point needing care is the threshold `δ` of Axiom 2. Translated truncations compose, +`(b^{|γ})^{|γ'} = b^{|γ + γ'}`, so a family of truncations of the truncations is again a family of +truncations of the `b_i`, but two distinct pairs `(j, γ)`, `(j, γ'')` can produce the same pair +`(j, γ + δ₁) = (j, γ'' + δ₂)` when `|γ - γ''| = |δ₁ - δ₂|`. Choosing `δ` below half the least +gap between exponents attached to the same index keeps the composed pairs distinct, and the +source's requirement "`γ_{i,j} ≠ γ_{i,j'}` for `j ≠ j'`" is preserved. +-/ + +open scoped HahnSeries NatOrdinal + +universe v + +public noncomputable section + +namespace FLLM24 + +open Berarducci + +variable {K : Type v} [Field K] + +variable (K) in +/-- Every finite family of translated truncations of the `b i` at distinct pairs, all of ordinal +value `ω^d` with `d ≥ 1`, has `K`-linearly independent classes `rv_J`. -/ +def TruncationsIndependent {ι : Type} (b : ι → Series K) : Prop := + ∀ (d : ℕ), 1 ≤ d → ∀ (κ : Type) [Finite κ] (j : κ → ι) (γ : κ → ℝ), + Function.Injective (fun k ↦ (j k, γ k)) → (∀ k, γ k ≤ 0) → + (∀ k, ordinalValue (translatedTruncation (b (j k) : K⟦ℝ⟧) (γ k)) = ω^ (d : NatOrdinal)) → + LinearIndependent K (fun k ↦ rvJ (translatedTruncation (b (j k) : K⟦ℝ⟧) (γ k))) + +/-- Introduction rule for `TruncationsIndependent`. -/ +theorem TruncationsIndependent.of {ι : Type} {b : ι → Series K} + (h : ∀ (d : ℕ), 1 ≤ d → ∀ (κ : Type) [Finite κ] (j : κ → ι) (γ : κ → ℝ), + Function.Injective (fun k ↦ (j k, γ k)) → (∀ k, γ k ≤ 0) → + (∀ k, ordinalValue (translatedTruncation (b (j k) : K⟦ℝ⟧) (γ k)) = ω^ (d : NatOrdinal)) → + LinearIndependent K (fun k ↦ rvJ (translatedTruncation (b (j k) : K⟦ℝ⟧) (γ k)))) : + TruncationsIndependent K b := + h + +theorem TruncationsIndependent.linearIndependent {ι : Type} {b : ι → Series K} + (hb : TruncationsIndependent K b) {d : ℕ} (hd : 1 ≤ d) (κ : Type) [Finite κ] (j : κ → ι) + (γ : κ → ℝ) (hinj : Function.Injective (fun k ↦ (j k, γ k))) (hγ : ∀ k, γ k ≤ 0) + (hval : ∀ k, ordinalValue (translatedTruncation (b (j k) : K⟦ℝ⟧) (γ k)) = + ω^ (d : NatOrdinal)) : + LinearIndependent K (fun k ↦ rvJ (translatedTruncation (b (j k) : K⟦ℝ⟧) (γ k))) := + hb d hd κ j γ hinj hγ hval + +/-- The least gap between two exponents attached to the same index of a finite family of pairs: +the minimum of the finite set `{|γ k - γ k'| : k ≠ k', j k = j k'}`, or `1` if the set is +empty. -/ +private theorem exists_gap {ι κ : Type} [Finite κ] (j : κ → ι) (γ : κ → ℝ) + (hinj : Function.Injective (fun k ↦ (j k, γ k))) : + ∃ g : ℝ, 0 < g ∧ ∀ k k', k ≠ k' → j k = j k' → g ≤ |γ k - γ k'| := by + classical + cases nonempty_fintype κ + let P : Finset (κ × κ) := Finset.univ.filter fun p ↦ p.1 ≠ p.2 ∧ j p.1 = j p.2 + let G : Finset ℝ := P.image fun p ↦ |γ p.1 - γ p.2| + have hpos : ∀ g ∈ G, 0 < g := by + intro g hg + obtain ⟨p, hp, rfl⟩ := Finset.mem_image.mp hg + obtain ⟨hne, hj⟩ := (Finset.mem_filter.mp hp).2 + rw [abs_pos, sub_ne_zero] + intro hγ + exact hne (hinj (Prod.ext hj hγ)) + rcases G.eq_empty_or_nonempty with hG | hG + · refine ⟨1, one_pos, fun k k' hne hj ↦ ?_⟩ + exfalso + have : |γ k - γ k'| ∈ G := + Finset.mem_image.mpr ⟨(k, k'), Finset.mem_filter.mpr ⟨Finset.mem_univ _, hne, hj⟩, rfl⟩ + rw [hG] at this + exact Finset.notMem_empty _ this + · refine ⟨G.min' hG, hpos _ (G.min'_mem hG), fun k k' hne hj ↦ ?_⟩ + exact G.min'_le _ + (Finset.mem_image.mpr ⟨(k, k'), Finset.mem_filter.mpr ⟨Finset.mem_univ _, hne, hj⟩, rfl⟩) + +/-- FLLM24, the common inductive core of Corollary 3.5 and Proposition 3.6: if all finite +families of translated truncations of the `b i` at distinct pairs and of a common positive degree +have independent classes, then every such family is hereditarily `rv_J`-independent. -/ +theorem TruncationsIndependent.hereditarilyRVIndependent {ι : Type} {b : ι → Series K} + (hb : TruncationsIndependent K b) {d : ℕ} (hd : 1 ≤ d) (κ : Type) [Finite κ] (j : κ → ι) + (γ : κ → ℝ) (hinj : Function.Injective (fun k ↦ (j k, γ k))) (hγ : ∀ k, γ k ≤ 0) + (hval : ∀ k, ordinalValue (translatedTruncation (b (j k) : K⟦ℝ⟧) (γ k)) = + ω^ (d : NatOrdinal)) : + HereditarilyRVIndependent d (fun k ↦ translatedTruncation (b (j k) : K⟦ℝ⟧) (γ k)) := by + induction d generalizing κ with + | zero => exact absurd hd (by decide) + | succ d ih => + refine HereditarilyRVIndependent.of_succ hval + (hb.linearIndependent hd κ j γ hinj hγ hval) fun hd' ↦ ?_ + obtain ⟨g, hg, hgap⟩ := exists_gap j γ hinj + refine ⟨-(g / 2), by linarith, fun κ' _ j' γ' hinj' hδγ' hγ' hval' ↦ ?_⟩ + -- The composed family of truncations of the `b i`. + have hcomp : ∀ k', translatedTruncation + ((translatedTruncation (b (j (j' k')) : K⟦ℝ⟧) (γ (j' k')) : Series K) : K⟦ℝ⟧) (γ' k') = + translatedTruncation (b (j (j' k')) : K⟦ℝ⟧) (γ (j' k') + γ' k') := fun k' ↦ + translatedTruncation_translatedTruncation _ _ (hγ' k') + have hinj'' : Function.Injective (fun k' ↦ (j (j' k'), γ (j' k') + γ' k')) := by + intro k₁ k₂ h + have h1 : j (j' k₁) = j (j' k₂) := congrArg Prod.fst h + have h2 : γ (j' k₁) + γ' k₁ = γ (j' k₂) + γ' k₂ := congrArg Prod.snd h + by_cases hk : j' k₁ = j' k₂ + · apply hinj' + refine Prod.ext hk ?_ + rw [hk] at h2 + exact add_left_cancel h2 + · exfalso + have hge := hgap _ _ hk h1 + have hsub : γ (j' k₁) - γ (j' k₂) = γ' k₂ - γ' k₁ := by linarith + rw [hsub] at hge + have h3 := hδγ' k₁ + have h4 := hδγ' k₂ + have h5 := hγ' k₁ + have h6 := hγ' k₂ + have hsmall : |γ' k₂ - γ' k₁| ≤ g / 2 := abs_sub_le_iff.mpr ⟨by linarith, by linarith⟩ + linarith + have hval'' : ∀ k', ordinalValue (translatedTruncation (b (j (j' k')) : K⟦ℝ⟧) + (γ (j' k') + γ' k')) = ω^ (d : NatOrdinal) := fun k' ↦ by + rw [← hcomp k']; exact hval' k' + have hQ := ih hd' κ' (fun k' ↦ j (j' k')) (fun k' ↦ γ (j' k') + γ' k') hinj'' + (fun k' ↦ add_nonpos (hγ (j' k')) (hγ' k')) hval'' + have hfun : (fun k' ↦ translatedTruncation + ((translatedTruncation (b (j (j' k')) : K⟦ℝ⟧) (γ (j' k')) : Series K) : K⟦ℝ⟧) + (γ' k')) = + fun k' ↦ translatedTruncation (b (j (j' k')) : K⟦ℝ⟧) (γ (j' k') + γ' k') := + funext hcomp + rw [hfun] + exact hQ + +/-- A finite family with independent truncations is hereditarily `rv_J`-independent at its +common positive degree. -/ +theorem TruncationsIndependent.hereditarilyRVIndependent_self {ι : Type} [Finite ι] + {b : ι → Series K} (hb : TruncationsIndependent K b) {d : ℕ} (hd : 1 ≤ d) + (hval : ∀ i, ordinalValue (b i) = ω^ (d : NatOrdinal)) : + HereditarilyRVIndependent d b := by + have h := hb.hereditarilyRVIndependent hd ι id (fun _ ↦ 0) + (fun i i' h ↦ congrArg Prod.fst h) (fun _ ↦ le_rfl) + (fun i ↦ by rw [translatedTruncation_zero]; exact hval i) + have hfun : (fun i ↦ translatedTruncation (b (id i) : K⟦ℝ⟧) 0) = b := by + funext i + exact translatedTruncation_zero (b i) + rwa [hfun] at h + +end FLLM24 + +end diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/SeriesMaximalFinite.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/SeriesMaximalFinite.lean new file mode 100644 index 0000000000..fd590c4d97 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/SeriesMaximalFinite.lean @@ -0,0 +1,382 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.RVMaximalFinite + +/-! +# Maximal finite-support divisors of Hahn series + +This module proves the intrinsic associate-class form of LM24, Proposition 5.5.1. It lifts the +maximal finite-support divisor from degree RV to the original ring `K((ℝ^{≤ 0}))` by +well-founded induction on Hahn-series degree. + +At degree at most zero, exact degree multiplicativity reflects ambient divisibility back into the +finite-support subring. At positive degree, an RV-maximal finite-support divisor is lifted to a +series factor; subtracting that factor lowers degree. A pairwise greatest-common-divisor +hypothesis combines its divisor class with the recursively constructed residual class. + +The definition and uniqueness of the intrinsic class do not depend on the existence proof. +Pairwise gcd existence remains an explicit hypothesis and is not installed as an instance; the +coefficient field has characteristic zero. +-/ + +open scoped HahnSeries NatOrdinal + +universe v + +namespace Berarducci + +public noncomputable section + +variable {K : Type v} [Field K] [CharZero K] + +/-- A finite-support series divides another finite-support series in the finite-support subring +exactly when it divides it in the ambient Hahn-series ring. -/ +theorem finiteSupport_dvd_iff_coe_dvd (p q : FiniteSupportRing (K := K)) : + q ∣ p ↔ (q : Series K) ∣ (p : Series K) := by + constructor + · exact map_dvd + (HahnSeries.Nonpositive.finiteSupportSubring (G := ℝ) (K := K)).subtype + · rintro ⟨c, hc⟩ + by_cases hp : p = 0 + · subst p + exact dvd_zero q + have hpCoe : (p : Series K) ≠ 0 := by + intro h + apply hp + exact Subtype.ext h + have hq : q ≠ 0 := by + intro hq + subst q + apply hpCoe + simpa using hc + have hpHahn : (p : K⟦ℝ⟧) ≠ 0 := by + intro h + apply hpCoe + exact Subtype.ext h + have hqHahn : (q : K⟦ℝ⟧) ≠ 0 := by + intro h + apply hq + apply Subtype.ext + exact Subtype.ext h + have hpDegree : (p : K⟦ℝ⟧).degree = 0 := by + rw [HahnSeries.degree_eq_zero] + exact ⟨hpHahn, + (HahnSeries.Nonpositive.mem_finiteSupportSubring_iff + (p : Series K)).mp p.2⟩ + have hqDegree : (q : K⟦ℝ⟧).degree = 0 := by + rw [HahnSeries.degree_eq_zero] + exact ⟨hqHahn, + (HahnSeries.Nonpositive.mem_finiteSupportSubring_iff + (q : Series K)).mp q.2⟩ + have hcDegree : (c : K⟦ℝ⟧).degree = 0 := by + have h := HahnSeries.Nonpositive.degree_mul (q : Series K) c + rw [← hc, hpDegree, hqDegree, zero_add] at h + exact h.symm + let c' : FiniteSupportRing (K := K) := ⟨c, by + rw [HahnSeries.Nonpositive.mem_finiteSupportSubring_iff, + ← HahnSeries.degree_le_zero_iff] + exact hcDegree.le⟩ + refine ⟨c', ?_⟩ + apply Subtype.ext + exact hc + +/-- An associate class records exactly the finite-support divisors of a Hahn series. -/ +def IsSeriesMaximalFiniteSupportDivisor + (b : Series K) (a : Associates (FiniteSupportRing (K := K))) : Prop := + IsMaximalDivisorAlong + (HahnSeries.Nonpositive.finiteSupportSubring (G := ℝ) (K := K)).subtype.toMonoidHom + b a + +omit [CharZero K] in +/-- The defining characterization of a maximal finite-support divisor class of a Hahn series. -/ +theorem isSeriesMaximalFiniteSupportDivisor_iff + (b : Series K) (a : Associates (FiniteSupportRing (K := K))) : + IsSeriesMaximalFiniteSupportDivisor b a ↔ + ∀ q : FiniteSupportRing (K := K), + Associates.mk q ≤ a ↔ (q : Series K) ∣ b := by + rw [IsSeriesMaximalFiniteSupportDivisor, isMaximalDivisorAlong_iff] + constructor <;> intro h q + · have hq := h q + change Associates.mk q ≤ a ↔ (q : Series K) ∣ b at hq + exact hq + · have hq := h q + change Associates.mk q ≤ a ↔ + (HahnSeries.Nonpositive.finiteSupportSubring + (G := ℝ) (K := K)).subtype q ∣ b + exact hq + +omit [CharZero K] in +/-- Representative form of the maximal finite-support divisor characterization. -/ +theorem isSeriesMaximalFiniteSupportDivisor_mk_iff (b : Series K) (p : FiniteSupportRing (K := K)) : + IsSeriesMaximalFiniteSupportDivisor b (Associates.mk p) ↔ + ∀ q : FiniteSupportRing (K := K), (q : Series K) ∣ b ↔ q ∣ p := by + rw [isSeriesMaximalFiniteSupportDivisor_iff] + constructor + · intro h q + constructor + · intro hqb + exact Associates.mk_le_mk_iff_dvd.mp ((h q).mpr hqb) + · intro hqp + exact (h q).mp (Associates.mk_le_mk_iff_dvd.mpr hqp) + · intro h q + constructor + · intro hqp + exact (h q).mpr (Associates.mk_le_mk_iff_dvd.mp hqp) + · intro hqb + exact Associates.mk_le_mk_iff_dvd.mpr ((h q).mp hqb) + +omit [CharZero K] in +/-- A Hahn series has at most one maximal finite-support divisor class. -/ +theorem IsSeriesMaximalFiniteSupportDivisor.eq + {b : Series K} {a c : Associates (FiniteSupportRing (K := K))} + (ha : IsSeriesMaximalFiniteSupportDivisor b a) + (hc : IsSeriesMaximalFiniteSupportDivisor b c) : a = c := by + exact IsMaximalDivisorAlong.eq ha hc + +omit [CharZero K] in +/-- Zero has the zero maximal finite-support divisor class. -/ +theorem IsSeriesMaximalFiniteSupportDivisor.zero : + IsSeriesMaximalFiniteSupportDivisor (0 : Series K) 0 := by + apply (isSeriesMaximalFiniteSupportDivisor_iff 0 0).mpr + intro q + constructor + · intro _ + exact dvd_zero _ + · intro _ + exact Associates.mk_le_mk_of_dvd (dvd_zero q) + +/-- Divisibility by a finite-support series splits across an RV-maximal divisor and the +corresponding subtraction residual. -/ +theorem coe_dvd_iff_dvd_rvMaximal_and_residual (b b' : Series K) (p q : FiniteSupportRing (K := K)) + (hp : IsRVMaximalFiniteSupportDivisor + ((HahnSeries.Nonpositive.degreeValuation K).rv b) + (Associates.mk p)) : + (q : Series K) ∣ b ↔ + q ∣ p ∧ (q : Series K) ∣ b - (p : Series K) * b' := by + have hpSpec := (isRVMaximalFiniteSupportDivisor_mk_iff _ p).mp hp + constructor + · intro hqb + have hqRV : finiteSupportRVEmbedding K q ∣ + (HahnSeries.Nonpositive.degreeValuation K).rv b := by + simpa only [finiteSupportRVEmbedding_apply] using + map_dvd + (HahnSeries.Nonpositive.degreeValuation K).rv hqb + have hqp : q ∣ p := (hpSpec q).mp hqRV + have hqpCoe : (q : Series K) ∣ (p : Series K) := + (finiteSupport_dvd_iff_coe_dvd p q).mp hqp + exact ⟨hqp, dvd_sub hqb (hqpCoe.mul_right b')⟩ + · rintro ⟨hqp, hqResidual⟩ + have hqpCoe : (q : Series K) ∣ (p : Series K) := + (finiteSupport_dvd_iff_coe_dvd p q).mp hqp + simpa only [sub_add_cancel] using + dvd_add hqResidual (hqpCoe.mul_right b') + +/-- A positive-degree Hahn series admits an RV-maximal finite-support factor whose subtraction +residual has strictly smaller degree. -/ +theorem exists_rvMaximalFiniteSupportApproximation_of_degree_pos + (hgcd : ∀ p q : FiniteSupportRing (K := K), + ∃ d : FiniteSupportRing (K := K), + ∀ e : FiniteSupportRing (K := K), e ∣ p ∧ e ∣ q ↔ e ∣ d) + {b : Series K} (hb : 0 < (b : K⟦ℝ⟧).degree) : + ∃ (p : FiniteSupportRing (K := K)) (b' : Series K), + IsRVMaximalFiniteSupportDivisor + ((HahnSeries.Nonpositive.degreeValuation K).rv b) + (Associates.mk p) ∧ + ((b - (p : Series K) * b' : Series K) : K⟦ℝ⟧).degree < + (b : K⟦ℝ⟧).degree := by + let w := HahnSeries.Nonpositive.degreeValuation K + obtain ⟨a, ha, _⟩ := + existsUnique_isRVMaximalFiniteSupportDivisor_of_exists_gcd hgcd (w.rv b) + induction a using Quotient.inductionOn with + | _ p => + have hpDvd : finiteSupportRVEmbedding K p ∣ w.rv b := + ((isRVMaximalFiniteSupportDivisor_mk_iff (w.rv b) p).mp ha p).mpr + dvd_rfl + obtain ⟨B', hB'⟩ := hpDvd + obtain ⟨b', hb'⟩ := w.rv_surjective B' + refine ⟨p, b', ha, ?_⟩ + have hbValue : w b ≠ ⊥ := by + rw [HahnSeries.Nonpositive.degreeValuation_apply] + intro hbot + rw [hbot] at hb + exact (not_lt_of_ge bot_le hb) + have hrv : w.rv b = w.rv ((p : Series K) * b') := by + calc + w.rv b = finiteSupportRVEmbedding K p * B' := hB' + _ = w.rv (p : Series K) * w.rv b' := by + rw [finiteSupportRVEmbedding_apply, hb'] + _ = w.rv ((p : Series K) * b') := (map_mul w.rv _ _).symm + have hdrop := (w.rv_eq_iff_of_value_ne_bot hbValue).mp hrv + simpa only [w, + HahnSeries.Nonpositive.degreeValuation_apply] using hdrop + +/-- Pairwise greatest-common-divisor existence gives a maximal finite-support divisor class for +every Hahn series. -/ +theorem exists_isSeriesMaximalFiniteSupportDivisor_of_exists_gcd + (hgcd : ∀ p q : FiniteSupportRing (K := K), + ∃ d : FiniteSupportRing (K := K), + ∀ e : FiniteSupportRing (K := K), e ∣ p ∧ e ∣ q ↔ e ∣ d) + (b : Series K) : + ∃ a : Associates (FiniteSupportRing (K := K)), + IsSeriesMaximalFiniteSupportDivisor b a := by + classical + let wf : WellFounded (Function.onFun (fun α β : WithBot NatOrdinal ↦ α < β) + (fun c : Series K ↦ (c : K⟦ℝ⟧).degree)) := + wellFounded_lt.onFun + refine wf.induction + (C := fun b ↦ ∃ a : Associates (FiniteSupportRing (K := K)), + IsSeriesMaximalFiniteSupportDivisor b a) b ?_ + intro b ih + by_cases hbFinite : (b : K⟦ℝ⟧).degree ≤ 0 + · let p : FiniteSupportRing (K := K) := ⟨b, by + rw [HahnSeries.Nonpositive.mem_finiteSupportSubring_iff, + ← HahnSeries.degree_le_zero_iff] + exact hbFinite⟩ + refine ⟨Associates.mk p, + (isSeriesMaximalFiniteSupportDivisor_mk_iff b p).mpr ?_⟩ + intro q + simpa only [p] using (finiteSupport_dvd_iff_coe_dvd p q).symm + · have hbPos : 0 < (b : K⟦ℝ⟧).degree := lt_of_not_ge hbFinite + obtain ⟨p, b', hp, hdrop⟩ := + exists_rvMaximalFiniteSupportApproximation_of_degree_pos hgcd hbPos + let c : Series K := b - (p : Series K) * b' + obtain ⟨a, ha⟩ := ih c (by simpa only [c] using hdrop) + induction a using Quotient.inductionOn with + | _ p' => + obtain ⟨d, hd⟩ := hgcd p p' + refine ⟨Associates.mk d, + (isSeriesMaximalFiniteSupportDivisor_mk_iff b d).mpr ?_⟩ + intro q + calc + (q : Series K) ∣ b ↔ q ∣ p ∧ (q : Series K) ∣ c := by + simpa only [c] using + coe_dvd_iff_dvd_rvMaximal_and_residual b b' p q hp + _ ↔ q ∣ p ∧ q ∣ p' := + and_congr Iff.rfl + ((isSeriesMaximalFiniteSupportDivisor_mk_iff c p').mp ha q) + _ ↔ q ∣ d := hd q + +/-- Pairwise greatest-common-divisor existence gives a unique maximal finite-support divisor +class for every Hahn series. -/ +theorem existsUnique_isSeriesMaximalFiniteSupportDivisor_of_exists_gcd + (hgcd : ∀ p q : FiniteSupportRing (K := K), + ∃ d : FiniteSupportRing (K := K), + ∀ e : FiniteSupportRing (K := K), e ∣ p ∧ e ∣ q ↔ e ∣ d) + (b : Series K) : + ∃! a : Associates (FiniteSupportRing (K := K)), + IsSeriesMaximalFiniteSupportDivisor b a := by + obtain ⟨a, ha⟩ := + exists_isSeriesMaximalFiniteSupportDivisor_of_exists_gcd hgcd b + exact ⟨a, ha, fun c hc ↦ hc.eq ha⟩ + +/-- The canonical maximal finite-support divisor class of a Hahn series. + +The fallback branch is unreachable whenever maximal-divisor existence has been established. -/ +noncomputable def seriesMaximalFiniteSupportDivisor + (b : Series K) : Associates (FiniteSupportRing (K := K)) := by + classical + exact if h : ∃ a : Associates (FiniteSupportRing (K := K)), + IsSeriesMaximalFiniteSupportDivisor b a then + Classical.choose h + else + 0 + +omit [CharZero K] in +/-- Any class satisfying the series characterization is the canonical class. -/ +theorem seriesMaximalFiniteSupportDivisor_eq_of_is + {b : Series K} {a : Associates (FiniteSupportRing (K := K))} + (ha : IsSeriesMaximalFiniteSupportDivisor b a) : + seriesMaximalFiniteSupportDivisor b = a := by + classical + let hex : ∃ c : Associates (FiniteSupportRing (K := K)), + IsSeriesMaximalFiniteSupportDivisor b c := ⟨a, ha⟩ + rw [seriesMaximalFiniteSupportDivisor, dite_eq_left hex] + exact (Classical.choose_spec hex).eq ha + +/-- Under pairwise greatest-common-divisor existence, the canonical class satisfies its defining +characterization. -/ +theorem seriesMaximalFiniteSupportDivisor_is_of_exists_gcd + (hgcd : ∀ p q : FiniteSupportRing (K := K), + ∃ d : FiniteSupportRing (K := K), + ∀ e : FiniteSupportRing (K := K), e ∣ p ∧ e ∣ q ↔ e ∣ d) + (b : Series K) : + IsSeriesMaximalFiniteSupportDivisor b + (seriesMaximalFiniteSupportDivisor b) := by + obtain ⟨a, ha, _⟩ := + existsUnique_isSeriesMaximalFiniteSupportDivisor_of_exists_gcd hgcd b + rw [seriesMaximalFiniteSupportDivisor_eq_of_is ha] + exact ha + +/-- Maximal finite-support divisor classes of Hahn series are supermultiplicative. -/ +theorem seriesMaximalFiniteSupportDivisor_mul_le_of_exists_gcd + (hgcd : ∀ p q : FiniteSupportRing (K := K), + ∃ d : FiniteSupportRing (K := K), + ∀ e : FiniteSupportRing (K := K), e ∣ p ∧ e ∣ q ↔ e ∣ d) + (b c : Series K) : + seriesMaximalFiniteSupportDivisor b * + seriesMaximalFiniteSupportDivisor c ≤ + seriesMaximalFiniteSupportDivisor (b * c) := by + exact IsMaximalDivisorAlong.mul_le + (seriesMaximalFiniteSupportDivisor_is_of_exists_gcd hgcd b) + (seriesMaximalFiniteSupportDivisor_is_of_exists_gcd hgcd c) + (seriesMaximalFiniteSupportDivisor_is_of_exists_gcd hgcd (b * c)) + +/-- The maximal divisor class of a finite-support series is its own associate class. -/ +theorem seriesMaximalFiniteSupportDivisor_coe (p : FiniteSupportRing (K := K)) : + seriesMaximalFiniteSupportDivisor (p : Series K) = Associates.mk p := by + apply seriesMaximalFiniteSupportDivisor_eq_of_is + apply (isSeriesMaximalFiniteSupportDivisor_mk_iff (p : Series K) p).mpr + intro q + exact (finiteSupport_dvd_iff_coe_dvd p q).symm + +/-- A principal Hahn series has the unit associate class as its maximal finite-support divisor. +-/ +theorem seriesMaximalFiniteSupportDivisor_eq_one_of_isPrincipal + {b : Series K} (hb : HahnSeries.Nonpositive.IsPrincipal b) : + seriesMaximalFiniteSupportDivisor b = 1 := by + let w := HahnSeries.Nonpositive.degreeValuation K + have hPrincipalRV : IsPrincipalRV (w.rv b) := + (isPrincipalRV_iff (w.rv b)).mpr ⟨b, hb, rfl⟩ + obtain ⟨k, hk⟩ := + exists_scalar_isRVMaximalFiniteSupportDivisor_of_isPrincipal (w.rv b) hPrincipalRV + let scalar := HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℝ) k + have hkSpec := (isRVMaximalFiniteSupportDivisor_mk_iff (w.rv b) scalar).mp hk + have hBNe : w.rv b ≠ 0 := by + intro hzero + have hbot := (w.rv_eq_zero_iff).mp hzero + rw [HahnSeries.Nonpositive.degreeValuation_apply, + HahnSeries.degree_eq_bot] at hbot + exact hb.ne_zero (Subtype.ext hbot) + have hkNe : k ≠ 0 := by + intro hkZero + subst k + have hzeroDvd : finiteSupportRVEmbedding K 0 ∣ w.rv b := + (hkSpec 0).mpr (by simp [scalar]) + apply hBNe + apply zero_dvd_iff.mp + simpa using hzeroDvd + have hscalarUnit : IsUnit scalar := by + exact (isUnit_iff_ne_zero.mpr hkNe).map + (HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℝ) (K := K)) + apply seriesMaximalFiniteSupportDivisor_eq_of_is + apply (isSeriesMaximalFiniteSupportDivisor_mk_iff b 1).mpr + intro q + constructor + · intro hqb + have hqRV : finiteSupportRVEmbedding K q ∣ w.rv b := by + simpa only [finiteSupportRVEmbedding_apply] using map_dvd w.rv hqb + exact isUnit_iff_dvd_one.mp + (isUnit_of_dvd_unit ((hkSpec q).mp hqRV) hscalarUnit) + · intro hqOne + exact (isUnit_of_dvd_one hqOne).map + (HahnSeries.Nonpositive.finiteSupportSubring + (G := ℝ) (K := K)).subtype |>.dvd + +end + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/SeriesMaximalMultiplicativity.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/SeriesMaximalMultiplicativity.lean new file mode 100644 index 0000000000..5f698c27b2 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/SeriesMaximalMultiplicativity.lean @@ -0,0 +1,412 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.NormalizedSeriesMaximalFinite + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.RVGradedMaximalFinite +import Mathlib.Algebra.GCDMonoid.Basic +import Mathlib.Order.RelClasses + +/-! +# Multiplicativity of maximal finite-support divisors of Hahn series + +This module proves the field-generic reduction underlying LM24, Proposition 6.3.8. The proof is +by lexicographic well-founded induction on the degrees of the two factors. Its explicit leading-RV +hypothesis is precisely the conclusion of LM24, Corollary 6.3.7. + +Pairwise greatest-common-divisor existence and the classification of finite-support units remain +explicit hypotheses. +-/ + +open scoped HahnSeries NatOrdinal + +universe v + +namespace Berarducci + +public noncomputable section + +open HahnSeries.Nonpositive + +variable {K : Type v} [Field K] [CharZero K] + +private def IsFiniteSupportPrimitive (b : Series K) : Prop := + ∀ q : FiniteSupportRing (K := K), (q : Series K) ∣ b → IsUnit q + +private theorem degree_rightFactor_eq_of_monicFiniteSupport {p : FiniteSupportRing (K := K)} + (hp : IsMonicFiniteSupport p) + {b b₀ : Series K} (hbFactor : b = (p : Series K) * b₀) : + (b₀ : K⟦ℝ⟧).degree = (b : K⟦ℝ⟧).degree := by + have hpHahn : (p : K⟦ℝ⟧) ≠ 0 := by + intro hpZero + apply hp.ne_zero + exact Subtype.ext (Subtype.ext hpZero) + have hpDegree : (p : K⟦ℝ⟧).degree = 0 := by + rw [HahnSeries.degree_eq_zero] + exact ⟨hpHahn, + (mem_finiteSupportSubring_iff (p : Series K)).mp p.2⟩ + have hproduct := HahnSeries.Nonpositive.degree_mul (p : Series K) b₀ + rw [← hbFactor, hpDegree, zero_add] at hproduct + exact hproduct.symm + +private theorem isFiniteSupportPrimitive_factor_of_normalizedMaximal + (hgcd : ∀ p q : FiniteSupportRing (K := K), + ∃ d : FiniteSupportRing (K := K), + ∀ e : FiniteSupportRing (K := K), e ∣ p ∧ e ∣ q ↔ e ∣ d) + {b b₀ : Series K} (hb : b ≠ 0) + (hbFactor : b = + (seriesNormalizedMaximalFiniteSupportDivisor b : Series K) * b₀) : + IsFiniteSupportPrimitive b₀ := by + let pB := seriesNormalizedMaximalFiniteSupportDivisor b + have hmax := (isNormalizedSeriesMaximalFiniteSupportDivisor_iff b pB).mp + (seriesNormalizedMaximalFiniteSupportDivisor_is_of_exists_gcd hgcd b) + have hpBMonic := seriesNormalizedMaximalFiniteSupportDivisor_isMonic_of_ne_zero hgcd hb + have hpB : pB ≠ 0 := hpBMonic.ne_zero + intro q hq + have hpBq : ((pB * q : FiniteSupportRing (K := K)) : Series K) ∣ b := by + rw [hbFactor] + change ((pB * q : FiniteSupportRing (K := K)) : Series K) ∣ + (pB : Series K) * b₀ + have hq' := mul_dvd_mul_left (pB : Series K) hq + simpa only [Subring.coe_mul] using hq' + have hpBqDvd : pB * q ∣ pB := (hmax.1 (pB * q)).mp hpBq + have hqOne : q ∣ 1 := by + apply (mul_dvd_mul_iff_left hpB).mp + simpa only [mul_one] using hpBqDvd + exact isUnit_of_dvd_one hqOne + +/-- A positive-degree series can be approximated by its normalized maximal finite-support +divisor of the leading RV class, with a remainder of strictly smaller degree. -/ +theorem exists_normalizedRVMaximalFiniteSupportApproximation_of_degree_pos + (hgcd : ∀ p q : FiniteSupportRing (K := K), + ∃ d : FiniteSupportRing (K := K), + ∀ e : FiniteSupportRing (K := K), e ∣ p ∧ e ∣ q ↔ e ∣ d) + {b : Series K} (hb : 0 < (b : K⟦ℝ⟧).degree) : + ∃ b' : Series K, + ((b - + (gradedNormalizedMaximalFiniteSupportDivisor + ((degreeValuation K).rvInitialFormHom + ((degreeValuation K).rv b)) : Series K) * + b' : Series K) : K⟦ℝ⟧).degree < + (b : K⟦ℝ⟧).degree := by + let w := degreeValuation K + let pB := gradedNormalizedMaximalFiniteSupportDivisor + (w.rvInitialFormHom (w.rv b)) + obtain ⟨p, b', hp, hdrop⟩ := + exists_rvMaximalFiniteSupportApproximation_of_degree_pos hgcd hb + have hpGraded : + IsGradedMaximalFiniteSupportDivisor + (w.rvInitialFormHom (w.rv b)) (Associates.mk p) := + (isRVMaximalFiniteSupportDivisor_iff_isGradedMaximalFiniteSupportDivisor (w.rv b) + (Associates.mk p)).mp hp + have hpBGraded : + IsGradedMaximalFiniteSupportDivisor + (w.rvInitialFormHom (w.rv b)) (Associates.mk pB) := by + exact (isGradedMaximalFiniteSupportDivisor_mk_iff _ pB).mpr + ((isNormalizedGradedMaximalFiniteSupportDivisor_iff _ pB).mp + (gradedNormalizedMaximalFiniteSupportDivisor_is_of_exists_gcd hgcd _)).1 + have hclasses : Associates.mk pB = Associates.mk p := + hpBGraded.eq hpGraded + obtain ⟨u, hu⟩ := Associates.mk_eq_mk_iff_associated.mp hclasses + let b'' : Series K := (((u : FiniteSupportRing (K := K)) : Series K) * b') + refine ⟨b'', ?_⟩ + have hproduct : (pB : Series K) * b'' = (p : Series K) * b' := by + have hpEq : p = pB * (u : FiniteSupportRing (K := K)) := hu.symm + calc + (pB : Series K) * b'' = + (pB : Series K) * + ((u : FiniteSupportRing (K := K)) : Series K) * b' := by + dsimp only [b''] + rw [mul_assoc] + _ = ((pB * (u : FiniteSupportRing (K := K)) : + FiniteSupportRing (K := K)) : Series K) * b' := by + exact congrArg (· * b') + (map_mul + (finiteSupportSubring (G := ℝ) (K := K)).subtype pB + (u : FiniteSupportRing (K := K))).symm + _ = (p : Series K) * b' := by rw [hpEq] + simpa only [pB, w, hproduct] using hdrop + +omit [CharZero K] in +/-- A finite-support-primitive series of degree at most `0` is a unit: it has finite support, so +it is its own finite-support divisor, and primitivity makes that divisor a unit. -/ +private theorem isUnit_of_isFiniteSupportPrimitive_of_degree_le_zero {b : Series K} + (hbPrimitive : IsFiniteSupportPrimitive b) (hbFinite : (b : K⟦ℝ⟧).degree ≤ 0) : + IsUnit b := by + let p : FiniteSupportRing (K := K) := ⟨b, by + rw [mem_finiteSupportSubring_iff, ← HahnSeries.degree_le_zero_iff] + exact hbFinite⟩ + have hpUnit : IsUnit p := hbPrimitive p (by simp [p]) + change IsUnit ((p : FiniteSupportRing (K := K)) : Series K) + exact hpUnit.map (finiteSupportSubring (G := ℝ) (K := K)).subtype + +/-- The coprimality step of the induction. Let `q` be a finite-support divisor of `b * c`, with +`b` finite-support primitive and the normalized maximal divisor of `c` a unit, and write +`b = p * b' + d` where multiplicativity of the normalized maximal divisor is known for `d * c`. +Every common finite-support divisor `r` of `q` and `p` divides `d * c`, hence the normalized +maximal divisor of `d`, hence `d`, hence `b`; primitivity of `b` makes `r` a unit. -/ +private theorem isRelPrime_of_dvd_mul_of_eq_mul_add + (hgcd : ∀ p q : FiniteSupportRing (K := K), + ∃ d : FiniteSupportRing (K := K), + ∀ e : FiniteSupportRing (K := K), e ∣ p ∧ e ∣ q ↔ e ∣ d) + {b c b' d : Series K} {q p : FiniteSupportRing (K := K)} + (hqbc : (q : Series K) ∣ b * c) + (hbPrimitive : IsFiniteSupportPrimitive b) + (hpCUnit : IsUnit (seriesNormalizedMaximalFiniteSupportDivisor c)) + (hsum : (p : Series K) * b' + d = b) + (hmul : seriesNormalizedMaximalFiniteSupportDivisor (d * c) = + seriesNormalizedMaximalFiniteSupportDivisor d * + seriesNormalizedMaximalFiniteSupportDivisor c) : + IsRelPrime q p := by + intro r hrq hrp + have hrbc : (r : Series K) ∣ b * c := + (map_dvd (finiteSupportSubring (G := ℝ) (K := K)).subtype hrq).trans hqbc + have hrpCoe : (r : Series K) ∣ (p : Series K) := + map_dvd (finiteSupportSubring (G := ℝ) (K := K)).subtype hrp + have hrdc : (r : Series K) ∣ d * c := by + have hdc : d * c = b * c - (p : Series K) * b' * c := by + rw [← hsum] + ring + rw [hdc] + exact dvd_sub hrbc ((hrpCoe.mul_right b').mul_right c) + have hmaxdc := (isNormalizedSeriesMaximalFiniteSupportDivisor_iff + (d * c) (seriesNormalizedMaximalFiniteSupportDivisor (d * c))).mp + (seriesNormalizedMaximalFiniteSupportDivisor_is_of_exists_gcd hgcd (d * c)) + have hrpdc := (hmaxdc.1 r).mp hrdc + rw [hmul] at hrpdc + have hrpd : r ∣ seriesNormalizedMaximalFiniteSupportDivisor d := + hpCUnit.dvd_mul_right.mp hrpdc + have hmaxd := (isNormalizedSeriesMaximalFiniteSupportDivisor_iff + d (seriesNormalizedMaximalFiniteSupportDivisor d)).mp + (seriesNormalizedMaximalFiniteSupportDivisor_is_of_exists_gcd hgcd d) + have hrd : (r : Series K) ∣ d := (hmaxd.1 r).mpr hrpd + apply hbPrimitive r + rw [← hsum] + exact dvd_add (hrpCoe.mul_right b') hrd + +/-- A finite-support divisor of a series divides the normalized maximal finite-support divisor of +the initial form of its leading RV class: the RV map and the initial-form map are multiplicative, +and on finite-support elements their composite is the graded embedding. -/ +private theorem dvd_gradedNormalizedMaximalFiniteSupportDivisor_rvInitialForm_of_dvd + (hgcd : ∀ p q : FiniteSupportRing (K := K), + ∃ d : FiniteSupportRing (K := K), + ∀ e : FiniteSupportRing (K := K), e ∣ p ∧ e ∣ q ↔ e ∣ d) + {d : Series K} {q : FiniteSupportRing (K := K)} (hqd : (q : Series K) ∣ d) : + q ∣ gradedNormalizedMaximalFiniteSupportDivisor + ((degreeValuation K).rvInitialFormHom ((degreeValuation K).rv d)) := by + let w := degreeValuation K + have hqRV : finiteSupportRVEmbedding K q ∣ w.rv d := by + simpa only [finiteSupportRVEmbedding_apply] using map_dvd w.rv hqd + have hqInitialRaw := map_dvd w.rvInitialFormHom hqRV + have hfinite : + w.rvInitialFormHom (finiteSupportRVEmbedding K q) = + finiteSupportGradedEmbedding K q := by + calc + w.rvInitialFormHom (finiteSupportRVEmbedding K q) = + ((w.rvEquivHomogeneous (finiteSupportRVEmbedding K q) : + w.HomogeneousClasses) : w.AssociatedGraded) := by + rw [w.rvEquivHomogeneous_apply, w.coe_rvHomogeneous] + _ = finiteSupportGradedEmbedding K q := by + simpa only [w] using + coe_rvEquivHomogeneous_finiteSupportRVEmbedding q + rw [hfinite] at hqInitialRaw + have hmax := (isNormalizedGradedMaximalFiniteSupportDivisor_iff + (w.rvInitialFormHom (w.rv d)) + (gradedNormalizedMaximalFiniteSupportDivisor (w.rvInitialFormHom (w.rv d)))).mp + (gradedNormalizedMaximalFiniteSupportDivisor_is_of_exists_gcd hgcd + (w.rvInitialFormHom (w.rv d))) + exact (hmax.1 q).mp hqInitialRaw + +/-- Under leading-RV multiplicativity, the normalized maximal finite-support divisor of the +initial form of `rv (b * c)` is the product of those of the initial forms of `rv b` and +`rv c`, because `rv` and the initial-form map are monoid homomorphisms. -/ +private theorem gradedNormalizedMaximalFiniteSupportDivisor_rvInitialForm_mul + (hgradedMul : ∀ B C : DegreeGraded K, + gradedNormalizedMaximalFiniteSupportDivisor (B * C) = + gradedNormalizedMaximalFiniteSupportDivisor B * + gradedNormalizedMaximalFiniteSupportDivisor C) + (b c : Series K) : + gradedNormalizedMaximalFiniteSupportDivisor + ((degreeValuation K).rvInitialFormHom ((degreeValuation K).rv (b * c))) = + gradedNormalizedMaximalFiniteSupportDivisor + ((degreeValuation K).rvInitialFormHom ((degreeValuation K).rv b)) * + gradedNormalizedMaximalFiniteSupportDivisor + ((degreeValuation K).rvInitialFormHom ((degreeValuation K).rv c)) := by + rw [map_mul, map_mul] + exact hgradedMul _ _ + +/-- The inductive step: the product of two finite-support-primitive series is finite-support +primitive, given multiplicativity of the normalized maximal divisor for pairs of strictly +smaller degree on either side. A factor of degree at most `0` is a unit and drops out. Otherwise +each factor is approximated by its leading-RV normalized maximal divisor with a remainder of +smaller degree; a finite-support divisor `q` of the product is coprime to both approximating +divisors and divides their product, so it is a unit. -/ +private theorem isFiniteSupportPrimitive_mul_of_induction + (hgcd : ∀ p q : FiniteSupportRing (K := K), + ∃ d : FiniteSupportRing (K := K), + ∀ e : FiniteSupportRing (K := K), e ∣ p ∧ e ∣ q ↔ e ∣ d) + (hgradedMul : ∀ B C : DegreeGraded K, + gradedNormalizedMaximalFiniteSupportDivisor (B * C) = + gradedNormalizedMaximalFiniteSupportDivisor B * + gradedNormalizedMaximalFiniteSupportDivisor C) + {b c : Series K} + (hbPrimitive : IsFiniteSupportPrimitive b) + (hcPrimitive : IsFiniteSupportPrimitive c) + (ihLeft : ∀ d : Series K, + (d : K⟦ℝ⟧).degree < (b : K⟦ℝ⟧).degree → + seriesNormalizedMaximalFiniteSupportDivisor (d * c) = + seriesNormalizedMaximalFiniteSupportDivisor d * + seriesNormalizedMaximalFiniteSupportDivisor c) + (ihRight : ∀ d : Series K, + (d : K⟦ℝ⟧).degree < (c : K⟦ℝ⟧).degree → + seriesNormalizedMaximalFiniteSupportDivisor (b * d) = + seriesNormalizedMaximalFiniteSupportDivisor b * + seriesNormalizedMaximalFiniteSupportDivisor d) : + IsFiniteSupportPrimitive (b * c) := by + classical + intro q hqbc + by_cases hbFinite : (b : K⟦ℝ⟧).degree ≤ 0 + · exact hcPrimitive q + ((isUnit_of_isFiniteSupportPrimitive_of_degree_le_zero hbPrimitive hbFinite).dvd_mul_left.mp + hqbc) + by_cases hcFinite : (c : K⟦ℝ⟧).degree ≤ 0 + · exact hbPrimitive q + ((isUnit_of_isFiniteSupportPrimitive_of_degree_le_zero hcPrimitive hcFinite).dvd_mul_right.mp + hqbc) + obtain ⟨b', hdropB⟩ := + exists_normalizedRVMaximalFiniteSupportApproximation_of_degree_pos hgcd + (lt_of_not_ge hbFinite) + obtain ⟨c', hdropC⟩ := + exists_normalizedRVMaximalFiniteSupportApproximation_of_degree_pos hgcd + (lt_of_not_ge hcFinite) + have hpBUnit : IsUnit (seriesNormalizedMaximalFiniteSupportDivisor b) := + hbPrimitive _ (seriesNormalizedMaximalFiniteSupportDivisor_dvd_of_exists_gcd hgcd b) + have hpCUnit : IsUnit (seriesNormalizedMaximalFiniteSupportDivisor c) := + hcPrimitive _ (seriesNormalizedMaximalFiniteSupportDivisor_dvd_of_exists_gcd hgcd c) + have hrelB := isRelPrime_of_dvd_mul_of_eq_mul_add hgcd hqbc hbPrimitive hpCUnit + (add_sub_cancel _ _) (ihLeft _ hdropB) + have hrelC := isRelPrime_of_dvd_mul_of_eq_mul_add hgcd (by rw [mul_comm]; exact hqbc) + hcPrimitive hpBUnit (add_sub_cancel _ _) (by rw [mul_comm, ihRight _ hdropC, mul_comm]) + have hq := dvd_gradedNormalizedMaximalFiniteSupportDivisor_rvInitialForm_of_dvd hgcd hqbc + rw [gradedNormalizedMaximalFiniteSupportDivisor_rvInitialForm_mul hgradedMul] at hq + let : GCDMonoid (FiniteSupportRing (K := K)) := gcdMonoidOfExistsGCD hgcd + exact (hrelB.mul_right hrelC).isUnit_of_dvd hq + +/-- Multiplicativity of normalized maximal finite-support divisors of Hahn series follows from +the corresponding leading-RV multiplicativity theorem. -/ +theorem seriesNormalizedMaximalFiniteSupportDivisor_mul_of_graded + (hgcd : ∀ p q : FiniteSupportRing (K := K), + ∃ d : FiniteSupportRing (K := K), + ∀ e : FiniteSupportRing (K := K), e ∣ p ∧ e ∣ q ↔ e ∣ d) + (hunits : ∀ u : FiniteSupportRing (K := K), + IsUnit u ↔ ∃ k : K, k ≠ 0 ∧ + u = finiteSupportScalarHom (G := ℝ) k) + (hgradedMul : ∀ B C : DegreeGraded K, + gradedNormalizedMaximalFiniteSupportDivisor (B * C) = + gradedNormalizedMaximalFiniteSupportDivisor B * + gradedNormalizedMaximalFiniteSupportDivisor C) + (b c : Series K) : + seriesNormalizedMaximalFiniteSupportDivisor (b * c) = + seriesNormalizedMaximalFiniteSupportDivisor b * + seriesNormalizedMaximalFiniteSupportDivisor c := by + classical + let degreePair : Series K × Series K → + WithBot NatOrdinal × WithBot NatOrdinal := + fun bc ↦ ((bc.1 : K⟦ℝ⟧).degree, (bc.2 : K⟦ℝ⟧).degree) + let wf : WellFounded + (Function.onFun (Prod.Lex (· < ·) (· < ·)) degreePair) := + (wellFounded_lt.prod_lex wellFounded_lt).onFun + refine wf.induction (C := fun bc ↦ + seriesNormalizedMaximalFiniteSupportDivisor (bc.1 * bc.2) = + seriesNormalizedMaximalFiniteSupportDivisor bc.1 * + seriesNormalizedMaximalFiniteSupportDivisor bc.2) (b, c) ?_ + rintro ⟨b, c⟩ ih + change seriesNormalizedMaximalFiniteSupportDivisor (b * c) = + seriesNormalizedMaximalFiniteSupportDivisor b * + seriesNormalizedMaximalFiniteSupportDivisor c + by_cases hb : b = 0 + · subst b + rw [zero_mul, + seriesNormalizedMaximalFiniteSupportDivisor_zero_of_exists_gcd hgcd, + zero_mul] + by_cases hc : c = 0 + · subst c + rw [mul_zero, + seriesNormalizedMaximalFiniteSupportDivisor_zero_of_exists_gcd hgcd, + mul_zero] + let pB := seriesNormalizedMaximalFiniteSupportDivisor b + let pC := seriesNormalizedMaximalFiniteSupportDivisor c + have hpBMonic := seriesNormalizedMaximalFiniteSupportDivisor_isMonic_of_ne_zero hgcd hb + have hpCMonic := seriesNormalizedMaximalFiniteSupportDivisor_isMonic_of_ne_zero hgcd hc + obtain ⟨b₀, hbFactor⟩ := + seriesNormalizedMaximalFiniteSupportDivisor_dvd_of_exists_gcd hgcd b + obtain ⟨c₀, hcFactor⟩ := + seriesNormalizedMaximalFiniteSupportDivisor_dvd_of_exists_gcd hgcd c + have hb₀Degree : (b₀ : K⟦ℝ⟧).degree = (b : K⟦ℝ⟧).degree := + degree_rightFactor_eq_of_monicFiniteSupport hpBMonic hbFactor + have hc₀Degree : (c₀ : K⟦ℝ⟧).degree = (c : K⟦ℝ⟧).degree := + degree_rightFactor_eq_of_monicFiniteSupport hpCMonic hcFactor + have hb₀Primitive : IsFiniteSupportPrimitive b₀ := + isFiniteSupportPrimitive_factor_of_normalizedMaximal hgcd hb hbFactor + have hc₀Primitive : IsFiniteSupportPrimitive c₀ := + isFiniteSupportPrimitive_factor_of_normalizedMaximal hgcd hc hcFactor + have hb₀c₀Primitive : IsFiniteSupportPrimitive (b₀ * c₀) := + isFiniteSupportPrimitive_mul_of_induction hgcd hgradedMul + hb₀Primitive hc₀Primitive + (fun d hd ↦ ih (d, c₀) (by + change Prod.Lex (· < ·) (· < ·) + ((d : K⟦ℝ⟧).degree, (c₀ : K⟦ℝ⟧).degree) + ((b : K⟦ℝ⟧).degree, (c : K⟦ℝ⟧).degree) + exact Prod.Lex.left _ _ (hd.trans_eq hb₀Degree))) + (fun d hd ↦ ih (b₀, d) (by + change Prod.Lex (· < ·) (· < ·) + ((b₀ : K⟦ℝ⟧).degree, (d : K⟦ℝ⟧).degree) + ((b : K⟦ℝ⟧).degree, (c : K⟦ℝ⟧).degree) + rw [hb₀Degree] + exact Prod.Lex.right _ (hd.trans_eq hc₀Degree))) + let pBC := seriesNormalizedMaximalFiniteSupportDivisor (b * c) + have hpProdDvd : pB * pC ∣ pBC := by + exact seriesNormalizedMaximalFiniteSupportDivisor_mul_dvd_of_exists_gcd hgcd b c + obtain ⟨r, hr⟩ := hpProdDvd + have hpBCDvd : (pBC : Series K) ∣ b * c := + seriesNormalizedMaximalFiniteSupportDivisor_dvd_of_exists_gcd hgcd (b * c) + have hleft : + ((pB * pC * r : FiniteSupportRing (K := K)) : Series K) = + (((pB * pC : FiniteSupportRing (K := K)) : Series K) * + (r : Series K)) := by + simp only [Subring.coe_mul] + have hright : + b * c = + ((pB * pC : FiniteSupportRing (K := K)) : Series K) * (b₀ * c₀) := by + rw [hbFactor, hcFactor] + simp only [Subring.coe_mul] + ring + have hrDiv : (r : Series K) ∣ b₀ * c₀ := by + have hdiv : + ((pB * pC * r : FiniteSupportRing (K := K)) : Series K) ∣ b * c := by + rw [← hr] + exact hpBCDvd + rw [hleft, hright] at hdiv + apply (mul_dvd_mul_iff_left ?_).mp hdiv + exact (map_ne_zero_iff + (finiteSupportSubring (G := ℝ) (K := K)).subtype + (finiteSupportSubring (G := ℝ) (K := K)).subtype_injective).mpr + (mul_ne_zero hpBMonic.ne_zero hpCMonic.ne_zero) + have hrUnit : IsUnit r := hb₀c₀Primitive r hrDiv + have hmaxBC := (isNormalizedSeriesMaximalFiniteSupportDivisor_iff + (b * c) pBC).mp + (seriesNormalizedMaximalFiniteSupportDivisor_is_of_exists_gcd hgcd (b * c)) + apply seriesNormalizedMaximalFiniteSupportDivisor_eq_of_is hgcd hunits + rw [isNormalizedSeriesMaximalFiniteSupportDivisor_iff] + constructor + · intro q + rw [hmaxBC.1 q, hr, hrUnit.dvd_mul_right] + · exact Or.inr ⟨mul_ne_zero hb hc, hpBMonic.mul hpCMonic⟩ + +end + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/SeriesPrimality.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/SeriesPrimality.lean new file mode 100644 index 0000000000..0713b96b0d --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/SeriesPrimality.lean @@ -0,0 +1,87 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.NormalizedSeriesMaximalFinite + +import Mathlib.Algebra.GCDMonoid.Basic + +/-! +# Primality of finite-support elements in the Hahn-series ring + +This module proves the field-generic reduction underlying LM24, Corollary 6.3.9. The stronger +theorem retains both factors inside the finite-support subring. Primality of their images in the +Hahn-series ring is derived from that witness theorem. +-/ + +open scoped HahnSeries + +universe v + +namespace Berarducci + +public noncomputable section + +open HahnSeries.Nonpositive + +variable {K : Type v} [Field K] [CharZero K] + +/-- A finite-support divisor of a product of Hahn series factors into finite-support divisors of +the two factors, assuming multiplicativity of normalized maximal finite-support divisors. -/ +theorem finiteSupportSeries_exists_factor_dvd_of_maximalMultiplicative + (hgcd : ∀ p q : FiniteSupportRing (K := K), + ∃ d : FiniteSupportRing (K := K), + ∀ e : FiniteSupportRing (K := K), e ∣ p ∧ e ∣ q ↔ e ∣ d) + (hmaxMul : ∀ b c : Series K, + seriesNormalizedMaximalFiniteSupportDivisor (b * c) = + seriesNormalizedMaximalFiniteSupportDivisor b * + seriesNormalizedMaximalFiniteSupportDivisor c) + (p : FiniteSupportRing (K := K)) (b c : Series K) + (hp : (p : Series K) ∣ b * c) : + ∃ p₁ p₂ : FiniteSupportRing (K := K), + p = p₁ * p₂ ∧ (p₁ : Series K) ∣ b ∧ (p₂ : Series K) ∣ c := by + classical + have hmaxBC := (isNormalizedSeriesMaximalFiniteSupportDivisor_iff + (b * c) (seriesNormalizedMaximalFiniteSupportDivisor (b * c))).mp + (seriesNormalizedMaximalFiniteSupportDivisor_is_of_exists_gcd hgcd (b * c)) + have hpMax : p ∣ seriesNormalizedMaximalFiniteSupportDivisor (b * c) := + (hmaxBC.1 p).mp hp + rw [hmaxMul b c] at hpMax + let : GCDMonoid (FiniteSupportRing (K := K)) := + gcdMonoidOfExistsGCD hgcd + obtain ⟨p₁, p₂, hp₁, hp₂, hpFactor⟩ := + exists_dvd_and_dvd_of_dvd_mul hpMax + have hmaxB := (isNormalizedSeriesMaximalFiniteSupportDivisor_iff + b (seriesNormalizedMaximalFiniteSupportDivisor b)).mp + (seriesNormalizedMaximalFiniteSupportDivisor_is_of_exists_gcd hgcd b) + have hmaxC := (isNormalizedSeriesMaximalFiniteSupportDivisor_iff + c (seriesNormalizedMaximalFiniteSupportDivisor c)).mp + (seriesNormalizedMaximalFiniteSupportDivisor_is_of_exists_gcd hgcd c) + exact ⟨p₁, p₂, hpFactor, + (hmaxB.1 p₁).mpr hp₁, (hmaxC.1 p₂).mpr hp₂⟩ + +/-- Every finite-support element is primal in the Hahn-series ring under the same explicit +prerequisites. -/ +theorem finiteSupportSeries_isPrimal_of_maximalMultiplicative + (hgcd : ∀ p q : FiniteSupportRing (K := K), + ∃ d : FiniteSupportRing (K := K), + ∀ e : FiniteSupportRing (K := K), e ∣ p ∧ e ∣ q ↔ e ∣ d) + (hmaxMul : ∀ b c : Series K, + seriesNormalizedMaximalFiniteSupportDivisor (b * c) = + seriesNormalizedMaximalFiniteSupportDivisor b * + seriesNormalizedMaximalFiniteSupportDivisor c) + (p : FiniteSupportRing (K := K)) : + IsPrimal (p : Series K) := by + intro b c hp + obtain ⟨p₁, p₂, hpFactor, hp₁, hp₂⟩ := + finiteSupportSeries_exists_factor_dvd_of_maximalMultiplicative hgcd hmaxMul p b c hp + refine ⟨(p₁ : Series K), (p₂ : Series K), hp₁, hp₂, ?_⟩ + exact congrArg + (finiteSupportSubring (G := ℝ) (K := K)).subtype hpFactor + +end + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Statements.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Statements.lean new file mode 100644 index 0000000000..4554e3ba16 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Statements.lean @@ -0,0 +1,21 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Statements.Factorization +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Statements.FiniteSupportFactorUniqueness +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Statements.MaximalFiniteMultiplicativity +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Statements.MaximalFiniteSupportDivisor +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Statements.PrincipalDivisibilityReflection +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Statements.PrincipalMaximalDivisor +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Statements.PrincipalScalarRedistribution +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Statements.PrincipalSubringFraction +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Statements.PrincipalSubringPrimality +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Statements.SeriesMaximalFiniteSupportDivisor +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Statements.SeriesPrimality + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Statements/Factorization.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Statements/Factorization.lean new file mode 100644 index 0000000000..fae37c9b55 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Statements/Factorization.lean @@ -0,0 +1,82 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.NormalizedSeriesMaximalFinite +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.DegreeTermCount + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.InfiniteSupport +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Statements.ProductValue +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.FiniteSupportUnit +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.FiniteSupportGCDProof +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Degree.Statements.Degree + +/-! +# LM24 factorisation statement + +This module gives the exact public signature of LM24, Proposition 5.6.1 for `K((ℝ^{≤ 0}))`. +A list represents the finite sequence `c₁, …, cₙ` from the paper, and its length is `n`. Every +list member is irreducible and has infinite support. The list length is bounded by the number of +terms in the uncompressed Cantor normal form of the degree. + +The first theorem retains the derived fact that the coefficient scalar is nonzero. The second +theorem has exactly the conclusion printed in Proposition 5.6.1. Both retain the normalized +maximal finite-support divisor `p(b)` from LM24, Notation 5.5.2. + +The proofs combine Berarducci multiplicativity, the finite-support greatest-common-divisor and +unit-classification theorems, Cantor-term arithmetic, residual reduction, and factorisation +induction. +-/ + +open scoped HahnSeries NatOrdinal + +universe v + +namespace Berarducci + +public noncomputable section + +variable {K : Type v} [Field K] [hchar : CharZero K] + +include hchar in +/-- Strengthened form of LM24, Proposition 5.6.1, recording that the coefficient scalar is +nonzero. -/ +theorem series_infinite_support_factorization_with_nonzero_scalar {b : Series K} (hb : b ≠ 0) : + ∃ (factors : List (Series K)) (k : K), + k ≠ 0 ∧ + b = HahnSeries.Nonpositive.C k * + (seriesNormalizedMaximalFiniteSupportDivisor b : Series K) * + factors.prod ∧ + (∀ c ∈ factors, + Irreducible c ∧ (c : K⟦ℝ⟧).support.Infinite) ∧ + factors.length ≤ HahnSeries.degreeCantorTermCount (b : K⟦ℝ⟧) := by + obtain ⟨k, factors, hk, hfactor, hfactors, hbound⟩ := + exists_series_infinite_support_factorization_of_exists_gcd + (HahnSeries.Nonpositive.finiteSupport_pairwise_gcd_exists + (G := ℝ) (K := K)) + (HahnSeries.Nonpositive.isUnit_finiteSupport_iff_exists_scalar + (G := ℝ) (K := K)) hb + exact ⟨factors, k, hk, hfactor, hfactors, hbound⟩ + +include hchar in +/-- LM24, Proposition 5.6.1: every nonzero series is a scalar times its normalized maximal +finite-support divisor and finitely many irreducible infinite-support series, with the number of +such factors bounded by the Cantor term count of its degree. -/ +theorem series_infinite_support_factorization {b : Series K} (hb : b ≠ 0) : + ∃ (factors : List (Series K)) (k : K), + b = HahnSeries.Nonpositive.C k * + (seriesNormalizedMaximalFiniteSupportDivisor b : Series K) * + factors.prod ∧ + (∀ c ∈ factors, + Irreducible c ∧ (c : K⟦ℝ⟧).support.Infinite) ∧ + factors.length ≤ HahnSeries.degreeCantorTermCount (b : K⟦ℝ⟧) := by + obtain ⟨factors, k, _, hfactor, hfactors, hbound⟩ := + series_infinite_support_factorization_with_nonzero_scalar hb + exact ⟨factors, k, hfactor, hfactors, hbound⟩ + +end + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Statements/FiniteSupportFactorUniqueness.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Statements/FiniteSupportFactorUniqueness.lean new file mode 100644 index 0000000000..b3dcc145ec --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Statements/FiniteSupportFactorUniqueness.lean @@ -0,0 +1,56 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.FiniteSupportFactorUniqueness + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Statements.ProductValue +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.FiniteSupportUnit +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.FiniteSupportGCDProof +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Degree.Statements.Degree +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Statements.MaximalFiniteMultiplicativity + +/-! +# LM24 uniqueness of the finite-support factor + +This module states LM24, Theorem 6.4.1. For each nonzero series, it gives one finite-support +factor and finitely many irreducible infinite-support factors. The number of infinite-support +factors is bounded by the number of terms in the Cantor normal form of the degree. Only the +finite-support factor is asserted to be unique, and only up to multiplication by a nonzero +coefficient scalar. + +The list represents the source sequence `c₁, …, cₙ`; its length is the source natural number +`n`. The proof combines LM24, Proposition 5.6.1 and Proposition 6.3.8. +-/ + +open scoped HahnSeries + +universe v + +namespace Berarducci + +public noncomputable section + +variable {K : Type v} [Field K] [CharZero K] + +/-- LM24, Theorem 6.4.1: every nonzero series factors into one finite-support factor and a +bounded finite list of irreducible infinite-support factors, and the finite-support factor is +unique up to multiplication by a nonzero coefficient scalar. -/ +theorem series_factorization_with_unique_finiteSupportFactor {b : Series K} (hb : b ≠ 0) : + ∃ (p : FiniteSupportRing (K := K)) (factors : List (Series K)), + IsInfiniteSupportIrreducibleFactorization b p factors ∧ + factors.length ≤ HahnSeries.degreeCantorTermCount (b : K⟦ℝ⟧) ∧ + IsUniqueFiniteSupportFactorUpToScalar b p := by + let hgcd := HahnSeries.Nonpositive.finiteSupport_pairwise_gcd_exists + (G := ℝ) (K := K) + let hunits := HahnSeries.Nonpositive.isUnit_finiteSupport_iff_exists_scalar + (G := ℝ) (K := K) + exact exists_factorization_with_unique_finiteSupportFactor hgcd hunits + (seriesMaximalFiniteSupportDivisor_mul (K := K)) hb + +end + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Statements/MaximalFiniteMultiplicativity.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Statements/MaximalFiniteMultiplicativity.lean new file mode 100644 index 0000000000..3ffc8a4580 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Statements/MaximalFiniteMultiplicativity.lean @@ -0,0 +1,72 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.NormalizedSeriesMaximalFinite + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.MaximalFiniteMultiplicativity +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.SeriesMaximalMultiplicativity +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Statements.ProductValue +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.FiniteSupportUnit +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.FiniteSupportGCDProof +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Degree.Statements.Degree +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Statements.PrincipalSubringPrimality + +/-! +# LM24 multiplicativity of maximal finite-support divisors + +This module states LM24, Corollary 6.3.7. The normalized maximal finite-support divisor of a +product in `RV̂` is the product of the two normalized maximal finite-support divisors. + +The proof applies the finite-support factor witness from Corollary 6.3.6 to the generic +normalization argument. + +Both statements assume only that the coefficient field has characteristic zero; Proposition +6.3.8 below has the printed signature on Hahn series. +-/ + +open scoped HahnSeries + +universe v + +namespace Berarducci + +public noncomputable section + +variable {K : Type v} [Field K] [hchar : CharZero K] + +include hchar in +/-- LM24, Corollary 6.3.7: the normalized maximal finite-support divisor is multiplicative on +the degree-graded ring `RV̂`. -/ +theorem maximalFiniteSupportDivisor_mul (B C : DegreeGraded K) : + gradedNormalizedMaximalFiniteSupportDivisor (B * C) = + gradedNormalizedMaximalFiniteSupportDivisor B * + gradedNormalizedMaximalFiniteSupportDivisor C := by + let hgcd := HahnSeries.Nonpositive.finiteSupport_pairwise_gcd_exists + (G := ℝ) (K := K) + let hunits := HahnSeries.Nonpositive.isUnit_finiteSupport_iff_exists_scalar + (G := ℝ) (K := K) + apply gradedNormalizedMaximalFiniteSupportDivisor_mul_of_factorization hgcd hunits + intro p X Y hp + exact finiteSupportGradedEmbedding_exists_factor_dvd p X Y hp + +include hchar in +/-- LM24, Proposition 6.3.8: the normalized maximal finite-support divisor is multiplicative on +the Hahn-series ring `K((ℝ^{≤ 0}))`. -/ +theorem seriesMaximalFiniteSupportDivisor_mul (b c : Series K) : + seriesNormalizedMaximalFiniteSupportDivisor (b * c) = + seriesNormalizedMaximalFiniteSupportDivisor b * + seriesNormalizedMaximalFiniteSupportDivisor c := by + let hgcd := HahnSeries.Nonpositive.finiteSupport_pairwise_gcd_exists + (G := ℝ) (K := K) + let hunits := HahnSeries.Nonpositive.isUnit_finiteSupport_iff_exists_scalar + (G := ℝ) (K := K) + exact seriesNormalizedMaximalFiniteSupportDivisor_mul_of_graded hgcd hunits + maximalFiniteSupportDivisor_mul b c + +end + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Statements/MaximalFiniteSupportDivisor.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Statements/MaximalFiniteSupportDivisor.lean new file mode 100644 index 0000000000..98bb8b0b53 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Statements/MaximalFiniteSupportDivisor.lean @@ -0,0 +1,204 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.NormalizedMaximalFinite +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.RVMaximalFinite + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Statements.ProductValue +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.FiniteSupportUnit +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.FiniteSupportGCDProof + +/-! +# LM24 maximal finite-support divisor statements + +This module gives representative-valued statements of LM24, Proposition 5.4.3 and Corollary +5.4.4. The proved core first constructs the maximal divisor intrinsically in the associates of +the finite-support ring. Here LM24, Fact 2.5.2 is used only to supply pairwise gcds and to identify +the units with nonzero constant series. + +The proposition is stated in the multiplicative RV quotient, whereas the corollary is stated in +the full degree-graded ring. These two divisibility relations are not conflated. +The proofs use Berarducci ordinal-value multiplicativity. Degree multiplicativity is an explicit +hypothesis. +-/ + +open scoped DirectSum HahnSeries NatOrdinal + +universe v + +public noncomputable section + +namespace Berarducci + +variable {K : Type v} [Field K] [CharZero K] + +private theorem rv_representative_spec_and_uniqueness (B : HahnDegreeRV K) + (p : FiniteSupportRing (K := K)) + (hp : IsRVMaximalFiniteSupportDivisor B (Associates.mk p)) : + (∀ q : FiniteSupportRing (K := K), + finiteSupportRVEmbedding K q ∣ B ↔ q ∣ p) ∧ + ∀ p' : FiniteSupportRing (K := K), + (∀ q : FiniteSupportRing (K := K), + finiteSupportRVEmbedding K q ∣ B ↔ q ∣ p') → + ∃ k : K, k ≠ 0 ∧ + p' = HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℝ) k * p := by + have hpSpec := + (isRVMaximalFiniteSupportDivisor_mk_iff B p).mp hp + refine ⟨hpSpec, ?_⟩ + intro p' hp'Spec + have hp' := + (isRVMaximalFiniteSupportDivisor_mk_iff B p').mpr hp'Spec + exact HahnSeries.Nonpositive.exists_nonzero_scalar_mul_of_mk_eq_mk + (HahnSeries.Nonpositive.isUnit_finiteSupport_iff_exists_scalar + (G := ℝ) (K := K)) + (IsRVMaximalFiniteSupportDivisor.eq hp hp') + +/-- LM24, Proposition 5.4.3: every RV class has a finite-support series with exactly the same +finite-support divisors. It is unique up to a nonzero scalar and can be chosen constant when the +RV class is principal. -/ +theorem rv_maximal_finite_support_divisor (B : HahnDegreeRV K) : + ∃ p : FiniteSupportRing (K := K), + (∀ q : FiniteSupportRing (K := K), + finiteSupportRVEmbedding K q ∣ B ↔ q ∣ p) ∧ + (∀ p' : FiniteSupportRing (K := K), + (∀ q : FiniteSupportRing (K := K), + finiteSupportRVEmbedding K q ∣ B ↔ q ∣ p') → + ∃ k : K, k ≠ 0 ∧ + p' = HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℝ) k * p) ∧ + (IsPrincipalRV B → + ∃ k : K, + p = HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℝ) k) := by + let hgcd := HahnSeries.Nonpositive.finiteSupport_pairwise_gcd_exists + (G := ℝ) (K := K) + by_cases hBPrincipal : IsPrincipalRV B + · obtain ⟨k, hk⟩ := + exists_scalar_isRVMaximalFiniteSupportDivisor_of_isPrincipal B hBPrincipal + obtain ⟨hkSpec, hkUnique⟩ := + rv_representative_spec_and_uniqueness B + (HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℝ) k) hk + exact ⟨HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℝ) k, + hkSpec, hkUnique, fun _ ↦ ⟨k, rfl⟩⟩ + · obtain ⟨a, ha, _⟩ := + existsUnique_isRVMaximalFiniteSupportDivisor_of_exists_gcd hgcd B + induction a using Quotient.inductionOn with + | _ p => + obtain ⟨hpSpec, hpUnique⟩ := + rv_representative_spec_and_uniqueness B p ha + exact ⟨p, hpSpec, hpUnique, fun hB ↦ (hBPrincipal hB).elim⟩ + +omit [CharZero K] in +private theorem graded_representative_spec_and_uniqueness (B : DegreeGraded K) + (p : FiniteSupportRing (K := K)) + (hp : IsGradedMaximalFiniteSupportDivisor B (Associates.mk p)) : + (∀ q : FiniteSupportRing (K := K), + finiteSupportGradedEmbedding K q ∣ B ↔ q ∣ p) ∧ + ∀ p' : FiniteSupportRing (K := K), + (∀ q : FiniteSupportRing (K := K), + finiteSupportGradedEmbedding K q ∣ B ↔ q ∣ p') → + ∃ k : K, k ≠ 0 ∧ + p' = HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℝ) k * p := by + have hpSpec := + (isGradedMaximalFiniteSupportDivisor_mk_iff B p).mp hp + refine ⟨hpSpec, ?_⟩ + intro p' hp'Spec + have hp' := + (isGradedMaximalFiniteSupportDivisor_mk_iff B p').mpr hp'Spec + exact HahnSeries.Nonpositive.exists_nonzero_scalar_mul_of_mk_eq_mk + (HahnSeries.Nonpositive.isUnit_finiteSupport_iff_exists_scalar + (G := ℝ) (K := K)) + (IsGradedMaximalFiniteSupportDivisor.eq hp hp') + +/-- LM24, Corollary 5.4.4: every element of the full associated graded ring has a finite-support +series with exactly the same finite-support divisors, unique up to a nonzero scalar. -/ +theorem graded_maximal_finite_support_divisor (B : DegreeGraded K) : + ∃ p : FiniteSupportRing (K := K), + (∀ q : FiniteSupportRing (K := K), + finiteSupportGradedEmbedding K q ∣ B ↔ q ∣ p) ∧ + ∀ p' : FiniteSupportRing (K := K), + (∀ q : FiniteSupportRing (K := K), + finiteSupportGradedEmbedding K q ∣ B ↔ q ∣ p') → + ∃ k : K, k ≠ 0 ∧ + p' = HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℝ) k * p := by + let hgcd := HahnSeries.Nonpositive.finiteSupport_pairwise_gcd_exists + (G := ℝ) (K := K) + obtain ⟨a, ha, _⟩ := + existsUnique_isGradedMaximalFiniteSupportDivisor_of_exists_gcd hgcd B + induction a using Quotient.inductionOn with + | _ p => + obtain ⟨hpSpec, hpUnique⟩ := + graded_representative_spec_and_uniqueness B p ha + exact ⟨p, hpSpec, hpUnique⟩ + +/-- LM24, Notation 5.4.5: there is exactly one maximal finite-support divisor that is zero for +the zero graded element and monic for every nonzero graded element. -/ +theorem existsUnique_normalized_maximal_finite_support_divisor (B : DegreeGraded K) : + ∃! p : FiniteSupportRing (K := K), + IsNormalizedGradedMaximalFiniteSupportDivisor B p := by + let hgcd := HahnSeries.Nonpositive.finiteSupport_pairwise_gcd_exists + (G := ℝ) (K := K) + let hunits := HahnSeries.Nonpositive.isUnit_finiteSupport_iff_exists_scalar + (G := ℝ) (K := K) + refine ⟨gradedNormalizedMaximalFiniteSupportDivisor B, ?_, ?_⟩ + · exact gradedNormalizedMaximalFiniteSupportDivisor_is_of_exists_gcd hgcd B + · intro p hp + exact (gradedNormalizedMaximalFiniteSupportDivisor_eq_of_is hgcd hunits hp).symm + +/-- The normalized maximal finite-support divisor satisfies its source-level defining +predicate. -/ +theorem maximalFiniteSupportDivisor_is (B : DegreeGraded K) : + IsNormalizedGradedMaximalFiniteSupportDivisor B + (gradedNormalizedMaximalFiniteSupportDivisor B) := by + let hgcd := HahnSeries.Nonpositive.finiteSupport_pairwise_gcd_exists + (G := ℝ) (K := K) + exact gradedNormalizedMaximalFiniteSupportDivisor_is_of_exists_gcd hgcd B + +/-- LM24, Remark 5.4.6: the maximal finite-support divisor embeds as a divisor of the graded +element. -/ +theorem maximalFiniteSupportDivisor_dvd (B : DegreeGraded K) : + finiteSupportGradedEmbedding K + (gradedNormalizedMaximalFiniteSupportDivisor B) ∣ B := by + have h := (isNormalizedGradedMaximalFiniteSupportDivisor_iff B + (gradedNormalizedMaximalFiniteSupportDivisor B)).mp + (maximalFiniteSupportDivisor_is B) + exact (h.1 (gradedNormalizedMaximalFiniteSupportDivisor B)).mpr dvd_rfl + +variable (K) in +/-- The maximal finite-support divisor of zero is zero. -/ +@[simp] +theorem maximalFiniteSupportDivisor_zero : + gradedNormalizedMaximalFiniteSupportDivisor + (0 : DegreeGraded K) = 0 := by + have hspec := (isNormalizedGradedMaximalFiniteSupportDivisor_iff (0 : DegreeGraded + K) + (gradedNormalizedMaximalFiniteSupportDivisor 0)).mp + (maximalFiniteSupportDivisor_is 0) + rcases hspec.2 with h | h + · exact h.2 + · exact (h.1 rfl).elim + +/-- The maximal finite-support divisor of a nonzero graded element is monic. -/ +theorem maximalFiniteSupportDivisor_isMonic {B : DegreeGraded K} (hB : B ≠ 0) : + HahnSeries.Nonpositive.IsMonicFiniteSupport + (gradedNormalizedMaximalFiniteSupportDivisor B) := by + have hspec := (isNormalizedGradedMaximalFiniteSupportDivisor_iff B + (gradedNormalizedMaximalFiniteSupportDivisor B)).mp + (maximalFiniteSupportDivisor_is B) + rcases hspec.2 with h | h + · exact (hB h.1).elim + · exact h.2 + +/-- LM24, Proposition 5.4.8: the product of the two normalized maximal finite-support divisors +divides the normalized maximal finite-support divisor of the product. -/ +theorem maximalFiniteSupportDivisor_mul_dvd (B C : DegreeGraded K) : + gradedNormalizedMaximalFiniteSupportDivisor B * + gradedNormalizedMaximalFiniteSupportDivisor C ∣ + gradedNormalizedMaximalFiniteSupportDivisor (B * C) := by + let hgcd := HahnSeries.Nonpositive.finiteSupport_pairwise_gcd_exists + (G := ℝ) (K := K) + exact gradedNormalizedMaximalFiniteSupportDivisor_mul_dvd_of_exists_gcd hgcd B C + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Statements/PrincipalDivisibilityReflection.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Statements/PrincipalDivisibilityReflection.lean new file mode 100644 index 0000000000..7d7e600430 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Statements/PrincipalDivisibilityReflection.lean @@ -0,0 +1,47 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalSubringFiniteSupport + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Statements.PrincipalScalarRedistribution + +/-! +# Divisibility reflection over the principal graded fraction field + +This module states LM24, Remark 6.3.5. Under the identification from Remark 6.1.3, coefficient +extension embeds `K(ℝ^{≤0})` in `Frac(P̂)(ℝ^{≤0})`. An extended finite-support series +divides another extended series if and only if the corresponding divisibility already holds over +`K`. + +The reverse implication uses Lemma 6.3.4 to redistribute a nonzero fraction-field scalar. A +nonzero coefficient of the first factor then forces that scalar to belong to `K`. +-/ + +open scoped HahnSeries + +universe v + +namespace Berarducci + +public noncomputable section + +variable {K : Type v} [Field K] [CharZero K] + +/-- LM24, Remark 6.3.5: coefficient extension from `K(ℝ^{≤0})` to +`Frac(P̂)(ℝ^{≤0})` reflects divisibility. -/ +theorem principalSubringFractionScalarExtension_dvd_iff + (p q : HahnSeries.Nonpositive.FiniteSupportRing (G := ℝ) (K := K)) : + principalSubringFractionScalarExtension K p ∣ + principalSubringFractionScalarExtension K q ↔ + p ∣ q := by + apply principalSubringFractionScalarExtension_dvd_iff_of_scalarRedistribution ?_ p q + intro p₁ p₂ hp₁ hp₂ hprod + exact principalSubringFraction_exists_scalarRedistribution hp₁ hp₂ hprod + +end + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Statements/PrincipalMaximalDivisor.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Statements/PrincipalMaximalDivisor.lean new file mode 100644 index 0000000000..532d5d58f9 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Statements/PrincipalMaximalDivisor.lean @@ -0,0 +1,65 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.NormalizedMaximalFinite +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.RVMaximalFinite + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.PrincipalMaximalFinite +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Statements.ProductValue +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.FiniteSupportGCDProof + +/-! +# LM24 principal-factor invariance statements + +This module states LM24, Lemmas 6.3.1--6.3.2. The first lemma concerns the multiplicative RV +quotient and the paper's set `P` of principal RV classes. The second concerns the full +degree-graded ring `RV̂` and the principal graded subring `P̂`. In both cases multiplication +by a nonzero principal factor preserves the normalized maximal finite-support divisor. + +The RV notation `p(B)` is represented by applying the full graded normalization to the canonical +graded image of `B`. The proofs use Berarducci multiplicativity and finite-support +greatest-common divisors. +-/ + +open scoped DirectSum HahnSeries NatOrdinal + +universe v + +namespace Berarducci + +public noncomputable section + +open HahnSeries.Nonpositive + +variable {K : Type v} [Field K] [CharZero K] + +/-- LM24, Lemma 6.3.1: multiplying an RV class by a nonzero principal RV class does not change +its normalized maximal finite-support divisor. -/ +theorem maximalFiniteSupportDivisor_rv_mul_principal (B C : HahnDegreeRV K) + (hC : IsPrincipalRV C) (hC0 : C ≠ 0) : + gradedNormalizedMaximalFiniteSupportDivisor + ((degreeValuation K).rvInitialFormHom (B * C)) = + gradedNormalizedMaximalFiniteSupportDivisor + ((degreeValuation K).rvInitialFormHom B) := by + let hgcd := HahnSeries.Nonpositive.finiteSupport_pairwise_gcd_exists + (G := ℝ) (K := K) + exact + gradedNormalizedMaximalFiniteSupportDivisor_rv_mul_principal_eq_of_exists_gcd hgcd B hC hC0 + +/-- LM24, Lemma 6.3.2: multiplying a full graded element by a nonzero element of the principal +graded subring does not change its normalized maximal finite-support divisor. -/ +theorem maximalFiniteSupportDivisor_mul_principal (B C : DegreeGraded K) + (hC : IsPrincipalGraded C) (hC0 : C ≠ 0) : + gradedNormalizedMaximalFiniteSupportDivisor (B * C) = + gradedNormalizedMaximalFiniteSupportDivisor B := by + let hgcd := HahnSeries.Nonpositive.finiteSupport_pairwise_gcd_exists + (G := ℝ) (K := K) + exact gradedNormalizedMaximalFiniteSupportDivisor_mul_principal_eq_of_exists_gcd hgcd B hC hC0 + +end + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Statements/PrincipalScalarRedistribution.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Statements/PrincipalScalarRedistribution.lean new file mode 100644 index 0000000000..790127e279 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Statements/PrincipalScalarRedistribution.lean @@ -0,0 +1,63 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalSubringFiniteSupport + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalSubringScalarRedistributionProof +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Statements.PrincipalSubringFraction + +/-! +# Scalar redistribution over the principal graded fraction field + +This module states LM24, Lemma 6.3.4. For nonzero finite-support series `p₁` and `p₂` over +`Frac(P̂)` whose product has coefficients in `K`, a nonzero coefficient `B ∈ Frac(P̂)` can be +moved from one factor to the other so that both resulting series have coefficients in `K`. + +The rendered statement writes `B⁻¹`, which conventionally presupposes `B ≠ 0`. Because +inversion is total in Lean, the theorem records that condition explicitly. The final theorem proves +that the formula without this condition is satisfied by `B = 0` for arbitrary inputs; it is a +regression theorem, not the mathematical content of Lemma 6.3.4. +-/ + +universe v + +namespace Berarducci + +public noncomputable section + +variable {K : Type v} [Field K] [CharZero K] + +/-- LM24, Lemma 6.3.4, with the conventional nonzeroness of the inverted coefficient made +explicit. -/ +theorem principalSubringFraction_exists_scalarRedistribution + {p₁ p₂ : PrincipalSubringFractionFiniteSupportRing K} + (hp₁ : p₁ ≠ 0) (hp₂ : p₂ ≠ 0) + (hprod : p₁ * p₂ ∈ principalSubringFractionCoefficientSubring K) : + ∃ B : PrincipalSubringFractionField K, + B ≠ 0 ∧ + p₁ * HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℝ) B ∈ + principalSubringFractionCoefficientSubring K ∧ + p₂ * HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℝ) B⁻¹ ∈ + principalSubringFractionCoefficientSubring K := by + apply principalSubringFraction_exists_scalarRedistribution_of_isRelativelyAlgebraicallyClosed + (isRelativelyAlgebraicallyClosed_principalGradedFractionField K) + hp₁ hp₂ hprod + +/-- If the nonzeroness of the inverted coefficient is omitted, Lean's total inverse makes the +displayed conclusion hold for arbitrary factors by taking the coefficient to be zero. -/ +theorem principalSubringFraction_exists_literalTotalInverseScalarRedistribution + (p₁ p₂ : PrincipalSubringFractionFiniteSupportRing K) : + ∃ B : PrincipalSubringFractionField K, + p₁ * HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℝ) B ∈ + principalSubringFractionCoefficientSubring K ∧ + p₂ * HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℝ) B⁻¹ ∈ + principalSubringFractionCoefficientSubring K := by + refine ⟨0, ?_, ?_⟩ <;> simp + +end + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Statements/PrincipalSubringFraction.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Statements/PrincipalSubringFraction.lean new file mode 100644 index 0000000000..e7cc483b7d --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Statements/PrincipalSubringFraction.lean @@ -0,0 +1,50 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalSubringFraction +public import LeanPool.ConwayRefinement.ConwayRefinement.FieldTheory.RelativeAlgebraicClosure + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalSubringFractionAlgebraic + +/-! +# Relative algebraic closure in the principal graded fraction field + +This module states LM24, Lemma 6.3.3: the coefficient field is relatively algebraically closed in +the fraction field of `P̂`. Equivalently, every element of `Frac(P̂)` that is +algebraic over `K` already belongs to the image of `K`. The coefficient field has characteristic +zero, which supplies the ordinal-value multiplicativity behind the ring structure on the intrinsic +ring `P̂`. + +The proof reduces to the minimal-polynomial bound for a nonzero algebraic fraction, which is +established in the Berarducci development. +-/ + +universe v + +namespace Berarducci + +public noncomputable section + +variable {K : Type v} [Field K] [CharZero K] + +variable (K) in +/-- LM24, Lemma 6.3.3: `K` is relatively algebraically closed in `Frac(P̂)`. -/ +theorem isRelativelyAlgebraicallyClosed_principalGradedFractionField : + @Algebra.IsRelativelyAlgebraicallyClosed K + (PrincipalSubringFractionField K) _ _ + (principalSubringFractionAlgebra K) := by + let := principalSubringFractionAlgebra K + apply Algebra.isRelativelyAlgebraicallyClosed_of_minpoly_natDegree_le_one + intro x hx + by_cases hx0 : x = 0 + · subst x + simp + · exact principalSubringFraction_minpoly_natDegree_le_one_of_ne_zero x hx hx0 + +end + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Statements/PrincipalSubringPrimality.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Statements/PrincipalSubringPrimality.lean new file mode 100644 index 0000000000..ddb2e39abf --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Statements/PrincipalSubringPrimality.lean @@ -0,0 +1,72 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalSubringTensor + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.PrincipalSubringPrimality +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Statements.ProductValue +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.FiniteSupportGCDProof +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Statements.PrincipalScalarRedistribution + +/-! +# LM24 primality in the degree-graded ring + +This module states LM24, Corollary 6.3.6. In the degree-graded ring `RV̂`, every +finite-support series is primal. The stronger witness theorem retains the two primal factors as +elements of `K(ℝ^{≤0})`; the source-level primality statement is derived from it. + +The proof depends only on the finite-support greatest-common-divisor and scalar-redistribution +prerequisites, both proved over the real exponents, and on the characteristic-zero hypothesis +that supplies ordinal-value and degree multiplicativity. +-/ + +open scoped HahnSeries + +universe v + +namespace Berarducci + +public noncomputable section + +open HahnSeries.Nonpositive + +variable {K : Type v} [Field K] [hchar : CharZero K] + +include hchar in +/-- The factor-witness form of LM24, Corollary 6.3.6: the two factors of `p` remain +finite-support series over `K`. -/ +theorem finiteSupportGradedEmbedding_exists_factor_dvd (p : FiniteSupportRing (K := K)) + (B C : DegreeGraded K) + (hp : finiteSupportGradedEmbedding K p ∣ B * C) : + ∃ p₁ p₂ : FiniteSupportRing (K := K), + p = p₁ * p₂ ∧ + finiteSupportGradedEmbedding K p₁ ∣ B ∧ + finiteSupportGradedEmbedding K p₂ ∣ C := by + let hgcdK := HahnSeries.Nonpositive.finiteSupport_pairwise_gcd_exists + (G := ℝ) (K := K) + let hgcdL := HahnSeries.Nonpositive.finiteSupport_pairwise_gcd_exists + (G := ℝ) (K := PrincipalSubringFractionField K) + let hredistribute : PrincipalSubringFractionScalarRedistribution K := + ⟨fun hp₁ hp₂ hprod ↦ + principalSubringFraction_exists_scalarRedistribution hp₁ hp₂ hprod⟩ + exact finiteSupportGradedEmbedding_exists_factor_dvd_of_scalarRedistribution hgcdK hgcdL + hredistribute p B C hp + +include hchar in +/-- LM24, Corollary 6.3.6: every finite-support series is primal in `RV̂`. -/ +theorem finiteSupportGradedEmbedding_isPrimal (p : FiniteSupportRing (K := K)) : + IsPrimal (finiteSupportGradedEmbedding K p) := by + intro B C hp + obtain ⟨p₁, p₂, hpFactors, hp₁, hp₂⟩ := + finiteSupportGradedEmbedding_exists_factor_dvd p B C hp + refine ⟨finiteSupportGradedEmbedding K p₁, + finiteSupportGradedEmbedding K p₂, hp₁, hp₂, ?_⟩ + rw [hpFactors, map_mul] + +end + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Statements/SeriesMaximalFiniteSupportDivisor.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Statements/SeriesMaximalFiniteSupportDivisor.lean new file mode 100644 index 0000000000..ce99f480a8 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Statements/SeriesMaximalFiniteSupportDivisor.lean @@ -0,0 +1,156 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.NormalizedSeriesMaximalFinite + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Statements.ProductValue +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.FiniteSupportUnit +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.FiniteSupportGCDProof + +/-! +# LM24 series-level maximal finite-support divisor statements + +This module states LM24, Proposition 5.5.1, Notation 5.5.2, Remark 5.5.3, and Proposition 5.5.5 +for the ring `K((ℝ^{≤ 0}))`. Proposition 5.5.1 is the bidirectional assertion + +`(q : K((ℝ^{≤ 0}))) ∣ b ↔ q ∣ p` + +for every finite-support `q`; its uniqueness clause is multiplication by a nonzero coefficient. +The notation is represented by the monic finite-support series +`seriesNormalizedMaximalFiniteSupportDivisor b`, with zero fixed separately. + +The theorem proofs use LM24, Fact 2.5.2 and Berarducci ordinal-value multiplicativity; the +coefficient field has characteristic zero. +-/ + +open scoped HahnSeries NatOrdinal + +universe v + +namespace Berarducci + +public noncomputable section + +variable {K : Type v} [Field K] [CharZero K] + +omit [CharZero K] in +private theorem series_representative_spec_and_uniqueness + (b : Series K) (p : FiniteSupportRing (K := K)) + (hp : IsSeriesMaximalFiniteSupportDivisor b (Associates.mk p)) : + (∀ q : FiniteSupportRing (K := K), (q : Series K) ∣ b ↔ q ∣ p) ∧ + ∀ p' : FiniteSupportRing (K := K), + (∀ q : FiniteSupportRing (K := K), (q : Series K) ∣ b ↔ q ∣ p') → + ∃ k : K, k ≠ 0 ∧ + p' = HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℝ) k * p := by + have hpSpec := (isSeriesMaximalFiniteSupportDivisor_mk_iff b p).mp hp + refine ⟨hpSpec, ?_⟩ + intro p' hp'Spec + have hp' := (isSeriesMaximalFiniteSupportDivisor_mk_iff b p').mpr hp'Spec + exact HahnSeries.Nonpositive.exists_nonzero_scalar_mul_of_mk_eq_mk + (HahnSeries.Nonpositive.isUnit_finiteSupport_iff_exists_scalar + (G := ℝ) (K := K)) + (hp.eq hp') + +/-- LM24, Proposition 5.5.1: every Hahn series has a finite-support series with exactly the same +finite-support divisors, unique up to multiplication by a nonzero coefficient. -/ +theorem series_maximal_finite_support_divisor (b : Series K) : + ∃ p : FiniteSupportRing (K := K), + (∀ q : FiniteSupportRing (K := K), (q : Series K) ∣ b ↔ q ∣ p) ∧ + ∀ p' : FiniteSupportRing (K := K), + (∀ q : FiniteSupportRing (K := K), (q : Series K) ∣ b ↔ q ∣ p') → + ∃ k : K, k ≠ 0 ∧ + p' = HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℝ) k * p := by + let hgcd := HahnSeries.Nonpositive.finiteSupport_pairwise_gcd_exists + (G := ℝ) (K := K) + obtain ⟨a, ha, _⟩ := + existsUnique_isSeriesMaximalFiniteSupportDivisor_of_exists_gcd hgcd b + induction a using Quotient.inductionOn with + | _ p => + obtain ⟨hpSpec, hpUnique⟩ := + series_representative_spec_and_uniqueness b p ha + exact ⟨p, hpSpec, hpUnique⟩ + +/-- LM24, Notation 5.5.2: the maximal finite-support divisor has a unique representative that is +zero at zero and monic otherwise. -/ +theorem existsUnique_normalized_series_maximal_finite_support_divisor (b : Series K) : + ∃! p : FiniteSupportRing (K := K), + IsNormalizedSeriesMaximalFiniteSupportDivisor b p := by + let hgcd := HahnSeries.Nonpositive.finiteSupport_pairwise_gcd_exists + (G := ℝ) (K := K) + let hunits := HahnSeries.Nonpositive.isUnit_finiteSupport_iff_exists_scalar + (G := ℝ) (K := K) + refine ⟨seriesNormalizedMaximalFiniteSupportDivisor b, ?_, ?_⟩ + · exact seriesNormalizedMaximalFiniteSupportDivisor_is_of_exists_gcd hgcd b + · intro p hp + exact (seriesNormalizedMaximalFiniteSupportDivisor_eq_of_is hgcd hunits hp).symm + +/-- The representative fixed by LM24, Notation 5.5.2 satisfies its defining predicate. -/ +theorem seriesNormalizedMaximalFiniteSupportDivisor_is (b : Series K) : + IsNormalizedSeriesMaximalFiniteSupportDivisor b + (seriesNormalizedMaximalFiniteSupportDivisor b) := by + let hgcd := HahnSeries.Nonpositive.finiteSupport_pairwise_gcd_exists + (G := ℝ) (K := K) + exact seriesNormalizedMaximalFiniteSupportDivisor_is_of_exists_gcd hgcd b + +/-- LM24, Remark 5.5.3: the normalized maximal finite-support divisor divides the Hahn series. -/ +theorem seriesMaximalFiniteSupportDivisor_dvd (b : Series K) : + (seriesNormalizedMaximalFiniteSupportDivisor b : Series K) ∣ b := by + have h := (isNormalizedSeriesMaximalFiniteSupportDivisor_iff + b (seriesNormalizedMaximalFiniteSupportDivisor b)).mp + (seriesNormalizedMaximalFiniteSupportDivisor_is b) + exact (h.1 (seriesNormalizedMaximalFiniteSupportDivisor b)).mpr dvd_rfl + +variable (K) in +/-- The series-level maximal finite-support divisor of zero is zero. -/ +theorem seriesMaximalFiniteSupportDivisor_zero : + seriesNormalizedMaximalFiniteSupportDivisor (0 : Series K) = 0 := by + have h := (isNormalizedSeriesMaximalFiniteSupportDivisor_iff + (0 : Series K) (seriesNormalizedMaximalFiniteSupportDivisor 0)).mp + (seriesNormalizedMaximalFiniteSupportDivisor_is 0) + rcases h.2 with hzero | hnonzero + · exact hzero.2 + · exact (hnonzero.1 rfl).elim +/-- LM24, Remark 5.5.3: on a finite-support input, the normalized maximal divisor is a nonzero +scalar multiple of that input. -/ +theorem exists_scalar_seriesMaximalFiniteSupportDivisor_coe (p : FiniteSupportRing (K := K)) : + ∃ k : K, k ≠ 0 ∧ + seriesNormalizedMaximalFiniteSupportDivisor (p : Series K) = + HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℝ) k * p := by + exact exists_scalar_seriesNormalizedMaximalFiniteSupportDivisor_coe + (HahnSeries.Nonpositive.isUnit_finiteSupport_iff_exists_scalar + (G := ℝ) (K := K)) p + +/-- LM24, Remark 5.5.3: on a finite-support input, the series-level normalized divisor +coincides with the normalized divisor from LM24, Notation 5.4.5. -/ +theorem seriesMaximalFiniteSupportDivisor_coe_eq_graded (p : FiniteSupportRing (K := K)) : + seriesNormalizedMaximalFiniteSupportDivisor (p : Series K) = + gradedNormalizedMaximalFiniteSupportDivisor + (finiteSupportGradedEmbedding K p) := by + exact seriesNormalizedMaximalFiniteSupportDivisor_coe_eq_graded p + +/-- LM24, Remark 5.5.3: the normalized maximal finite-support divisor of a principal Hahn series +is one. -/ +theorem seriesMaximalFiniteSupportDivisor_principal_eq_one + {b : Series K} (hb : HahnSeries.Nonpositive.IsPrincipal b) : + seriesNormalizedMaximalFiniteSupportDivisor b = 1 := by + exact seriesNormalizedMaximalFiniteSupportDivisor_eq_one_of_isPrincipal + (HahnSeries.Nonpositive.isUnit_finiteSupport_iff_exists_scalar + (G := ℝ) (K := K)) hb + +/-- LM24, Proposition 5.5.5: the product of the two normalized maximal finite-support divisors +divides the normalized maximal finite-support divisor of the product. -/ +theorem seriesMaximalFiniteSupportDivisor_mul_dvd (b c : Series K) : + seriesNormalizedMaximalFiniteSupportDivisor b * + seriesNormalizedMaximalFiniteSupportDivisor c ∣ + seriesNormalizedMaximalFiniteSupportDivisor (b * c) := by + exact seriesNormalizedMaximalFiniteSupportDivisor_mul_dvd_of_exists_gcd + (HahnSeries.Nonpositive.finiteSupport_pairwise_gcd_exists + (G := ℝ) (K := K)) b c + +end + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Statements/SeriesPrimality.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Statements/SeriesPrimality.lean new file mode 100644 index 0000000000..dbe224a46c --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Statements/SeriesPrimality.lean @@ -0,0 +1,89 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalComponentTensor +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.FiniteSupport +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Nonpositive +public import Mathlib.Algebra.Divisibility.Basic + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.SeriesPrimality +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Statements.ProductValue +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.FiniteSupportGCDProof +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Degree.Statements.Degree +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Statements.MaximalFiniteMultiplicativity + +/-! +# LM24 primality in the Hahn-series ring + +This module states LM24, Corollary 6.3.9. The stronger witness theorem retains the factors of the +finite-support divisor as elements of `K(ℝ^{≤ 0})`; primality of every element of the +finite-support subring is derived from it. +-/ + +open scoped HahnSeries + +universe v + +namespace Berarducci + +public noncomputable section + +variable {K : Type v} [Field K] [hchar : CharZero K] + +include hchar in +/-- The factor-witness form of LM24, Corollary 6.3.9: both factors remain elements of the +finite-support subring `K(ℝ^{≤ 0})`. -/ +theorem finiteSupportSeries_exists_factor_dvd (p : FiniteSupportRing (K := K)) (b c : Series K) + (hp : (p : Series K) ∣ b * c) : + ∃ p₁ p₂ : FiniteSupportRing (K := K), + (p : Series K) = (p₁ : Series K) * (p₂ : Series K) ∧ + (p₁ : Series K) ∣ b ∧ (p₂ : Series K) ∣ c := by + let hgcd := HahnSeries.Nonpositive.finiteSupport_pairwise_gcd_exists + (G := ℝ) (K := K) + obtain ⟨p₁, p₂, hpFactor, hp₁, hp₂⟩ := + finiteSupportSeries_exists_factor_dvd_of_maximalMultiplicative hgcd + (seriesMaximalFiniteSupportDivisor_mul (K := K)) + p b c hp + refine ⟨p₁, p₂, ?_, hp₁, hp₂⟩ + exact congrArg + (HahnSeries.Nonpositive.finiteSupportSubring + (G := ℝ) (K := K)).subtype hpFactor + +end + +end Berarducci + +namespace HahnSeries.Nonpositive + +public noncomputable section + +variable {K : Type v} [Field K] [CharZero K] + +/-- Strengthened form of LM24, Corollary 6.3.9: a finite-support divisor `p` of `b * c` +has a factorisation `p = p₁ * p₂` into finite-support series with `p₁ ∣ b` and +`p₂ ∣ c`. -/ +theorem exists_finiteSupport_split_of_dvd_mul + {p b c : Nonpositive ℝ K} (hp : p ∈ finiteSupportSubring) + (hdiv : p ∣ b * c) : + ∃ p₁ p₂ : Nonpositive ℝ K, + p₁ ∈ finiteSupportSubring ∧ p₂ ∈ finiteSupportSubring ∧ + p = p₁ * p₂ ∧ p₁ ∣ b ∧ p₂ ∣ c := by + let p' : Berarducci.FiniteSupportRing (K := K) := ⟨p, hp⟩ + obtain ⟨p₁, p₂, hpFactor, hp₁, hp₂⟩ := + Berarducci.finiteSupportSeries_exists_factor_dvd p' b c hdiv + exact ⟨p₁, p₂, p₁.property, p₂.property, hpFactor, hp₁, hp₂⟩ + +/-- LM24, Corollary 6.3.9: every finite-support nonpositive real Hahn series is primal. -/ +theorem isPrimal_of_mem_finiteSupportSubring + {p : Nonpositive ℝ K} (hp : p ∈ finiteSupportSubring) : IsPrimal p := by + intro b c hdiv + obtain ⟨p₁, p₂, -, -, hpFactor, hp₁, hp₂⟩ := exists_finiteSupport_split_of_dvd_mul hp hdiv + exact ⟨p₁, p₂, hp₁, hp₂, hpFactor⟩ + +end + +end HahnSeries.Nonpositive diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Tests.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Tests.lean new file mode 100644 index 0000000000..eb49c6efee --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Tests.lean @@ -0,0 +1,22 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Tests.AlmostIrreducible +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Tests.AlmostIrreducibleFactorization +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Tests.DegreeTwo +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Tests.GermLikeFactorization +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Tests.GradedDivisibility +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Tests.InfiniteSupportFactorization +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Tests.MaximalFiniteSupportDivisor +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Tests.NormalizedHPart +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Tests.NormalizedHPartMultiplicativity +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Tests.PrincipalMaximalFiniteSupportDivisor +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Tests.SectionSixFour +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Tests.SeriesMaximalFiniteSupportDivisor + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Tests/AlmostIrreducible.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Tests/AlmostIrreducible.lean new file mode 100644 index 0000000000..f6072981ee --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Tests/AlmostIrreducible.lean @@ -0,0 +1,85 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.AlmostIrreducible + +/-! +# API checks for almost-irreducible Hahn series + +The identity fixture preserves the exact boundary omitted from the second assertion of LM24, +Remark 6.5.1: `1` is almost irreducible and has real support supremum zero, but is not +irreducible. The negative monomial `t⁻¹` exercises the strict-negative-supremum assertion over +the divisible exponent group `ℝ` and is visibly nonzero and nonconstant. +-/ + +open scoped HahnSeries + +namespace Tests + +public noncomputable section + +open HahnSeries.Nonpositive + +/-- The full real exponent group, represented as an additive subgroup for the counterexample. -/ +abbrev RealExponentSubgroup : AddSubgroup ℝ := ⊤ + +/-- Rational Hahn series with nonpositive exponents in the full real subgroup. -/ +abbrev RealExponentSeries := + HahnSeries.Nonpositive RealExponentSubgroup ℚ + +/-- Integer divisibility on the full real exponent subgroup, inherited from the real numbers. -/ +noncomputable local instance : DivisibleBy RealExponentSubgroup ℤ where + div a n := ⟨DivisibleBy.div (a : ℝ) n, Set.mem_univ _⟩ + div_zero a := Subtype.ext (DivisibleBy.div_zero (a : ℝ)) + div_cancel a hn := Subtype.ext (DivisibleBy.div_cancel (a : ℝ) hn) + +/-- The printed support-supremum-zero implication in LM24, Remark 6.5.1 is false for the +multiplicative identity. -/ +theorem one_almostIrreducible_counterexample : + IsAlmostIrreducible (1 : RealExponentSeries) ∧ + realSupportSup RealExponentSubgroup (1 : RealExponentSeries) = 0 ∧ + ¬Irreducible (1 : RealExponentSeries) := + ⟨one_isAlmostIrreducible, + realSupportSup_one RealExponentSubgroup (K := ℚ), not_irreducible_one⟩ + +/-- The exponent `-1`, regarded as an element of the full real exponent subgroup. -/ +def minusOneExponent : RealExponentSubgroup := ⟨-1, Set.mem_univ _⟩ + +/-- The exponent `-1` is nonpositive. -/ +theorem minusOneExponent_nonpos : minusOneExponent ≤ 0 := by + change (-1 : ℝ) ≤ 0 + norm_num + +/-- The nonconstant monomial `t⁻¹`. -/ +def almostIrreducibleNegativeMonomial : RealExponentSeries := + single minusOneExponent 1 minusOneExponent_nonpos + +/-- The support of `t⁻¹` is exactly the singleton containing `-1`. -/ +theorem almostIrreducibleNegativeMonomial_support : + (almostIrreducibleNegativeMonomial : ℚ⟦RealExponentSubgroup⟧).support = + {minusOneExponent} := by + rw [almostIrreducibleNegativeMonomial, coe_single, + HahnSeries.support_single_of_ne one_ne_zero] + +/-- The real support supremum of `t⁻¹` is `-1`. -/ +theorem almostIrreducibleNegativeMonomial_realSupportSup : + realSupportSup RealExponentSubgroup almostIrreducibleNegativeMonomial = (-1 : ℝ) := by + rw [almostIrreducibleNegativeMonomial] + exact realSupportSup_single RealExponentSubgroup one_ne_zero + minusOneExponent_nonpos + +/-- The strict-negative-supremum clause of LM24, Remark 6.5.1 rejects the nonconstant +monomial `t⁻¹` as irreducible. -/ +theorem almostIrreducibleNegativeMonomial_not_irreducible : + ¬Irreducible almostIrreducibleNegativeMonomial := by + apply not_irreducible_of_realSupportSup_lt_zero + rw [almostIrreducibleNegativeMonomial_realSupportSup] + norm_num + +end + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Tests/AlmostIrreducibleFactorization.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Tests/AlmostIrreducibleFactorization.lean new file mode 100644 index 0000000000..a3e3a16970 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Tests/AlmostIrreducibleFactorization.lean @@ -0,0 +1,70 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.AlmostIrreducibleFactorization + +/-! +# API checks for exponent-subgroup factorisation + +The scalar series `2` has a corrected factorisation with no almost irreducible factors. The same +series is not the unscaled product with normalized finite-support factor `1`, monomial exponent +`0`, and an empty factor list. This is the smallest boundary example that detects the coefficient +scalar missing from the printed formula in LM24, Theorem 6.5.7. +-/ + +open scoped HahnSeries + +namespace Tests + +public noncomputable section + +open HahnSeries.Nonpositive + +/-- The full real exponent subgroup used in the explicit factorization fixtures. -/ +abbrev FactorizationExponentSubgroup : AddSubgroup ℝ := ⊤ + +/-- Rational Hahn series over the full real subgroup, supported at nonpositive exponents. -/ +abbrev FactorizationSeries := + HahnSeries.Nonpositive FactorizationExponentSubgroup ℚ + +/-- The zero exponent as an element of the nonpositive exponent monoid. -/ +def factorizationZeroExponent : + HahnSeries.Nonpositive.exponentMonoid FactorizationExponentSubgroup := + ⟨(0 : FactorizationExponentSubgroup), by + change (0 : FactorizationExponentSubgroup) ≤ 0 + exact le_rfl⟩ + +/-- The scalar series `2` has a corrected factorisation with an explicit coefficient scalar. -/ +theorem scalarTwo_almostIrreducibleFactorization : + IsAlmostIrreducibleFactorization + (C 2 : FactorizationSeries) (Units.mk0 2 (by norm_num)) + (1 : ConstantTermOneFiniteSupport + (G := FactorizationExponentSubgroup) (K := ℚ)) + factorizationZeroExponent [] := by + rw [isAlmostIrreducibleFactorization_iff] + constructor + · apply Subtype.ext + simp [factorizationZeroExponent, coe_finiteSupportMonomial, coe_C] + · simp + +/-- Omitting the coefficient scalar makes the corresponding empty factorisation of `2` false. -/ +theorem scalarTwo_ne_unscaled_empty_factorization : + (C 2 : FactorizationSeries) ≠ + (((1 : ConstantTermOneFiniteSupport + (G := FactorizationExponentSubgroup) (K := ℚ)) : + FiniteSupportRing (G := FactorizationExponentSubgroup) (K := ℚ)) : + FactorizationSeries) * + (finiteSupportMonomial (K := ℚ) factorizationZeroExponent : + FactorizationSeries) * ([] : List FactorizationSeries).prod := by + intro h + have hconstant := congrArg constantCoeff h + norm_num [factorizationZeroExponent, coe_finiteSupportMonomial, + constantCoeff_apply] at hconstant + +end + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Tests/DegreeTwo.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Tests/DegreeTwo.lean new file mode 100644 index 0000000000..47eab39f3b --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Tests/DegreeTwo.lean @@ -0,0 +1,13 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Tests.DegreeTwo.FactorizationClassification +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Tests.DegreeTwo.TranslatedSpanFactorization +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Tests.DegreeTwo.TranslatedTruncationSpan + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Tests/DegreeTwo/FactorizationClassification.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Tests/DegreeTwo/FactorizationClassification.lean new file mode 100644 index 0000000000..ce56f809cb --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Tests/DegreeTwo/FactorizationClassification.lean @@ -0,0 +1,48 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.DegreeTwo.FactorizationClassification + +/-! +# Public-interface check for PS06 Lemma 3.1 + +This separately compiled client exercises the complete factorisation classification through its +public signature. It does not unfold the degree-two support predicates or the critical-point +machinery used in the proof. +-/ + +universe v + +open scoped HahnSeries NatOrdinal + +public noncomputable section + +namespace Tests + +/-- The public PS06 Lemma 3.1 API reproduces the printed constant-or-balanced dichotomy. -/ +theorem ps06_degreeTwo_factorization_client + {K : Type v} [Field K] [CharZero K] + {a b c : Berarducci.Series K} + (haNear : a ∉ Berarducci.nearConstantSubgroup K) + (haType : (a : K⟦ℝ⟧).supportOrderType = + (Ordinal.omega0 ^ (2 : Ordinal)) ∨ + (a : K⟦ℝ⟧).supportOrderType = Ordinal.omega0 ^ (2 : Ordinal) + 1) + (habc : a = b * c) + (hle : Berarducci.ordinalValue b ≤ Berarducci.ordinalValue c) : + (∃ k : K, k ≠ 0 ∧ b = HahnSeries.Nonpositive.C k ∧ + c = HahnSeries.Nonpositive.C k⁻¹ * a ∧ + (c : K⟦ℝ⟧).supportOrderType = (a : K⟦ℝ⟧).supportOrderType) ∨ + (((b : K⟦ℝ⟧).supportOrderType = Ordinal.omega0 ∨ + (b : K⟦ℝ⟧).supportOrderType = Ordinal.omega0 + 1) ∧ + ((c : K⟦ℝ⟧).supportOrderType = Ordinal.omega0 ∨ + (c : K⟦ℝ⟧).supportOrderType = Ordinal.omega0 + 1) ∧ + Berarducci.ordinalValue b = ω^ (1 : NatOrdinal) ∧ + Berarducci.ordinalValue c = ω^ (1 : NatOrdinal)) := + PommersheimShahriari.factorization_cases_of_supportOrderType_wpow_two + haNear haType habc hle + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Tests/DegreeTwo/TranslatedSpanFactorization.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Tests/DegreeTwo/TranslatedSpanFactorization.lean new file mode 100644 index 0000000000..08ce84054c --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Tests/DegreeTwo/TranslatedSpanFactorization.lean @@ -0,0 +1,50 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.DegreeTwo.TranslatedSpanFactorization + +/-! +# Public-interface check for the PS06 translated-truncation-span irreducibility criterion + +This separately compiled client exercises the dimension bound and PS06, Corollary 3.3 through +their public signatures, without unfolding the quotient or translated-truncation-span definitions. +-/ + +universe v + +open scoped HahnSeries NatOrdinal + +public noncomputable section + +namespace Tests + +/-- The public Proposition 3.2 API bounds the translated-truncation span of a balanced product by +two. -/ +theorem ps06_balancedProduct_translatedTruncationSpan_client + {K : Type v} [Field K] {b c : Berarducci.Series K} + (hbValue : Berarducci.ordinalValue b = ω^ (1 : NatOrdinal)) + (hcValue : Berarducci.ordinalValue c = ω^ (1 : NatOrdinal)) + (hbCritical : Berarducci.IsCriticalPoint b 0) + (hcCritical : Berarducci.IsCriticalPoint c 0) : + Module.finrank K (PommersheimShahriari.translatedTruncationSpan (b * c)) ≤ 2 := + PommersheimShahriari.finrank_translatedTruncationSpan_mul_le_two + hbValue hcValue hbCritical hcCritical + +/-- The public Corollary 3.3 API reproduces PS06's degree-two irreducibility criterion. -/ +theorem ps06_degreeTwo_irreducibility_client + {K : Type v} [Field K] [CharZero K] {a : Berarducci.Series K} + (haNear : a ∉ Berarducci.nearConstantSubgroup K) + (haType : (a : K⟦ℝ⟧).supportOrderType = + Ordinal.omega0 ^ (2 : Ordinal) ∨ + (a : K⟦ℝ⟧).supportOrderType = Ordinal.omega0 ^ (2 : Ordinal) + 1) + (haDimension : 2 < + Module.finrank K (PommersheimShahriari.translatedTruncationSpan a)) : + Irreducible a := + PommersheimShahriari.irreducible_of_two_lt_finrank_translatedTruncationSpan + haNear haType haDimension + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Tests/DegreeTwo/TranslatedTruncationSpan.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Tests/DegreeTwo/TranslatedTruncationSpan.lean new file mode 100644 index 0000000000..5835ea200a --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Tests/DegreeTwo/TranslatedTruncationSpan.lean @@ -0,0 +1,62 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.DegreeTwo.TranslatedTruncationSpan +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Tests.Fixtures.ApproachZero + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValue + +/-! +# API checks for the Pommersheim--Shahriari translated-truncation span + +The constant-one series separates the [PS06] quotient by `J + K` from Berarducci's quotient by +`J`: it vanishes in the former and remains nonzero in the latter. The approach-zero series then +shows that quotienting constants has not collapsed the whole space. +-/ + +public noncomputable section + +namespace Tests + +open scoped HahnSeries + +/-- Constant one vanishes modulo `J + K`. -/ +theorem constant_one_eq_zero_modulo_constants : + PommersheimShahriari.toSeriesQuotientByJAddConstants + (HahnSeries.Nonpositive.C (1 : ℚ)) = 0 := by + rw [PommersheimShahriari.toSeriesQuotientByJAddConstants_eq_zero_iff] + exact Berarducci.mem_nearConstantSubgroup_iff.mpr + ⟨0, (HahnSeries.Nonpositive.negativeMonomialIdeal ℚ).zero_mem, 1, by simp⟩ + +/-- The same constant remains nonzero in Berarducci's quotient by `J` alone. -/ +theorem constant_one_ne_zero_in_berarducci_germ : + Berarducci.toGerm (HahnSeries.Nonpositive.C (1 : ℚ)) ≠ 0 := by + intro hzero + have hmem : HahnSeries.Nonpositive.C (1 : ℚ) ∈ + HahnSeries.Nonpositive.negativeMonomialIdeal ℚ := by + rw [← sub_zero (HahnSeries.Nonpositive.C (1 : ℚ)), + ← Berarducci.toGerm_eq_toGerm_iff] + simpa using hzero + have hcoeff := Berarducci.constantCoeff_eq_zero_of_mem_negativeMonomialIdeal hmem + norm_num at hcoeff + +/-- The approach-zero series is nonzero modulo `J + K`, so the [PS06] vector space is +nondegenerate. -/ +theorem approachZero_ne_zero_modulo_constants : + PommersheimShahriari.toSeriesQuotientByJAddConstants approachZeroNonpositive ≠ 0 := by + intro hzero + have hnear := + PommersheimShahriari.toSeriesQuotientByJAddConstants_eq_zero_iff.mp hzero + exact (Berarducci.one_lt_ordinalValue_iff.mp + (Berarducci.one_lt_ordinalValue_of_constantCoeff_eq_zero_of_supportSup_eq_zero + (by + rw [HahnSeries.Nonpositive.constantCoeff_apply, coe_approachZeroNonpositive] + exact not_ne_iff.mp (by + simpa [HahnSeries.mem_support] using zero_not_mem_approachZero_support)) + approachZero_supportSup)) hnear + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Tests/GermLikeFactorization.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Tests/GermLikeFactorization.lean new file mode 100644 index 0000000000..d64b4922c4 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Tests/GermLikeFactorization.lean @@ -0,0 +1,61 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.GermLike +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.DegreeTwo.DegreeTwoExample + +/-! +# Checks for germ-like factorisation + +The PS06 degree-two series with constant coefficient one exercises the second branch of the +LM17 germ-like definition: its support order type is `ω² + 1` and its ordinal value is `ω²`. +Thus this certificate distinguishes the intended definition from the nearby wrong definition +that retains only the equality `ot(a) = v_J(a)`. +-/ + +universe v + +open scoped HahnSeries NatOrdinal + +public noncomputable section + +namespace Tests.LM17 + +open Berarducci PommersheimShahriari PommersheimShahriari.DegreeTwoExample + +variable {K : Type v} [Field K] + +/-- The degree-two series with constant coefficient one is germ-like by the nontrivial +`ot(a) = v_J(a) + 1` branch. -/ +theorem degreeTwoWithConstant_isGermLike : + LM17.IsGermLike (degreeTwoWithConstant (K := K)) := by + rw [LM17.isGermLike_iff] + right + have hvalue : ordinalValue (degreeTwoWithConstant (K := K)) = ω^ (2 : NatOrdinal) := + ordinalValue_eq_wpow_two + (degreeTwoWithConstant_not_mem_nearConstantSubgroup (K := K)) + (Or.inr (degreeTwoWithConstant_supportOrderType (K := K))) + refine ⟨?_, ?_⟩ + · rw [hvalue, ← NatOrdinal.val.lt_iff_lt] + simp only [NatOrdinal.val_one, NatOrdinal.val_wpow] + rw [Ordinal.one_lt_opow] + exact ⟨Ordinal.one_lt_omega0, by norm_num⟩ + · rw [hvalue, NatOrdinal.val_wpow] + have h2 : (2 : NatOrdinal).val = (2 : Ordinal) := rfl + rw [h2] + exact degreeTwoWithConstant_supportOrderType (K := K) + +/-- The degree-two germ-like series with constant coefficient one admits an irreducible +factorisation. -/ +theorem degreeTwoWithConstant_exists_factorization [CharZero K] : + ∃ f : Multiset (Series K), + (∀ b ∈ f, Irreducible b) ∧ + Associated f.prod (degreeTwoWithConstant (K := K)) := + degreeTwoWithConstant_isGermLike.exists_factorization + (degreeTwoWithConstant_irreducible (K := K)).ne_zero + +end Tests.LM17 diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Tests/GradedDivisibility.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Tests/GradedDivisibility.lean new file mode 100644 index 0000000000..b49c3a3163 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Tests/GradedDivisibility.lean @@ -0,0 +1,300 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MonoidAlgebra.SingleZeroFactors +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.AssociatedGradedDivisibility +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalSubringMonoidAlgebra +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.GradedDivisibility +public import Mathlib.Data.Rat.Defs + +import Mathlib.Tactic.NormNum + +/-! +# API checks for graded divisibility + +The two-component fixture has independently nonzero grades zero and one. Its trailing grade is +zero, its leading grade is one, and it is not homogeneous. This distinguishes the minimum-grade +invariant used in LM24, Proposition 6.2.1 from the existing maximum-grade invariant, and it +distinguishes `RV` from the full associated graded ring `RV̂`. + +The strictly negative finite-support monomial does not divide one in the nonpositive-exponent +monoid algebra: such a quotient would require a positive exponent. Its graded image therefore +also does not divide one, exercising the reflection direction of LM24, Corollary 6.2.3 and +excluding a nearby group-algebra model with unrestricted real exponents. + +Finally, a principal coefficient multiplied by that strictly negative monomial has nonzero +monoid-algebra exponent. It lies outside `P̂`, distinguishing the principal graded subring from all +of `RV̂`. The principal-one and zero-boundary checks separately certify the exact embedded image +predicate for the paper's set `P`. +-/ + +open scoped DirectSum HahnSeries NatOrdinal + +universe v + +namespace Tests + +public noncomputable section + +/-- The strictly negative exponent used in the finite-support divisibility separator. -/ +def gradedDivisibilityNegativeExponent : + HahnSeries.Nonpositive.exponentMonoid ℝ := + ⟨-1, show (-1 : ℝ) ≤ 0 by norm_num⟩ + +/-- The finite-support Hahn monomial at exponent `-1`. -/ +def gradedDivisibilityNegativeMonomial : + HahnSeries.Nonpositive.finiteSupportSubring (G := ℝ) (K := ℚ) := + HahnSeries.Nonpositive.finiteSupportMonomial gradedDivisibilityNegativeExponent + +/-- The chosen strictly negative exponent is not zero. -/ +theorem gradedDivisibilityNegativeExponent_ne_zero : + gradedDivisibilityNegativeExponent ≠ 0 := by + intro h + have := congrArg Subtype.val h + norm_num [gradedDivisibilityNegativeExponent] at this + +/-- The finite-support monomial at exponent `-1` is nonzero. -/ +theorem gradedDivisibilityNegativeMonomial_ne_zero : + gradedDivisibilityNegativeMonomial ≠ 0 := by + intro h + have hcoeff := congrArg + (fun p : HahnSeries.Nonpositive.finiteSupportSubring (G := ℝ) (K := ℚ) ↦ + (((p : HahnSeries.Nonpositive ℝ ℚ) : ℚ⟦ℝ⟧).coeff (-1))) h + simp [gradedDivisibilityNegativeMonomial, gradedDivisibilityNegativeExponent] at hcoeff + +/-- A negative monomial cannot divide one within the nonpositive-exponent finite-support ring. -/ +theorem gradedDivisibilityNegativeMonomial_not_dvd_one : + ¬ gradedDivisibilityNegativeMonomial ∣ 1 := by + intro hDvd + obtain ⟨r, hr⟩ := hDvd + let e := HahnSeries.Nonpositive.finiteSupportAddMonoidAlgebraEquiv + (G := ℝ) (K := ℚ) + have her : e r ≠ 0 := by + intro hzero + have hrZero : r = 0 := by + apply e.injective + simpa using hzero + rw [hrZero, mul_zero] at hr + exact one_ne_zero hr + have heMonomial : e gradedDivisibilityNegativeMonomial = + AddMonoidAlgebra.single gradedDivisibilityNegativeExponent 1 := by + exact HahnSeries.Nonpositive.finiteSupportAddMonoidAlgebraEquiv_monomial + gradedDivisibilityNegativeExponent + have hProduct : + AddMonoidAlgebra.single gradedDivisibilityNegativeExponent (1 : ℚ) * e r = + AddMonoidAlgebra.single 0 1 := by + calc + AddMonoidAlgebra.single gradedDivisibilityNegativeExponent (1 : ℚ) * e r = + e gradedDivisibilityNegativeMonomial * e r := + congrArg (· * e r) heMonomial.symm + _ = e (gradedDivisibilityNegativeMonomial * r) := + (map_mul e gradedDivisibilityNegativeMonomial r).symm + _ = e 1 := congrArg e hr.symm + _ = 1 := map_one e + _ = AddMonoidAlgebra.single 0 1 := AddMonoidAlgebra.one_def + obtain ⟨_, _, ha, _⟩ := + AddMonoidAlgebra.exists_eq_single_zero_of_mul_eq_single_zero + (R := ℚ) (M := HahnSeries.Nonpositive.exponentMonoid ℝ) + (HahnSeries.Nonpositive.exponentMonoid_top_eq_zero ℝ) + (AddMonoidAlgebra.single_ne_zero.mpr one_ne_zero) + her hProduct + have hcoeff := congrArg + (fun f : AddMonoidAlgebra ℚ (HahnSeries.Nonpositive.exponentMonoid ℝ) ↦ + f.coeff gradedDivisibilityNegativeExponent) ha + simp [gradedDivisibilityNegativeExponent_ne_zero] at hcoeff + +/-- The graded image of the negative monomial does not divide the graded image of one. -/ +theorem gradedDivisibilityNegativeMonomialGraded_not_dvd_one : + ¬ Berarducci.finiteSupportGradedEmbedding ℚ + gradedDivisibilityNegativeMonomial ∣ + Berarducci.finiteSupportGradedEmbedding ℚ 1 := by + intro hDvd + exact gradedDivisibilityNegativeMonomial_not_dvd_one + ((Berarducci.finiteSupportGradedEmbedding_dvd_iff + gradedDivisibilityNegativeMonomial 1).mp hDvd) + +variable {K : Type v} [Field K] + +/-- A graded element supported in the two distinct grades zero and one. -/ +def gradedDivisibilityTwoComponent (a₀ : (HahnSeries.Nonpositive.degreeValuation K).Component 0) + (a₁ : (HahnSeries.Nonpositive.degreeValuation K).Component 1) : + Berarducci.DegreeGraded K := + DirectSum.of _ 0 a₀ + DirectSum.of _ 1 a₁ + +/-- The two-component fixture retains its prescribed grade-zero and grade-one components. -/ +theorem gradedDivisibilityTwoComponent_components + (a₀ : (HahnSeries.Nonpositive.degreeValuation K).Component 0) + (a₁ : (HahnSeries.Nonpositive.degreeValuation K).Component 1) : + gradedDivisibilityTwoComponent a₀ a₁ 0 = a₀ ∧ + gradedDivisibilityTwoComponent a₀ a₁ 1 = a₁ := by + simp [gradedDivisibilityTwoComponent, DirectSum.of_apply] + +/-- With a nonzero grade-zero component, the fixture's trailing grade is zero. -/ +theorem gradedDivisibilityTwoComponent_trailingValue + (a₀ : (HahnSeries.Nonpositive.degreeValuation K).Component 0) + (a₁ : (HahnSeries.Nonpositive.degreeValuation K).Component 1) + (ha₀ : a₀ ≠ 0) : + MaxAddDegree.associatedGradedTrailingValue + (HahnSeries.Nonpositive.degreeValuation K) + (gradedDivisibilityTwoComponent a₀ a₁) = 0 := by + let w := HahnSeries.Nonpositive.degreeValuation K + apply (w.associatedGradedTrailingValue_eq_coe_iff + (gradedDivisibilityTwoComponent a₀ a₁) 0).mpr + exact ⟨by simpa [gradedDivisibilityTwoComponent, DirectSum.of_apply] using ha₀, + fun _ _ ↦ bot_le⟩ + +/-- With a nonzero grade-one component, the fixture's leading grade is one. -/ +theorem gradedDivisibilityTwoComponent_leadingValue + (a₀ : (HahnSeries.Nonpositive.degreeValuation K).Component 0) + (a₁ : (HahnSeries.Nonpositive.degreeValuation K).Component 1) + (ha₁ : a₁ ≠ 0) : + (HahnSeries.Nonpositive.degreeValuation K).associatedGradedValue + (gradedDivisibilityTwoComponent a₀ a₁) = 1 := by + let w := HahnSeries.Nonpositive.degreeValuation K + apply (w.associatedGradedValue_eq_coe_iff + (gradedDivisibilityTwoComponent a₀ a₁) 1).mpr + constructor + · simpa [gradedDivisibilityTwoComponent, DirectSum.of_apply] using ha₁ + · intro i hi + by_cases hi₀ : i = 0 + · subst i + exact zero_le_one + by_cases hi₁ : i = 1 + · subst i + exact le_rfl + have hzero : gradedDivisibilityTwoComponent a₀ a₁ i = 0 := by + simp [gradedDivisibilityTwoComponent, DirectSum.of_apply, Ne.symm hi₀, Ne.symm hi₁] + exact (hi hzero).elim + +/-- With both displayed components nonzero, the two-component fixture is not in degree RV. -/ +theorem gradedDivisibilityTwoComponent_not_homogeneous + (a₀ : (HahnSeries.Nonpositive.degreeValuation K).Component 0) + (a₁ : (HahnSeries.Nonpositive.degreeValuation K).Component 1) + (ha₀ : a₀ ≠ 0) (ha₁ : a₁ ≠ 0) : + gradedDivisibilityTwoComponent a₀ a₁ ∉ + (HahnSeries.Nonpositive.degreeValuation K).homogeneousClasses := by + let w := HahnSeries.Nonpositive.degreeValuation K + intro hHomogeneous + rcases (w.mem_homogeneousClasses_iff_extremeGrades + (gradedDivisibilityTwoComponent a₀ a₁)).mp hHomogeneous with + hzero | ⟨m, htrail, hlead⟩ + · apply ha₀ + rw [← (gradedDivisibilityTwoComponent_components a₀ a₁).1, hzero] + rfl + · have htrailZero := gradedDivisibilityTwoComponent_trailingValue a₀ a₁ ha₀ + have hleadOne := gradedDivisibilityTwoComponent_leadingValue a₀ a₁ ha₁ + have hzeroM : (0 : NatOrdinal) = m := + WithTop.coe_injective (htrailZero.symm.trans htrail) + have honeM : (1 : NatOrdinal) = m := + WithBot.coe_injective (hleadOne.symm.trans hlead) + exact zero_ne_one (hzeroM.trans honeM.symm) + +variable [CharZero K] + +variable (K) in +/-- The degree-RV class of one, used as a nonzero principal-image boundary case. -/ +def gradedDivisibilityPrincipalOneRV : Berarducci.HahnDegreeRV K := + (HahnSeries.Nonpositive.degreeValuation K).rv 1 + +variable (K) in +/-- The degree-RV class of one is principal in the exact sense of LM24, Definition 5.2.1. -/ +theorem gradedDivisibilityPrincipalOneRV_isPrincipal : + Berarducci.IsPrincipalRV (gradedDivisibilityPrincipalOneRV K) := by + rw [Berarducci.isPrincipalRV_iff] + exact ⟨1, HahnSeries.Nonpositive.isPrincipal_one, rfl⟩ + +variable (K) in +/-- The canonical graded image of the principal RV class of one belongs to `P`. -/ +theorem gradedDivisibilityPrincipalOneRV_image : + Berarducci.IsPrincipalRVImage + ((HahnSeries.Nonpositive.degreeValuation K).rvInitialFormHom + (gradedDivisibilityPrincipalOneRV K)) := + Berarducci.isPrincipalRVImage_initialForm + (gradedDivisibilityPrincipalOneRV K) + (gradedDivisibilityPrincipalOneRV_isPrincipal K) + +variable (K) in +/-- Zero is not in the image of principal RV classes because principal series are nonzero. -/ +theorem gradedDivisibilityPrincipalRVImage_zero_false : + ¬ Berarducci.IsPrincipalRVImage (0 : Berarducci.DegreeGraded K) := by + intro hzero + exact (Berarducci.isPrincipalRVImage_iff _).mp hzero |>.1 rfl + +/-- The strictly negative exponent used to separate `P̂` from `RV̂`. -/ +def gradedDivisibilityNonprincipalExponent : + HahnSeries.Nonpositive.exponentMonoid ℝ := + ⟨-1, show (-1 : ℝ) ≤ 0 by norm_num⟩ + +variable (K) in +/-- A principal coefficient multiplied by a strictly negative finite-support monomial. -/ +def gradedDivisibilityNonprincipalElement : + Berarducci.DegreeGraded K := + Berarducci.principalSubringEmbedding K 1 * + Berarducci.finiteSupportGradedEmbedding K + (HahnSeries.Nonpositive.finiteSupportMonomial (K := K) + gradedDivisibilityNonprincipalExponent) + +variable (K) in +/-- The nonprincipal fixture has coefficient one at the strictly negative monoid exponent. -/ +theorem gradedDivisibilityNonprincipalElement_coordinate : + Berarducci.degreeGradedEquivPrincipalMonoidAlgebra K + (gradedDivisibilityNonprincipalElement K) = + AddMonoidAlgebra.single gradedDivisibilityNonprincipalExponent 1 := by + exact Berarducci.degreeGradedEquivPrincipalMonoidAlgebra_principal_monomial 1 + gradedDivisibilityNonprincipalExponent + +variable (K) in +/-- A nonzero monoid exponent prevents the fixture from lying in the principal graded +subalgebra. -/ +theorem gradedDivisibilityNonprincipalElement_not_mem : + gradedDivisibilityNonprincipalElement K ∉ + Berarducci.principalSubringSubalgebra K := by + intro hmem + let eP := Berarducci.principalSubringEquivSubalgebra K + let z : Berarducci.principalSubringSubalgebra K := + ⟨gradedDivisibilityNonprincipalElement K, hmem⟩ + let x := eP.symm z + have hx : Berarducci.principalSubringEmbedding K x = + gradedDivisibilityNonprincipalElement K := by + calc + Berarducci.principalSubringEmbedding K x = + (eP x : Berarducci.DegreeGraded K) := + (Berarducci.principalSubringEquivSubalgebra_apply x).symm + _ = gradedDivisibilityNonprincipalElement K := + congrArg Subtype.val (eP.apply_symm_apply z) + have hcoordinates := congrArg + (Berarducci.degreeGradedEquivPrincipalMonoidAlgebra K) hx + rw [Berarducci.degreeGradedEquivPrincipalMonoidAlgebra_principal, + gradedDivisibilityNonprincipalElement_coordinate] at hcoordinates + have hcoeff := congrArg + (fun f : AddMonoidAlgebra (Berarducci.PrincipalSubring K) + (HahnSeries.Nonpositive.exponentMonoid ℝ) ↦ + f.coeff gradedDivisibilityNonprincipalExponent) hcoordinates + have hne : gradedDivisibilityNonprincipalExponent ≠ 0 := by + intro h + have := congrArg Subtype.val h + norm_num [gradedDivisibilityNonprincipalExponent] at this + rw [AddMonoidAlgebra.coeff_single, Finsupp.single_apply, ite_eq_right (Ne.symm hne), + AddMonoidAlgebra.coeff_single, Finsupp.single_apply, ite_eq_left rfl] at hcoeff + have hgraded : + (0 : Berarducci.DegreeGraded K) = 1 := by + simpa using congrArg + (Berarducci.principalSubringEmbedding K) hcoeff + have hfinite : + (0 : Berarducci.FiniteSupportRing (K := K)) = 1 := by + apply Berarducci.finiteSupportGradedEmbedding_injective K + calc + Berarducci.finiteSupportGradedEmbedding K 0 = 0 := + map_zero (Berarducci.finiteSupportGradedEmbedding K) + _ = 1 := hgraded + _ = Berarducci.finiteSupportGradedEmbedding K 1 := + (map_one (Berarducci.finiteSupportGradedEmbedding K)).symm + exact zero_ne_one hfinite + +end + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Tests/InfiniteSupportFactorization.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Tests/InfiniteSupportFactorization.lean new file mode 100644 index 0000000000..161952cd47 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Tests/InfiniteSupportFactorization.lean @@ -0,0 +1,88 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.InfiniteSupport + +/-! +# API checks for infinite-support factorisation + +The zero series separates `HasOnlyUnitFiniteSupportDivisors` from a predicate that ignores the +zero finite-support divisor. The nonzero-scalar client runs the full parameterized factorisation +theorem and uses its Cantor-term bound to force the factor list to be empty. Thus the client +checks the degree-zero branch, the normalized maximal finite-support factor in the product, and +the exact orientation of the numerical bound. + +Pairwise gcd existence and the unit classification of the finite-support ring remain explicit +parameters of the generic theorem; the coefficient field has characteristic zero. +-/ + +open scoped HahnSeries NatOrdinal + +universe v + +namespace Tests + +public noncomputable section + +open Berarducci + +/-- Zero does not have only unit finite-support divisors because zero itself is a nonunit +finite-support divisor. -/ +theorem zero_not_hasOnlyUnitFiniteSupportDivisors : + ¬HasOnlyUnitFiniteSupportDivisors (0 : Series ℚ) := by + intro hzero + have hzeroSpec := (hasOnlyUnitFiniteSupportDivisors_iff (0 : Series ℚ)).mp hzero + exact not_isUnit_zero (hzeroSpec 0 (dvd_zero 0)) + +/-- The factorisation theorem produces no infinite-support factor for a nonzero scalar series. -/ +theorem scalar_factorization_has_no_infinite_support_factors {K : Type v} [Field K] [CharZero K] + (hgcd : ∀ p q : FiniteSupportRing (K := K), + ∃ d : FiniteSupportRing (K := K), + ∀ e : FiniteSupportRing (K := K), e ∣ p ∧ e ∣ q ↔ e ∣ d) + (hunits : ∀ p : FiniteSupportRing (K := K), + IsUnit p ↔ ∃ a : K, a ≠ 0 ∧ + p = HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℝ) a) + {k : K} (hk : k ≠ 0) : + ∃ (factors : List (Series K)) (a : K), + a ≠ 0 ∧ + HahnSeries.Nonpositive.C k = + HahnSeries.Nonpositive.C a * + (seriesNormalizedMaximalFiniteSupportDivisor + (HahnSeries.Nonpositive.C k) : Series K) * + factors.prod ∧ + (∀ c ∈ factors, + Irreducible c ∧ (c : K⟦ℝ⟧).support.Infinite) ∧ + factors = [] := by + have hb : (HahnSeries.Nonpositive.C k : Series K) ≠ 0 := by + intro hzero + apply HahnSeries.C_ne_zero (R := K) (Γ := ℝ) hk + simpa [HahnSeries.Nonpositive.coe_C] using congrArg + (fun b : Series K ↦ (b : K⟦ℝ⟧)) hzero + obtain ⟨a, factors, ha, hfactor, hfactors, hbound⟩ := + exists_series_infinite_support_factorization_of_exists_gcd hgcd hunits hb + have hbDegree : + ((HahnSeries.Nonpositive.C k : Series K) : K⟦ℝ⟧).degree = 0 := by + rw [HahnSeries.degree_eq_zero] + refine ⟨?_, ?_⟩ + · simpa only [HahnSeries.Nonpositive.coe_C] using + HahnSeries.C_ne_zero (R := K) (Γ := ℝ) hk + · rw [HahnSeries.Nonpositive.coe_C, HahnSeries.C_apply, + HahnSeries.support_single_of_ne hk] + exact Set.finite_singleton 0 + have hcount : + HahnSeries.degreeCantorTermCount + ((HahnSeries.Nonpositive.C k : Series K) : K⟦ℝ⟧) = 0 := by + rw [HahnSeries.degreeCantorTermCount_eq_of_degree hbDegree, + NatOrdinal.cantorTermCount_zero] + have hlength : factors.length = 0 := + Nat.eq_zero_of_le_zero (hcount ▸ hbound) + exact ⟨factors, a, ha, hfactor, hfactors, + List.length_eq_zero_iff.mp hlength⟩ + +end + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Tests/MaximalFiniteSupportDivisor.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Tests/MaximalFiniteSupportDivisor.lean new file mode 100644 index 0000000000..9f3e760a47 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Tests/MaximalFiniteSupportDivisor.lean @@ -0,0 +1,295 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.NormalizedMaximalFinite +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.RVMaximalFinite +public import Mathlib.Basic.Real.Basic + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Tests.Fixtures.ApproachZero + +/-! +# API checks for normalized maximal finite-support divisors + +The two-term fixture has support `{-1, 0}`, coefficient `2` at its least exponent, and coefficient +`1` at its greatest exponent. It is therefore monic in the precise sense used by LM24, Notation +5.4.5, while the nearby incorrect definition that normalizes at the least exponent rejects it. + +The RV fixture is the class of that nonconstant series. Its checks use the actual multiplicative +RV quotient and freeze the orientation `q ∣ B ↔ q ∣ p` from LM24, Proposition 5.4.3. A second +fixture has independently nonzero components in degrees zero and one; it tests the full direct-sum +graded ring of Corollary 5.4.4 rather than a single homogeneous class. The final certificate states +only the one-sided divisibility of Proposition 5.4.8. Pairwise gcd existence and the unit +classification of the finite-support ring remain explicit parameters. +-/ + +open scoped DirectSum HahnSeries NatOrdinal + +public noncomputable section + +namespace Tests + +/-- A two-term finite-support series whose coefficients distinguish greatest-endpoint +normalization from least-endpoint normalization. -/ +def normalizationAsymmetricSeries : HahnSeries.Nonpositive ℝ ℚ := + HahnSeries.Nonpositive.C 1 + + HahnSeries.Nonpositive.single (-1) 2 (by norm_num) + +/-- The asymmetric series has finite support. -/ +theorem normalizationAsymmetricSeries_mem : + normalizationAsymmetricSeries ∈ + (HahnSeries.Nonpositive.finiteSupportSubring : + Subring (HahnSeries.Nonpositive ℝ ℚ)) := by + rw [HahnSeries.Nonpositive.mem_finiteSupportSubring_iff] + apply Set.Finite.subset + ((Set.finite_singleton 0).union (Set.finite_singleton (-1))) + intro x hx + rcases HahnSeries.support_add_subset _ _ hx with hx | hx + · left + rw [HahnSeries.Nonpositive.coe_C] at hx + exact HahnSeries.support_single_subset hx + · right + rw [HahnSeries.Nonpositive.coe_single] at hx + exact HahnSeries.support_single_subset hx + +/-- The asymmetric fixture as an element of the finite-support subring. -/ +def normalizationAsymmetric : + HahnSeries.Nonpositive.finiteSupportSubring (G := ℝ) (K := ℚ) := + ⟨normalizationAsymmetricSeries, normalizationAsymmetricSeries_mem⟩ + +/-- The greatest exponent of the asymmetric fixture is zero. -/ +theorem normalizationAsymmetric_greatest : + IsGreatest + (((normalizationAsymmetric : HahnSeries.Nonpositive ℝ ℚ) : ℚ⟦ℝ⟧).support) 0 := by + constructor + · rw [HahnSeries.mem_support] + simp [normalizationAsymmetric, normalizationAsymmetricSeries] + · intro x hx + exact HahnSeries.Nonpositive.support_subset + (normalizationAsymmetric : HahnSeries.Nonpositive ℝ ℚ) hx + +/-- The least exponent of the asymmetric fixture is `-1`. -/ +theorem normalizationAsymmetric_least : + IsLeast + (((normalizationAsymmetric : HahnSeries.Nonpositive ℝ ℚ) : ℚ⟦ℝ⟧).support) + (-1) := by + constructor + · rw [HahnSeries.mem_support] + simp [normalizationAsymmetric, normalizationAsymmetricSeries] + · intro x hx + have hx' : x ∈ (normalizationAsymmetricSeries : ℚ⟦ℝ⟧).support := by + simpa [normalizationAsymmetric] using hx + rcases HahnSeries.support_add_subset _ _ hx' with hxConstant | hxNegative + · rw [HahnSeries.Nonpositive.coe_C] at hxConstant + have hxZero : x = 0 := by + simpa using HahnSeries.support_single_subset hxConstant + rw [hxZero] + norm_num + · rw [HahnSeries.Nonpositive.coe_single] at hxNegative + have hxNegOne : x = -1 := by + simpa using HahnSeries.support_single_subset hxNegative + rw [hxNegOne] + +/-- The coefficient at the greatest exponent is one. -/ +theorem normalizationAsymmetric_coeff_greatest : + ((normalizationAsymmetric : HahnSeries.Nonpositive ℝ ℚ) : ℚ⟦ℝ⟧).coeff 0 = 1 := by + simp [normalizationAsymmetric, normalizationAsymmetricSeries] + +/-- The coefficient at the least exponent is two, not one. -/ +theorem normalizationAsymmetric_coeff_least : + ((normalizationAsymmetric : HahnSeries.Nonpositive ℝ ℚ) : ℚ⟦ℝ⟧).coeff (-1) = 2 := by + simp [normalizationAsymmetric, normalizationAsymmetricSeries] + +/-- The fixture satisfies the intended greatest-exponent normalization. -/ +theorem normalizationAsymmetric_isMonic : + HahnSeries.Nonpositive.IsMonicFiniteSupport normalizationAsymmetric := by + rw [HahnSeries.Nonpositive.isMonicFiniteSupport_iff] + exact ⟨0, normalizationAsymmetric_greatest, + normalizationAsymmetric_coeff_greatest⟩ + +/-- The fixture rejects normalization at the least support exponent. -/ +theorem normalizationAsymmetric_least_coeff_ne_one : + ((normalizationAsymmetric : HahnSeries.Nonpositive ℝ ℚ) : ℚ⟦ℝ⟧).coeff + (-1) ≠ 1 := by + rw [normalizationAsymmetric_coeff_least] + norm_num + +/-- The nonconstant fixture is a normalized representative of its own associate class. -/ +theorem normalizationAsymmetric_isNormalizedRepresentative : + HahnSeries.Nonpositive.IsNormalizedAssociateRepresentative + (Associates.mk normalizationAsymmetric) normalizationAsymmetric := by + rw [HahnSeries.Nonpositive.isNormalizedAssociateRepresentative_iff] + exact Or.inr + ⟨Associates.mk_ne_zero.mpr normalizationAsymmetric_isMonic.ne_zero, + rfl, normalizationAsymmetric_isMonic⟩ + +/-- The chosen normalized representative preserves the fixture's nonzero associate class. -/ +theorem normalizationAsymmetric_chosen_mk : + Associates.mk + (HahnSeries.Nonpositive.normalizedAssociateRepresentative + (Associates.mk normalizationAsymmetric)) = + Associates.mk normalizationAsymmetric := + HahnSeries.Nonpositive.normalizedAssociateRepresentative_mk _ + +/-- The chosen representative of the fixture's associate class is monic. -/ +theorem normalizationAsymmetric_chosen_isMonic : + HahnSeries.Nonpositive.IsMonicFiniteSupport + (HahnSeries.Nonpositive.normalizedAssociateRepresentative + (Associates.mk normalizationAsymmetric)) := + HahnSeries.Nonpositive.normalizedAssociateRepresentative_isMonic_of_ne_zero + (Associates.mk_ne_zero.mpr normalizationAsymmetric_isMonic.ne_zero) + +/-- The normalized representative of the zero associate class is zero. -/ +theorem normalization_zero_class : + HahnSeries.Nonpositive.normalizedAssociateRepresentative + (0 : Associates + (HahnSeries.Nonpositive.finiteSupportSubring (G := ℝ) (K := ℚ))) = 0 := by + rw [HahnSeries.Nonpositive.normalizedAssociateRepresentative_zero] + +/-- The asymmetric fixture is not a coefficient scalar. -/ +theorem normalizationAsymmetric_not_scalar (k : ℚ) : + normalizationAsymmetric ≠ + HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℝ) k := by + intro h + have hcoeff := congrArg + (fun p : HahnSeries.Nonpositive.finiteSupportSubring (G := ℝ) (K := ℚ) ↦ + (((p : HahnSeries.Nonpositive ℝ ℚ) : ℚ⟦ℝ⟧).coeff (-1))) h + rw [normalizationAsymmetric_coeff_least] at hcoeff + rw [HahnSeries.Nonpositive.coe_finiteSupportScalarHom] at hcoeff + change 2 = (HahnSeries.C k).coeff (-1) at hcoeff + rw [HahnSeries.C_apply, + HahnSeries.coeff_single_of_ne (by norm_num : (-1 : ℝ) ≠ 0)] at hcoeff + norm_num at hcoeff + +/-- The actual degree-RV class of the nonconstant asymmetric finite-support series. -/ +def maximalFiniteRVFixture : Berarducci.HahnDegreeRV ℚ := + Berarducci.finiteSupportRVEmbedding ℚ normalizationAsymmetric + +/-- The nonconstant finite-support series gives a nonzero RV class. -/ +theorem maximalFiniteRVFixture_ne_zero : + maximalFiniteRVFixture ≠ 0 := by + intro h + apply normalizationAsymmetric_isMonic.ne_zero + apply Berarducci.finiteSupportRVEmbedding_injective ℚ + simpa [maximalFiniteRVFixture] using h + +/-- The RV fixture has a representative satisfying the exact divisibility orientation of LM24, +Proposition 5.4.3. -/ +theorem maximalFiniteRVFixture_exists_spec (hgcd : ∀ p q : Berarducci.FiniteSupportRing (K := ℚ), + ∃ d : Berarducci.FiniteSupportRing (K := ℚ), + ∀ e : Berarducci.FiniteSupportRing (K := ℚ), + e ∣ p ∧ e ∣ q ↔ e ∣ d) : + ∃ p : Berarducci.FiniteSupportRing (K := ℚ), + ∀ q : Berarducci.FiniteSupportRing (K := ℚ), + Berarducci.finiteSupportRVEmbedding ℚ q ∣ + maximalFiniteRVFixture ↔ + q ∣ p := by + obtain ⟨a, ha, _⟩ := + Berarducci.existsUnique_isRVMaximalFiniteSupportDivisor_of_exists_gcd hgcd + maximalFiniteRVFixture + induction a using Quotient.inductionOn with + | _ p => + exact ⟨p, + (Berarducci.isRVMaximalFiniteSupportDivisor_mk_iff maximalFiniteRVFixture p).mp ha⟩ + +/-- A nonzero element of the degree-zero component. -/ +def maximalFiniteDegreeZero : + (HahnSeries.Nonpositive.degreeValuation ℚ).Component 0 := + HahnSeries.Nonpositive.degreeFiniteSupportResidueEquiv ℚ 1 + +/-- The prescribed degree-zero component is nonzero. -/ +theorem maximalFiniteDegreeZero_ne_zero : + maximalFiniteDegreeZero ≠ 0 := by + intro h + let e := HahnSeries.Nonpositive.degreeFiniteSupportResidueEquiv ℚ + change e 1 = 0 at h + rw [← map_zero e] at h + exact one_ne_zero (e.injective h) + +/-- The degree-one component represented by the approach-zero principal series. -/ +def maximalFiniteDegreeOne : + (HahnSeries.Nonpositive.degreeValuation ℚ).Component 1 := + Berarducci.degreeLayerMk 1 approachZeroNonpositive + approachZero_degree_eq_one.le + +/-- The prescribed degree-one component is nonzero. -/ +theorem maximalFiniteDegreeOne_ne_zero : + maximalFiniteDegreeOne ≠ 0 := by + rw [maximalFiniteDegreeOne, ne_eq, + Berarducci.degreeLayerMk_eq_zero_iff, approachZero_degree_eq_one] + exact lt_irrefl _ + +/-- An associated-graded element with independently nonzero components in degrees zero and one. -/ +def maximalFiniteTwoComponentGraded : + Berarducci.DegreeGraded ℚ := + DirectSum.of _ 0 maximalFiniteDegreeZero + + DirectSum.of _ 1 maximalFiniteDegreeOne + +/-- Both prescribed components survive in the direct sum. -/ +theorem maximalFiniteTwoComponentGraded_components : + maximalFiniteTwoComponentGraded 0 = + maximalFiniteDegreeZero ∧ + maximalFiniteTwoComponentGraded 1 = + maximalFiniteDegreeOne := by + simp [maximalFiniteTwoComponentGraded, DirectSum.of_apply] + +/-- The two-component graded fixture is nonzero. -/ +theorem maximalFiniteTwoComponentGraded_ne_zero : + maximalFiniteTwoComponentGraded ≠ 0 := by + intro h + apply maximalFiniteDegreeOne_ne_zero + rw [← maximalFiniteTwoComponentGraded_components.2, h] + rfl + +/-- The two-component fixture has a representative satisfying the full-graded divisibility +characterization of LM24, Corollary 5.4.4. -/ +theorem maximalFiniteTwoComponentGraded_exists_spec + (hgcd : ∀ p q : Berarducci.FiniteSupportRing (K := ℚ), + ∃ d : Berarducci.FiniteSupportRing (K := ℚ), + ∀ e : Berarducci.FiniteSupportRing (K := ℚ), + e ∣ p ∧ e ∣ q ↔ e ∣ d) : + ∃ p : Berarducci.FiniteSupportRing (K := ℚ), + ∀ q : Berarducci.FiniteSupportRing (K := ℚ), + Berarducci.finiteSupportGradedEmbedding ℚ q ∣ + maximalFiniteTwoComponentGraded ↔ + q ∣ p := by + obtain ⟨a, ha, _⟩ := + Berarducci.existsUnique_isGradedMaximalFiniteSupportDivisor_of_exists_gcd hgcd + maximalFiniteTwoComponentGraded + induction a using Quotient.inductionOn with + | _ p => + exact ⟨p, + (Berarducci.isGradedMaximalFiniteSupportDivisor_mk_iff maximalFiniteTwoComponentGraded + p).mp ha⟩ + +/-- The normalized maximal divisor of the nonzero two-component fixture is monic. -/ +theorem maximalFiniteTwoComponentGraded_normalized_isMonic + (hgcd : ∀ p q : Berarducci.FiniteSupportRing (K := ℚ), + ∃ d : Berarducci.FiniteSupportRing (K := ℚ), + ∀ e : Berarducci.FiniteSupportRing (K := ℚ), + e ∣ p ∧ e ∣ q ↔ e ∣ d) : + HahnSeries.Nonpositive.IsMonicFiniteSupport + (Berarducci.gradedNormalizedMaximalFiniteSupportDivisor + maximalFiniteTwoComponentGraded) := + Berarducci.gradedNormalizedMaximalFiniteSupportDivisor_isMonic_of_ne_zero hgcd + maximalFiniteTwoComponentGraded_ne_zero + +/-- LM24, Proposition 5.4.8, with its stated one-sided divisibility conclusion. -/ +theorem maximalFiniteTwoComponentGraded_mul_dvd + (hgcd : ∀ p q : Berarducci.FiniteSupportRing (K := ℚ), + ∃ d : Berarducci.FiniteSupportRing (K := ℚ), + ∀ e : Berarducci.FiniteSupportRing (K := ℚ), + e ∣ p ∧ e ∣ q ↔ e ∣ d) : + Berarducci.gradedNormalizedMaximalFiniteSupportDivisor + maximalFiniteTwoComponentGraded * + Berarducci.gradedNormalizedMaximalFiniteSupportDivisor + maximalFiniteTwoComponentGraded ∣ + Berarducci.gradedNormalizedMaximalFiniteSupportDivisor + (maximalFiniteTwoComponentGraded * + maximalFiniteTwoComponentGraded) := + Berarducci.gradedNormalizedMaximalFiniteSupportDivisor_mul_dvd_of_exists_gcd hgcd _ _ + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Tests/NormalizedHPart.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Tests/NormalizedHPart.lean new file mode 100644 index 0000000000..1163f9802d --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Tests/NormalizedHPart.lean @@ -0,0 +1,100 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.NormalizedHPart + +/-! +# API checks for normalized exponent-subgroup parts + +The identity fixture exercises the existence-and-uniqueness predicate for a case that is proved +without Ritt factorisation. The second fixture constructs the genuinely nonconstant normalized +series `1 + t⁻¹` and proves that it is not the normalized subgroup part of `1`, separating the +divisor-characterization predicate from mere constant-term normalization. +-/ + +open scoped HahnSeries + +namespace Tests + +public noncomputable section + +open HahnSeries.Nonpositive + +/-- The full real exponent subgroup used to test normalized finite-support factors. -/ +abbrev HPartExponentSubgroup : AddSubgroup ℝ := ⊤ + +/-- The ring of rational Hahn series with finite nonpositive real support. -/ +abbrev HPartFiniteSupportRing := + FiniteSupportRing (G := HPartExponentSubgroup) (K := ℚ) + +/-- Finite-support rational Hahn series with nonpositive real exponents and constant coefficient +one. -/ +abbrev HPartNormalizedFiniteSupport := + ConstantTermOneFiniteSupport (G := HPartExponentSubgroup) (K := ℚ) + +/-- The exponent `-1` in the nonpositive exponent monoid of the full real subgroup. -/ +def hPartMinusOneExponent : exponentMonoid HPartExponentSubgroup := + ⟨⟨-1, Set.mem_univ _⟩, by + change (-1 : ℝ) ≤ 0 + norm_num⟩ + +/-- The underlying subgroup exponent `-1` differs from zero. -/ +theorem hPartMinusOneExponent_coe_ne_zero : + (hPartMinusOneExponent : HPartExponentSubgroup) ≠ 0 := by + intro h + have hval := congrArg (fun g : HPartExponentSubgroup ↦ (g : ℝ)) h + norm_num [hPartMinusOneExponent] at hval + +/-- The normalized nonconstant finite-support series `1 + t⁻¹`. -/ +def onePlusNegativeMonomial : HPartNormalizedFiniteSupport := + ⟨1 + finiteSupportMonomial (K := ℚ) hPartMinusOneExponent, by + rw [mem_constantTermOneSubmonoid_iff] + change constantCoeff + ((1 : HahnSeries.Nonpositive HPartExponentSubgroup ℚ) + + (finiteSupportMonomial (K := ℚ) hPartMinusOneExponent : + HahnSeries.Nonpositive HPartExponentSubgroup ℚ)) = 1 + rw [map_add, map_one, constantCoeff_apply, + coe_finiteSupportMonomial] + rw [HahnSeries.coeff_single_of_ne + hPartMinusOneExponent_coe_ne_zero.symm] + simp⟩ + +/-- The normalized series `1 + t⁻¹` is not the identity. -/ +theorem onePlusNegativeMonomial_ne_one : + onePlusNegativeMonomial ≠ 1 := by + intro h + have hcoeff := congrArg + (fun p : HPartNormalizedFiniteSupport ↦ + ((((p : HPartFiniteSupportRing) : + HahnSeries.Nonpositive HPartExponentSubgroup ℚ) : + ℚ⟦HPartExponentSubgroup⟧).coeff hPartMinusOneExponent)) h + simp [onePlusNegativeMonomial, hPartMinusOneExponent, + HahnSeries.Nonpositive.coe_finiteSupportMonomial] at hcoeff + +/-- The normalized `H`-part of one exists uniquely and is one. -/ +theorem one_unique_normalizedHPart : + ∃! q : HPartNormalizedFiniteSupport, + IsNormalizedHPart HPartExponentSubgroup + (1 : FiniteSupportRing (G := ℝ) (K := ℚ)) q := + existsUnique_normalizedHPart_one HPartExponentSubgroup + +/-- Constant-term normalization alone does not make `1 + t⁻¹` the normalized `H`-part of +one. -/ +theorem onePlusNegativeMonomial_not_normalizedHPart_one : + ¬IsNormalizedHPart HPartExponentSubgroup + (1 : FiniteSupportRing (G := ℝ) (K := ℚ)) + onePlusNegativeMonomial := by + intro hpart + apply onePlusNegativeMonomial_ne_one + apply ConstantTermOneFiniteSupport.eq_one_of_finiteSupportToReal_dvd_one + exact (Iff.mp (isNormalizedHPart_iff HPartExponentSubgroup + (1 : FiniteSupportRing (G := ℝ) (K := ℚ)) onePlusNegativeMonomial) hpart + onePlusNegativeMonomial).mpr (dvd_refl _) + +end + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Tests/NormalizedHPartMultiplicativity.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Tests/NormalizedHPartMultiplicativity.lean new file mode 100644 index 0000000000..310b179f01 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Tests/NormalizedHPartMultiplicativity.lean @@ -0,0 +1,99 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.NormalizedHPartMultiplicativity + +/-! +# API checks for multiplication of normalized exponent-subgroup parts + +For the trivial exponent subgroup, every normalized finite-support subgroup series is `1`. +The real finite-support series `1 + t⁻¹` is nevertheless nonconstant, so its normalized trivial- +subgroup part is genuinely smaller than the original series. Applying the multiplication theorem +to its square checks both directions of the divisor characterization and the product orientation. +-/ + +open scoped HahnSeries + +namespace Tests + +public noncomputable section + +open HahnSeries.Nonpositive + +/-- The zero exponent subgroup used to test multiplicativity of normalized factors. -/ +abbrev TrivialExponentSubgroup : AddSubgroup ℝ := ⊥ + +/-- Every normalized finite-support series over the trivial exponent subgroup is the identity. -/ +theorem normalized_trivialExponentSubgroup_eq_one + (p : ConstantTermOneFiniteSupport (G := TrivialExponentSubgroup) (K := ℚ)) : + p = 1 := by + apply Subtype.ext + apply Subtype.ext + apply Subtype.ext + apply HahnSeries.coeff_injective + funext g + have hg : g = 0 := Subsingleton.elim _ _ + subst g + simpa [constantCoeff_apply] using p.constantCoeff_eq_one + +/-- Normalized divisors over the trivial exponent subgroup satisfy the required product +refinement property. -/ +theorem trivialExponentSubgroup_hasNormalizedHDivisorRefinement : + HasNormalizedHDivisorRefinement TrivialExponentSubgroup (K := ℚ) := by + rw [hasNormalizedHDivisorRefinement_iff] + intro p q r _ + refine ⟨1, 1, ?_, ?_, ?_⟩ <;> + simp [normalized_trivialExponentSubgroup_eq_one r] + +/-- The identity is the normalized trivial-subgroup part of every finite-support real series. -/ +theorem one_isNormalizedTrivialExponentSubgroupPart + (p : FiniteSupportRing (G := ℝ) (K := ℚ)) : + IsNormalizedHPart TrivialExponentSubgroup p 1 := by + rw [isNormalizedHPart_iff] + intro r + rw [normalized_trivialExponentSubgroup_eq_one r] + simp + +/-- The real exponent `-1` as a nonpositive exponent. -/ +def normalizedPartMinusOneExponent : exponentMonoid ℝ := + ⟨-1, show (-1 : ℝ) ≤ 0 by norm_num⟩ + +/-- The nonconstant finite-support real series `1 + t⁻¹`. -/ +def normalizedPartNonconstantSeries : FiniteSupportRing (G := ℝ) (K := ℚ) := + 1 + finiteSupportMonomial normalizedPartMinusOneExponent + +/-- The fixture `1 + t⁻¹` is not the identity. -/ +theorem normalizedPartNonconstantSeries_ne_one : + normalizedPartNonconstantSeries ≠ 1 := by + intro h + have hcoeff := congrArg + (fun p : FiniteSupportRing (G := ℝ) (K := ℚ) ↦ + (((p : HahnSeries.Nonpositive ℝ ℚ) : ℚ⟦ℝ⟧).coeff (-1))) h + norm_num [normalizedPartNonconstantSeries, normalizedPartMinusOneExponent, + coe_finiteSupportMonomial] at hcoeff + +/-- The normalized trivial-subgroup part is not merely the original nonconstant series. -/ +theorem normalizedPartNonconstantSeries_ne_embeddedPart : + normalizedPartNonconstantSeries ≠ + finiteSupportToReal TrivialExponentSubgroup + (1 : FiniteSupportRing (G := TrivialExponentSubgroup) (K := ℚ)) := by + simpa using normalizedPartNonconstantSeries_ne_one + +/-- The product theorem computes the normalized trivial-subgroup part of +`(1 + t⁻¹)²` as `1`. -/ +theorem normalizedPartNonconstantSeries_mul_isNormalizedPart : + IsNormalizedHPart TrivialExponentSubgroup + (normalizedPartNonconstantSeries * normalizedPartNonconstantSeries) 1 := by + simpa using + (isNormalizedHPart_mul TrivialExponentSubgroup + trivialExponentSubgroup_hasNormalizedHDivisorRefinement + (one_isNormalizedTrivialExponentSubgroupPart normalizedPartNonconstantSeries) + (one_isNormalizedTrivialExponentSubgroupPart normalizedPartNonconstantSeries)) + +end + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Tests/PrincipalMaximalFiniteSupportDivisor.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Tests/PrincipalMaximalFiniteSupportDivisor.lean new file mode 100644 index 0000000000..b9a724f098 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Tests/PrincipalMaximalFiniteSupportDivisor.lean @@ -0,0 +1,246 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.NormalizedMaximalFinite +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.RVMaximalFinite + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Tests.Fixtures.ApproachZero +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.PrincipalMaximalFinite +import Mathlib.Tactic.NormNum + +/-! +# API checks for principal-factor invariance + +These checks exercise the field-generic cores of LM24, Lemmas 6.3.1--6.3.2. The finite-support +factor is the nonconstant monomial `t⁻¹`. The RV principal factor is represented by the +approach-zero series, so it is nonzero and nonconstant. + +For the full graded result, the principal factor has independently nonzero components in degrees +zero and one. It therefore tests `P̂` rather than a single RV component. A final boundary check +shows that replacing the nonzero principal factor by zero changes the maximal divisor. Pairwise +gcd existence remains an explicit parameter in these generic checks. +-/ + +open scoped DirectSum HahnSeries NatOrdinal + +namespace Tests + +public noncomputable section + +private theorem approachZero_ordinalValue_bound : + Berarducci.ordinalValue approachZeroNonpositive < ω^ (1 + 1 : NatOrdinal) := by + rw [Berarducci.ordinalValue_eq_wpow_of_isPrincipal approachZero_isPrincipal + approachZero_degree_eq_one] + exact NatOrdinal.wpow_lt_wpow.mpr (lt_add_one (1 : NatOrdinal)) + +/-- The nonzero class in `P_1` represented by the approach-zero series. -/ +def principalInvariantApproachZeroLayer : Berarducci.PrincipalComponent ℚ 1 := + Berarducci.principalComponentMk 1 approachZeroNonpositive + approachZero_ordinalValue_bound + +/-- The approach-zero class survives in the degree-one principal quotient. -/ +theorem principalInvariantApproachZeroLayer_ne_zero : + principalInvariantApproachZeroLayer ≠ 0 := by + rw [principalInvariantApproachZeroLayer, ne_eq, + Berarducci.principalComponentMk_eq_zero_iff, + Berarducci.ordinalValue_eq_wpow_of_isPrincipal approachZero_isPrincipal + approachZero_degree_eq_one] + exact lt_irrefl _ + +/-- The grade-zero principal class of the coefficient one. -/ +def principalInvariantScalarLayer : Berarducci.PrincipalComponent ℚ 0 := + Berarducci.principalComponentScalarHom ℚ 1 + +/-- The grade-zero class of one is nonzero. -/ +theorem principalInvariantScalarLayer_ne_zero : + principalInvariantScalarLayer ≠ 0 := by + rw [principalInvariantScalarLayer, + Berarducci.principalComponentScalarHom_apply, ne_eq, + Berarducci.principalComponentMk_eq_zero_iff, + Berarducci.ordinalValue_C_of_ne one_ne_zero] + simpa only [NatOrdinal.wpow_zero] using (lt_irrefl (1 : NatOrdinal)) + +/-- An intrinsic principal graded element supported in degrees zero and one. -/ +def principalInvariantTwoGrade : Berarducci.PrincipalSubring ℚ := + DirectSum.of _ 0 principalInvariantScalarLayer + + DirectSum.of _ 1 principalInvariantApproachZeroLayer + +/-- The two prescribed components of the intrinsic principal graded fixture are unchanged. -/ +theorem principalInvariantTwoGrade_components : + principalInvariantTwoGrade 0 = principalInvariantScalarLayer ∧ + principalInvariantTwoGrade 1 = principalInvariantApproachZeroLayer := by + simp [principalInvariantTwoGrade, DirectSum.of_apply] + +/-- The positive-degree component makes the intrinsic two-grade fixture nonzero. -/ +theorem principalInvariantTwoGrade_ne_zero : + principalInvariantTwoGrade ≠ 0 := by + intro hzero + apply principalInvariantApproachZeroLayer_ne_zero + rw [← principalInvariantTwoGrade_components.2, hzero] + rfl + +/-- The two-degree example embedded in the degree-graded ring. -/ +def principalInvariantGraded : Berarducci.DegreeGraded ℚ := + Berarducci.principalSubringEmbedding ℚ + principalInvariantTwoGrade + +/-- The embedded two-grade fixture satisfies the componentwise definition of `P̂`. -/ +theorem principalInvariantGraded_isPrincipal : + Berarducci.IsPrincipalGraded + principalInvariantGraded := by + rw [Berarducci.isPrincipalGraded_iff] + intro α + rw [principalInvariantGraded, + Berarducci.principalSubringEmbedding_apply] + exact Berarducci.principalComponentToHahnDegreeLayer_isPrincipal α (principalInvariantTwoGrade α) + +/-- Injectivity of the canonical graded embedding preserves nonzeroness of the fixture. -/ +theorem principalInvariantGraded_ne_zero : + principalInvariantGraded ≠ 0 := by + intro hzero + rw [principalInvariantGraded] at hzero + apply principalInvariantTwoGrade_ne_zero + apply Berarducci.principalSubringEmbedding_injective ℚ + simpa using hzero + +/-- The full graded principal factor has independently nonzero components in degrees zero and +one. -/ +theorem principalInvariantGraded_components_ne_zero : + principalInvariantGraded 0 ≠ 0 ∧ + principalInvariantGraded 1 ≠ 0 := by + constructor + · rw [principalInvariantGraded, Berarducci.principalSubringEmbedding_apply, + principalInvariantTwoGrade_components.1] + intro hzero + apply principalInvariantScalarLayer_ne_zero + apply Berarducci.principalComponentToHahnDegreeLayer_injective ℚ 0 + simpa using hzero + · rw [principalInvariantGraded, Berarducci.principalSubringEmbedding_apply, + principalInvariantTwoGrade_components.2] + intro hzero + apply principalInvariantApproachZeroLayer_ne_zero + apply Berarducci.principalComponentToHahnDegreeLayer_injective ℚ 1 + simpa using hzero + +/-- The strictly negative exponent used by the nonconstant finite-support fixture. -/ +def principalInvariantNegativeExponent : + HahnSeries.Nonpositive.exponentMonoid ℝ := + ⟨-1, show (-1 : ℝ) ≤ 0 by norm_num⟩ + +/-- The nonconstant finite-support monomial `t⁻¹`. -/ +def principalInvariantFiniteMonomial : Berarducci.FiniteSupportRing (K := ℚ) := + HahnSeries.Nonpositive.finiteSupportMonomial principalInvariantNegativeExponent + +/-- The coefficient at exponent `-1` proves that the finite-support fixture is nonzero. -/ +theorem principalInvariantFiniteMonomial_ne_zero : + principalInvariantFiniteMonomial ≠ 0 := by + intro hzero + have hcoeff := congrArg + (fun p : Berarducci.FiniteSupportRing (K := ℚ) ↦ + (((p : Berarducci.Series ℚ) : ℚ⟦ℝ⟧).coeff (-1))) hzero + simp [principalInvariantFiniteMonomial, + principalInvariantNegativeExponent] at hcoeff + +/-- The degree-RV class represented by the approach-zero principal series. -/ +def principalInvariantRV : Berarducci.HahnDegreeRV ℚ := + (HahnSeries.Nonpositive.degreeValuation ℚ).rv + approachZeroNonpositive + +/-- The approach-zero RV fixture is principal in the exact sense of LM24, Definition 5.2.1. -/ +theorem principalInvariantRV_isPrincipal : + Berarducci.IsPrincipalRV principalInvariantRV := + (Berarducci.isPrincipalRV_iff _).mpr + ⟨approachZeroNonpositive, approachZero_isPrincipal, rfl⟩ + +/-- Separatedness of the degree valuation proves that the approach-zero RV fixture is nonzero. -/ +theorem principalInvariantRV_ne_zero : principalInvariantRV ≠ 0 := by + intro hzero + let w := HahnSeries.Nonpositive.degreeValuation ℚ + have hbot : w approachZeroNonpositive = ⊥ := by + exact w.rv_eq_zero_iff.mp hzero + have hsep := + (MaxAddDegree.isSeparated_iff w).mp + (HahnSeries.Nonpositive.degreeValuation_isSeparated ℚ) + exact approachZero_ne_zero ((hsep approachZeroNonpositive).mp hbot) + +/-- Multiplication by the nonhomogeneous two-grade principal fixture preserves the normalized +maximal finite-support divisor of the negative monomial. -/ +theorem principalInvariant_fullGraded (hgcd : ∀ p q : Berarducci.FiniteSupportRing (K := ℚ), + ∃ d : Berarducci.FiniteSupportRing (K := ℚ), + ∀ e : Berarducci.FiniteSupportRing (K := ℚ), + e ∣ p ∧ e ∣ q ↔ e ∣ d) : + Berarducci.gradedNormalizedMaximalFiniteSupportDivisor + (Berarducci.finiteSupportGradedEmbedding ℚ + principalInvariantFiniteMonomial * + principalInvariantGraded) = + Berarducci.gradedNormalizedMaximalFiniteSupportDivisor + (Berarducci.finiteSupportGradedEmbedding ℚ + principalInvariantFiniteMonomial) := by + exact + Berarducci.gradedNormalizedMaximalFiniteSupportDivisor_mul_principal_eq_of_exists_gcd hgcd _ + principalInvariantGraded_isPrincipal + principalInvariantGraded_ne_zero + +/-- The same nonzero graded input has a different normalized maximal divisor after multiplication +by zero, certifying the nonzero-factor boundary. -/ +theorem principalInvariant_zero_factor_changes_divisor + (hgcd : ∀ p q : Berarducci.FiniteSupportRing (K := ℚ), + ∃ d : Berarducci.FiniteSupportRing (K := ℚ), + ∀ e : Berarducci.FiniteSupportRing (K := ℚ), + e ∣ p ∧ e ∣ q ↔ e ∣ d) : + Berarducci.gradedNormalizedMaximalFiniteSupportDivisor + (Berarducci.finiteSupportGradedEmbedding ℚ + principalInvariantFiniteMonomial * 0) ≠ + Berarducci.gradedNormalizedMaximalFiniteSupportDivisor + (Berarducci.finiteSupportGradedEmbedding ℚ + principalInvariantFiniteMonomial) := by + have hB : Berarducci.finiteSupportGradedEmbedding ℚ + principalInvariantFiniteMonomial ≠ 0 := by + intro hzero + apply principalInvariantFiniteMonomial_ne_zero + apply Berarducci.finiteSupportGradedEmbedding_injective ℚ + simpa using hzero + have hright := + Berarducci.gradedNormalizedMaximalFiniteSupportDivisor_isMonic_of_ne_zero hgcd hB |>.ne_zero + have hleft : + Berarducci.gradedNormalizedMaximalFiniteSupportDivisor + (Berarducci.finiteSupportGradedEmbedding ℚ + principalInvariantFiniteMonomial * 0) = 0 := by + rw [mul_zero] + have hspec := + (Berarducci.isNormalizedGradedMaximalFiniteSupportDivisor_iff (0 : + Berarducci.DegreeGraded ℚ) _).mp + (Berarducci.gradedNormalizedMaximalFiniteSupportDivisor_is_of_exists_gcd hgcd + (0 : Berarducci.DegreeGraded ℚ)) + rcases hspec.2 with hzero | hnonzero + · exact hzero.2 + · exact (hnonzero.1 rfl).elim + rw [hleft] + exact Ne.symm hright + +/-- Multiplication by the nonconstant approach-zero principal RV class preserves the normalized +maximal finite-support divisor of the negative-monomial RV class. -/ +theorem principalInvariant_rv (hgcd : ∀ p q : Berarducci.FiniteSupportRing (K := ℚ), + ∃ d : Berarducci.FiniteSupportRing (K := ℚ), + ∀ e : Berarducci.FiniteSupportRing (K := ℚ), + e ∣ p ∧ e ∣ q ↔ e ∣ d) : + Berarducci.gradedNormalizedMaximalFiniteSupportDivisor + ((HahnSeries.Nonpositive.degreeValuation ℚ).rvInitialFormHom + (Berarducci.finiteSupportRVEmbedding ℚ principalInvariantFiniteMonomial * + principalInvariantRV)) = + Berarducci.gradedNormalizedMaximalFiniteSupportDivisor + ((HahnSeries.Nonpositive.degreeValuation ℚ).rvInitialFormHom + (Berarducci.finiteSupportRVEmbedding ℚ + principalInvariantFiniteMonomial)) := by + exact + Berarducci.gradedNormalizedMaximalFiniteSupportDivisor_rv_mul_principal_eq_of_exists_gcd hgcd _ + principalInvariantRV_isPrincipal + principalInvariantRV_ne_zero + +end + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Tests/SectionSixFour.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Tests/SectionSixFour.lean new file mode 100644 index 0000000000..5653e01daf --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Tests/SectionSixFour.lean @@ -0,0 +1,105 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.FiniteSupportFactorUniqueness + +import Mathlib.Tactic.NormNum + +/-! +# API checks for LM24 Section 6.4 + +The empty-list fixture certifies that the source natural number `n` may be zero. The sign-change +fixture gives two factorisations of the same series with finite-support factors `1` and `-1`. +Those factors are unequal but differ by a nonzero coefficient scalar, separating the source's +uniqueness up to scalar from the stronger and false assertion of literal equality. + +The full uniqueness statement retains every unresolved mathematical prerequisite as an explicit +hypothesis. +-/ + +open scoped HahnSeries + +namespace Tests + +public noncomputable section + +open Berarducci HahnSeries.Nonpositive + +/-- The multiplicative identity has a Section 6.4 factorisation with no infinite-support +factors. -/ +theorem one_empty_infiniteSupportIrreducibleFactorization : + IsInfiniteSupportIrreducibleFactorization + (1 : Series ℚ) (1 : FiniteSupportRing (K := ℚ)) [] := by + rw [isInfiniteSupportIrreducibleFactorization_iff] + simp + +private theorem neg_irreducible {c : Series ℚ} (hc : Irreducible c) : + Irreducible (-c) := + Associated.irreducible ⟨-1, mul_neg_one c⟩ hc + +private theorem neg_support_infinite {c : Series ℚ} + (hc : (c : ℚ⟦ℝ⟧).support.Infinite) : + ((-c : Series ℚ) : ℚ⟦ℝ⟧).support.Infinite := by + change (-((c : Series ℚ) : ℚ⟦ℝ⟧)).support.Infinite + simpa only [HahnSeries.support_neg] using hc + +/-- A sign change may be transferred between the finite-support factor and the sole listed +infinite-support factor. -/ +theorem neg_one_neg_factorization {c : Series ℚ} + (hcIrreducible : Irreducible c) + (hcInfinite : (c : ℚ⟦ℝ⟧).support.Infinite) : + IsInfiniteSupportIrreducibleFactorization c + (-1 : FiniteSupportRing (K := ℚ)) [-c] := by + rw [isInfiniteSupportIrreducibleFactorization_iff] + constructor + · simp + · simp only [List.mem_singleton, forall_eq] + exact ⟨neg_irreducible hcIrreducible, neg_support_infinite hcInfinite⟩ + +/-- The two sign-related finite-support factors are not literally equal. -/ +theorem neg_one_finiteSupportFactor_ne_one : + (-1 : FiniteSupportRing (K := ℚ)) ≠ 1 := by + intro h + have hcoeff := congrArg + (fun p : FiniteSupportRing (K := ℚ) ↦ + ((p : Series ℚ) : ℚ⟦ℝ⟧).coeff 0) h + norm_num at hcoeff + +/-- The Section 6.4 uniqueness theorem identifies the sign-related finite-support factors up to +a nonzero coefficient scalar. -/ +theorem sign_changed_factorizations_are_unique_up_to_scalar + (hgcd : ∀ p q : FiniteSupportRing (K := ℚ), + ∃ d : FiniteSupportRing (K := ℚ), + ∀ e : FiniteSupportRing (K := ℚ), e ∣ p ∧ e ∣ q ↔ e ∣ d) + (hunits : ∀ p : FiniteSupportRing (K := ℚ), + IsUnit p ↔ ∃ k : ℚ, k ≠ 0 ∧ + p = finiteSupportScalarHom (G := ℝ) k) + (hmaxMul : ∀ b c : Series ℚ, + seriesNormalizedMaximalFiniteSupportDivisor (b * c) = + seriesNormalizedMaximalFiniteSupportDivisor b * + seriesNormalizedMaximalFiniteSupportDivisor c) + {c : Series ℚ} (hcIrreducible : Irreducible c) + (hcInfinite : (c : ℚ⟦ℝ⟧).support.Infinite) : + ∃ k : ℚ, k ≠ 0 ∧ + (-1 : FiniteSupportRing (K := ℚ)) = + finiteSupportScalarHom (G := ℝ) k * 1 := by + have hpositive : IsInfiniteSupportIrreducibleFactorization c + (1 : FiniteSupportRing (K := ℚ)) [c] := by + rw [isInfiniteSupportIrreducibleFactorization_iff] + constructor + · simp + · simp only [List.mem_singleton, forall_eq] + exact ⟨hcIrreducible, hcInfinite⟩ + exact finiteSupportFactor_eq_scalar_mul_of_factorizations + (b := c) (p := (1 : FiniteSupportRing (K := ℚ))) + (q := (-1 : FiniteSupportRing (K := ℚ))) + (factors := [c]) (otherFactors := [-c]) + hgcd hunits hmaxMul hpositive (neg_one_neg_factorization hcIrreducible hcInfinite) + +end + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Tests/SeriesMaximalFiniteSupportDivisor.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Tests/SeriesMaximalFiniteSupportDivisor.lean new file mode 100644 index 0000000000..a57e5cf67f --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Factorization/Tests/SeriesMaximalFiniteSupportDivisor.lean @@ -0,0 +1,319 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.NormalizedSeriesMaximalFinite +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Tests.Fixtures.ApproachZero + +/-! +# API checks for series-level maximal finite-support divisors + +This module formalizes the mechanism in LM24, Example 5.5.4. Put `x = t⁻¹`, let +`p₀ = 1 - x²`, let `p₁ = x + 1`, and let `a` be the principal series with support +`{-1/(n+1) | n ∈ ℕ}`. The series tested here is + +`b = p₀ * a + p₁`. + +The leading RV class of `b` has normalized maximal finite-support divisor `p₀`, whereas the +full series has normalized maximal finite-support divisor `p₁`. The proof also certifies that +`p₀ ≠ p₁`. Thus the client rejects the incorrect shortcut that defines the series-level +divisor solely from the leading RV class. Pairwise gcd existence and unit classification remain +explicit parameters. +-/ + +open scoped HahnSeries NatOrdinal + +namespace Tests + +public noncomputable section + +/-- The finite-support monomial `x = t⁻¹` used in LM24, Example 5.5.4. -/ +def seriesMaximalExampleMonomial : Berarducci.FiniteSupportRing (K := ℚ) := + HahnSeries.Nonpositive.finiteSupportMonomial (K := ℚ) ⟨-1, show (-1 : ℝ) ≤ 0 by norm_num⟩ + +/-- The leading-RV maximal divisor `p₀ = 1 - t⁻²` from LM24, Example 5.5.4. -/ +def seriesMaximalExampleRVDivisor : Berarducci.FiniteSupportRing (K := ℚ) := + 1 - seriesMaximalExampleMonomial * seriesMaximalExampleMonomial + +/-- The full-series maximal divisor `p₁ = t⁻¹ + 1` from LM24, Example 5.5.4. -/ +def seriesMaximalExampleDivisor : Berarducci.FiniteSupportRing (K := ℚ) := + seriesMaximalExampleMonomial + 1 + +/-- The Hahn series `b = (1 - t⁻²)a + (t⁻¹ + 1)` from LM24, Example 5.5.4. -/ +def seriesMaximalExample : Berarducci.Series ℚ := + (seriesMaximalExampleRVDivisor : Berarducci.Series ℚ) * + approachZeroNonpositive + + (seriesMaximalExampleDivisor : Berarducci.Series ℚ) + +/-- The full-series divisor `t⁻¹ + 1` is monic at its greatest support exponent. -/ +theorem seriesMaximalExampleDivisor_isMonic : + HahnSeries.Nonpositive.IsMonicFiniteSupport seriesMaximalExampleDivisor := by + rw [HahnSeries.Nonpositive.isMonicFiniteSupport_iff] + refine ⟨0, ⟨?_, ?_⟩, ?_⟩ + · rw [HahnSeries.mem_support] + simp [seriesMaximalExampleDivisor, seriesMaximalExampleMonomial] + · intro g hg + exact HahnSeries.Nonpositive.support_subset + (seriesMaximalExampleDivisor : HahnSeries.Nonpositive ℝ ℚ) hg + · simp [seriesMaximalExampleDivisor, seriesMaximalExampleMonomial] + +/-- The coefficient of `1 - t⁻²` at its greatest support exponent is one. -/ +theorem seriesMaximalExampleRVDivisor_coeff_zero : + (((seriesMaximalExampleRVDivisor : Berarducci.Series ℚ) : ℚ⟦ℝ⟧).coeff 0) = + 1 := by + simp only [seriesMaximalExampleRVDivisor, seriesMaximalExampleMonomial, + HahnSeries.Nonpositive.finiteSupportMonomial_mul, AddSubgroupClass.coe_sub, + OneMemClass.coe_one, HahnSeries.Nonpositive.coe_finiteSupportMonomial, + HahnSeries.coeff_sub', Pi.sub_apply, HahnSeries.coeff_one, reduceIte, sub_eq_self] + rw [HahnSeries.coeff_single_of_ne (by norm_num)] + +/-- The leading-RV divisor `1 - t⁻²` is monic at its greatest support exponent. -/ +theorem seriesMaximalExampleRVDivisor_isMonic : + HahnSeries.Nonpositive.IsMonicFiniteSupport seriesMaximalExampleRVDivisor := by + rw [HahnSeries.Nonpositive.isMonicFiniteSupport_iff] + refine ⟨0, ⟨?_, ?_⟩, seriesMaximalExampleRVDivisor_coeff_zero⟩ + · rw [HahnSeries.mem_support, seriesMaximalExampleRVDivisor_coeff_zero] + norm_num + · intro g hg + exact HahnSeries.Nonpositive.support_subset + (seriesMaximalExampleRVDivisor : HahnSeries.Nonpositive ℝ ℚ) hg + +/-- The leading-RV divisor is nonzero. -/ +theorem seriesMaximalExampleRVDivisor_ne_zero : + seriesMaximalExampleRVDivisor ≠ 0 := + seriesMaximalExampleRVDivisor_isMonic.ne_zero + +/-- The leading-RV and full-series divisors in LM24, Example 5.5.4 are distinct. -/ +theorem seriesMaximalExample_divisors_ne : + seriesMaximalExampleRVDivisor ≠ seriesMaximalExampleDivisor := by + intro h + have hcoeff := congrArg + (fun p : Berarducci.FiniteSupportRing (K := ℚ) ↦ + (((p : Berarducci.Series ℚ) : ℚ⟦ℝ⟧).coeff (-1))) h + simp [seriesMaximalExampleRVDivisor, seriesMaximalExampleDivisor, + seriesMaximalExampleMonomial] at hcoeff + +/-- The full-series divisor divides the leading-RV divisor: +`t⁻¹ + 1 ∣ 1 - t⁻²`. -/ +theorem seriesMaximalExampleDivisor_dvd_rvDivisor : + seriesMaximalExampleDivisor ∣ seriesMaximalExampleRVDivisor := by + refine ⟨1 - seriesMaximalExampleMonomial, ?_⟩ + dsimp only [seriesMaximalExampleRVDivisor, seriesMaximalExampleDivisor] + ring + +/-- The associated-graded representative of the leading RV class in LM24, +Example 5.5.4. -/ +def seriesMaximalExampleLeadingGraded : + Berarducci.DegreeGraded ℚ := + (((HahnSeries.Nonpositive.degreeValuation ℚ).rvEquivHomogeneous + ((HahnSeries.Nonpositive.degreeValuation ℚ).rv + seriesMaximalExample) : + (HahnSeries.Nonpositive.degreeValuation ℚ).HomogeneousClasses) : + Berarducci.DegreeGraded ℚ) + +/-- The leading-RV divisor has Hahn-series degree zero. -/ +theorem seriesMaximalExampleRVDivisor_degree : + ((seriesMaximalExampleRVDivisor : Berarducci.Series ℚ) : ℚ⟦ℝ⟧).degree = + 0 := by + rw [HahnSeries.degree_eq_zero] + exact ⟨by + intro hzero + apply seriesMaximalExampleRVDivisor_ne_zero + exact Subtype.ext (Subtype.ext hzero), + (HahnSeries.Nonpositive.mem_finiteSupportSubring_iff + (seriesMaximalExampleRVDivisor : Berarducci.Series ℚ)).mp + seriesMaximalExampleRVDivisor.2⟩ + +/-- The full-series divisor has Hahn-series degree zero. -/ +theorem seriesMaximalExampleDivisor_degree : + ((seriesMaximalExampleDivisor : Berarducci.Series ℚ) : ℚ⟦ℝ⟧).degree = 0 := by + rw [HahnSeries.degree_eq_zero] + exact ⟨by + intro hzero + apply seriesMaximalExampleDivisor_isMonic.ne_zero + exact Subtype.ext (Subtype.ext hzero), + (HahnSeries.Nonpositive.mem_finiteSupportSubring_iff + (seriesMaximalExampleDivisor : Berarducci.Series ℚ)).mp + seriesMaximalExampleDivisor.2⟩ + +/-- The leading term `(1 - t⁻²)a` has degree one. -/ +theorem seriesMaximalExample_leading_degree : + (((seriesMaximalExampleRVDivisor : Berarducci.Series ℚ) * + approachZeroNonpositive : Berarducci.Series ℚ) : ℚ⟦ℝ⟧).degree = 1 := by + rw [HahnSeries.Nonpositive.degree_mul, seriesMaximalExampleRVDivisor_degree, + approachZero_degree_eq_one, zero_add] + +/-- The series in LM24, Example 5.5.4 has degree one. -/ +theorem seriesMaximalExample_degree : + (seriesMaximalExample : ℚ⟦ℝ⟧).degree = 1 := by + calc + (seriesMaximalExample : ℚ⟦ℝ⟧).degree = + (((seriesMaximalExampleRVDivisor : Berarducci.Series ℚ) * + approachZeroNonpositive : Berarducci.Series ℚ) : ℚ⟦ℝ⟧).degree := by + apply HahnSeries.degree_add_eq_left_of_lt + rw [seriesMaximalExample_leading_degree, + seriesMaximalExampleDivisor_degree] + norm_num + _ = 1 := seriesMaximalExample_leading_degree + +/-- The leading RV class of the example is the RV class of `(1 - t⁻²)a`. -/ +theorem seriesMaximalExample_rv_eq : + (HahnSeries.Nonpositive.degreeValuation ℚ).rv + seriesMaximalExample = + (HahnSeries.Nonpositive.degreeValuation ℚ).rv + ((seriesMaximalExampleRVDivisor : Berarducci.Series ℚ) * + approachZeroNonpositive) := by + let w := HahnSeries.Nonpositive.degreeValuation ℚ + have hvalue : w seriesMaximalExample ≠ ⊥ := by + rw [HahnSeries.Nonpositive.degreeValuation_apply, + seriesMaximalExample_degree] + norm_num + apply (w.rv_eq_iff_of_value_ne_bot hvalue).mpr + rw [HahnSeries.Nonpositive.degreeValuation_apply, + HahnSeries.Nonpositive.degreeValuation_apply, + seriesMaximalExample_degree] + have hdiff : seriesMaximalExample - + (seriesMaximalExampleRVDivisor : Berarducci.Series ℚ) * + approachZeroNonpositive = + (seriesMaximalExampleDivisor : Berarducci.Series ℚ) := by + simp only [seriesMaximalExample] + abel + rw [hdiff, seriesMaximalExampleDivisor_degree] + norm_num + +/-- The associated-graded representative of the example's leading RV class is its +degree-one initial form. -/ +theorem seriesMaximalExampleLeadingGraded_eq : + seriesMaximalExampleLeadingGraded = + DirectSum.of + (HahnSeries.Nonpositive.degreeValuation ℚ).Component + 1 + (Berarducci.degreeLayerMk 1 + ((seriesMaximalExampleRVDivisor : Berarducci.Series ℚ) * + approachZeroNonpositive) + seriesMaximalExample_leading_degree.le) := by + rw [seriesMaximalExampleLeadingGraded, seriesMaximalExample_rv_eq] + calc + _ = (Berarducci.degreeHomogeneousClass 1 + (Berarducci.degreeLayerMk 1 + ((seriesMaximalExampleRVDivisor : Berarducci.Series ℚ) * + approachZeroNonpositive) + seriesMaximalExample_leading_degree.le) : + Berarducci.DegreeGraded ℚ) := + congrArg Subtype.val + (Berarducci.rvEquivHomogeneous_rv_eq_degreeHomogeneousClass 1 + ((seriesMaximalExampleRVDivisor : Berarducci.Series ℚ) * + approachZeroNonpositive) + seriesMaximalExample_leading_degree) + _ = _ := Berarducci.coe_degreeHomogeneousClass 1 _ + +/-- The leading RV class has maximal finite-support divisor class represented by +`1 - t⁻²`. -/ +theorem seriesMaximalExample_isRVMaximalFiniteSupportDivisor : + Berarducci.IsRVMaximalFiniteSupportDivisor + ((HahnSeries.Nonpositive.degreeValuation ℚ).rv + seriesMaximalExample) + (Associates.mk seriesMaximalExampleRVDivisor) := by + rw [seriesMaximalExample_rv_eq] + exact Berarducci.isRVMaximalFiniteSupportDivisor_finiteSupport_mul_principal 1 + seriesMaximalExampleRVDivisor + seriesMaximalExampleRVDivisor_ne_zero approachZeroNonpositive + approachZero_isPrincipal approachZero_degree_eq_one + +/-- The associated-graded representative of the leading RV class has maximal +finite-support divisor represented by `1 - t⁻²`. -/ +theorem seriesMaximalExample_isGradedMaximalFiniteSupportDivisor : + Berarducci.IsGradedMaximalFiniteSupportDivisor + seriesMaximalExampleLeadingGraded + (Associates.mk seriesMaximalExampleRVDivisor) := by + rw [seriesMaximalExampleLeadingGraded_eq] + exact Berarducci.isGradedMaximalFiniteSupportDivisor_finiteSupport_mul_principal 1 + seriesMaximalExampleRVDivisor approachZeroNonpositive + approachZero_isPrincipal approachZero_degree_eq_one + +/-- The full series has maximal finite-support divisor class represented by `t⁻¹ + 1`. -/ +theorem seriesMaximalExample_isSeriesMaximalFiniteSupportDivisor : + Berarducci.IsSeriesMaximalFiniteSupportDivisor seriesMaximalExample + (Associates.mk seriesMaximalExampleDivisor) := by + apply (Berarducci.isSeriesMaximalFiniteSupportDivisor_mk_iff + seriesMaximalExample seriesMaximalExampleDivisor).mpr + intro q + rw [Berarducci.coe_dvd_iff_dvd_rvMaximal_and_residual + seriesMaximalExample approachZeroNonpositive seriesMaximalExampleRVDivisor q + seriesMaximalExample_isRVMaximalFiniteSupportDivisor] + have hresidual : seriesMaximalExample - + (seriesMaximalExampleRVDivisor : Berarducci.Series ℚ) * + approachZeroNonpositive = + (seriesMaximalExampleDivisor : Berarducci.Series ℚ) := by + simp only [seriesMaximalExample] + abel + rw [hresidual, ← Berarducci.finiteSupport_dvd_iff_coe_dvd] + constructor + · exact fun h ↦ h.2 + · intro hq + exact ⟨dvd_trans hq seriesMaximalExampleDivisor_dvd_rvDivisor, hq⟩ + +variable + (hgcd : ∀ p q : Berarducci.FiniteSupportRing (K := ℚ), + ∃ d : Berarducci.FiniteSupportRing (K := ℚ), + ∀ e : Berarducci.FiniteSupportRing (K := ℚ), e ∣ p ∧ e ∣ q ↔ e ∣ d) + (hunits : ∀ u : Berarducci.FiniteSupportRing (K := ℚ), + IsUnit u ↔ ∃ k : ℚ, k ≠ 0 ∧ + u = HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℝ) k) + +include hgcd hunits in +/-- The earlier normalized divisor from LM24, Notation 5.4.5 is exactly `1 - t⁻²` on +the leading class in Example 5.5.4. -/ +theorem seriesMaximalExample_gradedNormalized_eq : + Berarducci.gradedNormalizedMaximalFiniteSupportDivisor + seriesMaximalExampleLeadingGraded = + seriesMaximalExampleRVDivisor := by + apply Berarducci.gradedNormalizedMaximalFiniteSupportDivisor_eq_of_is hgcd hunits + apply (Berarducci.isNormalizedGradedMaximalFiniteSupportDivisor_iff _ _).mpr + exact ⟨(Berarducci.isGradedMaximalFiniteSupportDivisor_mk_iff _ _).mp + seriesMaximalExample_isGradedMaximalFiniteSupportDivisor, + Or.inr ⟨by + intro hzero + have hclass := + seriesMaximalExample_isGradedMaximalFiniteSupportDivisor + rw [hzero] at hclass + have hzeroMax : + Berarducci.IsGradedMaximalFiniteSupportDivisor + (0 : Berarducci.DegreeGraded ℚ) 0 := by + rw [Berarducci.isGradedMaximalFiniteSupportDivisor_iff] + intro q + constructor + · intro _ + exact dvd_zero _ + · intro _ + exact Associates.mk_le_mk_of_dvd (dvd_zero q) + have hmkZero := hclass.eq hzeroMax + exact seriesMaximalExampleRVDivisor_ne_zero + (Associates.mk_eq_zero.mp hmkZero), + seriesMaximalExampleRVDivisor_isMonic⟩⟩ + +include hgcd hunits in +/-- The chosen normalized series-level maximal divisor of the example is `t⁻¹ + 1`, not +the normalized leading-RV divisor `1 - t⁻²`. -/ +theorem seriesMaximalExample_normalized_eq : + Berarducci.seriesNormalizedMaximalFiniteSupportDivisor seriesMaximalExample = + seriesMaximalExampleDivisor := by + apply Berarducci.seriesNormalizedMaximalFiniteSupportDivisor_eq_of_is hgcd hunits + apply (Berarducci.isNormalizedSeriesMaximalFiniteSupportDivisor_iff _ _).mpr + exact ⟨(Berarducci.isSeriesMaximalFiniteSupportDivisor_mk_iff _ _).mp + seriesMaximalExample_isSeriesMaximalFiniteSupportDivisor, + Or.inr ⟨by + intro hzero + have hHahn : (seriesMaximalExample : ℚ⟦ℝ⟧) = 0 := + congrArg Subtype.val hzero + have hdegree := HahnSeries.degree_eq_bot.mpr hHahn + rw [seriesMaximalExample_degree] at hdegree + norm_num at hdegree, + seriesMaximalExampleDivisor_isMonic⟩⟩ + +end + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/FiniteSupport.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/FiniteSupport.lean new file mode 100644 index 0000000000..49b35c868d --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/FiniteSupport.lean @@ -0,0 +1,340 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Nonpositive +public import Mathlib.Algebra.Order.Monoid.Submonoid +public import Mathlib.LinearAlgebra.Basis.Defs +public import Mathlib.LinearAlgebra.DFinsupp + +import Mathlib.LinearAlgebra.Finsupp.VectorSpace +import Mathlib.RingTheory.HahnSeries.Cardinal + +/-! +# Finite-support Hahn series + +This file packages finite-support Hahn series as the specialization at `Cardinal.aleph0` of +Mathlib's cardinal-bounded Hahn-series subring. It also pulls that subring back to nonpositive +Hahn series. The latter is the ring denoted by `K(G^{≤ 0})` in LM24. +-/ + +universe u v + +public noncomputable section + +namespace HahnSeries + +variable {G : Type u} {K : Type v} + +section HahnSeries + +variable [PartialOrder G] [AddCommMonoid G] [IsOrderedCancelAddMonoid G] [Ring K] + +/-- The subring of Hahn series with finite support. -/ +def finiteSupportSubring : Subring K⟦G⟧ := + let _ : Fact (Cardinal.aleph0.{u} ≤ Cardinal.aleph0.{u}) := ⟨le_rfl⟩ + HahnSeries.cardSuppLTSubring G K Cardinal.aleph0 + +/-- Membership in the finite-support subring is finiteness of the Hahn-series support. -/ +@[simp] +theorem mem_finiteSupportSubring_iff (b : K⟦G⟧) : + b ∈ (finiteSupportSubring : Subring K⟦G⟧) ↔ b.support.Finite := by + let : Fact (Cardinal.aleph0.{u} ≤ Cardinal.aleph0.{u}) := ⟨le_rfl⟩ + rw [finiteSupportSubring, HahnSeries.mem_cardSuppLTSubring, HahnSeries.cardSupp] + exact Cardinal.lt_aleph0_iff_set_finite + +end HahnSeries + +namespace Nonpositive + +/-- The additive monoid of nonpositive exponents. -/ +abbrev exponentMonoid (G : Type u) [PartialOrder G] [AddCommGroup G] + [IsOrderedAddMonoid G] : AddSubmonoid G where + carrier := Set.Iic 0 + zero_mem' := le_rfl + add_mem' := add_nonpos + +/-- Zero is the largest nonpositive exponent. -/ +instance exponentMonoidOrderTop (G : Type u) [PartialOrder G] [AddCommGroup G] + [IsOrderedAddMonoid G] : OrderTop (exponentMonoid G) where + top := 0 + le_top g := g.2 + +@[simp] +theorem exponentMonoid_top_eq_zero (G : Type u) [PartialOrder G] [AddCommGroup G] + [IsOrderedAddMonoid G] : (⊤ : exponentMonoid G) = 0 := + rfl + +variable [PartialOrder G] [AddCommGroup G] [IsOrderedAddMonoid G] [Ring K] + +/-- The subring of nonpositive Hahn series with finite support. -/ +def finiteSupportSubring : Subring (Nonpositive G K) := + HahnSeries.finiteSupportSubring.comap (HahnSeries.nonpositiveSubring G K).subtype + +/-- The type of finite-support nonpositive Hahn series. -/ +abbrev FiniteSupportRing := + (finiteSupportSubring : Subring (Nonpositive G K)) + +/-! The structures on the finite-support ring, named here rather than rebuilt at each use. +`Zero` is the one that matters: it is asked for by every comparison against `0`, and resolving it +through the `Subring` membership classes is not cheap. -/ + +instance : Zero (FiniteSupportRing (G := G) (K := K)) := inferInstance + +instance : One (FiniteSupportRing (G := G) (K := K)) := inferInstance + +instance : Semiring (FiniteSupportRing (G := G) (K := K)) := inferInstance + +instance : Ring (FiniteSupportRing (G := G) (K := K)) := inferInstance + +/-- The finite-support ring acts faithfully on the series ring, because it is a subring of it. +Named here because the generic route to this instance goes through torsion-freeness and freeness +first and is too expensive to re-run at every use. -/ +instance : FaithfulSMul (FiniteSupportRing (G := G) (K := K)) (Nonpositive G K) := + ⟨fun h ↦ Subtype.ext (eq_of_smul_eq_smul h)⟩ + +/-- Membership in the nonpositive finite-support subring is finiteness of the underlying support. +-/ +@[simp] +theorem mem_finiteSupportSubring_iff (b : Nonpositive G K) : + b ∈ (finiteSupportSubring : Subring (Nonpositive G K)) ↔ + (b : K⟦G⟧).support.Finite := by + rw [finiteSupportSubring, Subring.mem_comap] + rw [HahnSeries.mem_finiteSupportSubring_iff] + simp only [Subring.subtype_apply] + +end Nonpositive + +namespace Nonpositive + +variable [PartialOrder G] [AddCommGroup G] [IsOrderedAddMonoid G] [CommRing K] + +instance : CommRing (FiniteSupportRing (G := G) (K := K)) := inferInstance + +/-- The coefficient field embeds in the finite-support ring as constant Hahn series. -/ +def finiteSupportScalarHom : + K →+* (finiteSupportSubring : Subring (Nonpositive G K)) := + (C : K →+* Nonpositive G K).codRestrict finiteSupportSubring fun k ↦ by + rw [mem_finiteSupportSubring_iff, coe_C] + exact Set.Finite.subset (Set.finite_singleton (0 : G)) + HahnSeries.support_single_subset + +/-- The canonical coefficient-algebra structure on the finite-support ring. -/ +noncomputable instance finiteSupportAlgebra : + Algebra K (finiteSupportSubring : Subring (Nonpositive G K)) := + finiteSupportScalarHom.toAlgebra + +/-- Scalar multiplication in the finite-support algebra is multiplication by a constant +series. -/ +theorem smul_finiteSupport_eq_scalar_mul + (k : K) (b : (finiteSupportSubring : Subring (Nonpositive G K))) : + k • b = finiteSupportScalarHom k * b := by + rw [Algebra.smul_def] + rfl + +/-- The scalar map is the constant-series embedding on underlying Hahn series. -/ +@[simp] +theorem coe_finiteSupportScalarHom (k : K) : + ((((finiteSupportScalarHom (G := G) k : + (finiteSupportSubring : Subring (Nonpositive G K))) : + Nonpositive G K) : K⟦G⟧)) = HahnSeries.C k := + coe_C k + +/-- The constant-series embedding into the finite-support ring is injective. -/ +theorem finiteSupportScalarHom_injective : + Function.Injective (finiteSupportScalarHom (G := G) : + K → (finiteSupportSubring : Subring (Nonpositive G K))) := by + intro k l hkl + have hcoeff := congrArg + (fun b : (finiteSupportSubring : Subring (Nonpositive G K)) ↦ + ((b : Nonpositive G K) : K⟦G⟧)) hkl + apply (HahnSeries.C_injective (R := K) (Γ := G)) + simpa only [coe_finiteSupportScalarHom] using hcoeff + +/-- Read a finite-support nonpositive Hahn series as its finitely supported coefficient +function on the nonpositive exponents. -/ +def finiteSupportCoefficients : + (finiteSupportSubring : Subring (Nonpositive G K)) →ₗ[K] + (exponentMonoid G →₀ K) where + toFun b := Finsupp.ofSupportFinite + (fun g ↦ ((b : Nonpositive G K) : K⟦G⟧).coeff g) + (by + rw [show Function.support (fun g : exponentMonoid G ↦ + ((b : Nonpositive G K) : K⟦G⟧).coeff g) = + ((b : Nonpositive G K) : K⟦G⟧).support.preimage Subtype.val from rfl] + apply Set.Finite.preimage Subtype.val_injective.injOn + exact (mem_finiteSupportSubring_iff (b : Nonpositive G K)).mp b.2) + map_add' b c := by + ext g + simp only [Finsupp.ofSupportFinite_coe] + exact HahnSeries.coeff_add + map_smul' k b := by + ext g + simp only [Finsupp.ofSupportFinite_coe] + change (((((finiteSupportScalarHom (G := G) k) * b : + (finiteSupportSubring : Subring (Nonpositive G K))) : + Nonpositive G K) : K⟦G⟧).coeff g) = _ + rw [Subring.coe_mul] + change ((C k : Nonpositive G K) * (b : Nonpositive G K) : K⟦G⟧).coeff g = _ + rw [coe_C, HahnSeries.C_mul_eq_smul, HahnSeries.coeff_smul] + rfl + +/-- Evaluating the coefficient map returns the corresponding Hahn-series coefficient. -/ +@[simp] +theorem finiteSupportCoefficients_apply + (b : (finiteSupportSubring : Subring (Nonpositive G K))) + (g : exponentMonoid G) : + finiteSupportCoefficients b g = ((b : Nonpositive G K) : K⟦G⟧).coeff g := by + exact congrFun Finsupp.ofSupportFinite_coe g + +private theorem finiteSupportCoefficients_injective : + Function.Injective + (finiteSupportCoefficients (G := G) (K := K)) := by + intro b c hbc + apply Subtype.ext + apply Subtype.ext + apply HahnSeries.coeff_injective + funext g + by_cases hg : g ≤ 0 + · have h := DFunLike.congr_fun hbc ⟨g, hg⟩ + simpa only [finiteSupportCoefficients_apply] using h + · have hgb : g ∉ ((b : Nonpositive G K) : K⟦G⟧).support := by + intro hsupport + exact hg (support_subset (b : Nonpositive G K) hsupport) + have hgc : g ∉ ((c : Nonpositive G K) : K⟦G⟧).support := by + intro hsupport + exact hg (support_subset (c : Nonpositive G K) hsupport) + rw [HahnSeries.mem_support] at hgb hgc + exact (not_ne_iff.mp hgb).trans (not_ne_iff.mp hgc).symm + +private theorem finiteSupportCoefficients_surjective : + Function.Surjective + (finiteSupportCoefficients (G := G) (K := K)) := by + intro f + let e : exponentMonoid G ↪ G := Function.Embedding.subtype _ + let f' : G →₀ K := Finsupp.embDomain e f + let bHahn : K⟦G⟧ := HahnSeries.ofFinsupp f' + have hbSupport : bHahn.support ⊆ Set.Iic 0 := by + intro g hg + have hgf' : f' g ≠ 0 := by + simpa [bHahn, HahnSeries.mem_support] using hg + have hgrange : g ∈ Set.range e := by + contrapose! hgf' + exact Finsupp.embDomain_of_notMem_range e f g hgf' + obtain ⟨x, rfl⟩ := hgrange + exact x.2 + let b : Nonpositive G K := + ⟨bHahn, (mem_nonpositiveSubring (x := bHahn)).mpr hbSupport⟩ + have hbFinite : ((b : Nonpositive G K) : K⟦G⟧).support.Finite := by + change (Function.support (f' : G → K)).Finite + exact f'.hasFiniteSupport + let bd : (finiteSupportSubring : Subring (Nonpositive G K)) := ⟨b, by + rw [mem_finiteSupportSubring_iff] + exact hbFinite⟩ + refine ⟨bd, ?_⟩ + ext g + rw [finiteSupportCoefficients_apply] + change f' g = f g + exact Finsupp.embDomain_apply_self e f g + +/-- Finite-support nonpositive Hahn series are linearly equivalent to finitely supported +coefficient functions on the nonpositive exponents. -/ +def finiteSupportFinsuppEquiv : + (finiteSupportSubring : Subring (Nonpositive G K)) ≃ₗ[K] + (exponentMonoid G →₀ K) := + LinearEquiv.ofBijective finiteSupportCoefficients + ⟨finiteSupportCoefficients_injective, finiteSupportCoefficients_surjective⟩ + +/-- The finite-support linear equivalence evaluates as the coefficient map. -/ +@[simp] +theorem finiteSupportFinsuppEquiv_apply + (b : (finiteSupportSubring : Subring (Nonpositive G K))) : + finiteSupportFinsuppEquiv b = finiteSupportCoefficients b := + (rfl) + +/-- The finite-support monomial `t^g`, for a nonpositive exponent `g`. -/ +def finiteSupportMonomial (g : exponentMonoid G) : + (finiteSupportSubring : Subring (Nonpositive G K)) := + ⟨single (g : G) (1 : K) (show (g : G) ≤ 0 from g.2), by + rw [mem_finiteSupportSubring_iff, coe_single] + exact Set.Finite.subset (Set.finite_singleton (g : G)) + (HahnSeries.support_single_subset (a := (g : G)) (r := (1 : K)))⟩ + +/-- The underlying Hahn series of a finite-support monomial is the corresponding singleton. -/ +@[simp] +theorem coe_finiteSupportMonomial (g : exponentMonoid G) : + (((finiteSupportMonomial (K := K) g : + (finiteSupportSubring : Subring (Nonpositive G K))) : + Nonpositive G K) : K⟦G⟧) = HahnSeries.single (g : G) (1 : K) := + coe_single (g : G) (1 : K) g.2 + +/-- Multiplication of finite-support monomials adds their exponents. -/ +@[simp] +theorem finiteSupportMonomial_mul (g h : exponentMonoid G) : + finiteSupportMonomial (K := K) g * finiteSupportMonomial (K := K) h = + finiteSupportMonomial (K := K) + ⟨(g : G) + (h : G), add_nonpos g.2 h.2⟩ := by + apply Subtype.ext + change + (finiteSupportMonomial (K := K) g : Nonpositive G K) * + (finiteSupportMonomial (K := K) h : Nonpositive G K) = + (finiteSupportMonomial (K := K) + ⟨(g : G) + (h : G), add_nonpos g.2 h.2⟩ : Nonpositive G K) + apply Subtype.ext + change + (((finiteSupportMonomial (K := K) g : Nonpositive G K) : K⟦G⟧) * + ((finiteSupportMonomial (K := K) h : Nonpositive G K) : K⟦G⟧)) = _ + rw [coe_finiteSupportMonomial, coe_finiteSupportMonomial, + coe_finiteSupportMonomial, HahnSeries.single_mul_single, one_mul] + +/-- The coefficient function of `t^g` is the standard finitely supported basis vector. -/ +@[simp] +theorem finiteSupportCoefficients_monomial (g : exponentMonoid G) : + finiteSupportCoefficients (finiteSupportMonomial (K := K) g) = + Finsupp.single g 1 := by + classical + ext x + rw [finiteSupportCoefficients_apply] + rw [coe_finiteSupportMonomial] + change (HahnSeries.single (g : G) (1 : K)).coeff x = _ + rw [HahnSeries.coeff_single, Finsupp.single_apply] + by_cases hgx : g = x + · subst x + simp + · have hval : (x : G) ≠ g := by + intro h + exact hgx (Subtype.ext h.symm) + simp [hgx, hval] + +/-- The monomials `t^g`, indexed by the nonpositive exponents, form the canonical coefficient +basis of the finite-support ring. -/ +def finiteSupportBasis : + Module.Basis (exponentMonoid G) K + (finiteSupportSubring : Subring (Nonpositive G K)) := + (Finsupp.basisSingleOne (R := K)).map finiteSupportFinsuppEquiv.symm + +/-- The canonical finite-support basis vector at `g` is the monomial `t^g`. -/ +@[simp] +theorem finiteSupportBasis_apply (g : exponentMonoid G) : + finiteSupportBasis (K := K) g = finiteSupportMonomial (K := K) g := by + apply finiteSupportCoefficients_injective + rw [finiteSupportCoefficients_monomial] + change finiteSupportFinsuppEquiv + (finiteSupportFinsuppEquiv.symm (Finsupp.single g 1)) = _ + exact finiteSupportFinsuppEquiv.apply_symm_apply _ + +/-- The coordinate of a finite-support series at `g` is its Hahn-series coefficient at `g`. -/ +@[simp] +theorem finiteSupportBasis_repr_apply + (b : (finiteSupportSubring : Subring (Nonpositive G K))) + (g : exponentMonoid G) : + finiteSupportBasis.repr b g = ((b : Nonpositive G K) : K⟦G⟧).coeff g := by + change finiteSupportFinsuppEquiv b g = _ + exact finiteSupportCoefficients_apply b g + +end Nonpositive + +end HahnSeries diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/FiniteSupportConstantTermOne.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/FiniteSupportConstantTermOne.lean new file mode 100644 index 0000000000..48319843bd --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/FiniteSupportConstantTermOne.lean @@ -0,0 +1,70 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.FiniteSupport + +/-! +# Finite-support Hahn series with constant term one + +The multiplicative set written `1 + K(G^{< 0})` in LM24 consists intrinsically of the +finite-support nonpositive Hahn series whose coefficient at exponent zero is one. Packaging it +as a submonoid retains precisely the multiplication used in Sections 6.5 and 8.3, without +incorrectly giving it additive or unital-subring structure. +-/ + +open scoped HahnSeries + +universe u v + +public noncomputable section + +namespace HahnSeries.Nonpositive + +variable {G : Type u} {K : Type v} + [LinearOrder G] [AddCommGroup G] [IsOrderedAddMonoid G] + [Field K] + +/-- Finite-support nonpositive Hahn series whose coefficient at exponent zero is one. -/ +def constantTermOneSubmonoid : + Submonoid (FiniteSupportRing (G := G) (K := K)) where + carrier := {p | constantCoeff (p : Nonpositive G K) = 1} + one_mem' := by simp + mul_mem' := by + intro p q hp hq + change constantCoeff ((p * q : FiniteSupportRing (G := G) (K := K)) : + Nonpositive G K) = 1 + change constantCoeff ((p : Nonpositive G K) * (q : Nonpositive G K)) = 1 + rw [map_mul, hp, hq, one_mul] + +/-- The type of finite-support nonpositive Hahn series with constant term one. -/ +abbrev ConstantTermOneFiniteSupport := + ↥(constantTermOneSubmonoid (G := G) (K := K)) + +/-- Membership in `constantTermOneSubmonoid` is the constant-coefficient-one condition. -/ +@[simp] +theorem mem_constantTermOneSubmonoid_iff + (p : FiniteSupportRing (G := G) (K := K)) : + p ∈ constantTermOneSubmonoid ↔ constantCoeff (p : Nonpositive G K) = 1 := + Iff.rfl + +/-- A constant-term-one finite-support series has constant coefficient one after coercion. -/ +theorem ConstantTermOneFiniteSupport.constantCoeff_eq_one + (p : ConstantTermOneFiniteSupport (G := G) (K := K)) : + constantCoeff ((p : FiniteSupportRing (G := G) (K := K)) : + Nonpositive G K) = 1 := + p.2 + +/-- A constant-term-one finite-support series is nonzero in the finite-support ring. -/ +theorem ConstantTermOneFiniteSupport.ne_zero + (p : ConstantTermOneFiniteSupport (G := G) (K := K)) : + (p : FiniteSupportRing (G := G) (K := K)) ≠ 0 := by + intro hp + have hconstant := p.constantCoeff_eq_one + rw [hp] at hconstant + simp at hconstant + +end HahnSeries.Nonpositive diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/FiniteSupportGCDProof.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/FiniteSupportGCDProof.lean new file mode 100644 index 0000000000..61ac4e1c86 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/FiniteSupportGCDProof.lean @@ -0,0 +1,220 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.EPrimitive +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.FiniteSupport +public import Mathlib.Algebra.MonoidAlgebra.Defs +public import Mathlib.RingTheory.UniqueFactorizationDomain.Defs + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.SubgroupAlgebra +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.SubgroupGCD +import LeanPool.ConwayRefinement.ConwayRefinement.RingTheory.LaurentTower +import Mathlib.LinearAlgebra.FreeModule.PID +import Mathlib.RingTheory.Int.Basic +import Mathlib.RingTheory.UniqueFactorizationDomain.GCDMonoid + +/-! +# Greatest common divisors of finite-support nonpositive series + +LM24, Fact 2.5.2, following Gilmer and Parker, Theorem 6.4 specialized to a totally ordered +exponent group. + +Two series involve only finitely many exponents, so they live in a finitely generated subgroup, +which is free of finite rank because a linearly ordered group is torsion free. Its group ring is +reached from the coefficient field by a tower of Laurent extensions and so has unique +factorisation, hence least common multiples. Those transfer to the whole exponent group one coset +at a time, and greatest common divisors on the nonpositive exponents follow by splitting at the +largest exponent. +-/ + +open scoped HahnSeries + +universe u v + +public noncomputable section + +namespace HahnSeries + +variable {G : Type u} {K : Type v} +variable [LinearOrder G] [AddCommGroup G] [IsOrderedAddMonoid G] +variable [Field K] + +/-- A finitely generated subgroup of a linearly ordered group is free of finite rank. -/ +theorem exists_addEquiv_fin (S : Finset G) : + ∃ k : ℕ, Nonempty ((AddSubgroup.closure (S : Set G)) ≃+ (Fin k → ℤ)) := by + have heq : (AddSubgroup.closure (S : Set G)).toIntSubmodule = Submodule.span ℤ (S : Set G) := + AddSubgroup.toIntSubmodule_closure _ + have : Module.Finite ℤ (AddSubgroup.closure (S : Set G)) := + Module.Finite.iff_fg (N := (AddSubgroup.closure (S : Set G)).toIntSubmodule).mpr + (heq ▸ Submodule.fg_span S.finite_toSet) + obtain ⟨k, b⟩ := + Module.basisOfFiniteTypeTorsionFree' (R := ℤ) (M := (AddSubgroup.closure (S : Set G))) + exact ⟨k, ⟨b.equivFun.toAddEquiv⟩⟩ + +omit [LinearOrder G] [IsOrderedAddMonoid G] in +/-- The group ring of a free subgroup of finite rank has unique factorisation. -/ +theorem uniqueFactorizationMonoid_subgroupAlgebra {H : AddSubgroup G} + (h : ∃ k : ℕ, Nonempty (H ≃+ (Fin k → ℤ))) : + UniqueFactorizationMonoid (AddMonoidAlgebra K H) := by + obtain ⟨k, ⟨e⟩⟩ := h + exact MulEquiv.uniqueFactorizationMonoid + (AddMonoidAlgebra.domCongr (R := K) (A := K) (e := e)).symm.toRingEquiv.toMulEquiv + (AddMonoidAlgebra.uniqueFactorizationMonoid_finInt K k) + +omit [LinearOrder G] [IsOrderedAddMonoid G] in +/-- Least common multiples in the group ring of such a subgroup. -/ +theorem exists_lcm_subgroupAlgebra {H : AddSubgroup G} + (hufm : UniqueFactorizationMonoid (AddMonoidAlgebra K H)) (a b : AddMonoidAlgebra K H) : + ∃ c : AddMonoidAlgebra K H, ∀ d, a ∣ d ∧ b ∣ d ↔ c ∣ d := by + have := hufm + obtain ⟨inst⟩ : Nonempty (NormalizedGCDMonoid (AddMonoidAlgebra K H)) := inferInstance + let := inst + exact ⟨lcm a b, fun d ↦ ⟨fun h ↦ lcm_dvd h.1 h.2, + fun h ↦ ⟨(dvd_lcm_left a b).trans h, (dvd_lcm_right a b).trans h⟩⟩⟩ + +/-- Least common multiples of finite-support series, in the whole exponent group. -/ +theorem exists_lcm_dvdFS (f g : K⟦G⟧) (hf : f.support.Finite) (hg : g.support.Finite) : + ∃ h : K⟦G⟧, h.support.Finite ∧ ∀ m : K⟦G⟧, m.support.Finite → + (DvdFS f m ∧ DvdFS g m ↔ DvdFS h m) := by + classical + -- the exponents of both arguments generate a finitely generated subgroup + set S : Finset G := hf.toFinset ∪ hg.toFinset with hS + set H : AddSubgroup G := AddSubgroup.closure (S : Set G) with hH + have hfsub : f.support ⊆ (H : Set G) := fun x hx ↦ + AddSubgroup.subset_closure + (Finset.mem_coe.mpr (Finset.mem_union_left _ (hf.mem_toFinset.mpr hx))) + have hgsub : g.support ⊆ (H : Set G) := fun x hx ↦ + AddSubgroup.subset_closure + (Finset.mem_coe.mpr (Finset.mem_union_right _ (hg.mem_toFinset.mpr hx))) + have hufm : UniqueFactorizationMonoid (AddMonoidAlgebra K H) := + uniqueFactorizationMonoid_subgroupAlgebra (exists_addEquiv_fin S) + obtain ⟨a, ha⟩ := exists_subgroupAlgebraHom_eq H hf hfsub + obtain ⟨b, hb⟩ := exists_subgroupAlgebraHom_eq H hg hgsub + obtain ⟨c, hc⟩ := exists_lcm_subgroupAlgebra hufm a b + refine ⟨subgroupAlgebraHom H c, support_subgroupAlgebraHom_finite H c, fun m hm ↦ ?_⟩ + -- inside the subgroup the statement is the group-ring one + have hin : ∀ n : K⟦G⟧, n.support.Finite → n.support ⊆ (H : Set G) → + (DvdFS f n ∧ DvdFS g n → DvdFS (subgroupAlgebraHom H c) n) := by + intro n hnf hnsub hdvd + obtain ⟨d, hd⟩ := exists_subgroupAlgebraHom_eq H hnf hnsub + subst hd + rw [← ha, ← hb] at hdvd + rw [← dvd_iff_dvdFS_subgroupAlgebraHom, ← dvd_iff_dvdFS_subgroupAlgebraHom] at hdvd + exact (dvd_iff_dvdFS_subgroupAlgebraHom H c d).mp ((hc d).mp hdvd) + constructor + · rintro ⟨h1, h2⟩ + refine dvdFS_of_forall_subgroup hfsub hgsub ?_ hm h1 h2 + intro n hnf hnsub hn1 hn2 + exact hin n hnf hnsub ⟨hn1, hn2⟩ + · intro hdvd + have hcf : DvdFS f (subgroupAlgebraHom H c) := by + rw [← ha, ← dvd_iff_dvdFS_subgroupAlgebraHom] + exact ((hc c).mpr dvd_rfl).1 + have hcg : DvdFS g (subgroupAlgebraHom H c) := by + rw [← hb, ← dvd_iff_dvdFS_subgroupAlgebraHom] + exact ((hc c).mpr dvd_rfl).2 + exact ⟨hcf.trans hdvd, hcg.trans hdvd⟩ + +/-- Divisibility in the finite-support ring is divisibility with a finite-support quotient. -/ +theorem dvd_iff_dvdFS (a b : (HahnSeries.finiteSupportSubring : Subring K⟦G⟧)) : + a ∣ b ↔ DvdFS (a : K⟦G⟧) (b : K⟦G⟧) := by + constructor + · rintro ⟨c, rfl⟩ + exact dvdFS_iff.mpr + ⟨(c : K⟦G⟧), (HahnSeries.mem_finiteSupportSubring_iff _).mp c.2, rfl⟩ + · intro h + obtain ⟨w, hwf, hw⟩ := dvdFS_iff.mp h + exact ⟨⟨w, (HahnSeries.mem_finiteSupportSubring_iff w).mpr hwf⟩, Subtype.ext hw⟩ + +open Classical in +/-- Greatest common divisors of finite-support series, in the whole exponent group. -/ +theorem exists_gcd_dvdFS (x z : K⟦G⟧) (hx : x.support.Finite) (hz : z.support.Finite) : + ∃ d : K⟦G⟧, d.support.Finite ∧ + ∀ e : K⟦G⟧, e.support.Finite → (DvdFS e x ∧ DvdFS e z ↔ DvdFS e d) := by + let : GCDMonoid (HahnSeries.finiteSupportSubring : Subring K⟦G⟧) := by + refine gcdMonoidOfExistsLCM fun a b ↦ ?_ + obtain ⟨h, hhf, hh⟩ := exists_lcm_dvdFS (a : K⟦G⟧) (b : K⟦G⟧) + ((HahnSeries.mem_finiteSupportSubring_iff _).mp a.2) + ((HahnSeries.mem_finiteSupportSubring_iff _).mp b.2) + refine ⟨⟨h, (HahnSeries.mem_finiteSupportSubring_iff h).mpr hhf⟩, fun d ↦ ?_⟩ + rw [dvd_iff_dvdFS, dvd_iff_dvdFS, dvd_iff_dvdFS] + exact hh (d : K⟦G⟧) ((HahnSeries.mem_finiteSupportSubring_iff _).mp d.2) + set a : (HahnSeries.finiteSupportSubring : Subring K⟦G⟧) := + ⟨x, (HahnSeries.mem_finiteSupportSubring_iff x).mpr hx⟩ with ha + set b : (HahnSeries.finiteSupportSubring : Subring K⟦G⟧) := + ⟨z, (HahnSeries.mem_finiteSupportSubring_iff z).mpr hz⟩ with hb + set d : (HahnSeries.finiteSupportSubring : Subring K⟦G⟧) := gcd a b with hd + refine ⟨(d : K⟦G⟧), (HahnSeries.mem_finiteSupportSubring_iff _).mp d.2, fun e hef ↦ ?_⟩ + set c : (HahnSeries.finiteSupportSubring : Subring K⟦G⟧) := + ⟨e, (HahnSeries.mem_finiteSupportSubring_iff e).mpr hef⟩ with hc + rw [show x = (a : K⟦G⟧) from rfl, show z = (b : K⟦G⟧) from rfl, + show e = (c : K⟦G⟧) from rfl, ← dvd_iff_dvdFS, ← dvd_iff_dvdFS, ← dvd_iff_dvdFS, hd] + exact ⟨fun hq ↦ dvd_gcd hq.1 hq.2, + fun hq ↦ ⟨hq.trans (gcd_dvd_left a b), hq.trans (gcd_dvd_right a b)⟩⟩ + +namespace Nonpositive + +/-- Divisibility in the nonpositive finite-support ring. -/ +theorem dvd_iff_dvdNP (a b : (finiteSupportSubring : Subring (Nonpositive G K))) : + a ∣ b ↔ DvdNP ((a : Nonpositive G K) : K⟦G⟧) ((b : Nonpositive G K) : K⟦G⟧) := by + constructor + · rintro ⟨c, rfl⟩ + exact dvdNP_iff.mpr ⟨((c : Nonpositive G K) : K⟦G⟧), + (mem_finiteSupportSubring_iff _).mp c.2, + (HahnSeries.mem_nonpositiveSubring (Γ := G) (R := K)).mp (c : Nonpositive G K).2, rfl⟩ + · intro h + obtain ⟨w, hwf, hws, hw⟩ := dvdNP_iff.mp h + refine ⟨⟨⟨w, (HahnSeries.mem_nonpositiveSubring (Γ := G) (R := K)).mpr hws⟩, + (mem_finiteSupportSubring_iff _).mpr hwf⟩, ?_⟩ + exact Subtype.ext (Subtype.ext hw) + +/-- LM24, Fact 2.5.2: every pair of finite-support nonpositive series has a greatest common +divisor. -/ +@[blueprint "fact:finite-support-hahn-gcd" + (phase := "Primality and factorisation for real exponents") + (title := "Greatest common divisors of finite-support series") + (statement := /-- + Let $G$ be a linearly ordered abelian group and $K$ a field. For all $p,q$ + in the finite-support subring $K(G^{\le 0})$ of $K((G^{\le 0}))$, there is + $d\in K(G^{\le 0})$ such that, for every $e\in K(G^{\le 0})$, + \[ + e\mid p\ \text{and}\ e\mid q \quad\Longleftrightarrow\quad e\mid d. + \] + This is the greatest-common-divisor assertion of [LM24, Fact 2.5.2]. + -/) + (proof := /-- + The zero cases are immediate. Otherwise, the supports of $p$ and $q$ + generate a finite-rank free subgroup $H$ of $G$. Finite-support series with + exponents in $H$ form a Laurent polynomial ring, hence a unique factorisation + domain. Compute a least common multiple there, compare coefficients on + cosets of $H$ to transfer divisibility to finite-support series with exponents + in $G$, and use the lcm-to-gcd construction. Write each input as a monomial + times a series whose support meets $0$, and translate the resulting gcd by + the larger of the two monomial exponents. The gcd and its two cofactors then + have nonpositive support. + -/)] +theorem finiteSupport_pairwise_gcd_exists + (p q : (finiteSupportSubring : Subring (Nonpositive G K))) : + ∃ d : (finiteSupportSubring : Subring (Nonpositive G K)), + ∀ e : (finiteSupportSubring : Subring (Nonpositive G K)), + e ∣ p ∧ e ∣ q ↔ e ∣ d := by + obtain ⟨d, hdf, hds, hd⟩ := exists_gcd_nonpositive_of_exists_gcd + (fun x z hx hz ↦ exists_gcd_dvdFS x z hx hz) + ((mem_finiteSupportSubring_iff _).mp p.2) + ((HahnSeries.mem_nonpositiveSubring (Γ := G) (R := K)).mp (p : Nonpositive G K).2) + ((mem_finiteSupportSubring_iff _).mp q.2) + ((HahnSeries.mem_nonpositiveSubring (Γ := G) (R := K)).mp (q : Nonpositive G K).2) + refine ⟨⟨⟨d, (HahnSeries.mem_nonpositiveSubring (Γ := G) (R := K)).mpr hds⟩, + (mem_finiteSupportSubring_iff _).mpr hdf⟩, fun e ↦ ?_⟩ + rw [dvd_iff_dvdNP, dvd_iff_dvdNP, dvd_iff_dvdNP] + exact hd _ ((mem_finiteSupportSubring_iff _).mp e.2) + ((HahnSeries.mem_nonpositiveSubring (Γ := G) (R := K)).mp (e : Nonpositive G K).2) + +end Nonpositive + +end HahnSeries diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/FiniteSupportMonoidAlgebra.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/FiniteSupportMonoidAlgebra.lean new file mode 100644 index 0000000000..df5536cc91 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/FiniteSupportMonoidAlgebra.lean @@ -0,0 +1,133 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.FiniteSupport +public import Mathlib.Algebra.MonoidAlgebra.Basic + +/-! +# Finite-support Hahn series as an additive monoid algebra + +Finite-support nonpositive Hahn series are canonically the additive monoid algebra on the monoid +of nonpositive exponents. The equivalence is defined without a choice of basis: its inverse sends +each formal monomial to the corresponding Hahn monomial, and its forward map reads coefficients. + +This algebra equivalence is the multiplicative strengthening of `finiteSupportFinsuppEquiv`. +-/ + +open scoped HahnSeries + +universe u v + +namespace HahnSeries.Nonpositive + +public noncomputable section + +variable {G : Type u} {K : Type v} + [LinearOrder G] [AddCommGroup G] [IsOrderedAddMonoid G] [CommRing K] + +/-- The monoid homomorphism sending a formal nonpositive exponent to its Hahn monomial. -/ +def finiteSupportMonomialHom : + Multiplicative (exponentMonoid G) →* FiniteSupportRing (G := G) (K := K) where + toFun g := finiteSupportMonomial (K := K) g.toAdd + map_one' := by + apply Subtype.ext + apply Subtype.ext + rw [coe_finiteSupportMonomial] + exact HahnSeries.single_zero_one + map_mul' g h := by + rw [finiteSupportMonomial_mul] + apply congrArg (finiteSupportMonomial (K := K)) + apply Subtype.ext + rfl + +/-- Evaluate a finite formal sum of monomials as a finite-support Hahn series. -/ +def finiteSupportAddMonoidAlgebraToSeries : + AddMonoidAlgebra K (exponentMonoid G) →ₐ[K] + FiniteSupportRing (G := G) (K := K) := + AddMonoidAlgebra.lift K _ _ finiteSupportMonomialHom + +/-- Reading coefficients after evaluating a formal sum returns the original coefficient +function. -/ +@[simp] +theorem finiteSupportCoefficients_toSeries + (f : AddMonoidAlgebra K (exponentMonoid G)) : + finiteSupportCoefficients (finiteSupportAddMonoidAlgebraToSeries f) = + AddMonoidAlgebra.coeff f := by + induction f using AddMonoidAlgebra.induction_on with + | of g => + rw [AddMonoidAlgebra.of_apply] + rw [finiteSupportAddMonoidAlgebraToSeries, AddMonoidAlgebra.lift_single] + rw [one_smul] + change finiteSupportCoefficients + (finiteSupportMonomialHom (Multiplicative.ofAdd g)) = + AddMonoidAlgebra.coeff (AddMonoidAlgebra.single g 1) + rw [show finiteSupportMonomialHom (Multiplicative.ofAdd g) = + finiteSupportMonomial (K := K) g from rfl] + rw [finiteSupportCoefficients_monomial] + rfl + | add f g hf hg => + rw [map_add, map_add, hf, hg] + exact (AddMonoidAlgebra.coeff_add f g).symm + | smul k f hf => + rw [map_smul, map_smul, hf] + exact (AddMonoidAlgebra.coeff_smul k f).symm + +theorem finiteSupportAddMonoidAlgebraToSeries_bijective : + Function.Bijective (finiteSupportAddMonoidAlgebraToSeries (G := G) (K := K)) := by + constructor + · intro f g hfg + apply AddMonoidAlgebra.coeff_injective + rw [← finiteSupportCoefficients_toSeries f, + ← finiteSupportCoefficients_toSeries g, hfg] + · intro b + refine ⟨AddMonoidAlgebra.ofCoeff (finiteSupportFinsuppEquiv b), ?_⟩ + apply finiteSupportFinsuppEquiv.injective + rw [finiteSupportFinsuppEquiv_apply, finiteSupportFinsuppEquiv_apply, + finiteSupportCoefficients_toSeries, AddMonoidAlgebra.coeff_ofCoeff] + +/-- The canonical algebra equivalence between finite-support nonpositive Hahn series and the +additive monoid algebra on nonpositive exponents. -/ +def finiteSupportAddMonoidAlgebraEquiv : + FiniteSupportRing (G := G) (K := K) ≃ₐ[K] + AddMonoidAlgebra K (exponentMonoid G) := + (AlgEquiv.ofBijective finiteSupportAddMonoidAlgebraToSeries + finiteSupportAddMonoidAlgebraToSeries_bijective).symm + +/-- The inverse algebra equivalence evaluates formal sums as Hahn series. -/ +@[simp] +theorem finiteSupportAddMonoidAlgebraEquiv_symm_apply + (f : AddMonoidAlgebra K (exponentMonoid G)) : + finiteSupportAddMonoidAlgebraEquiv.symm f = + finiteSupportAddMonoidAlgebraToSeries f := + (rfl) + +/-- The forward algebra equivalence reads the Hahn-series coefficient function. -/ +@[simp] +theorem coeff_finiteSupportAddMonoidAlgebraEquiv + (b : FiniteSupportRing (G := G) (K := K)) : + AddMonoidAlgebra.coeff (finiteSupportAddMonoidAlgebraEquiv b) = + finiteSupportCoefficients b := by + have h := congrArg finiteSupportCoefficients + (finiteSupportAddMonoidAlgebraEquiv.symm_apply_apply b) + rw [finiteSupportAddMonoidAlgebraEquiv_symm_apply, + finiteSupportCoefficients_toSeries] at h + exact h + +/-- A Hahn monomial corresponds to the formal monomial with coefficient one. -/ +@[simp] +theorem finiteSupportAddMonoidAlgebraEquiv_monomial + (g : exponentMonoid G) : + finiteSupportAddMonoidAlgebraEquiv (finiteSupportMonomial (K := K) g) = + AddMonoidAlgebra.single g 1 := by + apply AddMonoidAlgebra.coeff_injective + rw [coeff_finiteSupportAddMonoidAlgebraEquiv, + finiteSupportCoefficients_monomial] + rfl + +end + +end HahnSeries.Nonpositive diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/FiniteSupportNormalization.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/FiniteSupportNormalization.lean new file mode 100644 index 0000000000..765512a372 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/FiniteSupportNormalization.lean @@ -0,0 +1,329 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.FiniteSupport + +import Mathlib.Data.Set.Finite.Lemmas + +/-! +# Normalized finite-support Hahn series + +A nonzero finite-support Hahn series is normalized when the coefficient at its greatest support +exponent is `1`. This is the normalization used in LM24, Notation 5.4.5. The definition uses the +intrinsic order-theoretic predicate `IsGreatest`; it does not choose a basis or identify the +greatest exponent with a real supremum. + +Every nonzero finite-support series is associated to such a normalized series. Consequently every +associate class has a canonical, choice-defined normalized representative, with the zero class +represented by zero. Uniqueness is stated separately under the exact hypothesis that all units are +nonzero constant series. +-/ + +open scoped HahnSeries + +universe u v + +namespace HahnSeries.Nonpositive + +public noncomputable section + +variable {G : Type u} {K : Type v} +variable [LinearOrder G] [AddCommGroup G] [IsOrderedAddMonoid G] +variable [Field K] + +/-- A finite-support nonpositive Hahn series is monic when its coefficient at the greatest +exponent in its support is one. -/ +def IsMonicFiniteSupport + (p : finiteSupportSubring (G := G) (K := K)) : Prop := + ∃ x : G, + IsGreatest (((p : Nonpositive G K) : K⟦G⟧).support) x ∧ + ((p : Nonpositive G K) : K⟦G⟧).coeff x = 1 + +/-- Characterization of a monic finite-support series by its greatest support exponent. -/ +theorem isMonicFiniteSupport_iff + (p : finiteSupportSubring (G := G) (K := K)) : + IsMonicFiniteSupport p ↔ + ∃ x : G, + IsGreatest (((p : Nonpositive G K) : K⟦G⟧).support) x ∧ + ((p : Nonpositive G K) : K⟦G⟧).coeff x = 1 := + Iff.rfl + +/-- A monic finite-support series is nonzero. -/ +theorem IsMonicFiniteSupport.ne_zero + {p : finiteSupportSubring (G := G) (K := K)} + (hp : IsMonicFiniteSupport p) : p ≠ 0 := by + rintro rfl + obtain ⟨x, hx, _⟩ := hp + exact hx.1 (by simp) + +/-- The multiplicative identity is a monic finite-support series. -/ +@[simp] +theorem isMonicFiniteSupport_one : + IsMonicFiniteSupport + (1 : finiteSupportSubring (G := G) (K := K)) := by + rw [isMonicFiniteSupport_iff] + refine ⟨0, ?_, ?_⟩ <;> simp + +/-- The product of two monic finite-support series is monic. -/ +theorem IsMonicFiniteSupport.mul + {p q : finiteSupportSubring (G := G) (K := K)} + (hp : IsMonicFiniteSupport p) (hq : IsMonicFiniteSupport q) : + IsMonicFiniteSupport (p * q) := by + obtain ⟨x, hxGreatest, hxCoeff⟩ := (isMonicFiniteSupport_iff p).mp hp + obtain ⟨y, hyGreatest, hyCoeff⟩ := (isMonicFiniteSupport_iff q).mp hq + let P : K⟦G⟧ := ((p : Nonpositive G K) : K⟦G⟧) + let Q : K⟦G⟧ := ((q : Nonpositive G K) : K⟦G⟧) + have hantidiagonal : + Finset.antidiagonal P.isPWO_support Q.isPWO_support (x + y) = {(x, y)} := by + ext ⟨i, j⟩ + simp only [Finset.mem_antidiagonal, Finset.mem_singleton, Prod.mk.injEq] + constructor + · rintro ⟨hi, hj, hij⟩ + have hix := hxGreatest.2 hi + have hjy := hyGreatest.2 hj + have hix' : i = x := by + apply le_antisymm hix + by_contra hxi + have hixStrict : i < x := lt_of_not_ge hxi + have : i + j < x + y := add_lt_add_of_lt_of_le hixStrict hjy + exact (ne_of_lt this) hij + subst i + exact ⟨rfl, add_left_cancel hij⟩ + · rintro ⟨rfl, rfl⟩ + exact ⟨hxGreatest.1, hyGreatest.1, rfl⟩ + have hcoeff : + ((((p * q : finiteSupportSubring (G := G) (K := K)) : + Nonpositive G K) : K⟦G⟧).coeff (x + y)) = 1 := by + have hPx : P.coeff x = 1 := by + simpa [P] using hxCoeff + have hQy : Q.coeff y = 1 := by + simpa [Q] using hyCoeff + change (P * Q).coeff (x + y) = 1 + rw [HahnSeries.coeff_mul, hantidiagonal] + simp [hPx, hQy] + rw [isMonicFiniteSupport_iff] + refine ⟨x + y, ?_, hcoeff⟩ + constructor + · exact (HahnSeries.mem_support _ _).mpr (hcoeff.trans_ne one_ne_zero) + · intro z hz + change z ∈ (P * Q).support at hz + obtain ⟨i, hi, j, hj, rfl⟩ := HahnSeries.support_mul_subset hz + exact add_le_add (hxGreatest.2 hi) (hyGreatest.2 hj) + +/-- Multiplication by a nonzero constant preserves the support of a finite-support series. -/ +theorem support_finiteSupportScalarHom_mul + {k : K} (hk : k ≠ 0) + (p : finiteSupportSubring (G := G) (K := K)) : + (((finiteSupportScalarHom (G := G) k * p : + finiteSupportSubring (G := G) (K := K)) : Nonpositive G K) : + K⟦G⟧).support = + ((p : Nonpositive G K) : K⟦G⟧).support := by + rw [Subring.coe_mul, Subring.coe_mul, coe_finiteSupportScalarHom, + HahnSeries.C_mul_eq_smul] + ext x + simp [HahnSeries.mem_support, HahnSeries.coeff_smul, hk] + +/-- Multiplication by a constant scales each coefficient of a finite-support series. -/ +theorem coeff_finiteSupportScalarHom_mul + (k : K) (p : finiteSupportSubring (G := G) (K := K)) (x : G) : + ((((finiteSupportScalarHom (G := G) k * p : + finiteSupportSubring (G := G) (K := K)) : Nonpositive G K) : + K⟦G⟧).coeff x) = + k * ((p : Nonpositive G K) : K⟦G⟧).coeff x := by + rw [Subring.coe_mul, Subring.coe_mul, coe_finiteSupportScalarHom, + HahnSeries.C_mul_eq_smul, HahnSeries.coeff_smul] + rfl + +/-- Every nonzero finite-support series is associated to a monic finite-support series. -/ +theorem exists_isMonicFiniteSupport_associated + (p : finiteSupportSubring (G := G) (K := K)) (hp : p ≠ 0) : + ∃ q : finiteSupportSubring (G := G) (K := K), + IsMonicFiniteSupport q ∧ Associates.mk q = Associates.mk p := by + let support : Set G := ((p : Nonpositive G K) : K⟦G⟧).support + have hsupportFinite : support.Finite := by + exact (mem_finiteSupportSubring_iff + (G := G) (K := K) (p : Nonpositive G K)).mp p.2 + have hsupportNonempty : support.Nonempty := by + rw [HahnSeries.support_nonempty_iff] + intro hzero + apply hp + apply Subtype.ext + apply Subtype.ext + exact hzero + obtain ⟨x, hxSupport, hxGreatest⟩ := + Set.exists_max_image support id hsupportFinite hsupportNonempty + let a : K := ((p : Nonpositive G K) : K⟦G⟧).coeff x + have ha : a ≠ 0 := (HahnSeries.mem_support _ _).mp hxSupport + let q : finiteSupportSubring (G := G) (K := K) := + finiteSupportScalarHom (G := G) a⁻¹ * p + have hsupportQ : + ((q : Nonpositive G K) : K⟦G⟧).support = support := by + exact support_finiteSupportScalarHom_mul (G := G) (K := K) + (inv_ne_zero ha) p + have hqMonic : IsMonicFiniteSupport q := by + refine ⟨x, ?_, ?_⟩ + · rw [hsupportQ] + exact ⟨hxSupport, fun y hy ↦ hxGreatest y hy⟩ + · rw [coeff_finiteSupportScalarHom_mul] + exact inv_mul_cancel₀ ha + refine ⟨q, hqMonic, ?_⟩ + apply Associates.mk_eq_mk_iff_associated.mpr + let uK : Kˣ := Units.mk0 a⁻¹ (inv_ne_zero ha) + let uD : (finiteSupportSubring (G := G) (K := K))ˣ := + Units.map (finiteSupportScalarHom (G := G)).toMonoidHom uK + apply Associated.symm + refine ⟨uD, ?_⟩ + change p * finiteSupportScalarHom (G := G) a⁻¹ = q + rw [mul_comm] + +/-- A normalized representative of an associate class is zero exactly for the zero class and is +otherwise a monic representative of that class. -/ +def IsNormalizedAssociateRepresentative + (a : Associates (finiteSupportSubring (G := G) (K := K))) + (p : finiteSupportSubring (G := G) (K := K)) : Prop := + (a = 0 ∧ p = 0) ∨ + (a ≠ 0 ∧ Associates.mk p = a ∧ IsMonicFiniteSupport p) + +/-- Characterization of normalized representatives of finite-support associate classes. -/ +theorem isNormalizedAssociateRepresentative_iff + (a : Associates (finiteSupportSubring (G := G) (K := K))) + (p : finiteSupportSubring (G := G) (K := K)) : + IsNormalizedAssociateRepresentative a p ↔ + (a = 0 ∧ p = 0) ∨ + (a ≠ 0 ∧ Associates.mk p = a ∧ IsMonicFiniteSupport p) := + Iff.rfl + +/-- Every finite-support associate class has a normalized representative. -/ +theorem exists_isNormalizedAssociateRepresentative + (a : Associates (finiteSupportSubring (G := G) (K := K))) : + ∃ p : finiteSupportSubring (G := G) (K := K), + IsNormalizedAssociateRepresentative a p := by + induction a using Quotient.inductionOn with + | _ p => + by_cases hp : p = 0 + · subst p + exact ⟨0, Or.inl ⟨rfl, rfl⟩⟩ + · obtain ⟨q, hqMonic, hqAssociated⟩ := + exists_isMonicFiniteSupport_associated p hp + exact ⟨q, Or.inr ⟨Associates.mk_ne_zero.mpr hp, + hqAssociated, hqMonic⟩⟩ + +/-- The choice-defined normalized representative of a finite-support associate class. -/ +noncomputable def normalizedAssociateRepresentative + (a : Associates (finiteSupportSubring (G := G) (K := K))) : + finiteSupportSubring (G := G) (K := K) := + Classical.choose (exists_isNormalizedAssociateRepresentative a) + +/-- The chosen representative satisfies the normalization predicate. -/ +theorem normalizedAssociateRepresentative_is + (a : Associates (finiteSupportSubring (G := G) (K := K))) : + IsNormalizedAssociateRepresentative a (normalizedAssociateRepresentative a) := + Classical.choose_spec (exists_isNormalizedAssociateRepresentative a) + +/-- The normalized representative of the zero associate class is zero. -/ +@[simp] +theorem normalizedAssociateRepresentative_zero : + normalizedAssociateRepresentative + (0 : Associates (finiteSupportSubring (G := G) (K := K))) = 0 := by + rcases normalizedAssociateRepresentative_is + (0 : Associates (finiteSupportSubring (G := G) (K := K))) with h | h + · exact h.2 + · exact (h.1 rfl).elim + +/-- The associate class of the normalized representative is the original class. -/ +theorem normalizedAssociateRepresentative_mk + (a : Associates (finiteSupportSubring (G := G) (K := K))) : + Associates.mk (normalizedAssociateRepresentative a) = a := by + rcases normalizedAssociateRepresentative_is a with h | h + · calc + Associates.mk (normalizedAssociateRepresentative a) = Associates.mk 0 := + congrArg Associates.mk h.2 + _ = 0 := Associates.mk_zero + _ = a := h.1.symm + · exact h.2.1 + +/-- The normalized representative of a nonzero associate class is monic. -/ +theorem normalizedAssociateRepresentative_isMonic_of_ne_zero + {a : Associates (finiteSupportSubring (G := G) (K := K))} + (ha : a ≠ 0) : + IsMonicFiniteSupport (normalizedAssociateRepresentative a) := by + rcases normalizedAssociateRepresentative_is a with h | h + · exact (ha h.1).elim + · exact h.2.2 + +/-- Normalized representatives are unique when every unit is a nonzero constant series. -/ +theorem IsNormalizedAssociateRepresentative.eq + (hunits : ∀ u : finiteSupportSubring (G := G) (K := K), + IsUnit u ↔ ∃ k : K, k ≠ 0 ∧ u = finiteSupportScalarHom (G := G) k) + {a : Associates (finiteSupportSubring (G := G) (K := K))} + {p q : finiteSupportSubring (G := G) (K := K)} + (hp : IsNormalizedAssociateRepresentative a p) + (hq : IsNormalizedAssociateRepresentative a q) : p = q := by + rcases hp with hpZero | hpNonzero + · rcases hq with hqZero | hqNonzero + · exact hpZero.2.trans hqZero.2.symm + · exact (hqNonzero.1 hpZero.1).elim + · rcases hq with hqZero | hqNonzero + · exact (hpNonzero.1 hqZero.1).elim + · obtain ⟨u, hu⟩ := Associates.mk_eq_mk_iff_associated.mp + (hpNonzero.2.1.trans hqNonzero.2.1.symm) + obtain ⟨k, hk, huk⟩ := + (hunits (u : finiteSupportSubring (G := G) (K := K))).mp u.isUnit + have hqp : q = finiteSupportScalarHom (G := G) k * p := by + calc + q = p * (u : finiteSupportSubring (G := G) (K := K)) := hu.symm + _ = p * finiteSupportScalarHom (G := G) k := congrArg (p * ·) huk + _ = finiteSupportScalarHom (G := G) k * p := mul_comm _ _ + obtain ⟨xp, hxpGreatest, hxpCoeff⟩ := hpNonzero.2.2 + obtain ⟨xq, hxqGreatest, hxqCoeff⟩ := hqNonzero.2.2 + have hsupport : + ((q : Nonpositive G K) : K⟦G⟧).support = + ((p : Nonpositive G K) : K⟦G⟧).support := by + rw [hqp] + exact support_finiteSupportScalarHom_mul (G := G) (K := K) hk p + have hxpq : xp = xq := by + apply le_antisymm + · exact hxqGreatest.2 (hsupport ▸ hxpGreatest.1) + · exact hxpGreatest.2 (hsupport.symm ▸ hxqGreatest.1) + subst xq + have hcoeff := congrArg + (fun r : finiteSupportSubring (G := G) (K := K) ↦ + ((r : Nonpositive G K) : K⟦G⟧).coeff xp) hqp + rw [coeff_finiteSupportScalarHom_mul, hxpCoeff, mul_one, hxqCoeff] at hcoeff + rw [hqp, hcoeff.symm, map_one, one_mul] + +/-- Equal associate classes differ by multiplication by a nonzero coefficient scalar when all +units are nonzero constant series. -/ +theorem exists_nonzero_scalar_mul_of_mk_eq_mk + (hunits : ∀ u : finiteSupportSubring (G := G) (K := K), + IsUnit u ↔ ∃ k : K, k ≠ 0 ∧ u = finiteSupportScalarHom (G := G) k) + {p q : finiteSupportSubring (G := G) (K := K)} + (h : Associates.mk p = Associates.mk q) : + ∃ k : K, k ≠ 0 ∧ q = finiteSupportScalarHom (G := G) k * p := by + obtain ⟨u, hu⟩ := Associates.mk_eq_mk_iff_associated.mp h + obtain ⟨k, hk, huk⟩ := + (hunits (u : finiteSupportSubring (G := G) (K := K))).mp u.isUnit + refine ⟨k, hk, ?_⟩ + calc + q = p * (u : finiteSupportSubring (G := G) (K := K)) := hu.symm + _ = p * finiteSupportScalarHom (G := G) k := congrArg (p * ·) huk + _ = finiteSupportScalarHom (G := G) k * p := mul_comm _ _ + +/-- The chosen normalized representative is the unique normalized representative when all units +are nonzero constant series. -/ +theorem normalizedAssociateRepresentative_eq_of_is + (hunits : ∀ u : finiteSupportSubring (G := G) (K := K), + IsUnit u ↔ ∃ k : K, k ≠ 0 ∧ u = finiteSupportScalarHom (G := G) k) + {a : Associates (finiteSupportSubring (G := G) (K := K))} + {p : finiteSupportSubring (G := G) (K := K)} + (hp : IsNormalizedAssociateRepresentative a p) : + normalizedAssociateRepresentative a = p := by + exact (normalizedAssociateRepresentative_is a).eq hunits hp + +end + +end HahnSeries.Nonpositive diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/FiniteSupportNormalizedGCD.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/FiniteSupportNormalizedGCD.lean new file mode 100644 index 0000000000..0b30632aff --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/FiniteSupportNormalizedGCD.lean @@ -0,0 +1,86 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.FiniteSupport +public import Mathlib.Algebra.GCDMonoid.Basic + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.FiniteSupportGCDProof +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.FiniteSupportNormalization +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.FiniteSupportUnit + +/-! +# A normalized GCD structure on finite-support nonpositive series + +LM24, Fact 2.5.2 shows that the finite-support nonpositive Hahn-series ring is a GCD domain and +that its units are precisely the nonzero constants. The normalization here represents the zero +associate class by zero and every nonzero class by the unique associate whose coefficient at its +greatest support exponent is one. This turns the existing pairwise GCD theorem into a +`NormalizedGCDMonoid` structure. +-/ + +open scoped HahnSeries + +universe u v + +public noncomputable section + +namespace HahnSeries.Nonpositive + +variable {G : Type u} {K : Type v} +variable [LinearOrder G] [AddCommGroup G] [IsOrderedAddMonoid G] +variable [Field K] + +private theorem normalizedAssociateRepresentative_one : + normalizedAssociateRepresentative + (1 : Associates (finiteSupportSubring (G := G) (K := K))) = 1 := by + apply normalizedAssociateRepresentative_eq_of_is isUnit_finiteSupport_iff_exists_scalar + rw [isNormalizedAssociateRepresentative_iff] + exact Or.inr ⟨one_ne_zero, by simp, isMonicFiniteSupport_one⟩ + +private theorem normalizedAssociateRepresentative_mul + (a b : Associates (finiteSupportSubring (G := G) (K := K))) : + normalizedAssociateRepresentative (a * b) = + normalizedAssociateRepresentative a * normalizedAssociateRepresentative b := by + by_cases ha : a = 0 + · subst a + simp + by_cases hb : b = 0 + · subst b + simp + apply normalizedAssociateRepresentative_eq_of_is isUnit_finiteSupport_iff_exists_scalar + rw [isNormalizedAssociateRepresentative_iff] + refine Or.inr ⟨mul_ne_zero ha hb, ?_, ?_⟩ + · rw [← Associates.mk_mul_mk, normalizedAssociateRepresentative_mk, + normalizedAssociateRepresentative_mk] + · exact (normalizedAssociateRepresentative_isMonic_of_ne_zero ha).mul + (normalizedAssociateRepresentative_isMonic_of_ne_zero hb) + +private noncomputable def normalizedAssociateRepresentativeMonoidHom : + Associates (finiteSupportSubring (G := G) (K := K)) →* + finiteSupportSubring (G := G) (K := K) where + toFun := normalizedAssociateRepresentative + map_one' := normalizedAssociateRepresentative_one + map_mul' := normalizedAssociateRepresentative_mul + +@[implicit_reducible] +private noncomputable def finiteSupportNormalizationMonoid : + NormalizationMonoid (finiteSupportSubring (G := G) (K := K)) := by + classical + exact (strongNormalizationMonoidOfMonoidHomRightInverse + (α := finiteSupportSubring (G := G) (K := K)) + normalizedAssociateRepresentativeMonoidHom + normalizedAssociateRepresentative_mk).toNormalizationMonoid + +/-- The nonpositive finite-support Hahn-series ring over a field is a normalized GCD domain. -/ +theorem nonemptyNormalizedGCDMonoid_finiteSupport : + Nonempty (NormalizedGCDMonoid (finiteSupportSubring (G := G) (K := K))) := by + classical + let : NormalizationMonoid (finiteSupportSubring (G := G) (K := K)) := + finiteSupportNormalizationMonoid + exact ⟨normalizedGCDMonoidOfExistsGCD finiteSupport_pairwise_gcd_exists⟩ + +end HahnSeries.Nonpositive diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/FiniteSupportResidue.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/FiniteSupportResidue.lean new file mode 100644 index 0000000000..6798356085 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/FiniteSupportResidue.lean @@ -0,0 +1,127 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.Residue +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.DegreeValuation +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.FiniteSupport + +/-! +# The degree-zero residue ring + +For a max-additive degree on nonpositive real Hahn series whose value is degree, the nonpositive +subring is the finite-support subring and the negative ideal is zero. The residue map is +therefore a ring isomorphism from finite-support nonpositive Hahn series. This is the proof of +LM24, Proposition 5.1.1, stated for any degree whose value is Hahn-series degree. +-/ + +universe v + +public noncomputable section + +open scoped DirectSum + +namespace HahnSeries.Nonpositive + +variable {K : Type v} [CommRing K] + +variable (w : MaxAddDegree (Nonpositive ℝ K) NatOrdinal) + +/-- A degree function equal to the Hahn-series degree has the finite-support subring as its +nonpositive subring. -/ +theorem nonpositiveSubring_eq_finiteSupportSubring_of_value_eq_degree + (hvalue : ∀ b, w b = (b : K⟦ℝ⟧).degree) : + w.nonpositiveSubring = finiteSupportSubring := by + ext b + rw [MaxAddDegree.mem_nonpositiveSubring_iff, + mem_finiteSupportSubring_iff, hvalue, HahnSeries.degree_le_zero_iff] + +/-- A degree function equal to the Hahn-series degree has zero strictly-negative ideal. -/ +theorem negativeIdeal_eq_bot_of_value_eq_degree + (hvalue : ∀ b, w b = (b : K⟦ℝ⟧).degree) : + w.negativeIdeal = ⊥ := by + ext b + rw [MaxAddDegree.mem_negativeIdeal_iff, Ideal.mem_bot, hvalue, + HahnSeries.degree_lt_zero_iff] + simp + +/-- The residue map of a degree function equal to the Hahn-series degree is injective. -/ +theorem residueMap_injective_of_value_eq_degree + (hvalue : ∀ b, w b = (b : K⟦ℝ⟧).degree) : + Function.Injective w.residueMap := by + apply (RingHom.injective_iff_ker_eq_bot w.residueMap).mpr + rw [w.residueMap_ker, negativeIdeal_eq_bot_of_value_eq_degree w hvalue] + +/-- LM24, Proposition 5.1.1 in the grade-zero-component presentation of the residue ring. -/ +def finiteSupportResidueEquiv + (hvalue : ∀ b, w b = (b : K⟦ℝ⟧).degree) : + (finiteSupportSubring : Subring (Nonpositive ℝ K)) ≃+* w.ResidueRing := + (RingEquiv.subringCongr + (nonpositiveSubring_eq_finiteSupportSubring_of_value_eq_degree w hvalue).symm).trans + (RingEquiv.ofBijective w.residueMap + ⟨residueMap_injective_of_value_eq_degree w hvalue, w.residueMap_surjective⟩) + +/-- The residue-ring equivalence is the restriction of the residue map. -/ +@[simp] +theorem finiteSupportResidueEquiv_apply + (hvalue : ∀ b, w b = (b : K⟦ℝ⟧).degree) + (b : (finiteSupportSubring : Subring (Nonpositive ℝ K))) : + finiteSupportResidueEquiv w hvalue b = + w.residueMap + (RingEquiv.subringCongr + (nonpositiveSubring_eq_finiteSupportSubring_of_value_eq_degree w hvalue).symm b) := by + rfl + +/-- Under the RV/homogeneous equivalence, the residue isomorphism is the restriction of `rv`. -/ +theorem coe_rvEquivHomogeneous_rv_eq_residueRingHom_finiteSupportResidueEquiv + [w.IsMultiplicative] + (hvalue : ∀ b, w b = (b : K⟦ℝ⟧).degree) + (b : (finiteSupportSubring : Subring (Nonpositive ℝ K))) : + (w.rvEquivHomogeneous (w.rv (b : Nonpositive ℝ K)) : + w.AssociatedGraded) = + w.residueRingHom (finiteSupportResidueEquiv w hvalue b) := by + rw [finiteSupportResidueEquiv_apply] + let x : w.nonpositiveSubring := + RingEquiv.subringCongr + (nonpositiveSubring_eq_finiteSupportSubring_of_value_eq_degree w hvalue).symm b + have hxcoe : (x : Nonpositive ℝ K) = b := by + exact RingEquiv.coe_subringCongr_apply _ b + have hxvalue : w (x : Nonpositive ℝ K) = 0 ∨ + w (x : Nonpositive ℝ K) = ⊥ := by + by_cases hb : (b : Nonpositive ℝ K) = 0 + · right + rw [hvalue, hxcoe, hb] + simp + · left + rw [hvalue, hxcoe] + apply HahnSeries.degree_eq_zero.mpr + refine ⟨?_, + (mem_finiteSupportSubring_iff (b : Nonpositive ℝ K)).mp b.2⟩ + simpa using hb + have hdiagram := + w.coe_rvEquivHomogeneous_rv_eq_residueRingHom_residueMap x hxvalue + rw [hxcoe] at hdiagram + exact hdiagram + +variable (K) in +/-- LM24, Proposition 5.1.1 for the degree valuation: the finite-support subring is its +degree-zero residue ring. -/ +def degreeFiniteSupportResidueEquiv [Nontrivial K] : + (finiteSupportSubring : Subring (Nonpositive ℝ K)) ≃+* (degreeValuation K).ResidueRing := + finiteSupportResidueEquiv (degreeValuation K) degreeValuation_apply + +/-- The degree-residue equivalence is the residue map restricted to finite-support series. -/ +@[simp] +theorem degreeFiniteSupportResidueEquiv_apply [Nontrivial K] + (b : (finiteSupportSubring : Subring (Nonpositive ℝ K))) : + degreeFiniteSupportResidueEquiv K b = + (degreeValuation K).residueMap + (RingEquiv.subringCongr + (nonpositiveSubring_eq_finiteSupportSubring_of_value_eq_degree + (degreeValuation K) degreeValuation_apply).symm b) := + finiteSupportResidueEquiv_apply (degreeValuation K) degreeValuation_apply b + +end HahnSeries.Nonpositive diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/FiniteSupportScalarExtension.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/FiniteSupportScalarExtension.lean new file mode 100644 index 0000000000..b1bfb30e15 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/FiniteSupportScalarExtension.lean @@ -0,0 +1,453 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.FiniteSupportMonoidAlgebra +public import Mathlib.Algebra.Field.IsField +public import Mathlib.Algebra.MonoidAlgebra.MapDomain + +import Mathlib.Algebra.GCDMonoid.Basic + +/-! +# Coefficient extension for finite-support Hahn series + +A ring homomorphism between coefficient rings induces a ring homomorphism between the +corresponding finite-support nonpositive Hahn-series rings. The construction is intrinsic: under +the canonical additive-monoid-algebra presentation, it applies the coefficient homomorphism and +leaves every exponent unchanged. + +The range characterization identifies the image with the series whose coefficients all belong to +the image of the coefficient homomorphism. In particular, scalar extension realizes the inclusion +of `K(ℝ^{≤0})` in `L(ℝ^{≤0})` used in LM24, Lemma 6.3.4. +-/ + +open scoped HahnSeries + +universe u v w + +namespace HahnSeries.Nonpositive + +public noncomputable section + +variable {G : Type u} {K : Type v} {L : Type w} + [LinearOrder G] [AddCommGroup G] [IsOrderedAddMonoid G] + [CommRing K] [CommRing L] + +/-- Apply a coefficient-ring homomorphism to a finite-support nonpositive Hahn series. -/ +def finiteSupportMap (f : K →+* L) : + FiniteSupportRing (G := G) (K := K) →+* + FiniteSupportRing (G := G) (K := L) := + (finiteSupportAddMonoidAlgebraEquiv (G := G) (K := L)).symm.toRingHom.comp + ((AddMonoidAlgebra.mapRingHom (exponentMonoid G) f).comp + (finiteSupportAddMonoidAlgebraEquiv (G := G) (K := K)).toRingHom) + +/-- Under the additive-monoid-algebra presentation, `finiteSupportMap` applies the coefficient +homomorphism. -/ +@[simp] +theorem finiteSupportAddMonoidAlgebraEquiv_map (f : K →+* L) + (b : FiniteSupportRing (G := G) (K := K)) : + finiteSupportAddMonoidAlgebraEquiv (finiteSupportMap f b) = + AddMonoidAlgebra.mapRingHom (exponentMonoid G) f + (finiteSupportAddMonoidAlgebraEquiv b) := by + rw [finiteSupportMap, RingHom.comp_apply, RingHom.comp_apply] + exact finiteSupportAddMonoidAlgebraEquiv.apply_symm_apply _ + +/-- `finiteSupportMap` applies the coefficient homomorphism at every exponent. -/ +theorem finiteSupportMap_coeff (f : K →+* L) + (b : FiniteSupportRing (G := G) (K := K)) + (g : exponentMonoid G) : + finiteSupportCoefficients (finiteSupportMap f b) g = + f (finiteSupportCoefficients b g) := by + calc + finiteSupportCoefficients (finiteSupportMap f b) g = + AddMonoidAlgebra.coeff + (finiteSupportAddMonoidAlgebraEquiv (finiteSupportMap f b)) g := + (congrArg (fun q : exponentMonoid G →₀ L ↦ q g) + (coeff_finiteSupportAddMonoidAlgebraEquiv + (G := G) (K := L) (finiteSupportMap f b))).symm + _ = f (finiteSupportCoefficients b g) := by + rw [finiteSupportAddMonoidAlgebraEquiv_map] + rw [AddMonoidAlgebra.coeff_mapRingHom] + exact congrArg f (congrArg (fun q : exponentMonoid G →₀ K ↦ q g) + (coeff_finiteSupportAddMonoidAlgebraEquiv (G := G) (K := K) b)) + +/-- An injective coefficient homomorphism induces an injective finite-support map. -/ +theorem finiteSupportMap_injective (f : K →+* L) + (hf : Function.Injective f) : + Function.Injective (finiteSupportMap (G := G) f) := by + intro b c hbc + apply finiteSupportFinsuppEquiv.injective + rw [finiteSupportFinsuppEquiv_apply, finiteSupportFinsuppEquiv_apply] + ext g + apply hf + have hcoeff := congrArg + (fun q : FiniteSupportRing (G := G) (K := L) ↦ + finiteSupportCoefficients q g) hbc + simpa only [finiteSupportMap_coeff] using hcoeff + +/-- Applying the identity coefficient homomorphism is the identity on finite-support series. -/ +@[simp] +theorem finiteSupportMap_id : + finiteSupportMap (G := G) (RingHom.id K) = RingHom.id _ := by + apply RingHom.ext + intro b + apply finiteSupportAddMonoidAlgebraEquiv.injective + rw [finiteSupportAddMonoidAlgebraEquiv_map, + AddMonoidAlgebra.mapRingHom_id] + rfl + +/-- Coefficient maps respect composition. -/ +@[simp] +theorem finiteSupportMap_comp {M : Type*} [CommRing M] + (g : L →+* M) (f : K →+* L) : + finiteSupportMap (G := G) (g.comp f) = + (finiteSupportMap (G := G) g).comp (finiteSupportMap (G := G) f) := by + apply RingHom.ext + intro b + apply finiteSupportAddMonoidAlgebraEquiv.injective + rw [finiteSupportAddMonoidAlgebraEquiv_map, + RingHom.comp_apply, finiteSupportAddMonoidAlgebraEquiv_map, + finiteSupportAddMonoidAlgebraEquiv_map, + AddMonoidAlgebra.mapRingHom_comp] + rfl + +/-- A coefficient map preserves every finite-support Hahn monomial. -/ +@[simp] +theorem finiteSupportMap_monomial (f : K →+* L) + (g : exponentMonoid G) : + finiteSupportMap f (finiteSupportMonomial (K := K) g) = + finiteSupportMonomial (K := L) g := by + apply finiteSupportAddMonoidAlgebraEquiv.injective + rw [finiteSupportAddMonoidAlgebraEquiv_map, + finiteSupportAddMonoidAlgebraEquiv_monomial, + AddMonoidAlgebra.mapRingHom_single, map_one, + finiteSupportAddMonoidAlgebraEquiv_monomial] + +/-- A coefficient map sends a constant series to the constant series with mapped coefficient. -/ +@[simp] +theorem finiteSupportMap_scalar (f : K →+* L) (k : K) : + finiteSupportMap f (finiteSupportScalarHom (G := G) k) = + finiteSupportScalarHom (G := G) (f k) := by + apply finiteSupportAddMonoidAlgebraEquiv.injective + rw [finiteSupportAddMonoidAlgebraEquiv_map] + change + AddMonoidAlgebra.mapRingHom (exponentMonoid G) f + (finiteSupportAddMonoidAlgebraEquiv + (algebraMap K (FiniteSupportRing (G := G) (K := K)) k)) = + finiteSupportAddMonoidAlgebraEquiv + (algebraMap L (FiniteSupportRing (G := G) (K := L)) (f k)) + rw [AlgEquiv.commutes, AlgEquiv.commutes] + change + AddMonoidAlgebra.mapRingHom (exponentMonoid G) f + (AddMonoidAlgebra.single 0 k) = + AddMonoidAlgebra.single 0 (f k) + exact AddMonoidAlgebra.mapRingHom_single f 0 k + +/-- A finite-support series belongs to the range of a coefficient map exactly when each of its +coefficients belongs to the range of the coefficient homomorphism. -/ +theorem mem_range_finiteSupportMap_iff (f : K →+* L) + (b : FiniteSupportRing (G := G) (K := L)) : + b ∈ Set.range (finiteSupportMap (G := G) f) ↔ + ∀ g, finiteSupportCoefficients b g ∈ Set.range f := by + constructor + · rintro ⟨a, rfl⟩ g + exact ⟨finiteSupportCoefficients a g, (finiteSupportMap_coeff f a g).symm⟩ + · intro hb + have hcoeff : ∀ g, + AddMonoidAlgebra.coeff (finiteSupportAddMonoidAlgebraEquiv b) g ∈ + Set.range f.toAddMonoidHom := by + intro g + rw [show AddMonoidAlgebra.coeff + (finiteSupportAddMonoidAlgebraEquiv b) g = + finiteSupportCoefficients b g from + congrArg (fun q : exponentMonoid G →₀ L ↦ q g) + (coeff_finiteSupportAddMonoidAlgebraEquiv + (G := G) (K := L) b)] + exact hb g + have hrange : finiteSupportAddMonoidAlgebraEquiv b ∈ + Set.range (AddMonoidAlgebra.map + (M := exponentMonoid G) f.toAddMonoidHom) := by + rw [AddMonoidAlgebra.range_map] + exact hcoeff + obtain ⟨a, ha⟩ := hrange + refine ⟨finiteSupportAddMonoidAlgebraEquiv.symm a, ?_⟩ + apply finiteSupportAddMonoidAlgebraEquiv.injective + rw [finiteSupportAddMonoidAlgebraEquiv_map, + finiteSupportAddMonoidAlgebraEquiv.apply_symm_apply] + change AddMonoidAlgebra.map f.toAddMonoidHom a = + finiteSupportAddMonoidAlgebraEquiv b + exact ha + +/-- If a nonzero finite-support series over `K` becomes a scalar multiple whose coefficients are +still in the image of `K`, then the scalar itself belongs to the image of `K`. -/ +theorem coefficient_mem_range_of_map_mul_scalar_mem_range + (hK : IsField K) (f : K →+* L) + {p : FiniteSupportRing (G := G) (K := K)} (hp : p ≠ 0) + {B : L} + (hmem : finiteSupportMap f p * finiteSupportScalarHom (G := G) B ∈ + Set.range (finiteSupportMap (G := G) f)) : + B ∈ Set.range f := by + have hpCoefficients : finiteSupportCoefficients p ≠ 0 := by + rw [← finiteSupportFinsuppEquiv_apply] + exact (finiteSupportFinsuppEquiv (G := G) (K := K)).map_ne_zero_iff.mpr hp + obtain ⟨g, hg⟩ := Finsupp.ne_iff.mp hpCoefficients + obtain ⟨q, hq⟩ := hmem + have hcoeff := congrArg + (fun r : FiniteSupportRing (G := G) (K := L) ↦ + finiteSupportCoefficients r g) hq + rw [finiteSupportMap_coeff, mul_comm, + ← smul_finiteSupport_eq_scalar_mul, map_smul, Finsupp.smul_apply, + finiteSupportMap_coeff] at hcoeff + obtain ⟨a, ha⟩ := hK.mul_inv_cancel hg + refine ⟨a * finiteSupportCoefficients q g, ?_⟩ + rw [map_mul, hcoeff] + change f a * (B * f (finiteSupportCoefficients p g)) = B + calc + _ = B * f (finiteSupportCoefficients p g * a) := by rw [map_mul]; ring + _ = B := by rw [ha, map_one, mul_one] + +section ScalarExtension + +variable [Algebra K L] + +/-- Extend the coefficients of a finite-support Hahn series along a coefficient algebra. -/ +def finiteSupportScalarExtension : + FiniteSupportRing (G := G) (K := K) →+* + FiniteSupportRing (G := G) (K := L) := + finiteSupportMap (G := G) (algebraMap K L) + +/-- Under the additive-monoid-algebra presentation, scalar extension applies the coefficient +algebra map. -/ +@[simp] +theorem finiteSupportAddMonoidAlgebraEquiv_scalarExtension + (b : FiniteSupportRing (G := G) (K := K)) : + finiteSupportAddMonoidAlgebraEquiv + (finiteSupportScalarExtension (G := G) (K := K) (L := L) b) = + AddMonoidAlgebra.mapRingHom (exponentMonoid G) (algebraMap K L) + (finiteSupportAddMonoidAlgebraEquiv b) := by + rw [finiteSupportScalarExtension, finiteSupportAddMonoidAlgebraEquiv_map] + +/-- Scalar extension applies the coefficient algebra map at every exponent. -/ +theorem finiteSupportScalarExtension_coeff + (b : FiniteSupportRing (G := G) (K := K)) + (g : exponentMonoid G) : + finiteSupportCoefficients + (finiteSupportScalarExtension (G := G) (K := K) (L := L) b) g = + algebraMap K L (finiteSupportCoefficients b g) := + finiteSupportMap_coeff (algebraMap K L) b g + +/-- Scalar extension preserves every finite-support Hahn monomial. -/ +@[simp] +theorem finiteSupportScalarExtension_monomial (g : exponentMonoid G) : + finiteSupportScalarExtension (G := G) (K := K) (L := L) + (finiteSupportMonomial (K := K) g) = + finiteSupportMonomial (K := L) g := + finiteSupportMap_monomial (algebraMap K L) g + +/-- Scalar extension sends a constant series through the coefficient algebra map. -/ +@[simp] +theorem finiteSupportScalarExtension_scalar (k : K) : + finiteSupportScalarExtension (G := G) (K := K) (L := L) + (finiteSupportScalarHom (G := G) k) = + finiteSupportScalarHom (G := G) (algebraMap K L k) := + finiteSupportMap_scalar (algebraMap K L) k + +/-- Scalar extension is injective when the coefficient algebra map is injective. -/ +theorem finiteSupportScalarExtension_injective + (hKL : Function.Injective (algebraMap K L)) : + Function.Injective + (finiteSupportScalarExtension (G := G) (K := K) (L := L)) := + finiteSupportMap_injective (algebraMap K L) hKL + +/-- The range of scalar extension consists exactly of the finite-support series whose coefficients +belong to the image of the coefficient algebra map. -/ +theorem mem_range_finiteSupportScalarExtension_iff + (b : FiniteSupportRing (G := G) (K := L)) : + b ∈ Set.range (finiteSupportScalarExtension (G := G) (K := K) (L := L)) ↔ + ∀ g, finiteSupportCoefficients b g ∈ Set.range (algebraMap K L) := + mem_range_finiteSupportMap_iff (algebraMap K L) b + +end ScalarExtension + +end + +end HahnSeries.Nonpositive + +namespace HahnSeries.Nonpositive + +public noncomputable section + +variable {G : Type u} {K : Type v} {L : Type w} + [LinearOrder G] [AddCommGroup G] [IsOrderedAddMonoid G] + [Field K] [Field L] + +private theorem mul_scalar_mul_inv_scalar + (B : L) (hB : B ≠ 0) + (x y : FiniteSupportRing (G := G) (K := L)) : + (x * finiteSupportScalarHom (G := G) B) * + (y * finiteSupportScalarHom (G := G) B⁻¹) = + x * y := by + calc + _ = x * y * + (finiteSupportScalarHom (G := G) B * + finiteSupportScalarHom (G := G) B⁻¹) := by ac_rfl + _ = x * y * finiteSupportScalarHom (G := G) (B * B⁻¹) := by + rw [map_mul] + _ = x * y := by rw [mul_inv_cancel₀ hB, map_one, mul_one] + +private theorem eq_mul_of_scalar_redistribution + (f : K →+* L) (hf : Function.Injective f) + (B : L) (hB : B ≠ 0) + {p p₁ p₂ : FiniteSupportRing (G := G) (K := K)} + {q₁ q₂ : FiniteSupportRing (G := G) (K := L)} + (hpq : finiteSupportMap f p = q₁ * q₂) + (hp₁ : finiteSupportMap f p₁ = + q₁ * finiteSupportScalarHom (G := G) B) + (hp₂ : finiteSupportMap f p₂ = + q₂ * finiteSupportScalarHom (G := G) B⁻¹) : + p = p₁ * p₂ := by + apply finiteSupportMap_injective f hf + calc + finiteSupportMap f p = q₁ * q₂ := hpq + _ = (q₁ * finiteSupportScalarHom (G := G) B) * + (q₂ * finiteSupportScalarHom (G := G) B⁻¹) := + (mul_scalar_mul_inv_scalar B hB q₁ q₂).symm + _ = finiteSupportMap f p₁ * finiteSupportMap f p₂ := by rw [← hp₁, ← hp₂] + _ = finiteSupportMap f (p₁ * p₂) := + ((finiteSupportMap f).map_mul p₁ p₂).symm + +private theorem map_dvd_of_eq_mul_scalar + (f : K →+* L) (B : L) (hB : B ≠ 0) + {p : FiniteSupportRing (G := G) (K := K)} + {q b : FiniteSupportRing (G := G) (K := L)} + (hp : finiteSupportMap f p = q * finiteSupportScalarHom (G := G) B) + (hq : q ∣ b) : + finiteSupportMap f p ∣ b := by + obtain ⟨r, hr⟩ := hq + refine ⟨r * finiteSupportScalarHom (G := G) B⁻¹, ?_⟩ + calc + b = q * r := hr + _ = (q * finiteSupportScalarHom (G := G) B) * + (r * finiteSupportScalarHom (G := G) B⁻¹) := + (mul_scalar_mul_inv_scalar B hB q r).symm + _ = finiteSupportMap f p * + (r * finiteSupportScalarHom (G := G) B⁻¹) := by rw [hp] + +/-- An injective coefficient map reflects divisibility of finite-support series provided that +nonzero factorisations whose product lies in its range can be scalar-redistributed into the +range. -/ +theorem finiteSupportMap_dvd_iff_of_scalarRedistribution + (f : K →+* L) (hf : Function.Injective f) + (hredistribute : + ∀ {p₁ p₂ : FiniteSupportRing (G := G) (K := L)}, + p₁ ≠ 0 → p₂ ≠ 0 → + p₁ * p₂ ∈ Set.range (finiteSupportMap (G := G) f) → + ∃ B : L, + B ≠ 0 ∧ + p₁ * finiteSupportScalarHom (G := G) B ∈ + Set.range (finiteSupportMap (G := G) f) ∧ + p₂ * finiteSupportScalarHom (G := G) B⁻¹ ∈ + Set.range (finiteSupportMap (G := G) f)) + (p q : FiniteSupportRing (G := G) (K := K)) : + finiteSupportMap f p ∣ finiteSupportMap f q ↔ p ∣ q := by + constructor + · rintro ⟨r, hr⟩ + by_cases hp : p = 0 + · subst p + have hqImage : finiteSupportMap f q = 0 := by simpa using hr + have hq : q = 0 := + (finiteSupportMap_injective f hf) (hqImage.trans (map_zero _).symm) + simp [hq] + by_cases hq : q = 0 + · simp [hq] + have hpImage : finiteSupportMap f p ≠ 0 := + (map_ne_zero_iff _ (finiteSupportMap_injective f hf)).mpr hp + have hqImage : finiteSupportMap f q ≠ 0 := + (map_ne_zero_iff _ (finiteSupportMap_injective f hf)).mpr hq + have hrNe : r ≠ 0 := by + intro hrZero + rw [hrZero, mul_zero] at hr + exact hqImage hr + have hprod : + finiteSupportMap f p * r ∈ + Set.range (finiteSupportMap (G := G) f) := by + exact ⟨q, hr⟩ + obtain ⟨B, hB, hleft, hright⟩ := + hredistribute hpImage hrNe hprod + have hBRange : B ∈ Set.range f := + coefficient_mem_range_of_map_mul_scalar_mem_range + (Field.toIsField K) f hp hleft + obtain ⟨k, hk⟩ := hBRange + obtain ⟨t, ht⟩ := hright + have hrRange : r ∈ Set.range (finiteSupportMap (G := G) f) := by + refine ⟨t * finiteSupportScalarHom (G := G) k, ?_⟩ + rw [map_mul, ht, finiteSupportMap_scalar, hk] + simp only [mul_assoc, ← map_mul, inv_mul_cancel₀ hB, map_one, mul_one] + obtain ⟨s, hs⟩ := hrRange + refine ⟨s, ?_⟩ + apply finiteSupportMap_injective f hf + rw [map_mul, hs, hr] + · rintro ⟨r, rfl⟩ + exact ⟨finiteSupportMap f r, map_mul _ _ _⟩ + +/-- Scalar redistribution descends the primal factor witnesses supplied by greatest-common- +divisor existence after coefficient extension. In particular, both descended factors remain in +the finite-support ring over the original coefficient field. -/ +theorem finiteSupportMap_exists_factor_dvd_of_scalarRedistribution + (f : K →+* L) (hf : Function.Injective f) + (hredistribute : + ∀ {p₁ p₂ : FiniteSupportRing (G := G) (K := L)}, + p₁ ≠ 0 → p₂ ≠ 0 → + p₁ * p₂ ∈ Set.range (finiteSupportMap (G := G) f) → + ∃ B : L, + B ≠ 0 ∧ + p₁ * finiteSupportScalarHom (G := G) B ∈ + Set.range (finiteSupportMap (G := G) f) ∧ + p₂ * finiteSupportScalarHom (G := G) B⁻¹ ∈ + Set.range (finiteSupportMap (G := G) f)) + (hgcd : ∀ p q : FiniteSupportRing (G := G) (K := L), + ∃ d : FiniteSupportRing (G := G) (K := L), + ∀ e : FiniteSupportRing (G := G) (K := L), + e ∣ p ∧ e ∣ q ↔ e ∣ d) + (p : FiniteSupportRing (G := G) (K := K)) + (b c : FiniteSupportRing (G := G) (K := L)) + (hp : finiteSupportMap f p ∣ b * c) : + ∃ p₁ p₂ : FiniteSupportRing (G := G) (K := K), + p = p₁ * p₂ ∧ + finiteSupportMap f p₁ ∣ b ∧ + finiteSupportMap f p₂ ∣ c := by + classical + by_cases hpZero : p = 0 + · obtain ⟨q, hq⟩ := hp + have hbc : b * c = 0 := by simpa [hpZero] using hq + rcases eq_zero_or_eq_zero_of_mul_eq_zero hbc with hb | hc + · exact ⟨0, 1, by simp [hpZero], by simp [hb], by simp⟩ + · exact ⟨1, 0, by simp [hpZero], by simp, by simp [hc]⟩ + · let : GCDMonoid (FiniteSupportRing (G := G) (K := L)) := + gcdMonoidOfExistsGCD hgcd + obtain ⟨q₁, q₂, hq₁b, hq₂c, hpq⟩ := + exists_dvd_and_dvd_of_dvd_mul hp + have hpImage : finiteSupportMap f p ≠ 0 := + (map_ne_zero_iff _ (finiteSupportMap_injective f hf)).mpr hpZero + have hq₁ : q₁ ≠ 0 := by + intro hzero + apply hpImage + simpa [hzero] using hpq + have hq₂ : q₂ ≠ 0 := by + intro hzero + apply hpImage + simpa [hzero] using hpq + obtain ⟨B, hB, hleft, hright⟩ := + hredistribute hq₁ hq₂ ⟨p, hpq⟩ + obtain ⟨p₁, hp₁⟩ := hleft + obtain ⟨p₂, hp₂⟩ := hright + refine ⟨p₁, p₂, eq_mul_of_scalar_redistribution f hf B hB hpq hp₁ hp₂, + map_dvd_of_eq_mul_scalar f B hB hp₁ hq₁b, ?_⟩ + simpa using map_dvd_of_eq_mul_scalar f B⁻¹ (inv_ne_zero hB) hp₂ hq₂c + +end + +end HahnSeries.Nonpositive diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/FiniteSupportScalarTensor.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/FiniteSupportScalarTensor.lean new file mode 100644 index 0000000000..a487a25d3a --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/FiniteSupportScalarTensor.lean @@ -0,0 +1,73 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.FiniteSupportScalarExtension +public import Mathlib.RingTheory.TensorProduct.Basic + +import Mathlib.RingTheory.TensorProduct.MonoidAlgebra + +/-! +# Scalar extension as a tensor product for finite-support Hahn series + +For commutative rings `K` and `L` with a `K`-algebra structure on `L`, finite-support +nonpositive Hahn series over `L` are the scalar extension of the corresponding ring over `K`. +The equivalence is transported through the canonical additive-monoid-algebra presentation, so it +does not choose a basis or enumerate the support. + +This is the generic base-change identification used for the localization of the principal graded +ring in LM24, Section 6.3. +-/ + +open scoped HahnSeries TensorProduct + +universe u v w + +namespace HahnSeries.Nonpositive + +public noncomputable section + +variable {G : Type u} {K : Type v} {L : Type w} + [LinearOrder G] [AddCommGroup G] [IsOrderedAddMonoid G] + [CommRing K] [CommRing L] [Algebra K L] + +/-- Base change of finite-support nonpositive Hahn series along a commutative-ring algebra. -/ +def finiteSupportScalarTensorEquiv : + L ⊗[K] FiniteSupportRing (G := G) (K := K) ≃ₐ[L] + FiniteSupportRing (G := G) (K := L) := + (Algebra.TensorProduct.congr + (AlgEquiv.refl : L ≃ₐ[L] L) + (finiteSupportAddMonoidAlgebraEquiv (G := G) (K := K))).trans + ((AddMonoidAlgebra.scalarTensorEquiv K L).trans + (finiteSupportAddMonoidAlgebraEquiv (G := G) (K := L)).symm) + +/-- On a pure tensor, finite-support scalar base change multiplies the constant series by the +coefficientwise scalar extension. -/ +theorem finiteSupportScalarTensorEquiv_tmul + (l : L) (p : FiniteSupportRing (G := G) (K := K)) : + finiteSupportScalarTensorEquiv (G := G) (K := K) (L := L) (l ⊗ₜ p) = + finiteSupportScalarHom (G := G) l * finiteSupportScalarExtension p := by + have hscalar : + finiteSupportAddMonoidAlgebraEquiv + (finiteSupportScalarHom (G := G) l) = + AddMonoidAlgebra.single 0 l := by + change finiteSupportAddMonoidAlgebraEquiv + (algebraMap L (FiniteSupportRing (G := G) (K := L)) l) = _ + rw [AlgEquiv.commutes] + rfl + rw [finiteSupportScalarTensorEquiv] + simp only [AlgEquiv.trans_apply, Algebra.TensorProduct.congr_apply, + Algebra.TensorProduct.map_tmul] + rw [AddMonoidAlgebra.scalarTensorEquiv_tmul] + apply finiteSupportAddMonoidAlgebraEquiv.injective + rw [finiteSupportAddMonoidAlgebraEquiv.apply_symm_apply, map_mul, hscalar] + rw [finiteSupportAddMonoidAlgebraEquiv_scalarExtension] + simp only [Algebra.smul_def] + congr 1 + +end + +end HahnSeries.Nonpositive diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/FiniteSupportUnit.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/FiniteSupportUnit.lean new file mode 100644 index 0000000000..0f7c9d96c6 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/FiniteSupportUnit.lean @@ -0,0 +1,98 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.FiniteSupport + +/-! +# Units of the nonpositive Hahn-series ring + +Half of LM24, Fact 2.5.2: the units of the finite-support nonpositive Hahn-series ring are +exactly the nonzero constant series. + +Finiteness of the support is not used. The order of a nonzero series is the least exponent of its +support, so it is at most zero here, and it is additive on products over a domain. A product equal +to one therefore forces both orders to vanish, which leaves the whole support at zero. +-/ + +open scoped HahnSeries + +universe u v + +public noncomputable section + +namespace HahnSeries.Nonpositive + +variable {G : Type u} {K : Type v} +variable [LinearOrder G] [AddCommGroup G] [IsOrderedAddMonoid G] +variable [Field K] + +/-- A factor of a product equal to one, among series supported in the nonpositive exponents, has +order zero. -/ +private theorem order_eq_zero_of_mul_eq_one {x y : K⟦G⟧} + (hx : x.support ⊆ Set.Iic 0) (hy : y.support ⊆ Set.Iic 0) (hxy : x * y = 1) : + x.order = 0 := by + have hx0 : x ≠ 0 := left_ne_zero_of_mul_eq_one hxy + have hy0 : y ≠ 0 := right_ne_zero_of_mul_eq_one hxy + have hmem : ∀ {z : K⟦G⟧}, z ≠ 0 → z.support ⊆ Set.Iic 0 → z.order ≤ 0 := by + intro z hz hsub + exact hsub ((HahnSeries.mem_support _ _).mpr + fun hc ↦ hz (HahnSeries.coeff_order_eq_zero.mp hc)) + have hsum := HahnSeries.order_mul hx0 hy0 + rw [hxy, HahnSeries.order_one] at hsum + refine le_antisymm (hmem hx0 hx) ?_ + by_contra hlt + rw [not_le] at hlt + refine absurd ?_ (lt_irrefl (0 : G)) + calc (0 : G) = x.order + y.order := hsum + _ < 0 + 0 := add_lt_add_of_lt_of_le hlt (hmem hy0 hy) + _ = 0 := add_zero 0 + +/-- A nonpositive series of order zero is a constant. -/ +private theorem eq_C_coeff_of_order_eq_zero {x : K⟦G⟧} (hx : x.support ⊆ Set.Iic 0) + (horder : x.order = 0) : x = HahnSeries.C (x.coeff 0) := by + ext g + rcases eq_or_ne g 0 with rfl | hg + · simp + · rw [HahnSeries.C_apply, HahnSeries.coeff_single_of_ne hg] + by_contra hne + exact hg (le_antisymm (hx hne) (horder ▸ HahnSeries.order_le_of_coeff_ne_zero hne)) + +/-- LM24, Fact 2.5.2: the units of the finite-support nonpositive Hahn-series ring are exactly +the nonzero constant series. -/ +theorem isUnit_finiteSupport_iff_exists_scalar + (p : (finiteSupportSubring : Subring (Nonpositive G K))) : + IsUnit p ↔ + ∃ k : K, k ≠ 0 ∧ p = finiteSupportScalarHom (G := G) k := by + constructor + · rintro ⟨u, rfl⟩ + obtain ⟨q, hq⟩ : ∃ q, (u : (finiteSupportSubring : Subring (Nonpositive G K))) * q = 1 := + ⟨↑u⁻¹, u.mul_inv⟩ + have hmul : (((u : (finiteSupportSubring : Subring (Nonpositive G K))) : + Nonpositive G K) : K⟦G⟧) * ((q : Nonpositive G K) : K⟦G⟧) = 1 := by + have hcast := congrArg (fun r : (finiteSupportSubring : Subring (Nonpositive G K)) ↦ + ((r : Nonpositive G K) : K⟦G⟧)) hq + simpa using hcast + have hsub : ∀ r : (finiteSupportSubring : Subring (Nonpositive G K)), + ((r : Nonpositive G K) : K⟦G⟧).support ⊆ Set.Iic 0 := + fun r ↦ (HahnSeries.mem_nonpositiveSubring (Γ := G) (R := K)).mp (r : Nonpositive G K).2 + have horder := order_eq_zero_of_mul_eq_one (hsub _) (hsub q) hmul + refine ⟨(((u : (finiteSupportSubring : Subring (Nonpositive G K))) : + Nonpositive G K) : K⟦G⟧).coeff 0, ?_, ?_⟩ + · rw [← horder] + intro hc + have h0 : (((u : (finiteSupportSubring : Subring (Nonpositive G K))) : + Nonpositive G K) : K⟦G⟧) = 0 := HahnSeries.coeff_order_eq_zero.mp hc + rw [h0, zero_mul] at hmul + exact one_ne_zero hmul.symm + · apply Subtype.ext + apply Subtype.ext + rw [coe_finiteSupportScalarHom] + exact eq_C_coeff_of_order_eq_zero (hsub _) horder + · rintro ⟨k, hk, rfl⟩ + exact (Ne.isUnit hk).map (finiteSupportScalarHom (G := G)) + +end HahnSeries.Nonpositive diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ.lean new file mode 100644 index 0000000000..eab2d5a796 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ.lean @@ -0,0 +1,11 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence.lean new file mode 100644 index 0000000000..501c3d46dc --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence.lean @@ -0,0 +1,51 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.Additive +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.AlgebraicIndependence +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.Boundary +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.Cancellation +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.CantorBendixsonRankLevels +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.CantorBendixsonValue +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.CantorBendixsonValueMultiplicativity +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.CofactorInduction +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.Convolution +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.Derivation +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.DerivationIdeal +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.DerivationSet +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.Derivative +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.Germ +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.GlobalCofactors +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.Graded +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.LeadingCoefficient +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.Leibniz +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.LiftFamily +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.Lifts +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.LimitOrdinalEvaluation +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.LimitOrdinalRelationAtCutoff +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.LinearMaximal +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.LowerTruncationDegree +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.Multiplication +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.Obligations +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.OrderedIntervalCantorBendixson +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.PartialDerivativeIndices +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.PartialDerivativesAtLimitOrdinal +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.Power +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.PrincipalSeries +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.Scalar +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.ScalarLeadingCoefficientAtLimitOrdinal +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.SeparatedPieceCantorBendixson +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.SuccessorLeibniz +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.SyzygyIntegration +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.TranslatedTruncationInterpolation +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.TranslatedTruncationInterpolationOnSets +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.Truncation +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.TruncationExpansion +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.TruncationPolynomial + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/Additive.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/Additive.lean new file mode 100644 index 0000000000..2549b8ff98 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/Additive.lean @@ -0,0 +1,204 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.CantorBendixsonValue +public import Mathlib.RingTheory.HahnSeries.Addition + +/-! +# Additive laws for the Cantor–Bendixson value + +Binary union commutes with every transfinite derivative. The support of a sum is contained in +the union of the factor supports, so the value of a sum is bounded by their maximum. If the +values differ, the larger value survives. A difference of value zero preserves the value. +These statements use the given order topology, with no completeness hypothesis. +-/ + +public noncomputable section + +open Set Topology TopologicalSpace + +universe u v + +namespace HahnSeries + +variable {G : Type u} {R : Type v} [LinearOrder G] [TopologicalSpace G] + [OrderTopology G] [Zero G] + +section AddMonoid + +variable [AddMonoid R] + +/-- The value of a sum is bounded by the maximum of the summand values. -/ +theorem cantorBendixsonValue_add_le (b d : HahnSeries G R) : + (b + d).cantorBendixsonValue ≤ max b.cantorBendixsonValue d.cantorBendixsonValue := by + by_cases hm : 0 ∈ closure (b + d).support + · have hsub : (b + d).closedSupport ≤ b.closedSupport ⊔ d.closedSupport := by + change ((b + d).closedSupport : Set G) ⊆ + (b.closedSupport : Set G) ∪ (d.closedSupport : Set G) + rw [coe_closedSupport, coe_closedSupport, coe_closedSupport, ← closure_union] + exact closure_mono (support_add_subset b d) + have hh := Closeds.cantorBendixson_mono hsub ((b + d).cantorBendixsonRank 0) + (((b + d).mem_support_derivative_iff 0 _).mpr ⟨hm, le_rfl⟩) + rw [Closeds.cantorBendixson_sup] at hh + rcases hh with hb | hd + · obtain ⟨hb0, hr⟩ := (b.mem_support_derivative_iff 0 _).mp hb + apply le_max_of_le_left + rw [(b + d).cantorBendixsonValue_of_mem hm, b.cantorBendixsonValue_of_mem hb0] + exact Ordinal.opow_le_opow_right Ordinal.omega0_pos hr + · obtain ⟨hd0, hr⟩ := (d.mem_support_derivative_iff 0 _).mp hd + apply le_max_of_le_right + rw [(b + d).cantorBendixsonValue_of_mem hm, d.cantorBendixsonValue_of_mem hd0] + exact Ordinal.opow_le_opow_right Ordinal.omega0_pos hr + · rw [(b + d).cantorBendixsonValue_of_notMem hm] + exact zero_le + +/-- Repeated addition cannot increase the value. -/ +theorem cantorBendixsonValue_nsmul_le (b : HahnSeries G R) (n : ℕ) : + (n • b).cantorBendixsonValue ≤ b.cantorBendixsonValue := by + induction n with + | zero => simp + | succ n ih => + rw [succ_nsmul] + exact (cantorBendixsonValue_add_le _ _).trans (max_le ih le_rfl) + +end AddMonoid + +section AddCommMonoid + +variable [AddCommMonoid R] + +/-- A finite sum preserves a strict positive upper bound on the values. -/ +theorem cantorBendixsonValue_sum_lt {ι : Type*} (s : Finset ι) (f : ι → HahnSeries G R) + {ρ : Ordinal.{u}} (hρ : 0 < ρ) (h : ∀ i ∈ s, (f i).cantorBendixsonValue < ρ) : + (∑ i ∈ s, f i).cantorBendixsonValue < ρ := by + classical + induction s using Finset.induction_on with + | empty => simpa only [Finset.sum_empty, cantorBendixsonValue_zero] using hρ + | insert a s ha ih => + rw [Finset.sum_insert ha] + exact (cantorBendixsonValue_add_le _ _).trans_lt + (max_lt (h a (Finset.mem_insert_self a s)) + (ih fun i hi ↦ h i (Finset.mem_insert_of_mem hi))) + +/-- A finite sum of value-zero terms has value zero. -/ +theorem cantorBendixsonValue_sum_eq_zero {ι : Type*} (s : Finset ι) (f : ι → HahnSeries G R) + (h : ∀ i ∈ s, (f i).cantorBendixsonValue = 0) : + (∑ i ∈ s, f i).cantorBendixsonValue = 0 := by + classical + induction s using Finset.induction_on with + | empty => simp only [Finset.sum_empty, cantorBendixsonValue_zero] + | insert a s ha ih => + rw [Finset.sum_insert ha] + apply le_antisymm _ zero_le + exact (cantorBendixsonValue_add_le _ _).trans (by + rw [h a (Finset.mem_insert_self a s), + ih (fun i hi ↦ h i (Finset.mem_insert_of_mem hi)), max_self]) + +end AddCommMonoid + +section AddGroup + +variable [AddGroup R] + +/-- Negation preserves the value. -/ +theorem cantorBendixsonValue_neg (b : HahnSeries G R) : + (-b).cantorBendixsonValue = b.cantorBendixsonValue := + cantorBendixsonValue_congr_support support_neg + +/-- Subtraction is bounded by the maximum of the two values. -/ +theorem cantorBendixsonValue_sub_le (b d : HahnSeries G R) : + (b - d).cantorBendixsonValue ≤ max b.cantorBendixsonValue d.cantorBendixsonValue := by + simpa only [sub_eq_add_neg, cantorBendixsonValue_neg] using + b.cantorBendixsonValue_add_le (-d) + +/-- When two values differ, their sum has the larger value. -/ +theorem cantorBendixsonValue_add_eq_max_of_ne (b d : HahnSeries G R) + (hne : b.cantorBendixsonValue ≠ d.cantorBendixsonValue) : + (b + d).cantorBendixsonValue = max b.cantorBendixsonValue d.cantorBendixsonValue := by + apply le_antisymm (b.cantorBendixsonValue_add_le d) + rcases lt_or_gt_of_ne hne with hlt | hgt + · rw [max_eq_right hlt.le] + have hd := (-b).cantorBendixsonValue_add_le (b + d) + rw [neg_add_cancel_left, cantorBendixsonValue_neg] at hd + exact (le_max_iff.mp hd).resolve_left (not_le_of_gt hlt) + · rw [max_eq_left hgt.le] + have hb := (b + d).cantorBendixsonValue_add_le (-d) + rw [add_neg_cancel_right, cantorBendixsonValue_neg] at hb + exact (le_max_iff.mp hb).resolve_right (not_le_of_gt hgt) + +/-- An error of value zero does not change the value. -/ +theorem cantorBendixsonValue_eq_of_sub_value_eq_zero (b d : HahnSeries G R) + (h : (b - d).cantorBendixsonValue = 0) : + b.cantorBendixsonValue = d.cantorBendixsonValue := by + have hbd := (b - d).cantorBendixsonValue_add_le d + rw [sub_add_cancel, h, max_eq_right zero_le] at hbd + have hdb := (d - b).cantorBendixsonValue_add_le b + rw [sub_add_cancel, ← neg_sub b d, cantorBendixsonValue_neg, h, + max_eq_right zero_le] at hdb + exact hbd.antisymm hdb + +/-- Value one means a nonzero ordinary coefficient with a remainder of value zero. -/ +theorem cantorBendixsonValue_eq_one_iff (b : HahnSeries G R) : + b.cantorBendixsonValue = 1 ↔ + b.coeff 0 ≠ 0 ∧ (b - single 0 (b.coeff 0)).cantorBendixsonValue = 0 := by + classical + constructor + · intro hv + have hm : 0 ∈ closure b.support := by + by_contra hn + have he := b.cantorBendixsonValue_of_notMem hn + rw [hv] at he + exact one_ne_zero he + have hr : b.cantorBendixsonRank 0 = 0 := by + rw [b.cantorBendixsonValue_of_mem hm, Ordinal.opow_eq_one_iff] at hv + exact hv.resolve_left Ordinal.one_lt_omega0.ne' + have hn : (0 : G) ∉ derivedSet (closure b.support) := by + have he := b.closedSupport.notMem_cantorBendixson_rank_add_one b.closedSupport_isPWO 0 + rw [← cantorBendixsonRank_eq, hr, zero_add, + show (1 : Ordinal.{u}) = 0 + 1 by simp, + Closeds.cantorBendixson_add_one, Closeds.cantorBendixson_zero] at he + simpa only [Closeds.coe_derived, coe_closedSupport] using he + have hcoeff : b.coeff 0 ≠ 0 := by + rw [closure_eq_self_union_derivedSet] at hm + exact hm.resolve_right (fun ha ↦ hn (derivedSet_mono _ _ subset_closure ha)) + refine ⟨hcoeff, cantorBendixsonValue_of_notMem _ ?_⟩ + rw [mem_closure_iff_frequently, Filter.not_frequently] + rw [mem_derivedSet, accPt_iff_frequently, Filter.not_frequently] at hn + filter_upwards [hn] with x hx + change ¬ (b - single 0 (b.coeff 0)).coeff x ≠ 0 + rw [coeff_sub] + by_cases hx0 : x = 0 + · subst x + simp + · have hbx : b.coeff x = 0 := by + by_contra hnonzero + exact hx ⟨hx0, subset_closure hnonzero⟩ + simp [hbx, hx0] + · rintro ⟨hc, hz⟩ + rw [b.cantorBendixsonValue_eq_of_sub_value_eq_zero _ hz] + apply cantorBendixsonValue_of_finite_of_coeff_ne_zero + · exact (finite_singleton _).subset support_single_subset + · simpa using hc + +end AddGroup + +section Ring + +variable [Ring R] [NoZeroDivisors R] + +/-- A natural scalar that is nonzero in the coefficient domain preserves the value. -/ +theorem cantorBendixsonValue_nsmul (b : HahnSeries G R) (n : ℕ) (hn : (n : R) ≠ 0) : + (n • b).cantorBendixsonValue = b.cantorBendixsonValue := by + apply cantorBendixsonValue_congr_support + ext x + simp only [mem_support] + rw [coeff_nsmul] + simp [nsmul_eq_mul, hn] + +end Ring + +end HahnSeries diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/AlgebraicIndependence.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/AlgebraicIndependence.lean new file mode 100644 index 0000000000..2081bc48c4 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/AlgebraicIndependence.lean @@ -0,0 +1,325 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.LeadingCoefficient +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.LinearMaximal +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.Obligations +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.PartialDerivativesAtLimitOrdinal +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.Scalar +public import LeanPool.ConwayRefinement.ConwayRefinement.Topology.Order.ArchimedeanBallBase +public import Mathlib.RingTheory.AlgebraicIndependent.Defs + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint + +/-! +# Algebraic independence for the Cantor--Bendixson degree + +A minimal system of homogeneous generators is algebraically independent. Equivalently, polynomial +evaluation at the generators is injective. The proof is a transfinite induction on weighted degree. +Degree zero is scalar. A successor weighted degree is handled by the lowering derivation. At a +non-zero limit weighted degree, maximal-variable linearity and the required partial-derivative +identities are established together. + +The argument for a successor degree is stated over an arbitrary filter. The argument for a limit +ordinal degree uses the hypotheses supplied by its ordered-group setting. This file records what +the induction needs and does not otherwise depend on the setting, so that what remains for the +Cantor--Bendixson degree is exactly the list of hypotheses below. +-/ + +universe u v w x + +open scoped NatOrdinal Topology + +open Filter MvPolynomial HahnSeries HahnSeries.Nonpositive + +public noncomputable section + +namespace HahnSeries.Germ + +variable {G : Type u} {K : Type v} +variable [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [UniformSpace G] [IsUniformAddGroup G] [OrderTopology G] [Nontrivial G] [CompleteSpace G] + [Field K] [CharZero K] + +local notation "ν" => (cantorBendixsonDegreeValuation (G := G) (R := K)) + +variable {ι : Type w} {wt : ι → NatOrdinal.{u}} + {xg : ι → (cantorBendixsonDegreeValuation (G := G) (R := K)).AssociatedGraded} +variable (σ : LiftFamily wt xg) +variable (hx : OrdinalGraded.IsMinimalSystem + (DirectSum.rangeLof K (cantorBendixsonDegreeValuation (G := G) (R := K)).Component) wt xg) +include hx + +/-- **Polynomiality, degree by degree.** Evaluation at a minimal system is injective in every +degree, given the successor step and the three inputs of the limit step in every degree below. -/ +theorem injectiveAt_of_isMinimalSystem + (hleading : ∀ α : NatOrdinal.{u}, (∀ β < α, OrdinalGraded.InjectiveAt K wt xg β) → + ∀ {F : MvPolynomial ι K}, IsWeightedHomogeneous wt F α → aeval xg F = 0 → + ∀ {B₀ : ι}, B₀ ∈ F.vars → (∀ i ∈ F.vars, wt i ≤ wt B₀) → wt B₀ < α → + ∀ {degHD : NatOrdinal.{u}}, degHD + degreeOf B₀ F • wt B₀ = α → + (degHD = 0 ∨ NatOrdinal.leastTerm degHD ≤ NatOrdinal.leastTerm (wt B₀)) → False) + (hlin : ∀ α : NatOrdinal.{u}, (∀ β < α, OrdinalGraded.InjectiveAt K wt xg β) → + ∀ S : LimitOrdinalRelationAtCutoff σ α, degreeOf S.B₀ S.F = 1) + (hpartials : ∀ α : NatOrdinal.{u}, (∀ β < α, OrdinalGraded.InjectiveAt K wt xg β) → + ∀ S : LimitOrdinalRelationAtCutoff σ α, ∀ v', v' ∈ S.F.vars → S.LowDegreePartAlgebraicLE v' → + ∃ (s : Finset ι) (U : ι → MvPolynomial ι K), (∀ v ∈ s, + S.ContributesToPartialDerivativeAt v' v) ∧ + (∀ v ∈ s, pderiv S.B₀ (U v) = 0) ∧ pderiv v' S.F = ∑ v ∈ s, pderiv v S.F * U v) + (α : NatOrdinal.{u}) : OrdinalGraded.InjectiveAt K wt xg α := by + let : Nontrivial ((cantorBendixsonDegreeValuation (G := G) (R := K)).Component 0) := + Function.Injective.nontrivial + (cantorBendixsonLayerScalarHom_injective (G := G) (K := K)) + let : Nontrivial (cantorBendixsonDegreeValuation (G := G) (R := K)).AssociatedGraded := + Function.Injective.nontrivial (DirectSum.of_injective 0) + exact OrdinalGraded.injectiveAt_of_zero_successor_limit + (OrdinalGraded.injectiveAt_zero hx.ne_zero) + (fun _ hcc ih ↦ HahnSeries.Nonpositive.injectiveAt_of_forall_lt hx + (pos_iff_ne_zero.mpr hcc) ih) + (fun α hα hcc ih ↦ + injectiveAt_of_limit σ hx (hleading α ih) (hlin α ih) (hpartials α ih) hα hcc) + α + +/-- **Polynomiality, degree by degree.** The leading-coefficient obstruction has been discharged; +only linearity of the maximal variable and the partial-derivative identities remain. -/ +@[blueprint "lem:cantor-bendixson-degree-induction" + (phase := "Algebraic independence in graded rings") + (title := "Degreewise injectivity of homogeneous evaluation") + (statement := /-- + Let $K$ be a field of characteristic zero and $G$ a nontrivial complete + ordered abelian group with compatible additive uniformity and order + topology. Let $\nu$ be the Cantor--Bendixson degree on + $K((G^{\le0}))$. Let $x_i\in(\operatorname{gr}_\nu)_{w_i}$ be a minimal + homogeneous generating system, and choose series $b_i$ representing + $x_i$ in degree $w_i$. Suppose + \[ + \nu(b_i)\le w_i, + \qquad \nu(b_i^{\vert y}) (cantorBendixsonDegreeValuation (G := G) (R := R)) + +/-- A product of a factor of degree at most `ρ` with a factor of degree strictly below `σ` has +degree strictly below every bound `τ` separated from `ρ` by `σ`. -/ +theorem degree_mul_lt_of_le_of_lt_of_separated + (a b : Nonpositive G R) (ρ σ τ : NatOrdinal.{u}) + (ha : ν a ≤ ρ) (hb : ν b < σ) + (hsep : ∀ θ, θ < σ → ρ + θ < τ) : + ν (a * b) < τ := by + have hmul := (ν).map_mul_le_add a b + cases hdegree : ν b using WithBot.recBotCoe with + | bot => + rw [hdegree, WithBot.add_bot] at hmul + exact hmul.trans_lt (WithBot.bot_lt_coe τ) + | coe θ => + have hθ : θ < σ := by simpa only [hdegree, WithBot.coe_lt_coe] using hb + apply hmul.trans_lt + rw [hdegree] + calc + ν a + (θ : WithBot NatOrdinal) ≤ (ρ : WithBot NatOrdinal) + θ := + by simpa only [add_comm] using add_le_add_right ha θ + _ = ((ρ + θ : NatOrdinal) : WithBot NatOrdinal) := (WithBot.coe_add ρ θ).symm + _ < (τ : WithBot NatOrdinal) := by + simpa only [WithBot.coe_lt_coe] using hsep θ hθ + +/-- Under the separation inequality, the nonboundary convolution terms and the truncation of the +second factor are strictly below `τ`. Hence only the first boundary term survives at degree at +least `τ`. -/ +theorem degree_translatedTruncLE_mul_sub_mul_lt_of_pointwise_bounds + (a b : Nonpositive G R) (ρ σ τ : NatOrdinal.{u}) + (ha : ν a ≤ ρ) + (hat : ∀ x : G, x < 0 → ν (translatedTruncLE x a) ≤ ρ) + (hbt : ∀ x : G, x < 0 → ν (translatedTruncLE x b) < σ) + (hsep : ∀ θ, θ < σ → ρ + θ < τ) + {γ : G} (hγ : γ < 0) : + ν (translatedTruncLE γ (a * b) - translatedTruncLE γ a * b) < τ := by + have hremValue := HahnSeries.cantorBendixsonValue_leibnizRemainder_lt_of_forall + (a : HahnSeries G R) (b : HahnSeries G R) a.property b.property hγ + (ρ := (ω^ τ).val) (NatOrdinal.wpow_pos τ) (fun x y _ hx _ hy _ ↦ by + have hprod := degree_mul_lt_of_le_of_lt_of_separated + (translatedTruncLE x a) (translatedTruncLE y b) ρ σ τ + (hat x hx) (hbt y hy) hsep + rw [cantorBendixsonDegreeValuation_apply, cantorBendixsonValuation_apply, + NatOrdinal.cantorDegree_lt_coe_iff] at hprod + exact NatOrdinal.of.lt_iff_lt.mp + (by simpa only [coe_translatedTruncLE, Subring.coe_mul, NatOrdinal.of_val] using hprod)) + have hrem : ν (translatedTruncLE γ (a * b) - translatedTruncLE γ a * b - + a * translatedTruncLE γ b) < τ := by + rw [cantorBendixsonDegreeValuation_apply, cantorBendixsonValuation_apply, + NatOrdinal.cantorDegree_lt_coe_iff] + change NatOrdinal.of (((translatedTruncLE γ (a * b) : HahnSeries G R) - + (translatedTruncLE γ a : HahnSeries G R) * b - + (a : HahnSeries G R) * translatedTruncLE γ b).cantorBendixsonValue) < ω^ τ + exact NatOrdinal.of.lt_iff_lt.mpr (by + simpa only [coe_translatedTruncLE, Subring.coe_mul, NatOrdinal.val_wpow] using hremValue) + have hlast : ν (a * translatedTruncLE γ b) < τ := + degree_mul_lt_of_le_of_lt_of_separated a (translatedTruncLE γ b) + ρ σ τ ha (hbt γ hγ) hsep + have heq : translatedTruncLE γ (a * b) - translatedTruncLE γ a * b = + (translatedTruncLE γ (a * b) - translatedTruncLE γ a * b - + a * translatedTruncLE γ b) + a * translatedTruncLE γ b := by + abel + rw [heq] + exact ((ν).map_add_le_max _ _).trans_lt (max_lt hrem hlast) + +end HahnSeries.Nonpositive diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/Cancellation.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/Cancellation.lean new file mode 100644 index 0000000000..9c6f7ffa10 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/Cancellation.lean @@ -0,0 +1,304 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.Power + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint +import LeanPool.ConwayRefinement.ConwayRefinement.Topology.Order.LeftNeighborhood +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Nonpositive +import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.NaturalPrincipal +import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.NaturalPowerFactorization + +/-! +# Cancellation through residual Cantor–Bendixson ranks + +A lower bound on translated truncations at residual-rank cutoffs reconstructs a lower bound +at zero. Applied to the power remainder, this proves the pure-power cancellation step. +For a power times a second factor, multiply the product rule by that factor; the smaller +remainder and the deficient-product term cannot cancel the term of known value. + +Both cancellation statements retain an explicit hypothesis about smaller products. They do +not assert multiplicativity on their own. The natural-number multiplicity survives because +the coefficient domain has characteristic zero. No field inverse is used. + +V denotes the value in NatOrdinal, and T denotes translated weak truncation, in the proofs. +The ordinal factorisation calculation is the one used in Berarducci, Lemma 8.2, applied here +to the Cantor–Bendixson value on an ordered exponent group that is Cauchy complete. +-/ + +public noncomputable section + +open Set Filter Topology +universe u v +namespace HahnSeries +variable {G : Type u} {R : Type v} [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [UniformSpace G] [IsUniformAddGroup G] [OrderTopology G] [Nontrivial G] [CompleteSpace G] + [CommRing R] [NoZeroDivisors R] [CharZero R] + + +local notation "V" => (fun b : HahnSeries G R ↦ NatOrdinal.of (cantorBendixsonValue b)) +local notation:max "T" x:arg "," c:arg => translate (-c) (truncLE c x) + +omit [CompleteSpace G] [NoZeroDivisors R] [CharZero R] in +/-- Eventual bounds at residual-rank cutoffs reconstruct an ordinary principal-factor multiple. -/ +theorem cantorBendixsonValue_residual_reconstruction (b d : HahnSeries G R) (hb : b.support ⊆ Iic 0) + (B : Ordinal.AdditivePrincipalAboveOne.{u}) (hB : b.cantorBendixsonValue = B.val) + (X : NatOrdinal.{u}) (hX : Ordinal.IsAdditivelyPrincipal X.val) + (hyp : ∀ᶠ γ in 𝓝[<] (0 : G), + NatOrdinal.of (translate (-γ) (truncLE γ b)).cantorBendixsonValue = + NatOrdinal.of B.residualFactor → + X ≤ NatOrdinal.of (translate (-γ) (truncLE γ d)).cantorBendixsonValue) : + X.val * B.principalFactor ≤ d.cantorBendixsonValue := by + let a := Ordinal.log Ordinal.omega0 B.residualFactor + let r := Ordinal.log Ordinal.omega0 B.principalFactor + let c := Ordinal.log Ordinal.omega0 X.val + have ha : Ordinal.omega0 ^ a = B.residualFactor := + B.residualFactor_isAdditivelyPrincipal.opow_log_self + have hr : Ordinal.omega0 ^ r = B.principalFactor := + B.principalFactor_isInfiniteMultiplicativelyPrincipal.isAdditivelyPrincipal.opow_log_self + have hc : Ordinal.omega0 ^ c = X.val := hX.opow_log_self + have hrpos : 0 < r := by + apply (Ordinal.opow_lt_opow_iff_right Ordinal.one_lt_omega0).mp + simpa only [Ordinal.opow_zero, hr] using B.one_lt_principalFactor + have hbv : b.cantorBendixsonValue = Ordinal.omega0 ^ (a + r) := by + rw [Ordinal.opow_add, ha, hr, B.residualFactor_mul_principalFactor, hB] + have hl : ∀ᶠ γ in 𝓝[<] (0 : G), + (T b, γ).cantorBendixsonValue = Ordinal.omega0 ^ a → + Ordinal.omega0 ^ c ≤ (T d, γ).cantorBendixsonValue := by + filter_upwards [hyp] with γ hγ he + rw [ha] at he + rw [hc] + exact hγ (congrArg NatOrdinal.of he) + have h := b.cantorBendixsonValue_reconstruction d hb a c r hrpos hbv hl + rwa [Ordinal.opow_add, hc, hr] at h + +/-- The expected values of the smaller residual-point products imply the pure-power formula. -/ +@[blueprint "lem:cantor-bendixson-pure-power-cancellation" + (phase := "Cantor–Bendixson ranks of supports") + (title := "Pure-power cancellation for the Cantor--Bendixson value") + (statement := /-- + Let $R$ be a characteristic-zero domain, let $G$ be a nontrivial complete + ordered abelian group equipped with a compatible additive uniformity and + its order topology, and let $b\in R((G^{\le0}))$. Suppose + $V_{\mathrm{CB}}(b)=B>1$, where $B$ is additively principal, and write + $B=\rho_B\odot\pi_B$ for its residual factor and its final infinite + multiplicatively principal factor. Let $m\in\mathbb N$. + + Suppose that, for every $\gamma<0$ sufficiently close to $0$, + \[ + V_{\mathrm{CB}}(b^{\vert\gamma})=\rho_B + \quad\Longrightarrow\quad + V_{\mathrm{CB}}(b^{\vert\gamma}b^m) + =B^{\odot m}\odot\rho_B. + \] + Then + \[ + V_{\mathrm{CB}}(b^{m+1})=B^{\odot(m+1)}. + \] + Here products and powers marked by $\odot$ are Hessenberg's natural + operations. + -/) + (proof := /-- + The translated truncation of $b^{m+1}$ is the main term + $(m+1)b^{\vert\gamma}b^m$ plus a remainder of smaller + Cantor--Bendixson value. Characteristic zero preserves the value of the + nonzero coefficient $m+1$, so the local hypothesis computes the value of + the main term and hence of the whole truncation. Applying + \ref{lem:cantor-bendixson-rank-reconstruction} supplies the required lower + bound at $0$; the reverse inequality follows by iterating + \ref{lem:cantor-bendixson-value-product-upper-bound} over the power. + -/)] +theorem cantorBendixsonValue_pow_eq_of_eventually (b : HahnSeries G R) (hb : b.support ⊆ Iic 0) + (B : Ordinal.AdditivePrincipalAboveOne.{u}) (hB : b.cantorBendixsonValue = B.val) (m : ℕ) + (hyp : ∀ᶠ γ in 𝓝[<] (0 : G), + NatOrdinal.of (translate (-γ) (truncLE γ b)).cantorBendixsonValue = + NatOrdinal.of B.residualFactor → + NatOrdinal.of (translate (-γ) (truncLE γ b) * b ^ m).cantorBendixsonValue = + NatOrdinal.of B.val ^ m * NatOrdinal.of B.residualFactor) : + NatOrdinal.of (b ^ (m + 1)).cantorBendixsonValue = + NatOrdinal.of B.val ^ (m + 1) := by + let X := NatOrdinal.of B.val ^ m * NatOrdinal.of B.residualFactor + have hX := B.power_residual_factorization m + have hkey : ∀ᶠ γ in 𝓝[<] (0 : G), V (T b, γ) = NatOrdinal.of B.residualFactor → + X ≤ V (T (b ^ (m + 1)), γ) := by + filter_upwards [hyp, b.eventually_cantorBendixsonValue_powerRemainder_lt hb B hB m] + with γ hγ hrem he + have hmain : V ((m + 1) • (T b, γ * b ^ m)) = X := by + dsimp only + rw [cantorBendixsonValue_nsmul _ _ (Nat.cast_ne_zero.mpr (Nat.succ_ne_zero m))] + exact hγ he + have hsmall : V (T (b ^ (m + 1)), γ - (m + 1) • (T b, γ * b ^ m)) < + V ((m + 1) • (T b, γ * b ^ m)) := by rwa [hmain] + have hsum := cantorBendixsonValue_add_eq_max_of_ne + (T (b ^ (m + 1)), γ - (m + 1) • (T b, γ * b ^ m)) + ((m + 1) • (T b, γ * b ^ m)) (ne_of_lt hsmall) + rw [sub_add_cancel, max_eq_right (NatOrdinal.of.le_iff_le.mp hsmall.le)] at hsum + exact le_of_eq ((congrArg NatOrdinal.of hsum).trans hmain).symm + have hlow := cantorBendixsonValue_residual_reconstruction b (b ^ (m + 1)) hb B hB X hX.1 hkey + have hid : X * NatOrdinal.of B.principalFactor = NatOrdinal.of B.val ^ (m + 1) := by + dsimp only [X] + rw [mul_assoc, B.naturalResidual_mul_naturalPrincipal, ← pow_succ] + rw [← hX.2, hid] at hlow + refine le_antisymm ?_ hlow + simpa only [hB] using b.cantorBendixsonValue_pow_le hb (m + 1) + + +omit [CharZero R] [NoZeroDivisors R] [CommRing R] [CompleteSpace G] [Nontrivial G] + [OrderTopology G] [IsUniformAddGroup G] [UniformSpace G] [IsOrderedAddMonoid G] + [LinearOrder G] [AddCommGroup G] in +private theorem small_mul_lt (B C : Ordinal.AdditivePrincipalAboveOne.{u}) + (hp : B.principalFactor ≤ C.principalFactor) (X : NatOrdinal.{u}) (hX : 0 < X) + (hfactor : (X * NatOrdinal.of B.principalFactor).val = X.val * B.principalFactor) + {s t : NatOrdinal.{u}} (hs : s < X * NatOrdinal.of B.principalFactor) + (ht : t < NatOrdinal.of C.val) : + s * t < X * NatOrdinal.of C.val := by + have hs' : s.val < X.val * B.principalFactor := by + rw [← hfactor] + exact hs + have ht' : t.val < C.residualFactor * C.principalFactor := by + rw [C.residualFactor_mul_principalFactor] + exact ht + obtain ⟨i, hi, hsi⟩ := (Ordinal.lt_mul_iff_of_isSuccLimit + B.principalFactor_isInfiniteMultiplicativelyPrincipal.isSuccLimit).mp hs' + obtain ⟨j, hj, htj⟩ := (Ordinal.lt_mul_iff_of_isSuccLimit + C.principalFactor_isInfiniteMultiplicativelyPrincipal.isSuccLimit).mp ht' + have hρ : 0 < NatOrdinal.of C.residualFactor := + pos_iff_ne_zero.mpr C.residualFactor_isAdditivelyPrincipal.ne_zero + have h := NatOrdinal.naturalMul_mul_lt_of_lt + (ρ₁ := X) (ρ₂ := NatOrdinal.of C.residualFactor) + (π₁ := NatOrdinal.of B.principalFactor) (π₂ := NatOrdinal.of C.principalFactor) + (α₁ := NatOrdinal.of i) (α₂ := NatOrdinal.of j) + C.principalFactor_isMultiplicativelyPrincipal hp hi hj (mul_pos hX hρ) + rw [mul_assoc, C.naturalResidual_mul_naturalPrincipal] at h + exact (mul_le_mul' (NatOrdinal.of.le_iff_le.mpr hsi.le) + (NatOrdinal.of.le_iff_le.mpr htj.le)).trans_lt h + +/-- The expected residual-point products imply the power-times-factor formula. +The second factor must have no smaller canonical principal factor. -/ +@[blueprint "lem:cantor-bendixson-power-factor-cancellation" + (phase := "Cantor–Bendixson ranks of supports") + (title := "Power-times-factor cancellation for the Cantor--Bendixson value") + (statement := /-- + Under the coefficient and exponent-group hypotheses of + \ref{lem:cantor-bendixson-pure-power-cancellation}, let + $b,c\in R((G^{\le0}))$ have additively principal values + $V_{\mathrm{CB}}(b)=B>1$ and $V_{\mathrm{CB}}(c)=C>1$. Write + $B=\rho_B\odot\pi_B$ and $C=\rho_C\odot\pi_C$ as above, and suppose + $\pi_B\le\pi_C$. If, for every $\gamma<0$ sufficiently close to $0$, + \[ + V_{\mathrm{CB}}(b^{\vert\gamma})=\rho_B + \quad\Longrightarrow\quad + V_{\mathrm{CB}}\!\left( + b^{\vert\gamma}b^mc^2 + \right) + =B^{\odot m}\odot\rho_B\odot C\odot C, + \] + then + \[ + V_{\mathrm{CB}}(b^{m+1}c) + =B^{\odot(m+1)}\odot C. + \] + -/) + (proof := /-- + Put $d=b^{m+1}c$. Multiply the translated-truncation expansion of $d$ + by $c$. Its main term is + $(m+1)b^{\vert\gamma}b^mc^2$; the two remaining terms have strictly + smaller value by + \ref{lem:cantor-bendixson-value-product-upper-bound}, the ordering + $\pi_B\le\pi_C$, and the ordinal factorisation of $B$ and $C$. Thus the + hypothesis computes $V_{\mathrm{CB}}(c d^{\vert\gamma})$. If + $V_{\mathrm{CB}}(d^{\vert\gamma})$ were too small, the same upper bound + would contradict this computation. The resulting local lower bound is + lifted to $0$ by + \ref{lem:cantor-bendixson-rank-reconstruction}; the product upper bound + gives the reverse inequality. + -/)] +theorem cantorBendixsonValue_pow_mul_eq_of_eventually (b c : HahnSeries G R) + (hb : b.support ⊆ Iic 0) (hc : c.support ⊆ Iic 0) + (B C : Ordinal.AdditivePrincipalAboveOne.{u}) + (hB : b.cantorBendixsonValue = B.val) (hC : c.cantorBendixsonValue = C.val) + (hp : B.principalFactor ≤ C.principalFactor) (m : ℕ) + (hyp : ∀ᶠ γ in 𝓝[<] (0 : G), + NatOrdinal.of (translate (-γ) (truncLE γ b)).cantorBendixsonValue = + NatOrdinal.of B.residualFactor → + NatOrdinal.of (translate (-γ) (truncLE γ b) * (b ^ m * c ^ 2)).cantorBendixsonValue = + NatOrdinal.of B.val ^ m * NatOrdinal.of B.residualFactor * + NatOrdinal.of C.val * NatOrdinal.of C.val) : + NatOrdinal.of (b ^ (m + 1) * c).cantorBendixsonValue = + NatOrdinal.of B.val ^ (m + 1) * NatOrdinal.of C.val := by + let X := NatOrdinal.of B.val ^ m * NatOrdinal.of B.residualFactor * NatOrdinal.of C.val + let d := b ^ (m + 1) * c + have hd : d.support ⊆ Iic 0 := + (nonpositiveSubring G R).mul_mem ((nonpositiveSubring G R).pow_mem hb _) hc + have hX := B.power_residual_mul_factorization C hp m + have hCpos : 0 < NatOrdinal.of C.val := pos_iff_ne_zero.mpr C.2.1.ne_zero + have hXpos : 0 < X := pos_iff_ne_zero.mpr hX.1.ne_zero + have hZ : X * NatOrdinal.of B.principalFactor = + NatOrdinal.of B.val ^ (m + 1) * NatOrdinal.of C.val := by + dsimp only [X] + rw [mul_assoc, mul_comm (NatOrdinal.of C.val), ← mul_assoc, mul_assoc _ _ + (NatOrdinal.of B.principalFactor), B.naturalResidual_mul_naturalPrincipal, ← pow_succ] + refine le_antisymm ?_ ?_ + · exact (cantorBendixsonValue_mul_le _ _ ((nonpositiveSubring G R).pow_mem hb _) hc).trans + (mul_le_mul' (by simpa only [hB] using b.cantorBendixsonValue_pow_le hb (m + 1)) + (le_of_eq (congrArg NatOrdinal.of hC))) + by_contra hcon + rw [not_le, ← hZ] at hcon + have hkey : ∀ᶠ γ in 𝓝[<] (0 : G), V (T b, γ) = NatOrdinal.of B.residualFactor → + X ≤ V (T d, γ) := by + have hcut := (c.eventually_value_translated_truncLE_lt + (hC ▸ C.2.1.ne_zero)).filter_mono (nhdsWithin_le_nhds (s := Iio (0 : G))) + filter_upwards [hyp, b.eventually_cantorBendixsonValue_leibnizPowerRemainder_lt + c hb hc B C hB hC hp m, hcut, self_mem_nhdsWithin] + with γ hγ hrem hcut hneg he + let main := (m + 1) • (T b, γ * (b ^ m * c ^ 2)) + let s1 := d * T c, γ + let s2 := c * leibnizPowerRemainder b c m γ + have hid : c * T d, γ = main + s1 + s2 := by + dsimp only [main, s1, s2, d] + rw [leibnizPowerRemainder_eq] + simp only [nsmul_eq_mul] + ring + have hmain : V main = X * NatOrdinal.of C.val := by + dsimp only [main] + rw [cantorBendixsonValue_nsmul _ _ (Nat.cast_ne_zero.mpr (Nat.succ_ne_zero m))] + exact hγ he + have hs1 : V s1 < X * NatOrdinal.of C.val := by + refine (d.cantorBendixsonValue_mul_le (T c, γ) hd + (c.support_translated_truncLE γ)).trans_lt ?_ + apply small_mul_lt B C hp X hXpos hX.2 hcon + exact NatOrdinal.of.lt_iff_lt.mpr (hC ▸ hcut (ne_of_lt hneg)) + have hs2 : V s2 < X * NatOrdinal.of C.val := by + have hle := c.cantorBendixsonValue_mul_le (leibnizPowerRemainder b c m γ) hc + (support_leibnizPowerRemainder b c hb hc m γ) + rw [hC] at hle + have hlt : NatOrdinal.of C.val * V (leibnizPowerRemainder b c m γ) < + NatOrdinal.of C.val * X := mul_lt_mul_of_pos_left hrem hCpos + rw [mul_comm _ X] at hlt + exact hle.trans_lt hlt + have hsmall : (s1 + s2).cantorBendixsonValue < + main.cantorBendixsonValue := by + apply (s1.cantorBendixsonValue_add_le s2).trans_lt + apply max_lt + · exact NatOrdinal.of.lt_iff_lt.mp (hs1.trans_eq hmain.symm) + · exact NatOrdinal.of.lt_iff_lt.mp (hs2.trans_eq hmain.symm) + have hsum := main.cantorBendixsonValue_add_eq_max_of_ne (s1 + s2) (ne_of_gt hsmall) + rw [max_eq_left hsmall.le] at hsum + have hval : V (c * T d, γ) = X * NatOrdinal.of C.val := by + rw [hid, add_assoc] + exact (congrArg NatOrdinal.of hsum).trans hmain + have hmul := c.cantorBendixsonValue_mul_le (T d, γ) hc (d.support_translated_truncLE γ) + rw [hC] at hmul + have hmul' : NatOrdinal.of C.val * X ≤ NatOrdinal.of C.val * V (T d, γ) := by + rw [mul_comm _ X, ← hval] + exact hmul + exact le_of_mul_le_mul_left hmul' hCpos + have hlow := cantorBendixsonValue_residual_reconstruction b d hb B hB X hX.1 hkey + rw [← hX.2] at hlow + exact (not_le.mpr hcon) hlow + +end HahnSeries diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/CantorBendixsonRankLevels.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/CantorBendixsonRankLevels.lean new file mode 100644 index 0000000000..b568257bbd --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/CantorBendixsonRankLevels.lean @@ -0,0 +1,197 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.TranslatedTruncationInterpolationOnSets + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint + +/-! +# Cantor–Bendixson rank levels of a closed support + +The interpolation theorem over an arbitrary set of centers asks for five things. This file checks +them for the exact-rank level of a single series, so that the level version is recovered, and +records the two closure facts in the form a union of levels will use: the closure of a level is the +corresponding derivative stage, and near zero a point of that derivative whose truncations have +already dropped lies in the level itself. +-/ + +universe u v w + +open scoped NatOrdinal Topology + +open Filter Set TopologicalSpace HahnSeries + +public noncomputable section + +namespace HahnSeries.Nonpositive + +variable {G : Type u} {R : Type v} +variable [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [UniformSpace G] [IsUniformAddGroup G] [OrderTopology G] [Nontrivial G] [CompleteSpace G] + [CommRing R] [NoZeroDivisors R] [CharZero R] + +local notation "ν" => (cantorBendixsonDegreeValuation (G := G) (R := R)) + +variable (p : Nonpositive G R) (α : NatOrdinal.{u}) + +/-- The exact-rank level of a series, as a subset of the exponents. -/ +def rankLevelSet : Set G := + {x | x ∈ (p : HahnSeries G R).closedSupport ∧ + (p : HahnSeries G R).closedSupport.cantorBendixsonRank + (p : HahnSeries G R).closedSupport_isPWO x = α.val} + +omit [IsUniformAddGroup G] [Nontrivial G] [CompleteSpace G] [NoZeroDivisors R] + [CharZero R] in +theorem mem_rankLevelSet_iff {x : G} : + x ∈ rankLevelSet p α ↔ x ∈ (p : HahnSeries G R).closedSupport ∧ + (p : HahnSeries G R).closedSupport.cantorBendixsonRank + (p : HahnSeries G R).closedSupport_isPWO x = α.val := Iff.rfl + +omit [IsUniformAddGroup G] [Nontrivial G] [CompleteSpace G] [NoZeroDivisors R] + [CharZero R] in +/-- A level sits at or below zero, since the support does. -/ +theorem rankLevelSet_subset_Iic : rankLevelSet p α ⊆ Iic 0 := fun _ hx ↦ + closure_minimal p.property isClosed_Iic ((mem_closedSupport _ _).mp hx.1) + +omit [IsUniformAddGroup G] [Nontrivial G] [CompleteSpace G] [NoZeroDivisors R] + [CharZero R] in +/-- The closure of a level is the corresponding derivative stage. -/ +theorem closure_rankLevelSet : + closure (rankLevelSet p α) = + ((p : HahnSeries G R).closedSupport.cantorBendixson α.val : Set G) := + (p : HahnSeries G R).closedSupport.closure_rank_level_eq + (p : HahnSeries G R).closedSupport_isPWO α.val + +/-- **Near zero the level is recovered from its closure.** Once the truncations of the series have +dropped to the level's degree, a point of the derivative stage has exactly that rank, so it lies in +the level. -/ +theorem eventually_mem_rankLevelSet_of_mem_closure (hp : ν p ≤ (α + 1 : NatOrdinal)) : + ∀ᶠ γ in 𝓝[<] (0 : G), γ ∈ closure (rankLevelSet p α) → γ ∈ rankLevelSet p α := by + filter_upwards [eventually_degree_translatedTruncLE_le p α hp] with γ hpγ hγ + rw [closure_rankLevelSet] at hγ + have hmem := ((p : HahnSeries G R).mem_support_derivative_iff γ α.val).mp hγ + refine ⟨(mem_closedSupport _ _).mpr hmem.1, ?_⟩ + rw [← cantorBendixsonRank_eq] + exact cantorBendixsonRank_eq_of_mem_derivative_of_degree_translatedTruncLE_le α p γ + ((mem_closedSupport _ _).mpr hmem.1) hmem.2 hpγ + +/-- The origin has dropped out of the stage two above the level's. -/ +theorem notMem_cantorBendixson_add_two (hp : ν p ≤ (α + 1 : NatOrdinal)) : + (0 : G) ∉ ((p : HahnSeries G R).closedSupport.cantorBendixson ((α.val + 1) + 1) : Set G) := by + have hpRank : (p : HahnSeries G R).cantorBendixsonRank 0 ≤ α.val + 1 := by + by_cases hm : 0 ∈ (p : HahnSeries G R).closedSupport + · rw [cantorBendixsonDegreeValuation_of_mem p hm, WithBot.coe_le_coe] at hp + have h := NatOrdinal.of.symm.monotone hp + change NatOrdinal.val (NatOrdinal.of ((p : HahnSeries G R).cantorBendixsonRank 0)) ≤ + NatOrdinal.val (α + 1) at h + simpa only [NatOrdinal.val_of, NatOrdinal.val_add_one] using h + · rw [cantorBendixsonRank_eq, + (p : HahnSeries G R).closedSupport.cantorBendixsonRank_of_notMem + (p : HahnSeries G R).closedSupport_isPWO hm] + exact zero_le + intro hm + have hr := ((p : HahnSeries G R).mem_support_derivative_iff 0 _).mp hm |>.2 + exact (not_le_of_gt (hpRank.trans_lt (lt_add_one _))) hr + +omit [IsUniformAddGroup G] [Nontrivial G] [CompleteSpace G] [NoZeroDivisors R] + [CharZero R] in +/-- **A level is discrete.** -/ +theorem isDiscrete_rankLevelSet : IsDiscrete (rankLevelSet p α) := + (p : HahnSeries G R).closedSupport.rankLevel_isDiscrete + (p : HahnSeries G R).closedSupport_isPWO α.val + +/-- **Near zero a level stays away from every point it does not contain.** Past the cutoff where +the truncations of the series have dropped to the level's degree, a point of the derivative stage +has exactly that rank, so the level agrees there with its own closure and its complement is a +neighbourhood of every other point. -/ +theorem exists_compl_rankLevelSet_mem_nhds (hp : ν p ≤ (α + 1 : NatOrdinal)) : + ∃ η < (0 : G), ∀ x, η < x → x < 0 → x ∉ rankLevelSet p α → + (rankLevelSet p α)ᶜ ∈ 𝓝 x := by + obtain ⟨η, hη, hcut⟩ := + eventually_nhdsLT_iff_exists.mp (eventually_mem_rankLevelSet_of_mem_closure p α hp) + refine ⟨η, hη, fun x hηx hx0 hxL ↦ ?_⟩ + have hopen : IsOpen (Ioo η 0 ∩ (closure (rankLevelSet p α))ᶜ) := + isOpen_Ioo.inter isClosed_closure.isOpen_compl + have hmem : x ∈ Ioo η 0 ∩ (closure (rankLevelSet p α))ᶜ := + ⟨⟨hηx, hx0⟩, fun hc ↦ hxL (hcut x hηx hx0 hc)⟩ + refine Filter.mem_of_superset (hopen.mem_nhds hmem) ?_ + exact fun y hy hyL ↦ hy.2 (subset_closure hyL) + +variable {B : Type w} [Finite B] + +/-- **A finite family of levels is discrete above a common cutoff.** Each level is discrete, and +past its own cutoff it stays away from the points it misses; taking the largest of finitely many +cutoffs makes all of them do so at once, so the union is discrete there. -/ +@[blueprint "lem:discrete-finite-union-cantor-bendixson-rank-sets" + (phase := "Algebraic independence in graded rings") + (title := "Discrete finite unions of Cantor--Bendixson rank sets") + (statement := /-- + Let $G$ be a nontrivial ordered abelian group with compatible additive + uniformity and order topology, and let $R$ be a characteristic-zero + domain. Assume that $G$ is Cauchy complete. Write $\nu$ for the + Cantor--Bendixson degree on + $R((G^{\leq 0}))$. For a series $q$ and an ordinal $\rho$, let + \[ + L_\rho(q)=\{\gamma\in\overline{\operatorname{supp}(q)}: + \operatorname{rk}_{\overline{\operatorname{supp}(q)}}(\gamma)=\rho\}. + \] + If $B$ is finite and $\nu(q_b)\leq\rho_b+1$ for every $b\in B$, then + there is $\eta<0$ such that + \[ + \bigcup_{b\in B}\bigl(L_{\rho_b}(q_b)\cap(\eta,0)\bigr) + \] + is discrete. + -/) + (proof := /-- + By \ref{thm:cantor-bendixson-value-multiplicative}, the Cantor--Bendixson + degree is the multiplicative degree denoted by $\nu$. Each exact-rank set + is discrete. Moreover, once the translated + truncations of $q_b$ have degree at most $\rho_b$, the exact-rank set + agrees locally with its closure. Choose such a negative cutoff for each + $b$ and take their maximum. Above this common cutoff, each set has a + neighbourhood disjoint from every other set at any point it does not + contain. The finite union is therefore discrete. + -/)] +theorem exists_isDiscrete_iUnion_rankLevelSet + (q : B → Nonpositive G R) (ρ : B → NatOrdinal.{u}) + (hq : ∀ b, ν (q b) ≤ (ρ b + 1 : NatOrdinal)) : + ∃ η < (0 : G), IsDiscrete (⋃ b : B, rankLevelSet (q b) (ρ b) ∩ Ioo η 0) := by + classical + cases nonempty_fintype B + choose ηf hηf hcut using fun b ↦ exists_compl_rankLevelSet_mem_nhds (q b) (ρ b) (hq b) + obtain ⟨η₀, hη₀⟩ := exists_lt (0 : G) + rcases isEmpty_or_nonempty B with hB | hB + · refine ⟨η₀, hη₀, ?_⟩ + simp only [Set.iUnion_of_empty] + rw [isDiscrete_iff_nhdsNE] + simp + have hne : ((Finset.univ : Finset B).image ηf).Nonempty := + (Finset.univ_nonempty (α := B)).image ηf + set ηmax : G := ((Finset.univ : Finset B).image ηf).max' hne with hηmaxdef + have hηmax0 : ηmax < 0 := by + obtain ⟨b, -, hb⟩ := Finset.mem_image.mp (Finset.max'_mem _ hne) + rw [hηmaxdef, ← hb] + exact hηf b + have hle : ∀ b, ηf b ≤ ηmax := fun b ↦ + Finset.le_max' _ _ (Finset.mem_image_of_mem ηf (Finset.mem_univ b)) + refine ⟨ηmax, hηmax0, ?_⟩ + have hiUnion : (⋃ b : B, rankLevelSet (q b) (ρ b) ∩ Ioo ηmax 0) = + ⋃ b ∈ (Finset.univ : Finset B), rankLevelSet (q b) (ρ b) ∩ Ioo ηmax 0 := by + simp + rw [hiUnion] + refine TopologicalSpace.Closeds.isDiscrete_biUnion _ _ (fun b _ ↦ ?_) (fun i _ j _ x hx hxi ↦ ?_) + · exact (isDiscrete_rankLevelSet (q b) (ρ b)).mono Set.inter_subset_left + · by_cases hxL : x ∈ rankLevelSet (q i) (ρ i) + · have hxIoo : x ∈ Ioo ηmax 0 := hx.2 + exact absurd ⟨hxL, hxIoo⟩ hxi + · refine Filter.mem_of_superset + (hcut i x (lt_of_le_of_lt (hle i) hx.2.1) hx.2.2 hxL) ?_ + exact fun y hy hyi ↦ hy hyi.1 + +end HahnSeries.Nonpositive + +end diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/CantorBendixsonValue.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/CantorBendixsonValue.lean new file mode 100644 index 0000000000..97edfd2aea --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/CantorBendixsonValue.lean @@ -0,0 +1,173 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Topology.CantorBendixsonRank +public import Mathlib.RingTheory.HahnSeries.Basic +public import Mathlib.SetTheory.Ordinal.Exponential +public import Mathlib.Topology.Order.LeftRightNhds + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint + +/-! +# Cantor–Bendixson ranks of closed Hahn supports + +The closed support is taken in the exponent type's given order topology. Its point ranks use +transfinite derived sets in that same topology, without passing to an order completion. + +At exponent zero the associated ordinal value is zero if zero is outside the closed support, +and is `omega` to the point rank otherwise. In particular, a finite support has value one exactly +when its zero coefficient is nonzero, and value zero otherwise. These definitions impose no +multiplicativity assertion. +-/ + +public noncomputable section + +open Set Topology TopologicalSpace + +universe u v + +namespace HahnSeries + +variable {Γ : Type u} {R : Type v} [LinearOrder Γ] [TopologicalSpace Γ] + [OrderTopology Γ] [Zero R] + +/-- The closure of the Hahn support in the given topology on the exponent type. -/ +def closedSupport (b : HahnSeries Γ R) : Closeds Γ := ⟨closure b.support, isClosed_closure⟩ + +omit [OrderTopology Γ] in +@[simp] +theorem coe_closedSupport (b : HahnSeries Γ R) : + (b.closedSupport : Set Γ) = closure b.support := (rfl) + +omit [OrderTopology Γ] in +@[simp] +theorem mem_closedSupport (b : HahnSeries Γ R) (x : Γ) : + x ∈ b.closedSupport ↔ x ∈ closure b.support := (Iff.rfl) + +/-- The ambient closed support remains well ordered. -/ +theorem closedSupport_isPWO (b : HahnSeries Γ R) : (b.closedSupport : Set Γ).IsPWO := by + rw [coe_closedSupport] + exact b.isPWO_support.closure + +/-- An abbreviation for the Cantor–Bendixson point rank of the closed support, zero outside it. -/ +def cantorBendixsonRank (b : HahnSeries Γ R) (x : Γ) : Ordinal.{u} := + b.closedSupport.cantorBendixsonRank b.closedSupport_isPWO x + +theorem cantorBendixsonRank_eq (b : HahnSeries Γ R) (x : Γ) : + b.cantorBendixsonRank x = b.closedSupport.cantorBendixsonRank b.closedSupport_isPWO x := (rfl) + +/-- Derivative membership characterizes the Cantor–Bendixson rank at each exponent. -/ +theorem mem_support_derivative_iff (b : HahnSeries Γ R) (x : Γ) (o : Ordinal.{u}) : + x ∈ (b.closedSupport.cantorBendixson o : Set Γ) ↔ + x ∈ closure b.support ∧ o ≤ b.cantorBendixsonRank x := by + rw [cantorBendixsonRank_eq, ← coe_closedSupport] + exact b.closedSupport.mem_cantorBendixson_iff b.closedSupport_isPWO x o + +variable [Zero Γ] + +/-- Zero off the closed support, and `omega` to its Cantor–Bendixson rank at zero otherwise. -/ +@[blueprint "def:cantor-bendixson-value" + (phase := "Cantor–Bendixson ranks of supports") + (title := "The Cantor--Bendixson value at exponent zero") + (statement := /-- + Let $G$ be a linearly ordered set with zero and its order topology, let + $R$ be a set with zero, and let $b\in R((G))$ be a generalised power + series. Write $C=\operatorname{cl}(\operatorname{supp}(b))$. If + $\operatorname{rk}_C(0)$ denotes the Cantor--Bendixson rank of $0$ in + $C$, define + \[ + V_{\mathrm{CB}}(b)= + \begin{cases} + \omega^{\operatorname{rk}_C(0)},&0\in C,\\ + 0,&0\notin C. + \end{cases} + \] + -/) + (proof := /-- + The closure of a well-ordered support is again well ordered, so its + Cantor--Bendixson point rank is defined. The displayed alternatives are + the two branches of the definition. + -/)] +def cantorBendixsonValue (b : HahnSeries Γ R) : Ordinal.{u} := by + classical + exact if 0 ∈ b.closedSupport then Ordinal.omega0 ^ b.cantorBendixsonRank 0 else 0 + +/-- At a closed-support point, the value is the corresponding power of `omega`. -/ +theorem cantorBendixsonValue_of_mem (b : HahnSeries Γ R) (h : 0 ∈ closure b.support) : + b.cantorBendixsonValue = Ordinal.omega0 ^ b.cantorBendixsonRank 0 := by + simp only [cantorBendixsonValue, mem_closedSupport, h, ite_true] + +/-- A support avoiding a neighborhood of zero has value zero. -/ +theorem cantorBendixsonValue_of_notMem (b : HahnSeries Γ R) (h : 0 ∉ closure b.support) : + b.cantorBendixsonValue = 0 := by + simp only [cantorBendixsonValue, mem_closedSupport, h, ite_false] + +/-- The value vanishes exactly when zero is outside the ambient closed support. -/ +theorem cantorBendixsonValue_eq_zero_iff (b : HahnSeries Γ R) : + b.cantorBendixsonValue = 0 ↔ 0 ∉ closure b.support := by + constructor + · intro hv hm + rw [b.cantorBendixsonValue_of_mem hm] at hv + exact (Ordinal.opow_pos _ Ordinal.omega0_pos).ne' hv + · exact b.cantorBendixsonValue_of_notMem + +@[simp] +theorem cantorBendixsonValue_zero : (0 : HahnSeries Γ R).cantorBendixsonValue = 0 := by + apply cantorBendixsonValue_of_notMem + simp + +omit [Zero Γ] in +/-- Finite Hahn supports have point rank zero everywhere. -/ +theorem cantorBendixsonRank_of_finite (b : HahnSeries Γ R) (hfin : b.support.Finite) (x : Γ) : + b.cantorBendixsonRank x = 0 := by + rw [cantorBendixsonRank_eq] + apply b.closedSupport.cantorBendixsonRank_of_finite b.closedSupport_isPWO + simpa only [coe_closedSupport, hfin.isClosed.closure_eq] using hfin + +/-- A finite support with nonzero ordinary coefficient has value one. -/ +theorem cantorBendixsonValue_of_finite_of_coeff_ne_zero (b : HahnSeries Γ R) + (hfin : b.support.Finite) (h : b.coeff 0 ≠ 0) : b.cantorBendixsonValue = 1 := by + rw [b.cantorBendixsonValue_of_mem (subset_closure h), b.cantorBendixsonRank_of_finite hfin] + exact Ordinal.opow_zero _ + +/-- A finite support with zero ordinary coefficient has value zero. -/ +theorem cantorBendixsonValue_of_finite_of_coeff_eq_zero (b : HahnSeries Γ R) + (hfin : b.support.Finite) (h : b.coeff 0 = 0) : b.cantorBendixsonValue = 0 := by + apply b.cantorBendixsonValue_of_notMem + rw [hfin.isClosed.closure_eq] + simpa using h + +/-- For nonpositive supports, value zero is equivalent to a strictly negative support bound. -/ +theorem cantorBendixsonValue_eq_zero_iff_support_bounded_lt [NoMinOrder Γ] + (b : HahnSeries Γ R) (hb : b.support ⊆ Iic 0) : + b.cantorBendixsonValue = 0 ↔ ∃ c < (0 : Γ), b.support ⊆ Iic c := by + rw [cantorBendixsonValue_eq_zero_iff] + constructor + · intro hn + have hnh : (closure b.support)ᶜ ∈ 𝓝[≤] (0 : Γ) := + nhdsWithin_le_nhds (isClosed_closure.isOpen_compl.mem_nhds hn) + obtain ⟨c, hc, hcut⟩ := mem_nhdsLE_iff_exists_Ioc_subset.mp hnh + refine ⟨c, hc, fun x hx ↦ ?_⟩ + apply le_of_not_gt + intro hcx + exact hcut ⟨hcx, hb hx⟩ (subset_closure hx) + · rintro ⟨c, hc, hbound⟩ hmem + exact (not_le_of_gt hc) (closure_minimal hbound isClosed_Iic hmem) + +/-- Equal supports give equal Cantor–Bendixson values. -/ +theorem cantorBendixsonValue_congr_support {b d : HahnSeries Γ R} (h : b.support = d.support) : + b.cantorBendixsonValue = d.cantorBendixsonValue := by + have he : b.closedSupport = d.closedSupport := by + apply Closeds.ext + simp only [coe_closedSupport, h] + have hr : b.cantorBendixsonRank 0 = d.cantorBendixsonRank 0 := by + simp only [cantorBendixsonRank_eq, he] + by_cases hm : 0 ∈ closure b.support + · rw [b.cantorBendixsonValue_of_mem hm, d.cantorBendixsonValue_of_mem (h ▸ hm), hr] + · rw [b.cantorBendixsonValue_of_notMem hm, d.cantorBendixsonValue_of_notMem (h ▸ hm)] + +end HahnSeries diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/CantorBendixsonValueMultiplicativity.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/CantorBendixsonValueMultiplicativity.lean new file mode 100644 index 0000000000..742429dadd --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/CantorBendixsonValueMultiplicativity.lean @@ -0,0 +1,300 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.Cancellation +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Nonpositive +import LeanPool.ConwayRefinement.ConwayRefinement.Data.Multiset.SelectionComplexity +import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.NaturalPowerFactorization + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint + +/-! +# Multiplicativity of the Cantor–Bendixson value + +For nonpositive Hahn series over a characteristic-zero domain, the value defined by the +Cantor--Bendixson rank at zero is multiplicative for natural ordinal multiplication. The +exponent group is a nontrivial ordered uniform additive group that is Cauchy complete. + +The finite-multiset induction selects a factor with least principal factor, then greatest +value. Replacing one copy by its residual truncation and doubling the remaining factors +strictly decreases the distinct-factor complexity. Conditional cancellation therefore applies +without a remaining hypothesis on smaller products. Values zero and one are handled separately. + +This proof uses Cantor–Bendixson ranks and the finite convolution theorem, not the real-exponent +order-value valuation. Completeness of the exponent group is retained. +-/ + +public noncomputable section +open Set Filter Topology +universe u v +namespace HahnSeries +variable {G : Type u} {R : Type v} [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [UniformSpace G] [OrderTopology G] [CommRing R] + +private abbrev Factor := {b : ↥(nonpositiveSubring G R) // + 1 < (b : HahnSeries G R).cantorBendixsonValue} + +private def factorOrdinal (b : Factor (G := G) (R := R)) : Ordinal.AdditivePrincipalAboveOne.{u} := + ⟨(b.1 : HahnSeries G R).cantorBendixsonValue, by + have hb : 0 ∈ closure (b.1 : HahnSeries G R).support := by + by_contra h + have hpos := b.2 + rw [cantorBendixsonValue_of_notMem _ h] at hpos + exact not_lt_of_ge (zero_le : (0 : Ordinal.{u}) ≤ 1) hpos + rw [cantorBendixsonValue_of_mem _ hb] + exact Ordinal.isAdditivelyPrincipal_omega0_opow _, b.2⟩ + +private def selection : Multiset.SelectionWeights.{u, max u v} (Factor (G := G) (R := R)) := + ⟨fun b ↦ (factorOrdinal b).principalFactor, fun b ↦ (b.1 : HahnSeries G R).cantorBendixsonValue⟩ + +private def eval (w : Multiset (Factor (G := G) (R := R))) : + ↥(nonpositiveSubring G R) := (w.map (·.1)).prod + +private def valueProd (w : Multiset (Factor (G := G) (R := R))) : NatOrdinal.{u} := + (w.map fun x ↦ NatOrdinal.of (x.1 : HahnSeries G R).cantorBendixsonValue).prod + +private theorem eval_add (w w' : Multiset (Factor (G := G) (R := R))) : + eval (w + w') = eval w * eval w' := by + simp only [eval, Multiset.map_add, Multiset.prod_add] + +private theorem eval_singleton (x : Factor (G := G) (R := R)) : + eval {x} = x.1 := by + simp only [eval, Multiset.map_singleton, Multiset.prod_singleton] + +private theorem valueProd_singleton (x : Factor (G := G) (R := R)) : + valueProd {x} = NatOrdinal.of (x.1 : HahnSeries G R).cantorBendixsonValue := by + simp only [valueProd, Multiset.map_singleton, Multiset.prod_singleton] + +private theorem eval_replicate (n : ℕ) (x : Factor (G := G) (R := R)) : + eval (Multiset.replicate n x) = x.1 ^ n := by + simp only [eval, Multiset.map_replicate, Multiset.prod_replicate] + +private theorem valueProd_add (w w' : Multiset (Factor (G := G) (R := R))) : + valueProd (w + w') = valueProd w * valueProd w' := by + simp only [valueProd, Multiset.map_add, Multiset.prod_add] + +private theorem valueProd_replicate (n : ℕ) (x : Factor (G := G) (R := R)) : + valueProd (Multiset.replicate n x) = + NatOrdinal.of (x.1 : HahnSeries G R).cantorBendixsonValue ^ n := by + simp only [valueProd, Multiset.map_replicate, Multiset.prod_replicate] + +private theorem one_le_valueProd (w : Multiset (Factor (G := G) (R := R))) : + 1 ≤ valueProd w := by + induction w using Multiset.induction with + | empty => simp [valueProd] + | cons a s ih => + rw [valueProd, Multiset.map_cons, Multiset.prod_cons, ← valueProd] + simpa only [NatOrdinal.of_one, one_mul] using mul_le_mul' + (NatOrdinal.of.le_iff_le.mpr a.2.le) ih + +private theorem one_lt_valueProd {w : Multiset (Factor (G := G) (R := R))} (hw : w ≠ 0) : + 1 < valueProd w := by + obtain ⟨a, ha⟩ := Multiset.exists_mem_of_ne_zero hw + obtain ⟨s, rfl⟩ := Multiset.exists_cons_of_mem ha + rw [valueProd, Multiset.map_cons, Multiset.prod_cons, ← valueProd] + calc (1 : NatOrdinal.{u}) < NatOrdinal.of (a.1 : HahnSeries G R).cantorBendixsonValue := + a.2 + _ = NatOrdinal.of (a.1 : HahnSeries G R).cantorBendixsonValue * 1 := (mul_one _).symm + _ ≤ _ := mul_le_mul' le_rfl (one_le_valueProd s) + +private theorem eval_zero : eval (0 : Multiset (Factor (G := G) (R := R))) = 1 := by + simp only [eval, Multiset.map_zero, Multiset.prod_zero] + +private theorem valueProd_zero : valueProd (0 : Multiset (Factor (G := G) (R := R))) = 1 := by + simp only [valueProd, Multiset.map_zero, Multiset.prod_zero] + +private def translated (b : ↥(nonpositiveSubring G R)) (γ : G) : + ↥(nonpositiveSubring G R) := + ⟨translate (-γ) (truncLE γ (b : HahnSeries G R)), support_translated_truncLE _ _⟩ + +local notation "V" => (fun b : ↥(nonpositiveSubring G R) ↦ + NatOrdinal.of (cantorBendixsonValue (b : HahnSeries G R))) + +variable [IsUniformAddGroup G] [Nontrivial G] [CompleteSpace G] + [NoZeroDivisors R] [CharZero R] + +omit [IsUniformAddGroup G] [Nontrivial G] [CompleteSpace G] [NoZeroDivisors R] in +private theorem value_one : V 1 = 1 := by + apply congrArg NatOrdinal.of + exact cantorBendixsonValue_of_finite_of_coeff_ne_zero (1 : HahnSeries G R) + (by rw [support_one]; exact finite_singleton _) (by simp) + +private theorem value_eval (w : Multiset (Factor (G := G) (R := R))) : + V (eval w) = valueProd w := by + let s := selection (G := G) (R := R) + suffices h : ∀ p : Multiset Ordinal.{u} × ℕ, + ∀ (w : Multiset (Factor (G := G) (R := R))) (hw : w ≠ 0), + s.complexity w hw = p → V (eval w) = valueProd w by + rcases eq_or_ne w 0 with rfl | hw + · rw [eval_zero, valueProd_zero, value_one] + · exact h _ w hw rfl + refine fun p ↦ Multiset.SelectionWeights.wellFounded_complexityLT.induction + (C := fun q ↦ ∀ (w : Multiset (Factor (G := G) (R := R))) (hw : w ≠ 0), + s.complexity w hw = q → V (eval w) = valueProd w) p ?_ + clear p + intro p ih w hw hp + classical + have IH : ∀ w' : Multiset (Factor (G := G) (R := R)), + (∀ hw' : w' ≠ 0, Multiset.SelectionWeights.ComplexityLT + (s.complexity w' hw') (s.complexity w hw)) → + V (eval w') = valueProd w' := by + intro w' hlt + rcases eq_or_ne w' 0 with rfl | hw' + · rw [eval_zero, valueProd_zero, value_one] + · exact ih (s.complexity w' hw') (hp ▸ hlt hw') w' hw' rfl + set x := s.selected w hw with hx + set r := s.unselected w hw with hrdef + obtain ⟨m, hm⟩ : ∃ m, s.selectedExponent w hw = m + 1 := + ⟨s.selectedExponent w hw - 1, by have := s.one_le_selectedExponent w hw; omega⟩ + have hdecomp : w = Multiset.replicate (m + 1) x + r := by + rw [hrdef, hx, ← hm, s.replicate_selectedExponent_add_unselected] + have heval : eval w = x.1 ^ (m + 1) * eval r := by + conv_lhs => rw [hdecomp] + rw [eval_add, eval_replicate] + have hvp : valueProd w = V x.1 ^ (m + 1) * valueProd r := by + conv_lhs => rw [hdecomp] + rw [valueProd_add, valueProd_replicate] + have hr : V (eval r) = valueProd r := + IH r fun hr0 ↦ s.complexityLT_unselected hw hr0 + have hIHred : ∀ t : Multiset (Factor (G := G) (R := R)), + (∀ u ∈ t, V u.1 < V x.1) → + (∀ u ∈ t, (factorOrdinal x).principalFactor ≤ (factorOrdinal u).principalFactor) → + V (eval t * x.1 ^ m * (eval r * eval r)) = + valueProd t * V x.1 ^ m * (valueProd r * valueProd r) := by + intro t ht htp + have hred := IH (s.reduced w hw t) fun hne ↦ + s.complexityLT_reduced w hw t ht htp hne + rw [s.reduced_eq, hm, Nat.add_sub_cancel] at hred + simpa only [eval_add, eval_replicate, valueProd_add, valueProd_replicate] using hred + have hkey : ∀ᶠ γ in 𝓝[<] (0 : G), + V (translated x.1 γ) = NatOrdinal.of (factorOrdinal x).residualFactor → + V (translated x.1 γ * x.1 ^ m * (eval r * eval r)) = + V x.1 ^ m * V (translated x.1 γ) * valueProd r * valueProd r := by + have hcut := ((x.1 : HahnSeries G R).eventually_value_translated_truncLE_lt + (ne_of_gt (zero_lt_one.trans x.2))).filter_mono + (nhdsWithin_le_nhds (s := Iio (0 : G))) + filter_upwards [hcut, self_mem_nhdsWithin] with γ hγ hneg he + have hsmall : V (translated x.1 γ) < V x.1 := hγ (ne_of_lt hneg) + by_cases hg1 : 1 < V (translated x.1 γ) + · let z : Factor (G := G) (R := R) := ⟨translated x.1 γ, hg1⟩ + have hpri : (factorOrdinal x).principalFactor ≤ (factorOrdinal z).principalFactor := + (factorOrdinal x).principalFactor_le_principalFactor_of_eq_residualFactor + (factorOrdinal z) (NatOrdinal.of.injective he) + have h := hIHred {z} + (fun u hu ↦ by rw [Multiset.mem_singleton.mp hu]; exact hsmall) + (fun u hu ↦ by rw [Multiset.mem_singleton.mp hu]; exact hpri) + rw [eval_singleton, valueProd_singleton] at h + change V (translated x.1 γ * x.1 ^ m * (eval r * eval r)) = _ at h + dsimp only at h + rw [h] + ring + · have hone : V (translated x.1 γ) = 1 := by + have hne : V (translated x.1 γ) ≠ 0 := by + dsimp only + rw [he] + exact (factorOrdinal x).residualFactor_isAdditivelyPrincipal.ne_zero + exact le_antisymm (not_lt.mp hg1) (Order.one_le_iff_pos.mpr (pos_iff_ne_zero.mpr hne)) + have h := hIHred 0 (by simp) (by simp) + rw [eval_zero, valueProd_zero, one_mul, one_mul] at h + have hmul : V (translated x.1 γ * (x.1 ^ m * (eval r * eval r))) = + V (x.1 ^ m * (eval r * eval r)) := + congrArg NatOrdinal.of (cantorBendixsonValue_mul_of_left_eq_one _ _ + (translated x.1 γ).property (x.1 ^ m * (eval r * eval r)).property + (NatOrdinal.of.injective hone)) + dsimp only at hmul h hone + rw [mul_assoc, hmul, h, hone] + ring + rcases eq_or_ne r 0 with hr0 | hr0 + · rw [heval, hvp, hr0, eval_zero, valueProd_zero, mul_one, mul_one] + apply cantorBendixsonValue_pow_eq_of_eventually (x.1 : HahnSeries G R) x.1.property + (factorOrdinal x) rfl m + filter_upwards [hkey] with γ hγ he + have h := hγ he + change V (translated x.1 γ) = _ at he + dsimp only at he + rw [he] at h + simpa only [hr0, eval_zero, valueProd_zero, mul_one, Subring.coe_mul, + Subring.coe_pow, translated, factorOrdinal] using h + · have hc1 : 1 < V (eval r) := hr ▸ one_lt_valueProd hr0 + let c : Factor (G := G) (R := R) := ⟨eval r, hc1⟩ + have hp' : (factorOrdinal x).principalFactor ≤ (factorOrdinal c).principalFactor := by + apply (factorOrdinal x).principalFactor_le_of_naturalProd (factorOrdinal c) + (r.map factorOrdinal) + · intro y hy + obtain ⟨z, hz, rfl⟩ := Multiset.mem_map.mp hy + exact (s.isSelected_selected w hw).min_priority z (s.mem_unselected.mp hz).1 + · simpa only [Multiset.map_map, Function.comp_def, valueProd, factorOrdinal] using hr + have hev : ∀ᶠ γ in 𝓝[<] (0 : G), + V (translated x.1 γ) = NatOrdinal.of (factorOrdinal x).residualFactor → + V (translated x.1 γ * (x.1 ^ m * c.1 ^ 2)) = + V x.1 ^ m * NatOrdinal.of (factorOrdinal x).residualFactor * V c.1 * V c.1 := by + filter_upwards [hkey] with γ hγ he + have h := hγ he + rw [he] at h + dsimp only at hr + simpa only [c, sq, mul_assoc, hr] using h + have h := cantorBendixsonValue_pow_mul_eq_of_eventually + (x.1 : HahnSeries G R) (c.1 : HahnSeries G R) x.1.property c.1.property + (factorOrdinal x) (factorOrdinal c) rfl rfl hp' m hev + rw [heval, hvp] + exact h.trans (congrArg (V x.1 ^ (m + 1) * ·) hr) + +/-- The Cantor–Bendixson value is multiplicative on nonpositive Hahn series over a +characteristic-zero domain with an ordered exponent group that is Cauchy complete. -/ +@[blueprint "thm:cantor-bendixson-value-multiplicative" + (phase := "Cantor–Bendixson ranks of supports") + (title := "Multiplicativity of the Cantor--Bendixson value") + (statement := /-- + Let $R$ be a characteristic-zero domain and let $G$ be a nontrivial + ordered abelian group equipped with a compatible additive uniformity and + its order topology. Assume that $G$ is Cauchy complete. For all + $b,c\in R((G^{\le0}))$, + \[ + V_{\mathrm{CB}}(bc) + =V_{\mathrm{CB}}(b)\odot V_{\mathrm{CB}}(c), + \] + where $\odot$ is Hessenberg's natural product. + -/) + (proof := /-- + If either value is $0$, the product upper bound forces the product value + to be $0$. A factor of value $1$ is a nonzero scalar at exponent $0$ + plus a remainder of value $0$, so it preserves the other value. For + values greater than $1$, argue by well-founded induction on the finite + multiset of factors. Choose a factor for which the final multiplicatively + principal factor is least, and among ties choose one of greatest value. + At a cutoff where its + translated truncation has the residual value, that truncation has smaller + value, so the induction hypothesis computes every required local product. + If no other factors remain, apply + \ref{lem:cantor-bendixson-pure-power-cancellation}; otherwise combine the + remaining factors and apply + \ref{lem:cantor-bendixson-power-factor-cancellation}. In both cases the + result is the natural product of the factor values, and the two-factor + statement follows. + -/) + (highlight)] +theorem cantorBendixsonValue_mul (b c : HahnSeries G R) + (hb : b.support ⊆ Iic 0) (hc : c.support ⊆ Iic 0) : + NatOrdinal.of (b * c).cantorBendixsonValue = + NatOrdinal.of b.cantorBendixsonValue * NatOrdinal.of c.cantorBendixsonValue := by + rcases eq_or_ne b.cantorBendixsonValue 0 with hb0 | hb0 + · rw [cantorBendixsonValue_mul_eq_zero_of_left b c hb hc hb0, hb0, + NatOrdinal.of_zero, zero_mul] + rcases eq_or_ne c.cantorBendixsonValue 0 with hc0 | hc0 + · rw [mul_comm b c, cantorBendixsonValue_mul_eq_zero_of_left c b hc hb hc0, hc0, + NatOrdinal.of_zero, mul_zero] + rcases eq_or_lt_of_le (Order.one_le_iff_pos.mpr (pos_iff_ne_zero.mpr hb0)) with hb1 | hb1 + · rw [cantorBendixsonValue_mul_of_left_eq_one b c hb hc hb1.symm, ← hb1, + NatOrdinal.of_one, one_mul] + rcases eq_or_lt_of_le (Order.one_le_iff_pos.mpr (pos_iff_ne_zero.mpr hc0)) with hc1 | hc1 + · rw [mul_comm b c, cantorBendixsonValue_mul_of_left_eq_one c b hc hb hc1.symm, ← hc1, + NatOrdinal.of_one, mul_one] + have h := value_eval ({⟨⟨b, hb⟩, hb1⟩, ⟨⟨c, hc⟩, hc1⟩} : + Multiset (Factor (G := G) (R := R))) + simpa [eval, valueProd] using h + +end HahnSeries diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/CofactorInduction.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/CofactorInduction.lean new file mode 100644 index 0000000000..aead30d0b4 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/CofactorInduction.lean @@ -0,0 +1,2040 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.GlobalCofactors +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.LowerTruncationDegree +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.SeparatedPieceCantorBendixson +public import LeanPool.ConwayRefinement.ConwayRefinement.Topology.Order.CantorBendixsonConvexCover +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MvPolynomial.ComponentsSpan +import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MvPolynomial.Components +import Mathlib.Algebra.MvPolynomial.CommRing +import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.GradedRing.HomogeneousSpan +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.Boundary +import LeanPool.ConwayRefinement.ConwayRefinement.Topology.Order.LeftNeighborhood + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint + +/-! +# Cofactors by well-founded induction + +This file constructs global cofactors by well-founded induction at arbitrary cofinality. Helper +lemmas transfer translated truncations between a sum, its terms on disjoint ordered convex +carriers, and the local series translated to the piece centers, all modulo series bounded strictly +below zero. +-/ + +public noncomputable section + +open Set Filter Topology MvPolynomial +open scoped NatOrdinal DirectSum + +universe u v w x + +namespace HahnSeries.Nonpositive + +variable {G : Type u} {K : Type v} [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [UniformSpace G] [IsUniformAddGroup G] [OrderTopology G] [Nontrivial G] [CompleteSpace G] + [Field K] [CharZero K] + +local notation "ν" => (cantorBendixsonDegreeValuation (G := G) (R := K)) + +/-- Reversing a difference preserves the property of having degree bottom. -/ +theorem degree_reverse_sub_eq_bot {a b : Nonpositive G K} (h : ν (a - b) = ⊥) : + ν (b - a) = ⊥ := by + rw [← (ν).map_neg, neg_sub] + exact h + +/-- Reversing a difference preserves every strict degree bound. -/ +theorem degree_reverse_sub_lt {a b : Nonpositive G K} {τ : WithBot NatOrdinal} + (h : ν (a - b) < τ) : ν (b - a) < τ := by + rw [← (ν).map_neg, neg_sub] + exact h + +/-- Three summands satisfying a common degree bound have a sum satisfying that bound. -/ +theorem degree_add_add_le {a b c : Nonpositive G K} {τ : WithBot NatOrdinal} + (ha : ν a ≤ τ) (hb : ν b ≤ τ) (hc : ν c ≤ τ) : ν (a + b + c) ≤ τ := + ((ν).map_add_le_max _ _).trans + (max_le (((ν).map_add_le_max _ _).trans (max_le ha hb)) hc) + +/-- Two terms and a finite family satisfying a common degree bound have a sum satisfying that +bound. -/ +theorem degree_add_add_sum_le {J : Type w} [Fintype J] + {a b : Nonpositive G K} {f : J → Nonpositive G K} {τ : WithBot NatOrdinal} + (ha : ν a ≤ τ) (hb : ν b ≤ τ) (hf : ∀ j, ν (f j) ≤ τ) : + ν (a + b + ∑ j, f j) ≤ τ := + ((ν).map_add_le_max _ _).trans (max_le + (((ν).map_add_le_max _ _).trans (max_le ha hb)) + ((ν).map_sum_le_of_forall_le Finset.univ f τ fun j _ ↦ hf j)) + +/-- Degrees agree modulo series bounded strictly below zero. -/ +theorem degree_eq_of_degree_sub_eq_bot {a b : Nonpositive G K} + (h : ν (a - b) = ⊥) : ν a = ν b := by + have h1 : ν a ≤ ν b := by + have := (ν).map_add_le_max (a - b) b + rw [sub_add_cancel, h, max_eq_right bot_le] at this + exact this + have h2 : ν b ≤ ν a := by + have hba : ν (b - a) = ⊥ := degree_reverse_sub_eq_bot h + have := (ν).map_add_le_max (b - a) a + rw [sub_add_cancel, hba, max_eq_right bot_le] at this + exact this + exact le_antisymm h1 h2 + +/-- The strict tail of a nonpositive series above a cutoff. -/ +def strictTail (c : G) (b : Nonpositive G K) : Nonpositive G K := + ⟨truncGT c (b : HahnSeries G K), fun _ hg ↦ b.property (support_truncGT_subset c _ hg)⟩ + +/-- Cutting away everything at or below a negative cutoff does not change the germ at zero. -/ +theorem degree_sub_strictTail_eq_bot {c : G} (hc : c < 0) (b : Nonpositive G K) : + ν (b - strictTail c b) = ⊥ := by + apply (cantorBendixsonDegreeValuation_eq_bot_iff _).mpr + refine ⟨c, hc, ?_⟩ + intro g hg + have hg' : (b : HahnSeries G K).coeff g - + (truncGT c (b : HahnSeries G K)).coeff g ≠ 0 := by + simpa only [AddSubgroupClass.coe_sub, HahnSeries.coeff_sub, strictTail] using + (mem_support _ _).mp hg + rw [HahnSeries.coeff_truncGT] at hg' + by_contra hcg + rw [ite_eq_left (not_le.mp hcg), sub_self] at hg' + exact hg' rfl + +/-- Above the cut, translated truncations of a series and its strict tail differ only by a series +bounded strictly below zero. -/ +theorem degree_translatedTruncLE_sub_strictTail_eq_bot {c y : G} (hcy : c < y) + (b : Nonpositive G K) : + ν (translatedTruncLE y (b - strictTail c b)) = ⊥ := by + apply (cantorBendixsonDegreeValuation_eq_bot_iff _).mpr + refine ⟨c - y, sub_neg.mpr hcy, ?_⟩ + intro g hg + have hg' : g + y ∈ ((b : HahnSeries G K) - + (strictTail c b : HahnSeries G K)).support := by + rw [coe_translatedTruncLE, mem_support, HahnSeries.coeff_translate, + HahnSeries.coeff_truncLE] at hg + split_ifs at hg with hle + · exact (mem_support _ _).mpr (by simpa using hg) + · exact absurd rfl hg + have hcoeff : (b : HahnSeries G K).coeff (g + y) - + (truncGT c (b : HahnSeries G K)).coeff (g + y) ≠ 0 := by + simpa only [HahnSeries.coeff_sub, strictTail] using (mem_support _ _).mp hg' + rw [HahnSeries.coeff_truncGT] at hcoeff + have hle : g + y ≤ c := by + by_contra hn + rw [ite_eq_left (not_le.mp hn), sub_self] at hcoeff + exact hcoeff rfl + simpa using sub_le_sub_right hle y + +omit [UniformSpace G] [IsUniformAddGroup G] [OrderTopology G] [Nontrivial G] [CompleteSpace G] + [CharZero K] in +/-- At or below the cut, every translated truncation of a strict tail vanishes. -/ +theorem translatedTruncLE_strictTail_eq_zero {c y : G} (hyc : y ≤ c) + (b : Nonpositive G K) : translatedTruncLE y (strictTail c b) = 0 := by + apply Subtype.ext + ext g + rw [coe_translatedTruncLE, HahnSeries.coeff_translate, HahnSeries.coeff_truncLE, + strictTail, HahnSeries.coeff_truncGT] + split_ifs with h1 h2 + · exact absurd h2 (not_lt.mpr (le_trans (by simpa using h1) hyc)) + · rfl + · rfl + +/-- A strict tail above a negative cutoff represents the same homogeneous germ. -/ +theorem represents_strictTail {c : G} (hc : c < 0) {b : Nonpositive G K} + {m : NatOrdinal.{u}} {e : (ν).AssociatedGraded} (h : Represents b m e) : + Represents (strictTail c b) m e := by + have hbot := degree_sub_strictTail_eq_bot hc b + have hdeg : ν b = ν (strictTail c b) := degree_eq_of_degree_sub_eq_bot hbot + rw [represents_iff] + refine ⟨hdeg ▸ h.degree_le, ?_⟩ + obtain ⟨hb, he⟩ := (represents_iff.mp h) + calc + (ν).homogeneousMk m ⟨strictTail c b, ((ν).mem_filtrationLE_iff m _).mpr (hdeg ▸ hb)⟩ = + (ν).homogeneousMk m ⟨b, ((ν).mem_filtrationLE_iff m _).mpr hb⟩ := by + rw [MaxAddDegree.homogeneousMk_apply, MaxAddDegree.homogeneousMk_apply] + congr 1 + apply ((ν).componentMk_eq_componentMk_iff m _ _).mpr + rw [show strictTail c b - b = -(b - strictTail c b) by ring, (ν).map_neg, hbot] + exact WithBot.bot_lt_coe m + _ = e := he + +/-- Strict tails preserve the degree and proper-truncation bounds. -/ +theorem hasLowerTruncationDegree_strictTail {c : G} (hc : c < 0) {b : Nonpositive G K} + {m : NatOrdinal.{u}} (h : HasLowerTruncationDegree b m) : + HasLowerTruncationDegree (strictTail c b) m := by + have hbot := degree_sub_strictTail_eq_bot hc b + have hdeg : ν b = ν (strictTail c b) := degree_eq_of_degree_sub_eq_bot hbot + rw [hasLowerTruncationDegree_iff] + refine ⟨hdeg ▸ h.degree_le, fun y hy ↦ ?_⟩ + by_cases hcy : c < y + · have hdiff := degree_translatedTruncLE_sub_strictTail_eq_bot hcy b + have heq := degree_eq_of_degree_sub_eq_bot + (a := translatedTruncLE y b) (b := translatedTruncLE y (strictTail c b)) + (by rw [← map_sub]; exact hdiff) + rw [← heq] + exact h.degree_translatedTruncLE_lt hy + · rw [translatedTruncLE_strictTail_eq_zero (not_lt.mp hcy), (ν).map_zero] + exact WithBot.bot_lt_coe m + +omit [UniformSpace G] [IsUniformAddGroup G] [OrderTopology G] [Nontrivial G] [CompleteSpace G] + [CharZero K] in +/-- The translated truncation of a placed local series reads the local series at the shifted +cutoff. -/ +theorem translatedTruncLE_placed (x y : G) (f : K⟦G⟧) + (hshift : (translate (-x) f).support ⊆ Iic 0) : + (translatedTruncLE (y - x) (⟨translate (-x) f, hshift⟩ : Nonpositive G K) : + HahnSeries G K) = translate (-y) (truncLE y f) := by + rw [coe_translatedTruncLE] + change translate (-(y - x)) (truncLE (y - x) (translate (-x) f)) = _ + rw [truncLE_translate, show y - x - -x = y by abel, translate_add_apply] + congr 1 + abel_nf + +omit [AddCommGroup G] [IsOrderedAddMonoid G] [UniformSpace G] [IsUniformAddGroup G] + [OrderTopology G] [Nontrivial G] [CompleteSpace G] [CharZero K] in +/-- A weak truncation of a series vanishes when the cutoff lies below the whole support. -/ +theorem truncLE_eq_zero_of_forall_lt (f : K⟦G⟧) (y : G) + (h : ∀ p ∈ f.support, y < p) : truncLE y f = 0 := by + ext g + rw [HahnSeries.coeff_truncLE] + by_cases hgy : g ≤ y + · rw [ite_eq_left hgy] + by_contra hne + exact absurd hgy (not_le.mpr (h g ((mem_support _ _).mpr hne))) + · rw [ite_eq_right hgy, HahnSeries.coeff_zero] + +omit [AddCommGroup G] [IsOrderedAddMonoid G] [UniformSpace G] [IsUniformAddGroup G] + [OrderTopology G] [Nontrivial G] [CompleteSpace G] in +/-- Outside a convex piece containing a bound of the support, support points are below the whole +piece. -/ +theorem lt_of_notMem_ordConnected {C : Set G} (hC : C.OrdConnected) + {x : G} (hx : x ∈ C) {p : G} (hp : p ≤ x) (hpC : p ∉ C) : + ∀ c ∈ C, p < c := by + intro c hc + by_contra hcp + exact hpC (hC.out hc hx ⟨not_lt.mp hcp, hp⟩) + +omit [AddCommGroup G] [IsOrderedAddMonoid G] [UniformSpace G] [IsUniformAddGroup G] + [OrderTopology G] [Nontrivial G] [CompleteSpace G] in +/-- A point below a convex piece but outside it lies below each element of the piece. -/ +theorem le_of_notMem_ordConnected {C : Set G} (hC : C.OrdConnected) + {y c p : G} (hy : y ∈ C) (hc : c ∈ C) (hpy : p ≤ y) (hpC : p ∉ C) : p ≤ c := + (lt_of_notMem_ordConnected hC hy hpy hpC c hc).le + +omit [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] [IsUniformAddGroup G] + [OrderTopology G] [Nontrivial G] [CompleteSpace G] [Field K] [CharZero K] in +/-- A point outside a closed set lies outside the closure of the range of its subtype coercion. -/ +theorem notMem_closure_range_subtype_coe {S : Set G} {y : G} (hS : closure S = S) + (hy : y ∉ S) : y ∉ closure (Set.range (fun x : S ↦ (x : G))) := by + rwa [Subtype.range_coe, hS] + +omit [AddCommGroup G] [IsOrderedAddMonoid G] [IsUniformAddGroup G] [Nontrivial G] + [CompleteSpace G] in +/-- In an open convex piece of a densely ordered group there is a piece element strictly below +any given piece element. -/ +theorem exists_lt_mem_of_isOpen_ordConnected [DenselyOrdered G] [NoMinOrder G] [NoMaxOrder G] + {C : Set G} (hCopen : IsOpen C) {y : G} (hy : y ∈ C) : + ∃ c ∈ C, c < y := by + obtain ⟨a, b, ⟨hay, hyb⟩, hab⟩ := mem_nhds_iff_exists_Ioo_subset.mp (hCopen.mem_nhds hy) + obtain ⟨c, hac, hcy⟩ := exists_between hay + exact ⟨c, hab ⟨hac, hcy.trans hyb⟩, hcy⟩ + +omit [AddCommGroup G] [IsOrderedAddMonoid G] [IsUniformAddGroup G] [Nontrivial G] + [CompleteSpace G] [CharZero K] in +/-- Cantor–Bendixson ranks of closed supports are monotone under support inclusion. -/ +theorem cantorBendixsonRank_le_of_support_subset {a b : K⟦G⟧} (h : a.support ⊆ b.support) (z : G) : + a.cantorBendixsonRank z ≤ b.cantorBendixsonRank z := by + have hle : a.closedSupport ≤ b.closedSupport := by + have h1 : (a.closedSupport : Set G) ⊆ (b.closedSupport : Set G) := by + rw [coe_closedSupport, coe_closedSupport] + exact closure_mono h + exact h1 + rw [cantorBendixsonRank_eq, cantorBendixsonRank_eq] + apply TopologicalSpace.Closeds.cantorBendixsonRank_le_of_notMem _ _ z + intro hmem + exact b.closedSupport.notMem_cantorBendixson_rank_add_one b.closedSupport_isPWO z + (TopologicalSpace.Closeds.cantorBendixson_mono hle _ hmem) + +omit [UniformSpace G] [IsUniformAddGroup G] [OrderTopology G] [Nontrivial G] [CompleteSpace G] + [CharZero K] in +/-- The translated truncation at a shifted cutoff reads the series placed at the shift. -/ +theorem translatedTruncLE_shift (x y : G) (b : Nonpositive G K) : + (translatedTruncLE (y - x) b : HahnSeries G K) = + translate (-y) (truncLE y (translate x (b : HahnSeries G K))) := by + rw [coe_translatedTruncLE, truncLE_translate, translate_add_apply] + congr 1 + abel_nf + +open Classical in +/-- Inside one piece, a separated sum of restricted translates has the same local germ as the +corresponding untranslated series. -/ +theorem degree_translatedTruncLE_separatedHsum_sub_piece_eq_bot + [DenselyOrdered G] [NoMinOrder G] [NoMaxOrder G] + {X : Type w} [LinearOrder X] (hX : (Set.univ : Set X).IsPWO) + (C : X → Set G) (hCopen : ∀ x, IsOpen (C x)) (hCconv : ∀ x, (C x).OrdConnected) + (f : X → K⟦G⟧) (hfC : ∀ x, (f x).support ⊆ C x) + (hord : ∀ x y : X, x < y → ∀ a ∈ C x, ∀ b ∈ C y, a < b) + (hsep : ∀ i j, i < j → ∀ a ∈ (f i).support, ∀ b ∈ (f j).support, a < b) + (x : X) (z : G) {y : G} (hy : y ∈ C x) (b : Nonpositive G K) + (hpiece : f x = setRestrict (C x) (translate z (b : HahnSeries G K))) + (c : Nonpositive G K) (hc : (c : HahnSeries G K) = separatedHsum hX f hsep) : + ν (translatedTruncLE y c - translatedTruncLE (y - z) b) = ⊥ := by + obtain ⟨cst, hcst, hcsty⟩ := exists_lt_mem_of_isOpen_ordConnected (hCopen x) hy + apply (cantorBendixsonDegreeValuation_eq_bot_iff _).mpr + refine ⟨cst - y, sub_neg.mpr hcsty, ?_⟩ + intro g hg + rw [AddSubgroupClass.coe_sub, translatedTruncLE_shift z y b, + coe_translatedTruncLE, hc] at hg + have hb : ∀ p ∈ (translate z (b : HahnSeries G K)).support, + p ∉ C x → p ≤ y → p ≤ cst := + fun _ _ hpC hpy ↦ le_of_notMem_ordConnected (hCconv x) hy hcst hpy hpC + exact support_translate_truncLE_separatedHsum_sub_source_subset + (G := G) (K := K) (X := X) hX C f hfC hord hsep x hy hcst + (translate z (b : HahnSeries G K)) hpiece hb hg + +open Classical in +/-- A separated sum has degree bottom at a cutoff outside every piece and outside the closure of +the piece centres. -/ +theorem degree_translatedTruncLE_separatedHsum_eq_bot_of_notMem + {X : Type w} [LinearOrder X] (hX : (Set.univ : Set X).IsPWO) + (C : X → Set G) (z : X → G) (f : X → K⟦G⟧) + (hfC : ∀ x, (f x).support ⊆ C x) (hfle : ∀ x, ∀ p ∈ (f x).support, p ≤ z x) + (hzC : ∀ x, z x ∈ C x) (hCopen : ∀ x, IsOpen (C x)) + (hCconv : ∀ x, (C x).OrdConnected) (hCdisj : ∀ x y, x ≠ y → Disjoint (C x) (C y)) + (hCord : ∀ x y, x < y → ∀ a ∈ C x, ∀ b ∈ C y, a < b) + (hsep : ∀ x y, x < y → ∀ a ∈ (f x).support, ∀ b ∈ (f y).support, a < b) + (c : Nonpositive G K) (hc : (c : HahnSeries G K) = separatedHsum hX f hsep) + {y : G} (hyC : ∀ x, y ∉ C x) (hyz : y ∉ closure (Set.range z)) : + ν (translatedTruncLE y c) = ⊥ := by + rw [degree_translatedTruncLE_eq, ite_eq_right ?_] + intro hy + exact (by + have hcl : ((c : HahnSeries G K).closedSupport : Set G) ⊆ + (⋃ x, C x) ∪ closure (Set.range z) := by + rw [coe_closedSupport, hc, support_separatedHsum] + exact closure_iUnion_subset_of_closure_piece_subset + (fun x ↦ (f x).support) C z hfC hfle hzC hCopen hCdisj hCord + (fun x ↦ closure_subset_of_isPWO_of_ordConnected (hCconv x) + (f x).isPWO_support (hfC x) (hzC x) (hfle x)) + rcases hcl hy with hy | hy + · obtain ⟨x, hyx⟩ := Set.mem_iUnion.mp hy + exact hyC x hyx + · exact hyz hy) + +private structure SeparatedHsumFamily (J : Type x) (X : Type w) [LinearOrder X] where + hX : (Set.univ : Set X).IsPWO + piece : X → Set G + center : X → G + term : J → X → K⟦G⟧ + support_subset : ∀ j x, (term j x).support ⊆ piece x + support_le_center : ∀ j x, ∀ p ∈ (term j x).support, p ≤ center x + center_mem : ∀ x, center x ∈ piece x + isOpen_piece : ∀ x, IsOpen (piece x) + ordConnected_piece : ∀ x, (piece x).OrdConnected + disjoint_piece : ∀ x y, x ≠ y → Disjoint (piece x) (piece y) + piece_lt_piece : ∀ x y, x < y → ∀ a ∈ piece x, ∀ b ∈ piece y, a < b + separated : ∀ j x y, x < y → + ∀ a ∈ (term j x).support, ∀ b ∈ (term j y).support, a < b + sum : J → Nonpositive G K + coe_sum : ∀ j, (sum j : HahnSeries G K) = separatedHsum hX (term j) (separated j) + +/-- Every member of a family of separated sums has degree bottom at a cutoff outside all pieces +and outside the closure of their common centres. -/ +private theorem SeparatedHsumFamily.degree_translatedTruncLE_eq_bot_of_notMem + {J : Type x} {X : Type w} [LinearOrder X] (F : SeparatedHsumFamily J X) + {y : G} (hyC : ∀ x, y ∉ F.piece x) (hyz : y ∉ closure (Set.range F.center)) : + ∀ j, ν (translatedTruncLE y (F.sum j)) = ⊥ := by + intro j + exact degree_translatedTruncLE_separatedHsum_eq_bot_of_notMem + (G := G) (K := K) (X := X) (hX := F.hX) (C := F.piece) (z := F.center) + (f := F.term j) (hfC := F.support_subset j) (hfle := F.support_le_center j) + (hzC := F.center_mem) (hCopen := F.isOpen_piece) + (hCconv := F.ordConnected_piece) (hCdisj := F.disjoint_piece) + (hCord := F.piece_lt_piece) (hsep := F.separated j) (c := F.sum j) + (hc := F.coe_sum j) (hyC := hyC) (hyz := hyz) + +/-- A translated truncation at a strictly positive cutoff is bounded strictly below zero. -/ +theorem degree_translatedTruncLE_of_pos {s : G} (hs : 0 < s) (b : Nonpositive G K) : + ν (translatedTruncLE s b) = ⊥ := by + apply (cantorBendixsonDegreeValuation_eq_bot_iff _).mpr + refine ⟨-s, neg_neg_iff_pos.mpr hs, ?_⟩ + intro g hg + rw [coe_translatedTruncLE, support_translate] at hg + obtain ⟨p, hp, rfl⟩ := hg + rw [support_truncLE] at hp + have hp0 : p ≤ 0 := b.property hp.1 + have h := add_le_add_left hp0 (-s) + rw [zero_add] at h + have h' : -s + p ≤ -s := by + rw [add_comm] + exact h + exact mem_Iic.mpr h' + +/-- A translated truncation at a point outside the closed support has degree bottom. -/ +theorem degree_translatedTruncLE_eq_bot_of_notMem_closedSupport + {s : G} {b : Nonpositive G K} (hs : s ∉ (b : HahnSeries G K).closedSupport) : + ν (translatedTruncLE s b) = ⊥ := by + rw [degree_translatedTruncLE_eq, ite_eq_right hs] + +/-- A uniform degree bound at nonpositive cutoffs extends to every cutoff. -/ +theorem degree_translatedTruncLE_le_of_nonpositive {b : Nonpositive G K} + {τ : WithBot NatOrdinal} (hb : ∀ s : G, s ≤ 0 → ν (translatedTruncLE s b) ≤ τ) + (s : G) : ν (translatedTruncLE s b) ≤ τ := by + rcases le_or_gt s 0 with hs | hs + · exact hb s hs + · rw [degree_translatedTruncLE_of_pos hs] + exact bot_le + +/-- The boundary estimate at every cutoff: strictly negative cutoffs by the finite convolution +estimate, zero trivially, and strictly positive cutoffs because both terms are bounded strictly +below zero. -/ +theorem degree_translatedTruncLE_mul_sub_mul_lt_forall + (a b : Nonpositive G K) (ρ σ τ : NatOrdinal.{u}) + (ha : ν a ≤ ρ) + (hat : ∀ x : G, x < 0 → ν (translatedTruncLE x a) ≤ ρ) + (hbt : ∀ x : G, x < 0 → ν (translatedTruncLE x b) < σ) + (hsep : ∀ θ, θ < σ → ρ + θ < τ) (γ : G) : + ν (translatedTruncLE γ (a * b) - translatedTruncLE γ a * b) < τ := by + rcases lt_trichotomy γ 0 with hγ | hγ | hγ + · exact degree_translatedTruncLE_mul_sub_mul_lt_of_pointwise_bounds a b ρ σ τ ha hat hbt hsep hγ + · subst hγ + rw [translatedTruncLE_zero, translatedTruncLE_zero, sub_self, (ν).map_zero] + exact WithBot.bot_lt_coe τ + · have h1 : ν (translatedTruncLE γ (a * b)) = ⊥ := degree_translatedTruncLE_of_pos hγ _ + have h2 : ν (translatedTruncLE γ a * b) = ⊥ := by + have := (ν).map_mul_le_add (translatedTruncLE γ a) b + rw [degree_translatedTruncLE_of_pos hγ, WithBot.bot_add] at this + exact le_bot_iff.mp this + refine ((ν).map_sub_le_max _ _).trans_lt ?_ + rw [h1, h2, max_self] + exact WithBot.bot_lt_coe τ + +/-- The translated product error is small when the first factor either vanishes below the target +degree or satisfies the complementary degree bound. -/ +theorem degree_translatedTruncLE_mul_sub_mul_lt_of_eq_zero_or_bounds + (a b : Nonpositive G K) (ρ σ τ β : NatOrdinal.{u}) + (ha0 : β ≤ τ → a = 0) + (ha : ν a ≤ ρ) + (hat : ∀ x : G, x < 0 → ν (translatedTruncLE x a) ≤ ρ) + (hbt : ∀ x : G, x < 0 → ν (translatedTruncLE x b) < σ) + (hsep : τ < β → ∀ θ, θ < σ → ρ + θ < τ) (γ : G) : + ν (translatedTruncLE γ (a * b) - translatedTruncLE γ a * b) < τ := by + by_cases hβτ : β ≤ τ + · rw [ha0 hβτ] + simp only [zero_mul, map_zero, sub_zero, (ν).map_zero] + exact WithBot.bot_lt_coe τ + · exact degree_translatedTruncLE_mul_sub_mul_lt_forall a b ρ σ τ ha hat hbt + (hsep (lt_of_not_ge hβτ)) γ + +omit [UniformSpace G] [IsUniformAddGroup G] [OrderTopology G] [Nontrivial G] + [CompleteSpace G] [CharZero K] in +/-- Decomposition of a summed residual into the local residual and three truncation errors. -/ +theorem translatedTruncLE_sub_sum_eq_local_errors + {J : Type w} [Fintype J] (y s : G) (R u : Nonpositive G K) + (cp cP q : J → Nonpositive G K) : + translatedTruncLE y R - ∑ j, translatedTruncLE y (cP j * q j) = + (translatedTruncLE y R - translatedTruncLE s u) + + translatedTruncLE s (u - ∑ j, cp j * q j) + + ∑ j, ((translatedTruncLE s (cp j * q j) - translatedTruncLE s (cp j) * q j) + + (translatedTruncLE s (cp j) - translatedTruncLE y (cP j)) * q j + + (translatedTruncLE y (cP j) * q j - translatedTruncLE y (cP j * q j))) := by + rw [map_sub, map_sum, Finset.sum_add_distrib, Finset.sum_add_distrib, + Finset.sum_congr rfl fun j _ ↦ sub_mul (translatedTruncLE s (cp j)) + (translatedTruncLE y (cP j)) (q j), + Finset.sum_sub_distrib, Finset.sum_sub_distrib, Finset.sum_sub_distrib] + abel + +/-- If the source cutoff and all first-factor cutoffs have degree bottom, then bounds on the +truncation product errors bound the residual finite sum. -/ +theorem degree_translatedTruncLE_sub_sum_le_of_eq_bot + {J : Type w} [Fintype J] (R : Nonpositive G K) (c q : J → Nonpositive G K) + {y : G} {τ : WithBot NatOrdinal} + (hR : ν (translatedTruncLE y R) = ⊥) + (herror : ∀ j, ν (translatedTruncLE y (c j * q j) - + translatedTruncLE y (c j) * q j) < τ) + (hc : ∀ j, ν (translatedTruncLE y (c j)) = ⊥) : + ν (translatedTruncLE y R - ∑ j, translatedTruncLE y (c j * q j)) ≤ τ := by + refine ((ν).map_sub_le_max _ _).trans ?_ + rw [hR] + refine max_le bot_le ?_ + apply (ν).map_sum_le_of_forall_le + intro j _ + have hsplit : translatedTruncLE y (c j * q j) = + (translatedTruncLE y (c j * q j) - translatedTruncLE y (c j) * q j) + + translatedTruncLE y (c j) * q j := by + abel + rw [hsplit] + refine ((ν).map_add_le_max _ _).trans (max_le (herror j).le ?_) + have hmul := (ν).map_mul_le_add (translatedTruncLE y (c j)) (q j) + rw [hc j, WithBot.bot_add] at hmul + exact hmul.trans bot_le + + +variable {κ : Type x} {ι : Type w} {κ' : Type w} + +/-- Lift a homogeneous ideal expression to a correction lowering the series degree. -/ +private theorem exists_degree_correction_of_componentsGE_mem [Fintype κ'] + {wt : ι → NatOrdinal.{u}} {V : ι → Nonpositive G K} + (xg : ι → (ν).AssociatedGraded) + (hV : ∀ i, Represents (V i) (wt i) (xg i)) {α : NatOrdinal.{u}} + (hinj : ∀ (β : NatOrdinal.{u}) (F : MvPolynomial ι K), β < α → + IsWeightedHomogeneous wt F β → aeval xg F = 0 → F = 0) + (Q : κ' → MvPolynomial ι K) (σQ : κ' → NatOrdinal.{u}) + (hQ : ∀ j, IsWeightedHomogeneous wt (Q j) (σQ j)) + {τ β : NatOrdinal.{u}} (hτβ : τ < β) + (P : κ' → NatOrdinal.{u}) (hP : ∀ j, P j + σQ j = β) + {y : Nonpositive G K} (hνy : ν y = (β : WithBot NatOrdinal)) + {F : MvPolynomial ι K} (hFw : ∀ d ∈ F.support, Finsupp.weight wt d < α) + (hFbot : ν (y - aeval V F) = ⊥) + (hFGE : MvPolynomial.componentsGE wt τ F ∈ Ideal.span (Set.range Q)) : + ∃ w : κ' → Nonpositive G K, (∀ j, ν (w j) ≤ P j) ∧ + ν (y - ∑ j, w j * aeval V (Q j)) < (β : WithBot NatOrdinal) := by + classical + have hνF : ν (aeval V F) = (β : WithBot NatOrdinal) := by + rw [← degree_eq_of_degree_sub_eq_bot hFbot, hνy] + have hwle : ∀ d ∈ F.support, (Finsupp.weight wt) d ≤ β := by + intro d hd + have := forall_weight_le_degree_aeval_of_injective xg hV hinj hFw d hd + rw [hνF] at this + exact WithBot.coe_le_coe.mp this + set Fβ := weightedHomogeneousComponent wt β F with hFβ_def + have hFβspan : Fβ ∈ Ideal.span (Set.range Q) := + weightedHomogeneousComponent_mem_span_of_componentsGE_mem wt hQ hFGE hτβ.le + let := weightedGradedAlgebra K wt + obtain ⟨A, hA, -, hAsum⟩ := OrdinalGraded.exists_eq_sum_mul_of_mem_span + (𝒜 := weightedHomogeneousSubmodule K wt) + (fun j ↦ (mem_weightedHomogeneousSubmodule _ _ _ _).mpr (hQ j)) + ((mem_weightedHomogeneousSubmodule _ _ _ _).mpr + (weightedHomogeneousComponent_isWeightedHomogeneous (w := wt) (n := β) (φ := F))) + hFβspan + have hAhom : ∀ j, IsWeightedHomogeneous wt (A j) (P j) := fun j ↦ + (mem_weightedHomogeneousSubmodule _ _ _ _).mp (hA j (P j) (hP j)) + refine ⟨fun j ↦ aeval V (A j), fun j ↦ (represents_aeval xg hV (hAhom j)).degree_le, ?_⟩ + have hsum : (∑ j, aeval V (A j) * aeval V (Q j)) = aeval V Fβ := by + rw [hFβ_def, hAsum, map_sum] + refine Finset.sum_congr rfl fun j _ ↦ ?_ + rw [map_mul, mul_comm] + rw [hsum] + have hrest : ∀ d ∈ (F - Fβ).support, (Finsupp.weight wt) d < β := by + intro d hd + have hne := MvPolynomial.mem_support_iff.mp hd + rw [MvPolynomial.coeff_sub, hFβ_def, coeff_weightedHomogeneousComponent] at hne + by_cases hdw : (Finsupp.weight wt) d = β + · rw [ite_eq_left hdw, sub_self] at hne + exact absurd rfl hne + · rw [ite_eq_right hdw, sub_zero] at hne + exact lt_of_le_of_ne (hwle d (MvPolynomial.mem_support_iff.mpr hne)) hdw + have hkey : y - aeval V Fβ = + (y - aeval V F) + aeval V (F - Fβ) := by + rw [map_sub] + ring + rw [hkey] + refine ((ν).map_add_le_max _ _).trans_lt (max_lt ?_ ?_) + · rw [hFbot] + exact WithBot.bot_lt_coe β + · exact degree_aeval_lt_of_forall_weight_lt xg hV hrest + +/-- Subtracting degree-controlled generator multiples preserves local polynomial ideal data. -/ +private theorem local_ideal_presentation_sub_sum_mul [Fintype κ'] + {wt : ι → NatOrdinal.{u}} {V : ι → Nonpositive G K} + (xg : ι → (ν).AssociatedGraded) (hV : ∀ i, Represents (V i) (wt i) (xg i)) + (α : NatOrdinal.{u}) + (hgen : ∀ β : NatOrdinal.{u}, β < α → ∀ y ∈ DirectSum.rangeLof K (ν).Component β, + ∃ F : MvPolynomial ι K, IsWeightedHomogeneous wt F β ∧ aeval xg F = y) + (Q : κ' → MvPolynomial ι K) (σQ : κ' → NatOrdinal.{u}) + (hQ : ∀ j, IsWeightedHomogeneous wt (Q j) (σQ j)) + (τ β : NatOrdinal.{u}) (hτα : τ < α) (hβα : β < α) + (P : κ' → NatOrdinal.{u}) (hP : ∀ j, P j + σQ j = β) + (hPsmall : ∀ j, P j < α) + (hW : ∀ j, HasLowerTruncationDegree (aeval V (Q j)) (σQ j)) + (hPsep : ∀ j θ, θ < σQ j → P j + θ < τ) + (u : Nonpositive G K) (ctop : κ' → Nonpositive G K) + (hctopb : ∀ j y, y ≤ 0 → ν (translatedTruncLE y (ctop j)) ≤ P j) + (hp : ∀ y : G, y ≤ 0 → ∃ F : MvPolynomial ι K, + (∀ d ∈ F.support, Finsupp.weight wt d < α) ∧ + ν (translatedTruncLE y u - aeval V F) = ⊥ ∧ + MvPolynomial.componentsGE wt τ F ∈ Ideal.span (Set.range Q)) : + ∀ y : G, y ≤ 0 → ∃ F : MvPolynomial ι K, + (∀ d ∈ F.support, Finsupp.weight wt d < α) ∧ + ν (translatedTruncLE y (u - ∑ j, ctop j * aeval V (Q j)) - aeval V F) = ⊥ ∧ + MvPolynomial.componentsGE wt τ F ∈ Ideal.span (Set.range Q) := by + classical + let q : κ' → Nonpositive G K := fun j ↦ aeval V (Q j) + let R : Nonpositive G K := u - ∑ j, ctop j * q j + have hR_def : R = u - ∑ j, ctop j * q j := rfl + change ∀ y : G, y ≤ 0 → ∃ F : MvPolynomial ι K, + (∀ d ∈ F.support, Finsupp.weight wt d < α) ∧ + ν (translatedTruncLE y R - aeval V F) = ⊥ ∧ + MvPolynomial.componentsGE wt τ F ∈ Ideal.span (Set.range Q) + intro y hy + obtain ⟨F₀, hF₀w, hF₀bot, hF₀GE⟩ := hp y hy + have hpolc : ∀ j, ∃ A' : MvPolynomial ι K, + (∀ d ∈ A'.support, + (((Finsupp.weight wt) d : NatOrdinal) : WithBot NatOrdinal) ≤ + ν (translatedTruncLE y (ctop j))) ∧ + (∀ d ∈ A'.support, (Finsupp.weight wt) d < α) ∧ + ν (translatedTruncLE y (ctop j) - aeval V A') = ⊥ := fun j ↦ + exists_forall_weight_lt_and_degree_sub_aeval_eq_bot xg hV α hgen _ + ((hctopb j y hy).trans_lt (WithBot.coe_lt_coe.mpr + (hPsmall j))) + choose A' hA'd hA'w hA'bot using hpolc + have hEbound : ∀ j, ν (translatedTruncLE y (ctop j * q j) - + translatedTruncLE y (ctop j) * q j) < (τ : WithBot NatOrdinal) := by + intro j + exact degree_translatedTruncLE_mul_sub_mul_lt_forall (ctop j) (q j) + (P j) (σQ j) τ (by simpa only [translatedTruncLE_zero] using hctopb j 0 le_rfl) + (fun x hx ↦ hctopb j x hx.le) + (fun x hx ↦ (hW j).degree_translatedTruncLE_lt hx) + (hPsep j) y + have hpolE : ∀ j, ∃ FE : MvPolynomial ι K, + (∀ d ∈ FE.support, + (((Finsupp.weight wt) d : NatOrdinal) : WithBot NatOrdinal) ≤ + ν (translatedTruncLE y (ctop j * q j) - + translatedTruncLE y (ctop j) * q j)) ∧ + (∀ d ∈ FE.support, (Finsupp.weight wt) d < α) ∧ + ν ((translatedTruncLE y (ctop j * q j) - + translatedTruncLE y (ctop j) * q j) - aeval V FE) = ⊥ := fun j ↦ + exists_forall_weight_lt_and_degree_sub_aeval_eq_bot xg hV α hgen _ + ((hEbound j).trans (WithBot.coe_lt_coe.mpr hτα)) + choose FE hFEd hFEw hFEbot using hpolE + have hFEGE : ∀ j, MvPolynomial.componentsGE wt τ (FE j) = 0 := by + intro j + apply componentsGE_eq_zero_of_forall_lt + intro d hd + have h1 := (hFEd j d hd).trans_lt (hEbound j) + exact WithBot.coe_lt_coe.mp h1 + refine ⟨F₀ - ∑ j, A' j * Q j - ∑ j, FE j, ?_, ?_, ?_⟩ + · intro d hd + rcases Finset.mem_union.mp (MvPolynomial.support_sub ι _ _ hd) with hd | hd + · rcases Finset.mem_union.mp (MvPolynomial.support_sub ι _ _ hd) with hd | hd + · exact hF₀w d hd + · have hsum := MvPolynomial.support_sum hd + rw [Finset.mem_biUnion] at hsum + obtain ⟨j, -, hdj⟩ := hsum + have hmul := MvPolynomial.support_mul _ _ hdj + rw [Finset.mem_add] at hmul + obtain ⟨d₁, hd₁, d₂, hd₂, rfl⟩ := hmul + rw [map_add] + have h1 : (Finsupp.weight wt) d₁ ≤ P j := by + have := (hA'd j d₁ hd₁).trans (hctopb j y hy) + exact WithBot.coe_le_coe.mp this + have h2 : (Finsupp.weight wt) d₂ = σQ j := + hQ j (MvPolynomial.mem_support_iff.mp hd₂) + calc + (Finsupp.weight wt) d₁ + (Finsupp.weight wt) d₂ ≤ P j + σQ j := by + rw [h2] + exact add_le_add h1 le_rfl + _ = β := hP j + _ < α := hβα + · have hsum := MvPolynomial.support_sum hd + rw [Finset.mem_biUnion] at hsum + obtain ⟨j, -, hdj⟩ := hsum + exact hFEw j d hdj + · have hTsub : translatedTruncLE y R = + translatedTruncLE y u - ∑ j, translatedTruncLE y (ctop j * q j) := by + rw [hR_def, map_sub, map_sum] + have hAQ : ∀ j, aeval V (A' j * Q j) = aeval V (A' j) * q j := + fun j ↦ map_mul _ _ _ + have hcalc : translatedTruncLE y R - aeval V (F₀ - ∑ j, A' j * Q j - ∑ j, FE j) = + (translatedTruncLE y u - aeval V F₀) - + ∑ j, (translatedTruncLE y (ctop j * q j) - + aeval V (A' j) * q j - aeval V (FE j)) := by + rw [hTsub, map_sub, map_sub, map_sum, map_sum, + Finset.sum_congr rfl fun j _ ↦ hAQ j] + conv_rhs => rw [Finset.sum_sub_distrib, Finset.sum_sub_distrib] + abel + rw [hcalc] + have hbot1 : ∀ j, ν (translatedTruncLE y (ctop j * q j) - + aeval V (A' j) * q j - aeval V (FE j)) = ⊥ := by + intro j + have hshape : translatedTruncLE y (ctop j * q j) - + aeval V (A' j) * q j - aeval V (FE j) = + (translatedTruncLE y (ctop j) - aeval V (A' j)) * q j + + ((translatedTruncLE y (ctop j * q j) - + translatedTruncLE y (ctop j) * q j) - aeval V (FE j)) := by + ring + rw [hshape] + have h1 : ν ((translatedTruncLE y (ctop j) - aeval V (A' j)) * q j) = ⊥ := by + have := (ν).map_mul_le_add (translatedTruncLE y (ctop j) - aeval V (A' j)) + (q j) + rw [hA'bot j, WithBot.bot_add] at this + exact le_bot_iff.mp this + have h2 := hFEbot j + refine le_bot_iff.mp (((ν).map_add_le_max _ _).trans ?_) + rw [h1, h2, max_self] + have hsumbot : ν (∑ j, (translatedTruncLE y (ctop j * q j) - + aeval V (A' j) * q j - aeval V (FE j))) = ⊥ := + le_bot_iff.mp ((ν).map_sum_le_of_forall_le _ _ ⊥ fun j _ ↦ (hbot1 j).le) + refine le_bot_iff.mp (((ν).map_sub_le_max _ _).trans ?_) + rw [hF₀bot, hsumbot, max_self] + · rw [componentsGE_sub, componentsGE_sub, componentsGE_sum, componentsGE_sum] + have hAQGE : ∀ j ∈ Finset.univ, MvPolynomial.componentsGE wt τ (A' j * Q j) ∈ + Ideal.span (Set.range Q) := by + intro j _ + exact componentsGE_mem_span wt hQ + (Ideal.mul_mem_left _ _ (Ideal.subset_span ⟨j, rfl⟩)) τ + have hFEGE' : (∑ j, MvPolynomial.componentsGE wt τ (FE j)) = 0 := by + rw [Finset.sum_congr rfl fun j _ ↦ hFEGE j, Finset.sum_const_zero] + rw [hFEGE', sub_zero] + exact Ideal.sub_mem _ hF₀GE (Ideal.sum_mem _ hAQGE) + +open Classical in +/-- A translated restriction with uniformly smaller local degree has empty target derivative. -/ +private theorem cantorBendixson_restricted_translate_eq_empty + (C : Set G) (z₀ : G) (c : Nonpositive G K) (β : NatOrdinal.{u}) + (hbounds : c = 0 ∨ ∃ a : NatOrdinal.{u}, a < β ∧ + ∀ s : G, s ≤ 0 → ν (translatedTruncLE s c) ≤ (a : WithBot NatOrdinal)) : + (((setRestrict C (translate z₀ (c : HahnSeries G K))).closedSupport).cantorBendixson β.val : + Set G) = ∅ := by + classical + let f := setRestrict C (translate z₀ (c : HahnSeries G K)) + have hf : f = setRestrict C (translate z₀ (c : HahnSeries G K)) := rfl + apply Set.eq_empty_iff_forall_notMem.mpr + intro z hz + change z ∈ (f.closedSupport.cantorBendixson β.val : Set G) at hz + rcases hbounds with hzero | ⟨a, hab, hb⟩ + · have hfzero : f = 0 := by + rw [hf, hzero] + rw [show ((0 : Nonpositive G K) : HahnSeries G K) = 0 from rfl, map_zero] + ext g + rw [coeff_setRestrict] + split_ifs <;> rfl + rw [hfzero] at hz + have hzs := TopologicalSpace.Closeds.cantorBendixson_le _ _ hz + rw [mem_closedSupport, HahnSeries.support_zero, closure_empty] at hzs + exact hzs + · obtain ⟨hzs, hzr⟩ := (f.mem_support_derivative_iff z β.val).mp hz + have h1 : f.cantorBendixsonRank z ≤ + (translate z₀ (c : HahnSeries G K)).cantorBendixsonRank z := + cantorBendixsonRank_le_of_support_subset (by + rw [hf, support_setRestrict] + exact inter_subset_left) z + have h2 : (translate z₀ (c : + HahnSeries G K)).cantorBendixsonRank z = + (c : HahnSeries G K).cantorBendixsonRank (z - z₀) := by + have := cantorBendixsonRank_translate (c : HahnSeries G K) + z₀ (z - z₀) + rw [show z₀ + (z - z₀) = z by abel] at this + exact this + have h3 : (c : HahnSeries G K).cantorBendixsonRank (z - z₀) ≤ + a.val := by + by_cases hm : z - z₀ ∈ + (c : HahnSeries G K).closedSupport + · have hz0 : z - z₀ ≤ 0 := closure_minimal (c).property isClosed_Iic + ((mem_closedSupport _ _).mp hm) + have hprof := hb (z - z₀) hz0 + rw [degree_translatedTruncLE_eq, ite_eq_left hm, WithBot.coe_le_coe] at hprof + have hval := NatOrdinal.of.symm.monotone hprof + change NatOrdinal.val (NatOrdinal.of _) ≤ NatOrdinal.val _ at hval + rwa [NatOrdinal.val_of] at hval + · rw [cantorBendixsonRank_eq, TopologicalSpace.Closeds.cantorBendixsonRank_of_notMem _ _ hm] + exact zero_le (a := a.val) + have h4 : a.val < β.val := NatOrdinal.of.symm.strictMono hab + exact absurd hzr (not_le_of_gt (((h1.trans_eq h2).trans h3).trans_lt h4)) + +open Classical in +/-- Restricting to an open convex piece preserves local polynomial presentations and bounds rank. -/ +private theorem translated_convex_piece_local_data + [DenselyOrdered G] [NoMinOrder G] [NoMaxOrder G] + {ι : Type w} {κ' : Type x} {wt : ι → NatOrdinal.{u}} {V : ι → Nonpositive G K} + (Q : κ' → MvPolynomial ι K) (α τ : NatOrdinal.{u}) + (u piece : Nonpositive G K) (z : G) (C : Set G) (f : HahnSeries G K) + (hf : f = setRestrict C (u : HahnSeries G K)) + (hpiece : (piece : HahnSeries G K) = translate (-z) f) + (hCopen : IsOpen C) (hCconv : C.OrdConnected) (hCmem : z ∈ C) + (hCrank : ∀ y ∈ ((u : HahnSeries G K).closedSupport : Set G) ∩ C, y ≠ z → + (u : HahnSeries G K).cantorBendixsonRank y < + (u : HahnSeries G K).cantorBendixsonRank z) + (β : NatOrdinal.{u}) (hβ : β = NatOrdinal.of ((u : HahnSeries G K).cantorBendixsonRank z)) + (hp : ∀ y : G, y ≤ z → ∃ F : MvPolynomial ι K, + (∀ d ∈ F.support, (Finsupp.weight wt) d < α) ∧ + ν (translatedTruncLE y u - aeval V F) = ⊥ ∧ + MvPolynomial.componentsGE wt τ F ∈ Ideal.span (Set.range Q)) : + (∀ s : G, (translatedTruncLE s piece : HahnSeries G K) = + translate (-(z + s)) (truncLE (z + s) f)) ∧ + (∀ y ∈ C, ν (translatedTruncLE (y - z) piece - translatedTruncLE y u) = ⊥) ∧ + (∀ s : G, s ≤ 0 → ν (translatedTruncLE s piece) ≤ (β : WithBot NatOrdinal)) ∧ + ∀ s : G, s ≤ 0 → ∃ F : MvPolynomial ι K, + (∀ d ∈ F.support, (Finsupp.weight wt) d < α) ∧ + ν (translatedTruncLE s piece - aeval V F) = ⊥ ∧ + MvPolynomial.componentsGE wt τ F ∈ Ideal.span (Set.range Q) := by + classical + have hfC : f.support ⊆ C := by rw [hf, support_setRestrict]; exact inter_subset_right + have hplaced_eq : ∀ s : G, + ((translatedTruncLE s piece : Nonpositive G K) : HahnSeries G K) = + translate (-(z + s)) (truncLE (z + s) f) := by + intro s + have h2 : (z + s) - z = s := by abel + have hshift : ((translatedTruncLE ((z + s) - z) piece : Nonpositive G K) : + HahnSeries G K) = translate (-(z + s)) (truncLE (z + s) + (translate z ((piece : Nonpositive G K) : HahnSeries G K))) := + translatedTruncLE_shift z (z + s) piece + rw [h2] at hshift + have hcancel : translate z (translate (-z) f) = f := by + rw [translate_add_apply, add_neg_cancel, translate_zero_apply] + rw [hshift, hpiece, hcancel] + have hloc : ∀ y' : G, y' ∈ C → + ν (translatedTruncLE (y' - z) piece - translatedTruncLE y' u) = ⊥ := by + intro y' hy' + obtain ⟨cst, hcst, hcsty⟩ := exists_lt_mem_of_isOpen_ordConnected (hCopen) hy' + apply (cantorBendixsonDegreeValuation_eq_bot_iff _).mpr + refine ⟨cst - y', sub_neg.mpr hcsty, ?_⟩ + intro g hg + have hcoe1 : ((translatedTruncLE (y' - z) piece : Nonpositive G K) : + HahnSeries G K) = translate (-y') (truncLE y' f) := by + have h2 : z + (y' - z) = y' := by abel + have := hplaced_eq (y' - z) + rw [h2] at this + exact this + rw [AddSubgroupClass.coe_sub, hcoe1, coe_translatedTruncLE] at hg + have hcombine : translate (-y') (truncLE y' f) - + translate (-y') (truncLE y' ((u : Nonpositive G K) : HahnSeries G K)) = + translate (-y') (truncLE y' f - + truncLE y' ((u : Nonpositive G K) : HahnSeries G K)) := + (map_sub (translate (-y')) _ _).symm + rw [hcombine, support_translate] at hg + obtain ⟨q, hq, rfl⟩ := hg + have hb2 : ∀ p ∈ ((u : Nonpositive G K) : HahnSeries G K).support, p ∉ C → + p ≤ y' → p ≤ cst := by + intro p _ hpC hpy + by_contra hgt + exact hpC ((hCconv).out hcst hy' ⟨(not_le.mp hgt).le, hpy⟩) + have hq2 := support_truncLE_sub_truncLE_setRestrict_subset (C) + ((u : Nonpositive G K) : HahnSeries G K) y' hb2 + have hqrev : q ∈ (truncLE y' ((u : Nonpositive G K) : HahnSeries G K) - + truncLE y' (setRestrict (C) ((u : Nonpositive G K) : HahnSeries G K))).support := by + rw [← support_neg, neg_sub, ← hf] + exact hq + have hqc : q ≤ cst := hq2 hqrev + have h3 : -y' + q ≤ cst - y' := by + have h2 : -y' + q ≤ -y' + cst := add_le_add le_rfl hqc + calc -y' + q ≤ -y' + cst := h2 + _ = cst - y' := by abel + exact mem_Iic.mpr h3 + -- Degree profile and local ideal condition of each piece. + have hux_prof : ∀ s : G, s ≤ 0 → + ν (translatedTruncLE s piece) ≤ (β : WithBot NatOrdinal) := by + intro s hs + have hy'x : z + s ≤ z := by + calc z + s ≤ z + 0 := add_le_add le_rfl hs + _ = z := add_zero _ + by_cases hy'C : z + s ∈ C + · have h1 := hloc (z + s) hy'C + have h2 : (z + s) - z = s := by abel + rw [h2] at h1 + rw [degree_eq_of_degree_sub_eq_bot h1, degree_translatedTruncLE_eq] + by_cases hm : z + s ∈ ((u : Nonpositive G K) : HahnSeries G K).closedSupport + · rw [ite_eq_left hm] + rcases eq_or_ne (z + s) z with heq | hne + · rw [heq, hβ] + · have hlt' := hCrank (z + s) ⟨hm, hy'C⟩ hne + rw [hβ] + exact WithBot.coe_le_coe.mpr (NatOrdinal.of.monotone hlt'.le) + · rw [ite_eq_right hm] + exact bot_le + · have hbelow := lt_of_notMem_ordConnected (hCconv) (hCmem) hy'x hy'C + have hzero : truncLE (z + s) f = 0 := + truncLE_eq_zero_of_forall_lt _ _ (fun p hp ↦ hbelow p (hfC hp)) + have hzero' : translatedTruncLE s piece = 0 := by + apply Subtype.ext + rw [hplaced_eq s, hzero, map_zero] + rfl + rw [hzero', (ν).map_zero] + exact bot_le + have hpux : ∀ s : G, s ≤ 0 → ∃ F : MvPolynomial ι K, + (∀ d ∈ F.support, (Finsupp.weight wt) d < α) ∧ + ν (translatedTruncLE s piece - aeval V F) = ⊥ ∧ + MvPolynomial.componentsGE wt τ F ∈ Ideal.span (Set.range Q) := by + intro s hs + have hy'z : z + s ≤ z := by simpa using add_le_add_left hs z + by_cases hy'C : z + s ∈ C + · obtain ⟨F, hFw, hFbot, hFGE⟩ := hp (z + s) hy'z + refine ⟨F, hFw, ?_, hFGE⟩ + have h1 := hloc (z + s) hy'C + have h2 : (z + s) - z = s := by abel + rw [h2] at h1 + have hsplit : translatedTruncLE s piece - aeval V F = + (translatedTruncLE s piece - translatedTruncLE (z + s) u) + + (translatedTruncLE (z + s) u - aeval V F) := by + abel + rw [hsplit] + refine le_bot_iff.mp (((ν).map_add_le_max _ _).trans ?_) + rw [h1, hFbot, max_self] + · have hy'x : z + s ≤ z := by + calc z + s ≤ z + 0 := add_le_add le_rfl hs + _ = z := add_zero _ + have hbelow := lt_of_notMem_ordConnected (hCconv) (hCmem) hy'x hy'C + have hzero : truncLE (z + s) f = 0 := + truncLE_eq_zero_of_forall_lt _ _ (fun p hp ↦ hbelow p (hfC hp)) + have hzero' : translatedTruncLE s piece = 0 := by + apply Subtype.ext + rw [hplaced_eq s, hzero, map_zero] + rfl + refine ⟨0, by simp, ?_, ?_⟩ + · rw [hzero', map_zero, sub_zero, (ν).map_zero] + · rw [componentsGE_zero] + exact Ideal.zero_mem _ + exact ⟨hplaced_eq, hloc, hux_prof, hpux⟩ + +open Classical in +/-- Local corrections on separated pieces give a global residual bound at each cutoff. -/ +private theorem SeparatedHsumFamily.degree_residual_le + [DenselyOrdered G] [NoMinOrder G] [NoMaxOrder G] + {J : Type x} [Fintype J] {X : Type w} [LinearOrder X] + (F : SeparatedHsumFamily J X) (R : Nonpositive G K) (v : X → Nonpositive G K) + (cp : X → J → Nonpositive G K) (q : J → Nonpositive G K) + (τ : NatOrdinal.{u}) (Pg σQ : J → NatOrdinal.{u}) (bx : X → NatOrdinal.{u}) + (Pl : X → J → NatOrdinal.{u}) + (hplaced : ∀ j x, F.term j x = setRestrict (F.piece x) + (translate (F.center x) (cp x j : HahnSeries G K))) + (hcp0 : ∀ x, bx x ≤ τ → ∀ j, cp x j = 0) + (hcpb : ∀ x j s, s ≤ 0 → ν (translatedTruncLE s (cp x j)) ≤ Pl x j) + (hcpres : ∀ x s, s ≤ 0 → ν (translatedTruncLE s (v x - ∑ j, cp x j * q j)) ≤ τ) + (hcPb : ∀ j s, s ≤ 0 → ν (translatedTruncLE s (F.sum j)) ≤ Pg j) + (hW : ∀ j, HasLowerTruncationDegree (q j) (σQ j)) + (hPg : ∀ j θ, θ < σQ j → Pg j + θ < τ) + (hPl : ∀ x, τ < bx x → ∀ j θ, θ < σQ j → Pl x j + θ < τ) + (hloc : ∀ x y, y ∈ F.piece x → + ν (translatedTruncLE (y - F.center x) (v x) - translatedTruncLE y R) = ⊥) + (y : G) (hout : (¬ ∃ x, y ∈ F.piece x) → + ν (translatedTruncLE y R) = ⊥ ∧ ∀ j, ν (translatedTruncLE y (F.sum j)) = ⊥) : + ν (translatedTruncLE y (R - ∑ j, F.sum j * q j)) ≤ τ := by + classical + rw [map_sub, map_sum] + have hEc : ∀ j, ν (translatedTruncLE y (F.sum j * q j) - + translatedTruncLE y (F.sum j) * q j) < (τ : WithBot NatOrdinal) := fun j ↦ + degree_translatedTruncLE_mul_sub_mul_lt_forall (F.sum j) (q j) + (Pg j) (σQ j) τ (by simpa only [translatedTruncLE_zero] using hcPb j 0 le_rfl) + (fun z hz ↦ hcPb j z hz.le) (fun z hz ↦ (hW j).degree_translatedTruncLE_lt hz) + (hPg j) y + by_cases hyC : ∃ x : X, y ∈ F.piece x + · obtain ⟨x, hyx⟩ := hyC + have hRloc := hloc x y hyx + have hcPloc : ∀ j, ν (translatedTruncLE y (F.sum j) - + translatedTruncLE (y - F.center x) (cp x j)) = ⊥ := fun j ↦ + degree_translatedTruncLE_separatedHsum_sub_piece_eq_bot F.hX F.piece F.isOpen_piece + F.ordConnected_piece + (F.term j) (F.support_subset j) F.piece_lt_piece (F.separated j) x (F.center x) hyx + (cp x j) (hplaced j x) + (F.sum j) (F.coe_sum j) + have hEin (j : J) := + degree_translatedTruncLE_mul_sub_mul_lt_of_eq_zero_or_bounds + (cp x j) (q j) (Pl x j) (σQ j) τ (bx x) + (fun h ↦ hcp0 x h j) + (by simpa only [translatedTruncLE_zero] using hcpb x j 0 le_rfl) + (fun z hz ↦ hcpb x j z hz.le) + (fun z hz ↦ (hW j).degree_translatedTruncLE_lt hz) + (fun h ↦ hPl x h j) (y - F.center x) + have hkey := translatedTruncLE_sub_sum_eq_local_errors y (y - F.center x) R (v x) + (cp x) F.sum q + rw [hkey] + apply degree_add_add_sum_le + · rw [degree_reverse_sub_eq_bot hRloc] + exact bot_le + · exact degree_translatedTruncLE_le_of_nonpositive (hcpres x) (y - F.center x) + · intro j + apply degree_add_add_le (hEin j).le + · rw [degree_mul_eq_bot_of_left + (b := q j) (degree_reverse_sub_eq_bot (hcPloc j))] + exact bot_le + · exact (degree_reverse_sub_lt (hEc j)).le + · obtain ⟨hyR, hycP⟩ := hout hyC + exact degree_translatedTruncLE_sub_sum_le_of_eq_bot + (R := R) (c := F.sum) (q := q) (y := y) (τ := τ) hyR hEc hycP + +open Classical in +/-- Discrete piece centres preserve strict local degree bounds when cofactors are summed. -/ +private theorem SeparatedHsumFamily.degree_le_of_discrete_centers + [NoMinOrder G] [NoMaxOrder G] + {J : Type x} {X : Type w} [LinearOrder X] (F : SeparatedHsumFamily J X) + (cp : X → J → Nonpositive G K) (τ : NatOrdinal.{u}) (Pg : J → NatOrdinal.{u}) + (bx : X → NatOrdinal.{u}) (Pl : X → J → NatOrdinal.{u}) + (hplaced : ∀ j x, F.term j x = setRestrict (F.piece x) + (translate (F.center x) (cp x j : HahnSeries G K))) + (hcp0 : ∀ x, bx x ≤ τ → ∀ j, cp x j = 0) + (hcpb : ∀ x j s, s ≤ 0 → ν (translatedTruncLE s (cp x j)) ≤ Pl x j) + (hPlt : ∀ x j, τ < bx x → Pl x j < Pg j) + (hdiscP : ∀ z : G, ¬ AccPt z (𝓟 (Set.range F.center))) : + ∀ j y, ν (translatedTruncLE y (F.sum j)) ≤ Pg j := by + classical + have hstageP : ∀ j x, + (((F.term j x).closedSupport).cantorBendixson (Pg j).val : Set G) ⊆ {F.center x} := by + intro j x + have he := cantorBendixson_restricted_translate_eq_empty (F.piece x) (F.center x) (cp x j) + (Pg j) (by + by_cases h : bx x ≤ τ + · exact Or.inl (hcp0 x h j) + · exact Or.inr ⟨Pl x j, hPlt x j (lt_of_not_ge h), hcpb x j⟩) + rw [hplaced j x, he] + exact Set.empty_subset _ + intro j y + have hbounds := cantorBendixsonRank_separatedHsum_bounds F.hX F.piece F.center (F.term j) + (F.support_subset j) (F.support_le_center j) F.center_mem F.isOpen_piece F.disjoint_piece + F.piece_lt_piece (F.separated j) hdiscP (Pg j).val (hstageP j) + rw [degree_translatedTruncLE_eq] + by_cases hm : y ∈ ((F.sum j : Nonpositive G K) : HahnSeries G K).closedSupport + · rw [ite_eq_left hm] + have hrank : ((F.sum j : Nonpositive G K) : HahnSeries G K).cantorBendixsonRank y ≤ + (Pg j).val := by + have hr := hbounds.1 y + have hreq : ((F.sum j : Nonpositive G K) : HahnSeries G K).cantorBendixsonRank y = + (separatedHsum F.hX (F.term j) (F.separated j)).cantorBendixsonRank y := by + rw [F.coe_sum j] + rw [hreq] + exact hr + calc ((NatOrdinal.of (((F.sum j : Nonpositive G K) : HahnSeries G K).cantorBendixsonRank y)) : + WithBot NatOrdinal) ≤ (NatOrdinal.of ((Pg j).val) : WithBot NatOrdinal) := + WithBot.coe_le_coe.mpr (NatOrdinal.of.monotone hrank) + _ = (Pg j : WithBot NatOrdinal) := by rw [NatOrdinal.of_val] + · rw [ite_eq_right hm] + exact bot_le + +/-- Adding a fixed generator degree reflects comparisons of cofactor degrees. -/ +private theorem cofactor_degree_mono {J : Type*} + (P : J → NatOrdinal.{u} → NatOrdinal.{u}) (σ : J → NatOrdinal.{u}) + {τ μ : NatOrdinal.{u}} (hP : ∀ j β, τ < β → β ≤ μ → P j β + σ j = β) + (j : J) (β' β'' : NatOrdinal.{u}) (h1 : τ < β') (h2 : β' ≤ β'') (h3 : β'' ≤ μ) : + P j β' ≤ P j β'' := by + have h : P j β' + σ j ≤ P j β'' + σ j := by + rw [hP j β' h1 (h2.trans h3), hP j β'' (h1.trans_le h2) h3] + exact h2 + exact le_of_add_le_add_right h + +/-- Strict stage comparisons remain strict after subtracting the same generator degree. -/ +private theorem cofactor_degree_lt {J : Type*} + (P : J → NatOrdinal.{u} → NatOrdinal.{u}) (σ : J → NatOrdinal.{u}) + {τ μ : NatOrdinal.{u}} (hP : ∀ j β, τ < β → β ≤ μ → P j β + σ j = β) + (j : J) (β' β'' : NatOrdinal.{u}) (h1 : τ < β') (h2 : β' < β'') (h3 : β'' ≤ μ) : + P j β' < P j β'' := by + have h : P j β' + σ j < P j β'' + σ j := by + rw [hP j β' h1 (h2.le.trans h3), hP j β'' (h1.trans h2) h3] + exact h2 + exact lt_of_add_lt_add_right h + +open Classical in +/-- **Cofactors by well-founded induction.** Fix representatives of homogeneous classes generating +the associated graded ring below `α`, each satisfying its assigned degree and proper-truncation +bounds, with graded evaluation injective below `α`, finitely many weighted homogeneous ideal +generators, and natural-sum separation data for their degrees. +If every translated truncation of `u` has degree at most `β ≤ μ` and, at every nonpositive +cutoff, the truncation agrees below every negative bound with an evaluated polynomial whose part +at or above `τ` lies in the polynomial ideal, then there are global cofactors, with the +prescribed pointwise degree bounds, whose combination with the evaluated generators corrects every +translated truncation of `u` to degree at most `τ`. The recursion covers each residual support by +disjoint convex pieces on a nested convex subgroup base and combines the local cofactors, so no +countability or cofinality hypothesis enters. -/ +theorem exists_cofactors_degree_translatedTruncLE_le_of_locallyIdeal + [DenselyOrdered G] [NoMinOrder G] [NoMaxOrder G] + [LinearOrder κ] [WellFoundedLT κ] [Fintype κ'] + (U : κ → AddSubgroup G) + (hUmono : ∀ {i j : κ}, i ≤ j → (U j : Set G) ⊆ (U i : Set G)) + (hUopen : ∀ i, IsOpen (U i : Set G)) + (hUconv : ∀ i, (U i : Set G).OrdConnected) + (hUbase : ∀ ε : G, 0 < ε → ∃ i, (U i : Set G) ⊆ Ioo (-ε) ε) + {wt : ι → NatOrdinal.{u}} {V : ι → Nonpositive G K} + (xg : ι → (ν).AssociatedGraded) + (hV : ∀ i, Represents (V i) (wt i) (xg i)) + (hVbounds : ∀ i, HasLowerTruncationDegree (V i) (wt i)) + (α : NatOrdinal.{u}) + (hgen : ∀ β : NatOrdinal.{u}, β < α → ∀ y ∈ DirectSum.rangeLof K (ν).Component β, + ∃ F : MvPolynomial ι K, IsWeightedHomogeneous wt F β ∧ aeval xg F = y) + (hinj : ∀ (β : NatOrdinal.{u}) (F : MvPolynomial ι K), β < α → + IsWeightedHomogeneous wt F β → aeval xg F = 0 → F = 0) + (Q : κ' → MvPolynomial ι K) (σQ : κ' → NatOrdinal.{u}) + (hQ : ∀ j, IsWeightedHomogeneous wt (Q j) (σQ j)) + (τ μ : NatOrdinal.{u}) (hτμ : τ < μ) (hμα : μ < α) + (P : κ' → NatOrdinal.{u} → NatOrdinal.{u}) + (hP : ∀ j β, τ < β → β ≤ μ → P j β + σQ j = β) + (hPsep : ∀ j θ, θ < σQ j → P j μ + θ < τ) + (β : NatOrdinal.{u}) (hβμ : β ≤ μ) + (u : Nonpositive G K) + (hu : ∀ y : G, y ≤ 0 → ν (translatedTruncLE y u) ≤ β) + (hp : ∀ y : G, y ≤ 0 → ∃ F : MvPolynomial ι K, + (∀ d ∈ F.support, (Finsupp.weight wt) d < α) ∧ + ν (translatedTruncLE y u - aeval V F) = ⊥ ∧ + MvPolynomial.componentsGE wt τ F ∈ Ideal.span (Set.range Q)) : + ∃ c : κ' → Nonpositive G K, + (∀ j, ∀ y : G, y ≤ 0 → ν (translatedTruncLE y (c j)) ≤ P j β) ∧ + (β ≤ τ → ∀ j, c j = 0) ∧ + ∀ y : G, y ≤ 0 → + ν (translatedTruncLE y (u - ∑ j, c j * aeval V (Q j))) ≤ τ := by + classical + let q : κ' → Nonpositive G K := fun j ↦ aeval V (Q j) + change ∃ c : κ' → Nonpositive G K, + (∀ j, ∀ y : G, y ≤ 0 → ν (translatedTruncLE y (c j)) ≤ P j β) ∧ + (β ≤ τ → ∀ j, c j = 0) ∧ + ∀ y : G, y ≤ 0 → ν (translatedTruncLE y (u - ∑ j, c j * q j)) ≤ τ + -- Global data used at every stage of the induction. + have hW : ∀ j, HasLowerTruncationDegree (q j) (σQ j) := fun j ↦ + hasLowerTruncationDegree_aeval hVbounds (hQ j) + have hPle : ∀ j β', τ < β' → β' ≤ μ → P j β' ≤ μ := by + intro j β' h1 h2 + exact (NatOrdinal.le_add_right.trans_eq (hP j β' h1 h2)).trans h2 + have hPmono := cofactor_degree_mono P σQ hP + have hPlt := cofactor_degree_lt P σQ hP + have hPsep' : ∀ j β', τ < β' → β' ≤ μ → ∀ θ, θ < σQ j → P j β' + θ < τ := by + intro j β' h1 h2 θ hθ + exact (add_le_add (hPmono j β' μ h1 h2 le_rfl) le_rfl).trans_lt (hPsep j θ hθ) + -- The induction over the stage. + induction β using WellFoundedLT.induction generalizing u with + | _ β ih => + by_cases hβτ : β ≤ τ + · -- Base: the truncations are already at the floor. + refine ⟨fun _ ↦ 0, ?_, fun _ j ↦ rfl, ?_⟩ + · intro j y hy + rw [map_zero, (ν).map_zero] + exact bot_le + · intro y hy + have hz : (∑ j, (0 : Nonpositive G K) * q j) = 0 := by + simp + rw [hz, sub_zero] + exact (hu y hy).trans (WithBot.coe_le_coe.mpr hβτ) + -- Main case: correct the top rank level, then partition and recurse. + · have hτβ : τ < β := lt_of_not_ge hβτ + have hβα : β < α := lt_of_le_of_lt hβμ hμα + -- Step A: choose local cofactors at every exact rank-`β` cutoff. + have hlocal : ∀ i : {x // x ∈ (u : HahnSeries G K).closedSupport ∧ + (u : HahnSeries G K).closedSupport.cantorBendixsonRank + (u : HahnSeries G K).closedSupport_isPWO x = β.val}, + ∃ w : κ' → Nonpositive G K, (∀ j, ν (w j) ≤ P j β) ∧ + ν (translatedTruncLE (i : G) u - ∑ j, w j * q j) < + (β : WithBot NatOrdinal) := by + rintro ⟨z, hzs, hzr⟩ + have hz0 : z ≤ 0 := closure_minimal u.property isClosed_Iic + ((mem_closedSupport _ _).mp hzs) + obtain ⟨F, hFw, hFbot, hFGE⟩ := hp z hz0 + have hνT : ν (translatedTruncLE z u) = (β : WithBot NatOrdinal) := by + rw [degree_translatedTruncLE_eq, ite_eq_left hzs, cantorBendixsonRank_eq, hzr, + NatOrdinal.of_val] + exact exists_degree_correction_of_componentsGE_mem xg hV hinj Q σQ hQ hτβ + (fun j ↦ P j β) (fun j ↦ hP j β hτβ hβμ) hνT hFw hFbot hFGE + choose wA hwAb hwAcorr using hlocal + obtain ⟨ctop, hctopb, hRdrop⟩ := + exists_forall_degree_translatedTruncLE_sub_sum_mul_lt β q + (fun j ↦ P j β) σQ (fun j ↦ (hP j β hτβ hβμ).le) (fun j ↦ (hW j).degree_le) + (fun j x hx ↦ (hW j).degree_translatedTruncLE_lt hx) u hu wA hwAb hwAcorr + set R : Nonpositive G K := u - ∑ j, ctop j * q j with hR_def + have hτα : τ < α := hτμ.trans hμα + -- Step B: the local ideal condition passes to the corrected residual. + have hpR : ∀ y : G, y ≤ 0 → ∃ F : MvPolynomial ι K, + (∀ d ∈ F.support, (Finsupp.weight wt) d < α) ∧ + ν (translatedTruncLE y R - aeval V F) = ⊥ ∧ + MvPolynomial.componentsGE wt τ F ∈ Ideal.span (Set.range Q) := by + exact local_ideal_presentation_sub_sum_mul xg hV α hgen Q σQ hQ τ β hτα hβα + (fun j ↦ P j β) (fun j ↦ hP j β hτβ hβμ) + (fun j ↦ (hPle j β hτβ hβμ).trans_lt hμα) hW + (fun j ↦ hPsep' j β hτβ hβμ) u ctop hctopb hp + -- Step C: cover the residual support by disjoint convex pieces and recurse. + obtain ⟨Xset, C, hXs, hCmem, hCopen, hCconv, hCdisj, hCord, hCcov, hCmax, hCrank, hXdisc⟩ := + TopologicalSpace.Closeds.exists_disjoint_convex_cover_with_rank_lt_center + (R : HahnSeries G K).closedSupport (R : HahnSeries G K).closedSupport_isPWO + U hUmono hUopen hUconv hUbase + have hXpieces : Xset ⊆ ⋃ x : ↥Xset, C x := hXs.trans hCcov + have hX0 : ∀ x : ↥Xset, (x : G) ≤ 0 := fun x ↦ + closure_minimal R.property isClosed_Iic ((mem_closedSupport _ _).mp (hXs x.2)) + have hXset_pwo : Xset.IsPWO := (R : HahnSeries G K).closedSupport_isPWO.mono hXs + have hXpwo : (Set.univ : Set ↥Xset).IsPWO := by + rw [Set.isPWO_iff_exists_monotone_subseq] + intro f _ + obtain ⟨g, hg⟩ := hXset_pwo.exists_monotone_subseq fun n ↦ (f n).2 + exact ⟨g, fun a b hab ↦ Subtype.coe_le_coe.mp (hg hab)⟩ + let fx : ↥Xset → HahnSeries G K := fun x ↦ setRestrict (C x) (R : HahnSeries G K) + have hfxC : ∀ x, (fx x).support ⊆ C x := by + intro x + rw [show fx x = setRestrict (C x) (R : HahnSeries G K) from rfl, support_setRestrict] + exact inter_subset_right + have hfxle : ∀ x : ↥Xset, ∀ p ∈ (fx x).support, p ≤ (x : G) := by + intro x p hp + have hp' : p ∈ (R : HahnSeries G K).support ∩ C x := by + rwa [show fx x = setRestrict (C x) (R : HahnSeries G K) from rfl, + support_setRestrict] at hp + exact hCmax x p ⟨(mem_closedSupport _ _).mpr (subset_closure hp'.1), hp'.2⟩ + have hfx_shift : ∀ x : ↥Xset, (translate (-(x : G)) (fx x)).support ⊆ Iic 0 := by + intro x + rw [support_translate] + rintro g ⟨p, hp, rfl⟩ + have hpx := hfxle x p hp + exact mem_Iic.mpr (by + simpa only [sub_eq_add_neg, add_comm] using (sub_nonpos.mpr hpx)) + let ux : ↥Xset → Nonpositive G K := fun x ↦ ⟨translate (-(x : G)) (fx x), hfx_shift x⟩ + let bx : ↥Xset → NatOrdinal.{u} := fun x ↦ + NatOrdinal.of ((R : HahnSeries G K).cantorBendixsonRank (x : G)) + have hpieceData (x : ↥Xset) := translated_convex_piece_local_data Q α τ R (ux x) + (x : G) (C x) (fx x) rfl rfl (hCopen x) (hCconv x) (hCmem x) + (fun y hy hne ↦ by + simpa only [cantorBendixsonRank_eq] using hCrank x y hy hne) + (bx x) rfl (fun y hy ↦ hpR y (hy.trans (hX0 x))) + have hloc := fun x ↦ (hpieceData x).2.1 + have hux_prof := fun x ↦ (hpieceData x).2.2.1 + have hpux := fun x ↦ (hpieceData x).2.2.2 + have hbx_lt : ∀ x : ↥Xset, bx x < β := by + intro x + have h1 := hRdrop (x : G) (hX0 x) + have hm : (x : G) ∈ (R : HahnSeries G K).closedSupport := hXs x.2 + rw [degree_translatedTruncLE_eq, ite_eq_left hm] at h1 + exact WithBot.coe_lt_coe.mp h1 + have hpiece : ∀ x : ↥Xset, ∃ cp : κ' → Nonpositive G K, + (∀ j, ∀ s : G, s ≤ 0 → ν (translatedTruncLE s (cp j)) ≤ P j (bx x)) ∧ + (bx x ≤ τ → ∀ j, cp j = 0) ∧ + ∀ s : G, s ≤ 0 → + ν (translatedTruncLE s (ux x - ∑ j, cp j * q j)) ≤ τ := + fun x ↦ ih (bx x) (hbx_lt x) ((hbx_lt x).le.trans hβμ) (ux x) (hux_prof x) (hpux x) + choose cp hcpb hcp0 hcpres using hpiece + -- Step D: translate the piece cofactors back and sum them. + obtain ⟨placed, hplaced⟩ : ∃ placed : κ' → ↥Xset → K⟦G⟧, ∀ j x, + placed j x = setRestrict (C x) + (translate (x : G) ((cp x j : Nonpositive G K) : HahnSeries G K)) := + ⟨fun j x ↦ setRestrict (C x) + (translate (x : G) ((cp x j : Nonpositive G K) : HahnSeries G K)), fun _ _ ↦ rfl⟩ + have hplC : ∀ j x, (placed j x).support ⊆ C x := by + intro j x + rw [hplaced j x, support_setRestrict] + exact inter_subset_right + have hplle : ∀ j (x : ↥Xset), ∀ p ∈ (placed j x).support, p ≤ (x : G) := by + intro j x p hp + rw [hplaced j x, support_setRestrict] at hp + obtain ⟨hp1, -⟩ := hp + rw [support_translate] at hp1 + obtain ⟨q, hq, rfl⟩ := hp1 + have hq0 : q ≤ 0 := (cp x j).property hq + calc (x : G) + q ≤ (x : G) + 0 := add_le_add le_rfl hq0 + _ = (x : G) := add_zero _ + have hsepP : ∀ j, ∀ a b : ↥Xset, a < b → + ∀ p ∈ (placed j a).support, ∀ q ∈ (placed j b).support, p < q := + fun j a b hab p hp q hq ↦ hCord a b hab p (hplC j a hp) q (hplC j b hq) + have hcPnonpos : ∀ j, (separatedHsum hXpwo (placed j) (hsepP j)).support ⊆ Iic 0 := by + intro j g hg + rw [support_separatedHsum, Set.mem_iUnion] at hg + obtain ⟨x, hgx⟩ := hg + exact (hplle j x g hgx).trans (hX0 x) + obtain ⟨cP, hcP_coe⟩ : ∃ cP : κ' → Nonpositive G K, ∀ j, + ((cP j : Nonpositive G K) : HahnSeries G K) = + separatedHsum hXpwo (placed j) (hsepP j) := + ⟨fun j ↦ ⟨separatedHsum hXpwo (placed j) (hsepP j), hcPnonpos j⟩, fun _ ↦ rfl⟩ + let pieceFamily : SeparatedHsumFamily κ' ↥Xset := + { hX := hXpwo + piece := C + center := fun x ↦ (x : G) + term := placed + support_subset := hplC + support_le_center := hplle + center_mem := hCmem + isOpen_piece := hCopen + ordConnected_piece := hCconv + disjoint_piece := hCdisj + piece_lt_piece := hCord + separated := hsepP + sum := cP + coe_sum := hcP_coe } + have hcPb : ∀ j y, y ≤ 0 → ν (translatedTruncLE y (cP j)) ≤ P j β := by + intro j y _ + exact pieceFamily.degree_le_of_discrete_centers cp τ (fun j ↦ P j β) bx + (fun x j ↦ P j (bx x)) hplaced hcp0 hcpb + (fun x j h ↦ hPlt j (bx x) β h (hbx_lt x) hβμ) + (fun z ↦ by simpa only [pieceFamily, Subtype.range_coe] using hXdisc z) j y + -- Step E: the final cofactors correct every truncation to the floor. + refine ⟨fun j ↦ ctop j + cP j, ?_, ?_, ?_⟩ + · intro j y hy + rw [map_add] + exact ((ν).map_add_le_max _ _).trans (max_le (hctopb j y hy) (hcPb j y hy)) + · intro habs + exact (hβτ habs).elim + · intro y hy + have hres_eq : u - ∑ j, (ctop j + cP j) * q j = + R - ∑ j, cP j * q j := by + rw [hR_def, Finset.sum_congr rfl fun j _ ↦ add_mul (ctop j) (cP j) (q j), + Finset.sum_add_distrib] + ring + rw [hres_eq] + exact pieceFamily.degree_residual_le R ux cp q τ (fun j ↦ P j β) σQ bx + (fun x j ↦ P j (bx x)) hplaced hcp0 hcpb hcpres hcPb hW + (fun j ↦ hPsep' j β hτβ hβμ) + (fun x h j ↦ hPsep' j (bx x) h ((hbx_lt x).le.trans hβμ)) hloc y (by + intro hyC + have hyR := degree_translatedTruncLE_eq_bot_of_notMem_closedSupport (b := R) (by + intro hm + exact hyC (Set.mem_iUnion.mp (hCcov hm))) + have hXclosed : closure Xset = Xset := + (isClosed_iff_accPt.mpr fun z hz ↦ (hXdisc z hz).elim).closure_eq + have hyPieces : ∀ x : ↥Xset, y ∉ C x := fun x hyx ↦ hyC ⟨x, hyx⟩ + have hyX : y ∉ Xset := fun h ↦ hyC (Set.mem_iUnion.mp (hXpieces h)) + have hyCenters : y ∉ closure (Set.range (fun x : ↥Xset ↦ (x : G))) := + notMem_closure_range_subtype_coe hXclosed hyX + have hycP := + pieceFamily.degree_translatedTruncLE_eq_bot_of_notMem hyPieces hyCenters + exact ⟨hyR, by simpa only [pieceFamily] using hycP⟩) + + + +open Classical in +/-- **The graded conclusion of the cofactor construction.** Under the hypotheses at the top degree +`μ`, the homogeneous class of `u` in degree `μ` lies in the ideal of the associated graded ring +generated by the classes of the evaluated generators. The cofactors exhibit this membership, and +the resulting residual has degree at most `τ < μ`, hence represents zero in degree `μ`. -/ +theorem homogeneousClass_mem_span_of_locallyIdeal + [DenselyOrdered G] [NoMinOrder G] [NoMaxOrder G] + [LinearOrder κ] [WellFoundedLT κ] [Finite κ'] + (U : κ → AddSubgroup G) + (hUmono : ∀ {i j : κ}, i ≤ j → (U j : Set G) ⊆ (U i : Set G)) + (hUopen : ∀ i, IsOpen (U i : Set G)) + (hUconv : ∀ i, (U i : Set G).OrdConnected) + (hUbase : ∀ ε : G, 0 < ε → ∃ i, (U i : Set G) ⊆ Ioo (-ε) ε) + {wt : ι → NatOrdinal.{u}} {V : ι → Nonpositive G K} + (xg : ι → (ν).AssociatedGraded) + (hV : ∀ i, Represents (V i) (wt i) (xg i)) + (hVbounds : ∀ i, HasLowerTruncationDegree (V i) (wt i)) + (α : NatOrdinal.{u}) + (hgen : ∀ β : NatOrdinal.{u}, β < α → ∀ y ∈ DirectSum.rangeLof K (ν).Component β, + ∃ F : MvPolynomial ι K, IsWeightedHomogeneous wt F β ∧ aeval xg F = y) + (hinj : ∀ (β : NatOrdinal.{u}) (F : MvPolynomial ι K), β < α → + IsWeightedHomogeneous wt F β → aeval xg F = 0 → F = 0) + (Q : κ' → MvPolynomial ι K) (σQ : κ' → NatOrdinal.{u}) + (hQ : ∀ j, IsWeightedHomogeneous wt (Q j) (σQ j)) + (τ μ : NatOrdinal.{u}) (hτμ : τ < μ) (hμα : μ < α) + (P : κ' → NatOrdinal.{u} → NatOrdinal.{u}) + (hP : ∀ j β, τ < β → β ≤ μ → P j β + σQ j = β) + (hPsep : ∀ j θ, θ < σQ j → P j μ + θ < τ) + (u : Nonpositive G K) (eu : (ν).AssociatedGraded) (heu : Represents u μ eu) + (hu : ∀ y : G, y ≤ 0 → ν (translatedTruncLE y u) ≤ μ) + (hp : ∀ y : G, y ≤ 0 → ∃ F : MvPolynomial ι K, + (∀ d ∈ F.support, (Finsupp.weight wt) d < α) ∧ + ν (translatedTruncLE y u - aeval V F) = ⊥ ∧ + MvPolynomial.componentsGE wt τ F ∈ Ideal.span (Set.range Q)) : + eu ∈ Ideal.span (Set.range fun j ↦ aeval xg (Q j)) := by + classical + let := Fintype.ofFinite κ' + obtain ⟨c, hcb, -, hres⟩ := exists_cofactors_degree_translatedTruncLE_le_of_locallyIdeal + U hUmono hUopen hUconv hUbase xg hV hVbounds α hgen hinj Q σQ hQ τ μ hτμ hμα P hP hPsep + μ le_rfl u hu hp + have hcrep : ∀ j, Represents (c j) (P j μ) + ((ν).homogeneousMk (P j μ) ⟨c j, ((ν).mem_filtrationLE_iff (P j μ) (c j)).mpr + (by simpa only [translatedTruncLE_zero] using hcb j 0 le_rfl)⟩) := + fun j ↦ represents_iff.mpr + ⟨by simpa only [translatedTruncLE_zero] using hcb j 0 le_rfl, rfl⟩ + have hQrep : ∀ j, Represents (aeval V (Q j)) (σQ j) (aeval xg (Q j)) := + fun j ↦ represents_aeval xg hV (hQ j) + have hterm : ∀ j, Represents (c j * aeval V (Q j)) μ + ((ν).homogeneousMk (P j μ) ⟨c j, ((ν).mem_filtrationLE_iff (P j μ) (c j)).mpr + (by simpa only [translatedTruncLE_zero] using hcb j 0 le_rfl)⟩ * aeval xg (Q j)) := + fun j ↦ (hcrep j).mul (hP j μ (lt_of_lt_of_le hτμ le_rfl) le_rfl).symm (hQrep j) + have hsumrep := represents_sum (s := (Finset.univ : Finset κ')) (m := μ) + fun j _ ↦ hterm j + have hzero : Represents (u - ∑ j, c j * aeval V (Q j)) μ 0 := by + apply represents_of_degree_lt + have hle := hres 0 le_rfl + rw [translatedTruncLE_zero] at hle + exact hle.trans_lt (WithBot.coe_lt_coe.mpr hτμ) + have hsplit : u = (u - ∑ j, c j * aeval V (Q j)) + ∑ j, c j * aeval V (Q j) := by abel + have hurep : Represents u μ (0 + ∑ j, (ν).homogeneousMk (P j μ) + ⟨c j, ((ν).mem_filtrationLE_iff (P j μ) (c j)).mpr + (by simpa only [translatedTruncLE_zero] using hcb j 0 le_rfl)⟩ * aeval xg (Q j)) := by + rw [hsplit] + exact hzero.add hsumrep + rw [heu.unique hurep, zero_add] + exact Ideal.sum_mem _ fun j _ ↦ Ideal.mul_mem_left _ _ (Ideal.subset_span ⟨j, rfl⟩) + +open Classical in +/-- **Ideal membership from proper translated truncations.** Suppose `ν u ≤ μ` and every +translated truncation at a strictly negative cutoff has degree below `μ`. If those truncations are +locally congruent to +evaluated polynomials with ideal high part, there are cofactors of the prescribed degrees whose +combination with the evaluated generators corrects the series to degree at most `τ + 1`. The +hypothesis is never used at the cutoff zero, where it would assert the conclusion: the closed +support is partitioned inside the strictly negative region, every piece is treated by the +well-founded cofactor construction at its own strictly smaller rank, and the translated local +cofactors combine with strict local stages, so the resulting cofactors keep their degrees at zero. +-/ +@[blueprint "lem:well-founded-cofactor-construction" + (phase := "Algebraic independence in graded rings") + (title := "Cofactors from local data by well-founded induction") + (statement := /-- + Let $K$ be a field of characteristic zero and let $G$ be a complete + densely ordered abelian group with a decreasing well-founded neighbourhood + basis $(U_i)$ of open convex additive subgroups. Let $b_i$ represent + homogeneous classes $x_i$ of degrees $w_i$ in the Cantor--Bendixson + associated graded ring, with + \[ + \nu(b_i)\le w_i, + \qquad \nu(b_i^{\vert y}) (cantorBendixsonDegreeValuation (G := G) (R := R)) + +private def successorDerivation (α : NatOrdinal.{u}) : + (ν).Component (α + 1) →+ Filter.Germ (𝓝[<] (0 : G)) (ν).AssociatedGraded := + (Filter.Germ.mapLinear (DirectSum.of (ν).Component α).toIntLinearMap).toAddMonoidHom.comp + (cantorBendixsonLayerDeriv α) + +private theorem successorDerivation_componentMk (α : NatOrdinal.{u}) + (b : (ν).filtrationLE (α + 1)) : + successorDerivation α ((ν).componentMk (α + 1) b) = + ((fun γ ↦ DirectSum.of (ν).Component α + (cantorBendixsonDerivAt α (b : Nonpositive G R) γ)) : + Filter.Germ (𝓝[<] (0 : G)) (ν).AssociatedGraded) := by + rw [successorDerivation, AddMonoidHom.comp_apply, LinearMap.toAddMonoidHom_coe, + cantorBendixsonLayerDeriv_componentMk, Filter.Germ.mapLinear_coe] + rfl + +private theorem remove_one_add_one {α : NatOrdinal.{u}} (h : 0 < α.constantCoeff) : + α.removeNat 1 + 1 = α := by + simpa only [Nat.cast_one] using NatOrdinal.removeNat_add_natCast h + +open Classical in +/-- The truncation map included in the graded ring, zero on zero and limit grades. -/ +def cantorBendixsonHomogeneousDerivation (α : NatOrdinal.{u}) : + (ν).Component α →+ Filter.Germ (𝓝[<] (0 : G)) (ν).AssociatedGraded := + if h : 0 < α.constantCoeff then + (successorDerivation (α.removeNat 1)).comp + (AddEquiv.cast (M := (ν).Component) (remove_one_add_one h).symm).toAddMonoidHom + else 0 + +/-- The homogeneous map vanishes when the finite Cantor coefficient is zero. -/ +theorem cantorBendixsonHomogeneousDerivation_limit (α : NatOrdinal.{u}) + (hα : α.constantCoeff = 0) : + cantorBendixsonHomogeneousDerivation (G := G) (R := R) α = 0 := by + rw [cantorBendixsonHomogeneousDerivation, dite_eq_right (by simp [hα])] + +private theorem successorDerivation_cast {α β : NatOrdinal.{u}} + (h : α = β) (e : β + 1 = α + 1) : + (successorDerivation (G := G) (R := R) α).comp + (AddEquiv.cast (M := (ν).Component) e).toAddMonoidHom = successorDerivation β := by + subst β + rfl + +private theorem cantorBendixsonHomogeneousDerivation_succ (α : NatOrdinal.{u}) : + cantorBendixsonHomogeneousDerivation (G := G) (R := R) (α + 1) = + successorDerivation α := by + have hc : 0 < (α + 1).constantCoeff := by + have he := NatOrdinal.constantCoeff_add_natCast α 1 + simp only [Nat.cast_one] at he + rw [he] + exact Nat.zero_lt_succ _ + rw [cantorBendixsonHomogeneousDerivation, dite_eq_left hc] + have he : (α + 1).removeNat 1 = α := by + apply add_right_cancel (b := (1 : NatOrdinal)) + simpa only [Nat.cast_one] using NatOrdinal.removeNat_add_natCast hc + exact successorDerivation_cast he _ + +/-- The additive extension of the homogeneous truncation maps to the associated graded ring. -/ +def cantorBendixsonGradedDerivation : + (ν).AssociatedGraded →+ Filter.Germ (𝓝[<] (0 : G)) (ν).AssociatedGraded := + DirectSum.toAddMonoid (cantorBendixsonHomogeneousDerivation (G := G) (R := R)) + +/-- On a homogeneous inclusion, the graded derivation is the homogeneous truncation map. -/ +theorem cantorBendixsonGradedDerivation_of (α : NatOrdinal.{u}) (a : (ν).Component α) : + cantorBendixsonGradedDerivation (DirectSum.of (ν).Component α a) = + cantorBendixsonHomogeneousDerivation α a := by + rw [cantorBendixsonGradedDerivation, DirectSum.toAddMonoid_of] + +/-- A successor representative is sent to its translated truncation classes near zero. -/ +@[blueprint "lem:cantor-bendixson-derivation-successor-formula" + (phase := "Algebraic independence in graded rings") + (title := "The successor formula for the Cantor--Bendixson derivation") + (statement := /-- + Let $\nu$ be the Cantor--Bendixson degree on + $R((G^{\leq0}))$, and let $\partial_{\mathrm{CB}}$ be the additive map + from $\operatorname{gr}_\nu$ to functions + $G\to\operatorname{gr}_\nu$ modulo equality on a left neighbourhood of + $0$. If $\nu(b)\leq\alpha+1$, then + \[ + \partial_{\mathrm{CB}}\bigl(\operatorname{in}_{\alpha+1}(b)\bigr) + = + \left[\gamma\longmapsto + \operatorname{in}_{\alpha}\bigl(b^{\mid\gamma}\bigr)\right]_{\gamma\to0^-}, + \] + where $b^{\mid\gamma}$ is the translated truncation of $b$ at $\gamma$. + -/) + (proof := /-- + By \ref{thm:cantor-bendixson-value-multiplicative}, the + Cantor--Bendixson degree defines the multiplicative filtration and + associated graded ring used here. On the component of degree + $\alpha+1$, the map + $\partial_{\mathrm{CB}}$ is defined by taking the degree-$\alpha$ class + of each translated truncation. Including those classes in the associated + graded ring gives the displayed equality. + -/)] +theorem cantorBendixsonGradedDerivation_homogeneousMk_succ {δ : NatOrdinal.{u}} + (α : NatOrdinal.{u}) (hδ : δ = α + 1) (b : (ν).filtrationLE δ) : + cantorBendixsonGradedDerivation ((ν).homogeneousMk δ b) = + ((fun γ ↦ DirectSum.of (ν).Component α + (cantorBendixsonDerivAt α (b : Nonpositive G R) γ)) : + Filter.Germ (𝓝[<] (0 : G)) (ν).AssociatedGraded) := by + subst δ + rw [(ν).homogeneousMk_apply, cantorBendixsonGradedDerivation_of, + cantorBendixsonHomogeneousDerivation_succ, successorDerivation_componentMk] + +/-- Zero and limit homogeneous representatives have zero derivative. -/ +theorem cantorBendixsonGradedDerivation_homogeneousMk_limit (α : NatOrdinal.{u}) + (hα : α.constantCoeff = 0) (b : (ν).filtrationLE α) : + cantorBendixsonGradedDerivation ((ν).homogeneousMk α b) = 0 := by + rw [(ν).homogeneousMk_apply, cantorBendixsonGradedDerivation_of, + cantorBendixsonHomogeneousDerivation_limit _ hα, AddMonoidHom.zero_apply] + +/-- The Leibniz rule holds on every pair of homogeneous representatives. -/ +theorem cantorBendixsonGradedDerivation_mul_homogeneous (α β : NatOrdinal.{u}) + (b : (ν).filtrationLE α) (c : (ν).filtrationLE β) : + cantorBendixsonGradedDerivation ((ν).homogeneousMk α b * (ν).homogeneousMk β c) = + cantorBendixsonGradedDerivation ((ν).homogeneousMk α b) * + ((ν).homogeneousMk β c : Filter.Germ (𝓝[<] (0 : G)) (ν).AssociatedGraded) + + ((ν).homogeneousMk α b : Filter.Germ (𝓝[<] (0 : G)) (ν).AssociatedGraded) * + cantorBendixsonGradedDerivation ((ν).homogeneousMk β c) := by + let LeibnizAt : (ν).AssociatedGraded → (ν).AssociatedGraded → Prop := fun x y ↦ + cantorBendixsonGradedDerivation (x * y) = + cantorBendixsonGradedDerivation x * + (y : Filter.Germ (𝓝[<] (0 : G)) (ν).AssociatedGraded) + + (x : Filter.Germ (𝓝[<] (0 : G)) (ν).AssociatedGraded) * + cantorBendixsonGradedDerivation y + change LeibnizAt ((ν).homogeneousMk α b) ((ν).homogeneousMk β c) + have succ_succ (α β : NatOrdinal.{u}) + (b : (ν).filtrationLE (α + 1)) (c : (ν).filtrationLE (β + 1)) : + LeibnizAt ((ν).homogeneousMk (α + 1) b) ((ν).homogeneousMk (β + 1) c) := by + dsimp only [LeibnizAt] + rw [(ν).homogeneousMk_mul, + cantorBendixsonGradedDerivation_homogeneousMk_succ (α + β + 1) (by ac_rfl), + cantorBendixsonGradedDerivation_homogeneousMk_succ α rfl, + cantorBendixsonGradedDerivation_homogeneousMk_succ β rfl] + simp only [(ν).coe_mulFiltrationLE] + exact Filter.EventuallyEq.germ_eq (eventually_homogeneousDerivAt_mul_succ α β b c) + have succ_limit (α β : NatOrdinal.{u}) (hβ : β.constantCoeff = 0) + (b : (ν).filtrationLE (α + 1)) (c : (ν).filtrationLE β) : + LeibnizAt ((ν).homogeneousMk (α + 1) b) ((ν).homogeneousMk β c) := by + dsimp only [LeibnizAt] + rw [(ν).homogeneousMk_mul, + cantorBendixsonGradedDerivation_homogeneousMk_succ (α + β) (by ac_rfl), + cantorBendixsonGradedDerivation_homogeneousMk_succ α rfl, + cantorBendixsonGradedDerivation_homogeneousMk_limit β hβ, mul_zero, add_zero] + simp only [(ν).coe_mulFiltrationLE] + exact Filter.EventuallyEq.germ_eq (eventually_homogeneousDerivAt_mul_limit α β hβ b c) + have succ (α β : NatOrdinal.{u}) + (b : (ν).filtrationLE (α + 1)) (c : (ν).filtrationLE β) : + LeibnizAt ((ν).homogeneousMk (α + 1) b) ((ν).homogeneousMk β c) := by + by_cases hβ : β.constantCoeff = 0 + · exact succ_limit α β hβ b c + · obtain ⟨β', rfl⟩ : ∃ β', β = β' + 1 := + ⟨β.removeNat 1, (remove_one_add_one (Nat.pos_of_ne_zero hβ)).symm⟩ + exact succ_succ α β' b c + dsimp only [LeibnizAt] + by_cases hα : α.constantCoeff = 0 + · by_cases hβ : β.constantCoeff = 0 + · have hs : (α + β).constantCoeff = 0 := by + rw [NatOrdinal.constantCoeff_add, hα, hβ, zero_add] + rw [(ν).homogeneousMk_mul, cantorBendixsonGradedDerivation_homogeneousMk_limit _ hs, + cantorBendixsonGradedDerivation_homogeneousMk_limit _ hα, + cantorBendixsonGradedDerivation_homogeneousMk_limit _ hβ, + zero_mul, mul_zero, add_zero] + · obtain ⟨β', rfl⟩ : ∃ β', β = β' + 1 := + ⟨β.removeNat 1, (remove_one_add_one (Nat.pos_of_ne_zero hβ)).symm⟩ + have h := succ β' α c b + rw [mul_comm ((ν).homogeneousMk α b) ((ν).homogeneousMk (β' + 1) c), h] + rw [add_comm] + congr 1 <;> exact mul_comm _ _ + · obtain ⟨α', rfl⟩ : ∃ α', α = α' + 1 := + ⟨α.removeNat 1, (remove_one_add_one (Nat.pos_of_ne_zero hα)).symm⟩ + exact succ α' β b c + +private theorem const_add (x y : (ν).AssociatedGraded) : + ((x + y : (ν).AssociatedGraded) : Filter.Germ (𝓝[<] (0 : G)) (ν).AssociatedGraded) = + (x : Filter.Germ (𝓝[<] (0 : G)) (ν).AssociatedGraded) + + (y : Filter.Germ (𝓝[<] (0 : G)) (ν).AssociatedGraded) := rfl + +private theorem const_zero : + ((0 : (ν).AssociatedGraded) : Filter.Germ (𝓝[<] (0 : G)) (ν).AssociatedGraded) = 0 := rfl + +/-- The graded truncation map satisfies the Leibniz rule, using constant function germs. -/ +@[blueprint "lem:cantor-bendixson-derivation-leibniz" + (phase := "Algebraic independence in graded rings") + (title := "The Leibniz rule for the Cantor--Bendixson derivation") + (statement := /-- + For all $x,y\in\operatorname{gr}_\nu$, + \[ + \partial_{\mathrm{CB}}(xy) + =\partial_{\mathrm{CB}}(x)y+x\partial_{\mathrm{CB}}(y), + \] + where elements of $\operatorname{gr}_\nu$ on the right are regarded as + constant functions near $0$. + -/) + (proof := /-- + Decompose $x$ and $y$ into homogeneous components. On successor + components, \ref{lem:cantor-bendixson-derivation-successor-formula} + turns the identity into the translated-truncation product formula. The + derivative vanishes on components whose constant Cantor coefficient is + zero. Additivity then gives the formula for arbitrary $x$ and $y$. + -/)] +theorem cantorBendixsonGradedDerivation_mul (x y : (ν).AssociatedGraded) : + cantorBendixsonGradedDerivation (x * y) = + cantorBendixsonGradedDerivation x * + (y : Filter.Germ (𝓝[<] (0 : G)) (ν).AssociatedGraded) + + (x : Filter.Germ (𝓝[<] (0 : G)) (ν).AssociatedGraded) * + cantorBendixsonGradedDerivation y := by + induction x using DirectSum.induction_on with + | zero => simp [const_zero] + | of α a => + induction y using DirectSum.induction_on with + | zero => simp [const_zero] + | of β b => + induction a using MaxAddDegree.componentInductionOn with + | H a => + induction b using MaxAddDegree.componentInductionOn with + | H b => + simpa only [(ν).homogeneousMk_apply] using + cantorBendixsonGradedDerivation_mul_homogeneous α β a b + | add y z hy hz => + rw [mul_add, map_add, hy, hz, map_add, const_add, mul_add, mul_add] + abel + | add x z hx hz => + rw [add_mul, map_add, hx, hz, map_add, const_add, add_mul, add_mul] + abel + +/-- Restriction of the graded derivation to each successor homogeneous component is injective. -/ +theorem cantorBendixsonGradedDerivation_injective_on_successor (α : NatOrdinal.{u}) : + Function.Injective (fun a : (ν).Component (α + 1) ↦ + cantorBendixsonGradedDerivation (DirectSum.of (ν).Component (α + 1) a)) := by + intro a b hab + simp only [cantorBendixsonGradedDerivation_of, + cantorBendixsonHomogeneousDerivation_succ] at hab + apply cantorBendixsonLayerDeriv_injective α + apply Filter.Germ.mapLinear_injective (DirectSum.of (ν).Component α).toIntLinearMap + (DirectSum.of_injective α) + exact hab + +end HahnSeries.Nonpositive diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/DerivationIdeal.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/DerivationIdeal.lean new file mode 100644 index 0000000000..96f9bd51d7 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/DerivationIdeal.lean @@ -0,0 +1,334 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.GradedRing.HomogeneousSpan +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.Scalar +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.TranslatedTruncationInterpolation + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint + +/-! +# Successor ideal integration for the Cantor–Bendixson derivation + +Prescribed homogeneous coefficient germs on one exact Cantor–Bendixson rank can be integrated at +arbitrary cofinality. This module combines that construction with homogeneous ideal +decomposition and the injective successor derivation. +-/ + +public noncomputable section + +open Set Filter Topology +open scoped DirectSum NatOrdinal + +universe u v w + +namespace HahnSeries.Nonpositive + +variable {G : Type u} {K : Type v} [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [UniformSpace G] [IsUniformAddGroup G] [OrderTopology G] [Nontrivial G] [CompleteSpace G] + [Field K] [CharZero K] + +local notation "ν" => (cantorBendixsonDegreeValuation (G := G) (R := K)) + +/-- A finite pointwise sum represents the sum of the corresponding filter germs. -/ +theorem germ_coe_sum {ι : Type w} [Fintype ι] (g : ι → G → (ν).AssociatedGraded) : + ((fun γ ↦ ∑ i, g i γ : G → (ν).AssociatedGraded) : + Filter.Germ (𝓝[<] (0 : G)) (ν).AssociatedGraded) = + ∑ i, ((g i : G → (ν).AssociatedGraded) : + Filter.Germ (𝓝[<] (0 : G)) (ν).AssociatedGraded) := by + have hfun : (fun γ ↦ ∑ i, g i γ : G → (ν).AssociatedGraded) = ∑ i, g i := by + ext γ + simp only [Finset.sum_apply] + rw [hfun] + exact map_sum (Filter.Germ.coeRingHom (𝓝[<] (0 : G))) g Finset.univ + +/-- The graded derivative vanishes on a homogeneous element whose grade has zero finite Cantor +coefficient. -/ +theorem cantorBendixsonGradedDerivation_eq_zero_of_constantCoeff_eq_zero + {c : NatOrdinal.{u}} (hc : c.constantCoeff = 0) {q : (ν).AssociatedGraded} + (hq : q ∈ DirectSum.rangeLof K (ν).Component c) : + cantorBendixsonGradedDerivation q = 0 := by + obtain ⟨a, ha⟩ := (DirectSum.mem_rangeLof_iff K (ν).Component c q).mp hq + rw [DirectSum.lof_eq_of] at ha + rw [← ha, cantorBendixsonGradedDerivation_of, + cantorBendixsonHomogeneousDerivation_limit c hc, AddMonoidHom.zero_apply] + +open Classical in +/-- A homogeneous function prescribed on the exact-rank points of a successor representative is +the graded derivative of a homogeneous class. The product with a fixed homogeneous element has +the expected successor grade. -/ +@[blueprint "lem:prescribed-cantor-bendixson-derivative-exact-rank" + (phase := "Algebraic independence in graded rings") + (title := "Prescribing the Cantor--Bendixson derivative on one exact-rank set") + (statement := /-- + Let $q\in\operatorname{gr}_\nu$ be homogeneous of degree $c$, and let a + series $p$ have Cantor--Bendixson degree at most $\delta+1$. Prescribe at + every point of exact rank $\delta$ in + $\overline{\operatorname{supp}(p)}$ a homogeneous class $a_\gamma$ whose + degree $\beta$ satisfies $\beta+c=\delta$, taking $a_\gamma=0$ when no + such $\beta$ exists. Then there is $z\in\operatorname{gr}_\nu$ such that + $qz$ is homogeneous of degree $\delta+1$ and the Cantor--Bendixson + derivative of $z$ agrees near $0$ with $a_\gamma$ on that exact-rank set + and is zero away from it. + -/) + (proof := /-- + If no $\beta$ satisfies $\beta+c=\delta$, take $z=0$. Otherwise, all + prescribed values have the same degree $\beta$. Choose component + representatives and place them on pairwise separated left intervals + ending at the exact-rank points of $p$. Their Hahn sum has degree at most + $\beta+1$ and has the prescribed translated-truncation classes. Its + degree-$(\beta+1)$ class is $z$; the graded product has degree + $c+(\beta+1)=\delta+1$, and + \ref{lem:cantor-bendixson-derivation-successor-formula} gives the required + near-zero equality. + -/)] +theorem exists_grading_mul_and_derivation_eq_rankLevel + {δ c : NatOrdinal.{u}} {q : (ν).AssociatedGraded} + (hq : q ∈ DirectSum.rangeLof K (ν).Component c) + (p : Nonpositive G K) (hp : ν p ≤ (δ + 1 : NatOrdinal)) + (a : {x // x ∈ (p : HahnSeries G K).closedSupport ∧ + (p : HahnSeries G K).closedSupport.cantorBendixsonRank + (p : HahnSeries G K).closedSupport_isPWO x = δ.val} → (ν).AssociatedGraded) + (ha : ∀ i β, β + c = δ → + a i ∈ DirectSum.rangeLof K (ν).Component β) + (ha0 : ∀ i, (¬ ∃ β, β + c = δ) → a i = 0) : + ∃ z : (ν).AssociatedGraded, + q * z ∈ DirectSum.rangeLof K (ν).Component (δ + 1) ∧ + cantorBendixsonGradedDerivation z = + ((fun γ ↦ if h : γ ∈ (p : HahnSeries G K).closedSupport ∧ + (p : HahnSeries G K).closedSupport.cantorBendixsonRank + (p : HahnSeries G K).closedSupport_isPWO γ = δ.val then + a ⟨γ, h⟩ else 0) : + Filter.Germ (𝓝[<] (0 : G)) (ν).AssociatedGraded) := by + classical + by_cases hβ : ∃ β, β + c = δ + · obtain ⟨β, hβ⟩ := hβ + have hcomponent : ∀ i, ∃ b : (ν).Component β, + DirectSum.of (ν).Component β b = a i := by + intro i + obtain ⟨b, hb⟩ := (DirectSum.mem_rangeLof_iff K (ν).Component β (a i)).mp + (ha i β hβ) + exact ⟨b, by simpa only [DirectSum.lof_eq_of] using hb⟩ + choose b hb using hcomponent + obtain ⟨s, hs, -, hderiv⟩ := exists_prescribed_components_on_rankLevel δ β p hp b + let z : (ν).AssociatedGraded := + (ν).homogeneousMk (β + 1) + ⟨s, ((ν).mem_filtrationLE_iff (β + 1) s).mpr hs⟩ + refine ⟨z, ?_, ?_⟩ + · have hz : z ∈ DirectSum.rangeLof K (ν).Component (β + 1) := by + dsimp only [z] + rw [(ν).homogeneousMk_apply] + exact DirectSum.of_mem_rangeLof K (ν).Component (β + 1) _ + have hmul := SetLike.mul_mem_graded hq hz + have hgrade : c + (β + 1) = δ + 1 := by + rw [← hβ] + ac_rfl + rwa [hgrade] at hmul + · rw [show z = (ν).homogeneousMk (β + 1) + ⟨s, ((ν).mem_filtrationLE_iff (β + 1) s).mpr hs⟩ from rfl, + cantorBendixsonGradedDerivation_homogeneousMk_succ β rfl] + calc + ((fun γ ↦ DirectSum.of (ν).Component β + (cantorBendixsonDerivAt β s γ)) : + Filter.Germ (𝓝[<] (0 : G)) (ν).AssociatedGraded) = + Filter.Germ.mapLinear (DirectSum.of (ν).Component β).toIntLinearMap + (cantorBendixsonLayerDeriv β + ((ν).componentMk (β + 1) + ⟨s, ((ν).mem_filtrationLE_iff (β + 1) s).mpr hs⟩)) := by + rw [cantorBendixsonLayerDeriv_componentMk, Filter.Germ.mapLinear_coe] + rfl + _ = Filter.Germ.mapLinear (DirectSum.of (ν).Component β).toIntLinearMap + (((fun γ ↦ if h : γ ∈ (p : HahnSeries G K).closedSupport ∧ + (p : HahnSeries G K).closedSupport.cantorBendixsonRank + (p : HahnSeries G K).closedSupport_isPWO γ = δ.val then + b ⟨γ, h⟩ else 0) : + Filter.Germ (𝓝[<] (0 : G)) ((ν).Component β))) := + congrArg _ hderiv + _ = _ := by + rw [Filter.Germ.mapLinear_coe, Filter.Germ.coe_eq] + exact Filter.Eventually.of_forall fun γ ↦ by + by_cases hγ : γ ∈ (p : HahnSeries G K).closedSupport ∧ + (p : HahnSeries G K).closedSupport.cantorBendixsonRank + (p : HahnSeries G K).closedSupport_isPWO γ = δ.val + · simp only [dite_eq_left hγ, Function.comp_apply] + change DirectSum.of (ν).Component β (b ⟨γ, hγ⟩) = a ⟨γ, hγ⟩ + exact hb ⟨γ, hγ⟩ + · simp only [dite_eq_right hγ, Function.comp_apply, map_zero] + · refine ⟨0, ?_, ?_⟩ + · rw [mul_zero] + exact zero_mem _ + · rw [map_zero, ← Filter.Germ.coe_zero, Filter.Germ.coe_eq] + exact Filter.Eventually.of_forall fun γ ↦ by + by_cases hγ : γ ∈ (p : HahnSeries G K).closedSupport ∧ + (p : HahnSeries G K).closedSupport.cantorBendixsonRank + (p : HahnSeries G K).closedSupport_isPWO γ = δ.val + · simp only [Pi.zero_apply, dite_eq_left hγ, ha0 ⟨γ, hγ⟩ hβ] + · simp only [Pi.zero_apply, dite_eq_right hγ] + +open Classical in +/-- Ideal membership of a successor homogeneous class follows from pointwise ideal membership +of its Cantor–Bendixson derivative germ. -/ +@[blueprint "lem:successor-ideal-membership-from-cantor-bendixson-derivative" + (phase := "Algebraic independence in graded rings") + (title := "The derivative criterion for successor ideal membership") + (statement := /-- + Let $(q_j)$ be a finite homogeneous family in $\operatorname{gr}_\nu$, of + degrees $c_j$ with zero constant Cantor coefficient. Let $x$ be + homogeneous of degree $\delta+1$. If the Cantor--Bendixson derivative of + $x$ is represented near $0$ by a function $f$ satisfying + \[ + f(\gamma)\in(q_j:j)\qquad\text{for every }\gamma\in G, + \] + then $x\in(q_j:j)$. + -/) + (proof := /-- + Decompose each $f(\gamma)$ homogeneously in the generators $q_j$ using + \ref{lem:homogeneous-element-of-generated-ideal}. On the exact-rank set + of a representative of $x$, apply + \ref{lem:prescribed-cantor-bendixson-derivative-exact-rank} to each + coefficient. The resulting classes $z_j$ make + $y=\sum_jq_jz_j$ homogeneous of degree $\delta+1$ and give $x$ and $y$ + the same Cantor--Bendixson derivative near $0$. The derivative is + injective in successor degree, so $x=y\in(q_j:j)$. Products are + differentiated using + \ref{lem:cantor-bendixson-derivation-leibniz}. + -/)] +theorem mem_span_of_cantorBendixsonGradedDerivation_eq_coe + {ι : Type w} [Finite ι] + {q : ι → (ν).AssociatedGraded} {c : ι → NatOrdinal.{u}} + (hq : ∀ j, q j ∈ DirectSum.rangeLof K (ν).Component (c j)) + (hc : ∀ j, (c j).constantCoeff = 0) + {δ : NatOrdinal.{u}} {x : (ν).AssociatedGraded} + (hx : x ∈ DirectSum.rangeLof K (ν).Component (δ + 1)) + {f : G → (ν).AssociatedGraded} + (hf : ∀ γ, f γ ∈ Ideal.span (Set.range q)) + (hD : cantorBendixsonGradedDerivation x = + (f : Filter.Germ (𝓝[<] (0 : G)) (ν).AssociatedGraded)) : + x ∈ Ideal.span (Set.range q) := by + classical + let := Fintype.ofFinite ι + obtain ⟨xδ, hxδ⟩ := + (DirectSum.mem_rangeLof_iff K (ν).Component (δ + 1) x).mp hx + rw [DirectSum.lof_eq_of] at hxδ + rw [← hxδ] + induction xδ using MaxAddDegree.componentInductionOn with + | H p => + have hp : ν (p : Nonpositive G K) ≤ (δ + 1 : NatOrdinal) := + ((ν).mem_filtrationLE_iff (δ + 1) _).mp p.property + have hDrep : cantorBendixsonGradedDerivation + (DirectSum.of (ν).Component (δ + 1) ((ν).componentMk (δ + 1) p)) = + ((fun γ ↦ DirectSum.of (ν).Component δ + (cantorBendixsonDerivAt δ (p : Nonpositive G K) γ)) : + Filter.Germ (𝓝[<] (0 : G)) (ν).AssociatedGraded) := by + rw [← (ν).homogeneousMk_apply, + cantorBendixsonGradedDerivation_homogeneousMk_succ δ rfl] + have hD' : cantorBendixsonGradedDerivation + (DirectSum.of (ν).Component (δ + 1) ((ν).componentMk (δ + 1) p)) = + (f : Filter.Germ (𝓝[<] (0 : G)) (ν).AssociatedGraded) := by + rw [hxδ] + exact hD + have hevent : ∀ᶠ γ in 𝓝[<] (0 : G), + DirectSum.of (ν).Component δ + (cantorBendixsonDerivAt δ (p : Nonpositive G K) γ) = f γ := by + rw [hDrep] at hD' + exact Filter.Germ.coe_eq.mp hD' + let good : Set G := {γ | DirectSum.of (ν).Component δ + (cantorBendixsonDerivAt δ (p : Nonpositive G K) γ) = f γ} + have hgood : ∀ᶠ γ in 𝓝[<] (0 : G), γ ∈ good := hevent + let I := {γ // γ ∈ (p : HahnSeries G K).closedSupport ∧ + (p : HahnSeries G K).closedSupport.cantorBendixsonRank + (p : HahnSeries G K).closedSupport_isPWO γ = δ.val} + let a : I → (ν).AssociatedGraded := fun i ↦ + if (i : G) ∈ good then f i else 0 + have haGrade : ∀ i, a i ∈ DirectSum.rangeLof K (ν).Component δ := by + intro i + by_cases hi : (i : G) ∈ good + · change (if (i : G) ∈ good then f i else 0) ∈ + DirectSum.rangeLof K (ν).Component δ + rw [ite_eq_left hi, ← hi] + exact DirectSum.of_mem_rangeLof K (ν).Component δ _ + · change (if (i : G) ∈ good then f i else 0) ∈ + DirectSum.rangeLof K (ν).Component δ + rw [ite_eq_right hi] + exact zero_mem _ + have haIdeal : ∀ i, a i ∈ Ideal.span (Set.range q) := by + intro i + by_cases hi : (i : G) ∈ good + · change (if (i : G) ∈ good then f i else 0) ∈ Ideal.span (Set.range q) + rw [ite_eq_left hi] + exact hf i + · change (if (i : G) ∈ good then f i else 0) ∈ Ideal.span (Set.range q) + rw [ite_eq_right hi] + exact Ideal.zero_mem _ + have hdec := fun i ↦ OrdinalGraded.exists_eq_sum_mul_of_mem_span + (𝒜 := DirectSum.rangeLof K (ν).Component) hq (haGrade i) (haIdeal i) + choose u hu hu0 hsum using hdec + have hreal := fun j ↦ exists_grading_mul_and_derivation_eq_rankLevel + (hq j) (p : Nonpositive G K) hp (fun i ↦ u i j) + (fun i β hβ ↦ hu i j β hβ) (fun i hnone ↦ hu0 i j hnone) + choose z hz hDz using hreal + let y : (ν).AssociatedGraded := ∑ j, q j * z j + have hy : y ∈ DirectSum.rangeLof K (ν).Component (δ + 1) := by + exact sum_mem fun j _ ↦ hz j + have hDy : cantorBendixsonGradedDerivation y = + ((fun γ ↦ ∑ j, q j * + (if h : γ ∈ (p : HahnSeries G K).closedSupport ∧ + (p : HahnSeries G K).closedSupport.cantorBendixsonRank + (p : HahnSeries G K).closedSupport_isPWO γ = δ.val then + u ⟨γ, h⟩ j else 0)) : + Filter.Germ (𝓝[<] (0 : G)) (ν).AssociatedGraded) := by + dsimp only [y] + rw [map_sum, germ_coe_sum] + refine Finset.sum_congr rfl fun j _ ↦ ?_ + rw [cantorBendixsonGradedDerivation_mul, + cantorBendixsonGradedDerivation_eq_zero_of_constantCoeff_eq_zero + (hc j) (hq j), zero_mul, zero_add, hDz j] + rfl + have hDxy : cantorBendixsonGradedDerivation + (DirectSum.of (ν).Component (δ + 1) ((ν).componentMk (δ + 1) p)) = + cantorBendixsonGradedDerivation y := by + rw [hDrep, hDy, Filter.Germ.coe_eq] + filter_upwards [hgood, eventually_degree_translatedTruncLE_le + (p : Nonpositive G K) δ hp] with γ hγgood hγdegree + by_cases hγ : γ ∈ (p : HahnSeries G K).closedSupport ∧ + (p : HahnSeries G K).closedSupport.cantorBendixsonRank + (p : HahnSeries G K).closedSupport_isPWO γ = δ.val + · simp only [dite_eq_left hγ] + calc + DirectSum.of (ν).Component δ + (cantorBendixsonDerivAt δ (p : Nonpositive G K) γ) = + f γ := hγgood + _ = a ⟨γ, hγ⟩ := by + change f γ = if γ ∈ good then f γ else 0 + rw [ite_eq_left hγgood] + _ = ∑ j, q j * u ⟨γ, hγ⟩ j := hsum ⟨γ, hγ⟩ + · simp only [dite_eq_right hγ, mul_zero, Finset.sum_const_zero] + have hzero : cantorBendixsonDerivAt δ (p : Nonpositive G K) γ = 0 := by + by_contra hne + have hs := (cantorBendixsonDerivAt_ne_zero_iff δ + (p : Nonpositive G K) γ hγdegree).mp hne + apply hγ + refine ⟨hs.1, ?_⟩ + simpa only [cantorBendixsonRank_eq] using hs.2 + rw [hzero, map_zero] + obtain ⟨yδ, hyδ⟩ := + (DirectSum.mem_rangeLof_iff K (ν).Component (δ + 1) y).mp hy + rw [DirectSum.lof_eq_of] at hyδ + have hcomp : (ν).componentMk (δ + 1) p = yδ := by + apply cantorBendixsonGradedDerivation_injective_on_successor δ + calc + cantorBendixsonGradedDerivation + (DirectSum.of (ν).Component (δ + 1) ((ν).componentMk (δ + 1) p)) = + cantorBendixsonGradedDerivation y := hDxy + _ = cantorBendixsonGradedDerivation + (DirectSum.of (ν).Component (δ + 1) yδ) := + congrArg cantorBendixsonGradedDerivation hyδ.symm + rw [hcomp, hyδ] + exact Ideal.sum_mem _ fun j _ ↦ + Ideal.mul_mem_right _ _ (Ideal.subset_span ⟨j, rfl⟩) + +end HahnSeries.Nonpositive diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/DerivationSet.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/DerivationSet.lean new file mode 100644 index 0000000000..a93c0431ae --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/DerivationSet.lean @@ -0,0 +1,121 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.DerivationIdeal +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.TranslatedTruncationInterpolationOnSets + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint + +/-! +# Prescribing a derivative germ on a discrete set of exponents + +The graded derivative of a class of successor degree is the germ of a function supported on the +exact-rank level of a representative. Conversely a function supported on any discrete set of +nonpositive exponents, with homogeneous values of one fixed degree, is such a germ. + +This is the integration theorem for a discrete set of cutoffs, stated in the associated graded +ring rather than in one component, which is the form required by the syzygy induction. +-/ + +universe u v w + +open scoped NatOrdinal Topology + +open Filter Set HahnSeries + +public noncomputable section + +namespace HahnSeries.Nonpositive + +variable {G : Type u} {K : Type v} +variable [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [UniformSpace G] [IsUniformAddGroup G] [OrderTopology G] [Nontrivial G] [CompleteSpace G] + [Field K] [CharZero K] + +local notation "ν" => (cantorBendixsonDegreeValuation (G := G) (R := K)) + +open Classical in +/-- **A function supported on a discrete set is a derivative germ.** Prescribed homogeneous values +of degree `ρ` at the points of a discrete set of nonpositive exponents, whose closure adds nothing +near zero, are the graded derivative of a class of degree `ρ + 1`. -/ +@[blueprint "lem:prescribed-cantor-bendixson-derivative-discrete-set" + (phase := "Algebraic independence in graded rings") + (title := "Prescribing the Cantor--Bendixson derivative on a discrete set") + (statement := /-- + Let $K$ be a field of characteristic zero and $G$ a nontrivial complete + ordered abelian group with compatible additive uniformity and order + topology. Write $\nu$ for the Cantor--Bendixson degree on + $K((G^{\leq 0}))$. Suppose $S\subseteq G^{\leq0}$ is partially well + ordered and discrete, and that $\overline S\subseteq S$ on some left + neighbourhood of $0$. If every $a(\gamma)$ is homogeneous of degree + $\rho$ in $\operatorname{gr}_\nu$, then there is a homogeneous + $s\in\operatorname{gr}_\nu$ of degree $\rho+1$ whose + Cantor--Bendixson derivative agrees near $0$ with + \[ + \gamma\longmapsto + \begin{cases}a(\gamma),&\gamma\in S,\\0,&\gamma\notin S. + \end{cases} + \] + -/) + (proof := /-- + Regard each prescribed value as an element of the degree-$\rho$ + component. Discreteness supplies pairwise separated left intervals about + the points of $S$. Place a representative of $a(\gamma)$ in the interval + ending at $\gamma$ and sum the resulting Hahn series. Partial + well-ordering makes the family summable. Because the closure of $S$ adds + no points near $0$, translated truncation at a point of $S$ recovers the + prescribed class and gives zero elsewhere. The resulting series has + degree at most $\rho+1$, and its degree-$(\rho+1)$ class is the required + $s$ by + \ref{lem:cantor-bendixson-derivation-successor-formula}. + -/)] +theorem exists_derivation_eq_of_isDiscrete (ρ : NatOrdinal.{u}) (S : Set G) + (hSneg : S ⊆ Iic 0) (hSpwo : (Set.univ : Set ↥S).IsPWO) (hSdisc : IsDiscrete S) + (hnear : ∀ᶠ γ in 𝓝[<] (0 : G), γ ∈ closure S → γ ∈ S) + (a : G → (ν).AssociatedGraded) + (ha : ∀ γ, a γ ∈ DirectSum.rangeLof K (ν).Component ρ) : + ∃ s : (ν).AssociatedGraded, s ∈ DirectSum.rangeLof K (ν).Component (ρ + 1) ∧ + cantorBendixsonGradedDerivation s = + ((fun γ ↦ if γ ∈ S then a γ else 0) : + Filter.Germ (𝓝[<] (0 : G)) (ν).AssociatedGraded) := by + classical + -- the prescribed values, as elements of the component + have hcomp : ∀ i : ↥S, ∃ y : (ν).Component ρ, + DirectSum.of (ν).Component ρ y = a (i : G) := by + intro i + obtain ⟨y, hy⟩ := (DirectSum.mem_rangeLof_iff K (ν).Component ρ (a (i : G))).mp (ha (i : G)) + exact ⟨y, by simpa only [DirectSum.lof_eq_of] using hy⟩ + choose y hy using hcomp + obtain ⟨c, hc, -, hderiv⟩ := + exists_prescribed_components_on_set_of_isDiscrete ρ S hSneg hSpwo hSdisc hnear y + refine ⟨(ν).homogeneousMk (ρ + 1) ⟨c, ((ν).mem_filtrationLE_iff (ρ + 1) c).mpr hc⟩, ?_, ?_⟩ + · rw [(ν).homogeneousMk_apply] + exact DirectSum.of_mem_rangeLof K (ν).Component (ρ + 1) _ + · rw [cantorBendixsonGradedDerivation_homogeneousMk_succ ρ rfl] + calc + ((fun γ ↦ DirectSum.of (ν).Component ρ (cantorBendixsonDerivAt ρ c γ)) : + Filter.Germ (𝓝[<] (0 : G)) (ν).AssociatedGraded) = + Filter.Germ.mapLinear (DirectSum.of (ν).Component ρ).toIntLinearMap + (cantorBendixsonLayerDeriv ρ + ((ν).componentMk (ρ + 1) + ⟨c, ((ν).mem_filtrationLE_iff (ρ + 1) c).mpr hc⟩)) := by + rw [cantorBendixsonLayerDeriv_componentMk, Filter.Germ.mapLinear_coe] + rfl + _ = Filter.Germ.mapLinear (DirectSum.of (ν).Component ρ).toIntLinearMap + (((fun γ ↦ if h : γ ∈ S then y ⟨γ, h⟩ else 0) : + Filter.Germ (𝓝[<] (0 : G)) ((ν).Component ρ))) := congrArg _ hderiv + _ = _ := by + rw [Filter.Germ.mapLinear_coe, Filter.Germ.coe_eq] + refine Filter.Eventually.of_forall fun γ ↦ ?_ + by_cases hγ : γ ∈ S + · simp only [dite_eq_left hγ, ite_eq_left hγ, Function.comp_apply] + exact hy ⟨γ, hγ⟩ + · simp only [dite_eq_right hγ, ite_eq_right hγ, Function.comp_apply, map_zero] + +end HahnSeries.Nonpositive + +end diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/Derivative.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/Derivative.lean new file mode 100644 index 0000000000..ca2c3c6ddd --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/Derivative.lean @@ -0,0 +1,441 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.Graded +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.LeastTermSup +public import Mathlib.Order.Filter.Germ.Basic +import LeanPool.ConwayRefinement.ConwayRefinement.Topology.Order.LeftNeighborhood + +/-! +# Translated truncation from degree `α + 1` to degree `α` + +Translated weak truncation induces an additive map from the homogeneous component of degree +`α + 1` to germs, at negative cutoffs approaching zero, of the component of degree `α`. +The strict drop in Cantor–Bendixson rank makes the map independent of representatives. Local rank +reconstruction proves injectivity: eventual disappearance in the lower component forces the +original representative into the strict filtration. + +The exponent group retains its ordered uniform structure, assumed Cauchy complete, in any +universe; no Archimedean or countability hypothesis is imposed. The map is additive here. Scalar +linearity and a product rule are separate assertions, not consequences of injectivity alone. +-/ + +public noncomputable section +open Set Filter Topology +open scoped NatOrdinal +universe u v +namespace HahnSeries.Nonpositive +variable {G : Type u} {R : Type v} [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [CommRing R] + +/-- Weak truncation at a cutoff, translated to exponent zero, as an additive endomorphism. -/ +def translatedTruncLE (γ : G) : Nonpositive G R →+ Nonpositive G R where + toFun b := ⟨translate (-γ) (truncLE γ (b : HahnSeries G R)), support_translated_truncLE _ _⟩ + map_zero' := by apply Subtype.ext; simp + map_add' b c := by + apply Subtype.ext + change translate (-γ) (truncLE γ ((b : HahnSeries G R) + (c : HahnSeries G R))) = _ + rw [truncLE_add, map_add] + rfl + +/-- The underlying Hahn series of the translated weak truncation. -/ +@[simp] +theorem coe_translatedTruncLE (γ : G) (b : Nonpositive G R) : + (translatedTruncLE γ b : HahnSeries G R) = translate (-γ) (truncLE γ b) := (rfl) + +/-- At cutoff zero the translated weak truncation is the identity. -/ +@[simp] +theorem translatedTruncLE_zero (b : Nonpositive G R) : translatedTruncLE (0 : G) b = b := by + apply Subtype.ext + rw [coe_translatedTruncLE, neg_zero, translate_zero_apply, + truncLE_eq_self_of_support_subset_Iic b.property] + +variable [UniformSpace G] [IsUniformAddGroup G] [OrderTopology G] [Nontrivial G] [CompleteSpace G] + [NoZeroDivisors R] [CharZero R] + +local notation "ν" => (cantorBendixsonDegreeValuation (G := G) (R := R)) + +private theorem degree_lt_succ_iff (d : WithBot NatOrdinal.{u}) (α : NatOrdinal.{u}) : + d < (↑(α + 1) : WithBot NatOrdinal) ↔ d ≤ α := by + cases d using WithBot.recBotCoe with + | bot => simp + | coe d => + rw [WithBot.coe_lt_coe, WithBot.coe_le_coe] + exact Order.lt_add_one_iff + +open Classical in +/-- The degree of a translated weak truncation is the Cantor–Bendixson rank at its cutoff, and +bottom away from the closed support. -/ +theorem degree_translatedTruncLE_eq (b : Nonpositive G R) (γ : G) : + ν (translatedTruncLE γ b) = + if γ ∈ (b : HahnSeries G R).closedSupport then + (NatOrdinal.of ((b : HahnSeries G R).cantorBendixsonRank γ) : WithBot NatOrdinal) + else ⊥ := by + rw [cantorBendixsonDegreeValuation_apply, cantorBendixsonValuation_apply, + coe_translatedTruncLE, HahnSeries.cantorBendixsonValue_translated_truncLE] + by_cases hm : γ ∈ (b : HahnSeries G R).closedSupport + · simp only [ite_eq_left hm, NatOrdinal.of_omega0_opow, NatOrdinal.cantorDegree_wpow] + · simp only [ite_eq_right hm, NatOrdinal.of_zero, NatOrdinal.cantorDegree_zero] + +/-- Translated truncations have degree strictly below any bound for the original degree, +at all sufficiently close negative cutoffs. -/ +theorem eventually_degree_translatedTruncLE_lt (b : Nonpositive G R) (α : NatOrdinal.{u}) + (hb : ν b ≤ α) : + ∀ᶠ γ in 𝓝[<] (0 : G), ν (translatedTruncLE γ b) < α := by + classical + by_cases hmem : 0 ∈ (b : HahnSeries G R).closedSupport + · have hbr : NatOrdinal.of ((b : HahnSeries G R).cantorBendixsonRank 0) ≤ α := by + rwa [cantorBendixsonDegreeValuation_of_mem _ hmem, WithBot.coe_le_coe] at hb + have hv : (b : HahnSeries G R).cantorBendixsonValue ≠ 0 := by + rw [cantorBendixsonValue_of_mem _ ((mem_closedSupport _ _).mp hmem)] + exact Ordinal.opow_ne_zero _ Ordinal.omega0_ne_zero + have hcut := ((b : HahnSeries G R).eventually_value_translated_truncLE_lt hv).filter_mono + (nhdsWithin_le_nhds (s := Iio (0 : G))) + filter_upwards [hcut, self_mem_nhdsWithin] with γ hγ hγ0 + rw [cantorBendixsonDegreeValuation_apply, cantorBendixsonValuation_apply, + NatOrdinal.cantorDegree_lt_coe_iff, coe_translatedTruncLE] + have h := NatOrdinal.of.strictMono (hγ (ne_of_lt hγ0)) + rw [cantorBendixsonValue_of_mem _ ((mem_closedSupport _ _).mp hmem), + NatOrdinal.of_omega0_opow] at h + exact h.trans_le (NatOrdinal.wpow_le_wpow.mpr hbr) + · have hnh : ((b : HahnSeries G R).closedSupport : Set G)ᶜ ∈ 𝓝 (0 : G) := + (b : HahnSeries G R).closedSupport.isClosed.isOpen_compl.mem_nhds hmem + filter_upwards [nhdsWithin_le_nhds hnh] with γ hγ + change γ ∉ (b : HahnSeries G R).closedSupport at hγ + rw [cantorBendixsonDegreeValuation_apply, cantorBendixsonValuation_apply, + coe_translatedTruncLE, cantorBendixsonValue_translated_truncLE, ite_eq_right hγ, + NatOrdinal.of_zero, NatOrdinal.cantorDegree_zero] + exact WithBot.bot_lt_coe α + +/-- A successor-degree representative has translated truncations in the preceding weak +filtration near zero. -/ +theorem eventually_degree_translatedTruncLE_le (b : Nonpositive G R) (α : NatOrdinal.{u}) + (hb : ν b ≤ (α + 1 : NatOrdinal)) : + ∀ᶠ γ in 𝓝[<] (0 : G), ν (translatedTruncLE γ b) ≤ α := + (eventually_degree_translatedTruncLE_lt b (α + 1) hb).mono fun _ h ↦ + (degree_lt_succ_iff _ _).mp h + +/-- Vanishing of the lower-rank truncations forces a successor representative into the +strict filtration. -/ +theorem degree_lt_succ_of_eventually_translatedTruncLE_lt (b : Nonpositive G R) + (α : NatOrdinal.{u}) (hb : ν b ≤ (α + 1 : NatOrdinal)) + (hcut : ∀ᶠ γ in 𝓝[<] (0 : G), ν (translatedTruncLE γ b) < α) : + ν b < (α + 1 : NatOrdinal) := by + classical + by_contra hlt + have he : ν b = (α + 1 : NatOrdinal) := hb.antisymm (not_lt.mp hlt) + have hmem : 0 ∈ (b : HahnSeries G R).closedSupport := by + by_contra hn + have hz : ν b = ⊥ := by + rw [cantorBendixsonDegreeValuation_apply, cantorBendixsonValuation_apply, + cantorBendixsonValue_of_notMem _ (by simpa only [mem_closedSupport] using hn), + NatOrdinal.of_zero, NatOrdinal.cantorDegree_zero] + rw [hz] at he + exact WithBot.bot_ne_coe he + have hr : (b : HahnSeries G R).cantorBendixsonRank 0 = α.val + 1 := by + rw [cantorBendixsonDegreeValuation_of_mem _ hmem, WithBot.coe_eq_coe] at he + have h := congrArg NatOrdinal.val he + simpa only [NatOrdinal.val_of, NatOrdinal.val_add_one] using h + have hv : (b : HahnSeries G R).cantorBendixsonValue = + Ordinal.omega0 ^ (α.val + 1) := by + rw [cantorBendixsonValue_of_mem _ ((mem_closedSupport _ _).mp hmem), hr] + have h := cantorBendixsonValue_reconstruction (b : HahnSeries G R) 0 b.property + α.val 0 1 zero_lt_one hv (by + filter_upwards [hcut] with γ hγ heγ + rw [cantorBendixsonDegreeValuation_apply, cantorBendixsonValuation_apply, + coe_translatedTruncLE, heγ, NatOrdinal.of_omega0_opow, NatOrdinal.of_val, + NatOrdinal.cantorDegree_wpow] at hγ + exact (lt_irrefl _ hγ).elim) + rw [cantorBendixsonValue_zero, zero_add, Ordinal.opow_one] at h + exact (not_le_of_gt Ordinal.omega0_pos) h + +open Classical in +/-- The lower homogeneous class of the translated truncation, with zero outside its domain. +For a successor-filtered input this convention is immaterial in the left filter germ. -/ +def cantorBendixsonDerivAt (α : NatOrdinal.{u}) (b : Nonpositive G R) (γ : G) : (ν).Component α := + if h : ν (translatedTruncLE γ b) ≤ α then + (ν).componentMk α ⟨translatedTruncLE γ b, ((ν).mem_filtrationLE_iff _ _).mpr h⟩ + else 0 + +/-- Within the lower weak filtration, the derivative value is the homogeneous quotient class. -/ +theorem cantorBendixsonDerivAt_eq (α : NatOrdinal.{u}) (b : Nonpositive G R) (γ : G) + (h : ν (translatedTruncLE γ b) ≤ α) : + cantorBendixsonDerivAt α b γ = + (ν).componentMk α ⟨translatedTruncLE γ b, ((ν).mem_filtrationLE_iff _ _).mpr h⟩ := by + rw [cantorBendixsonDerivAt, dite_eq_left h] + +/-- Under the successor-filtration bound, the pointwise derivative is nonzero exactly at the +points of the representative's closed support having the prescribed Cantor–Bendixson rank. -/ +theorem cantorBendixsonDerivAt_ne_zero_iff (α : NatOrdinal.{u}) + (b : Nonpositive G R) (γ : G) (h : ν (translatedTruncLE γ b) ≤ α) : + cantorBendixsonDerivAt α b γ ≠ 0 ↔ + γ ∈ (b : HahnSeries G R).closedSupport ∧ + (b : HahnSeries G R).cantorBendixsonRank γ = α.val := by + classical + rw [cantorBendixsonDerivAt_eq α b γ h, ne_eq, (ν).componentMk_eq_zero_iff, + not_lt] + have hdegree := degree_translatedTruncLE_eq b γ + rw [hdegree] + by_cases hm : γ ∈ (b : HahnSeries G R).closedSupport + · rw [ite_eq_left hm, WithBot.coe_le_coe] + constructor + · intro hle + refine ⟨hm, ?_⟩ + have heq : NatOrdinal.of ((b : HahnSeries G R).cantorBendixsonRank γ) = α := + le_antisymm (by simpa only [hdegree, ite_eq_left hm, WithBot.coe_le_coe] using h) hle + have := congrArg NatOrdinal.val heq + simpa only [NatOrdinal.val_of] using this + · rintro ⟨_, hr⟩ + rw [hr, NatOrdinal.of_val] + · rw [ite_eq_right hm] + exact ⟨fun hbot ↦ ((not_le_of_gt (WithBot.bot_lt_coe α)) hbot).elim, + fun hmem ↦ (hm hmem.1).elim⟩ + +/-- A derivative-stage point has exact rank when its translated truncation lies in the +corresponding weak filtration. -/ +theorem cantorBendixsonRank_eq_of_mem_derivative_of_degree_translatedTruncLE_le + (α : NatOrdinal.{u}) (b : Nonpositive G R) (γ : G) + (hm : γ ∈ (b : HahnSeries G R).closedSupport) + (hr : α.val ≤ (b : HahnSeries G R).cantorBendixsonRank γ) + (h : ν (translatedTruncLE γ b) ≤ α) : + (b : HahnSeries G R).cantorBendixsonRank γ = α.val := by + have hzero : 0 ∈ (translatedTruncLE γ b : Nonpositive G R).1.closedSupport := by + have ht := ((truncLE γ (b : HahnSeries G R)).mem_closedSupport_translate (-γ) γ).mpr + ((b : HahnSeries G R).mem_closedSupport_truncLE γ |>.mpr hm) + simpa only [coe_translatedTruncLE, neg_add_cancel] using ht + rw [cantorBendixsonDegreeValuation_of_mem (translatedTruncLE γ b) hzero, + WithBot.coe_le_coe] at h + have hval := NatOrdinal.of.symm.monotone h + change NatOrdinal.val + (NatOrdinal.of ((translatedTruncLE γ b : Nonpositive G R).1.cantorBendixsonRank 0)) ≤ + NatOrdinal.val α at hval + rw [NatOrdinal.val_of] at hval + have hsr : ((translatedTruncLE γ b : Nonpositive G R).1).cantorBendixsonRank 0 = + (b : HahnSeries G R).cantorBendixsonRank γ := by + simpa only [coe_translatedTruncLE] using + (b : HahnSeries G R).cantorBendixsonRank_translated_truncLE γ + rw [hsr] at hval + exact hval.antisymm hr + +private theorem eventually_derivAt_add (α : NatOrdinal.{u}) (b c : Nonpositive G R) + (hb : ν b ≤ (α + 1 : NatOrdinal)) (hc : ν c ≤ (α + 1 : NatOrdinal)) : + ∀ᶠ γ in 𝓝[<] (0 : G), cantorBendixsonDerivAt α (b + c) γ = + cantorBendixsonDerivAt α b γ + cantorBendixsonDerivAt α c γ := by + have hbc : ν (b + c) ≤ (α + 1 : NatOrdinal) := + ((ν).map_add_le_max b c).trans (max_le hb hc) + filter_upwards [eventually_degree_translatedTruncLE_le b α hb, + eventually_degree_translatedTruncLE_le c α hc, + eventually_degree_translatedTruncLE_le (b + c) α hbc] with γ hbg hcg hbcg + rw [cantorBendixsonDerivAt_eq _ _ _ hbg, cantorBendixsonDerivAt_eq _ _ _ hcg, + cantorBendixsonDerivAt_eq _ _ _ hbcg, ← map_add] + apply congrArg ((ν).componentMk α) + apply Subtype.ext + exact map_add (translatedTruncLE γ) b c + +private def filtrationDeriv (α : NatOrdinal.{u}) : + (ν).filtrationLE (α + 1) →+ Filter.Germ (𝓝[<] (0 : G)) ((ν).Component α) where + toFun b := ((fun γ ↦ cantorBendixsonDerivAt α (b : Nonpositive G R) γ) : + Filter.Germ (𝓝[<] (0 : G)) ((ν).Component α)) + map_zero' := by + rw [← Filter.Germ.coe_zero, Filter.Germ.coe_eq] + apply Filter.Eventually.of_forall + intro γ + have hzero : ν (translatedTruncLE γ 0) ≤ α := by simp + change cantorBendixsonDerivAt α 0 γ = 0 + rw [cantorBendixsonDerivAt_eq _ _ _ hzero, + (ν).componentMk_eq_zero_iff] + change ν (translatedTruncLE γ 0) < α + simp + map_add' b c := by + rw [← Filter.Germ.coe_add, Filter.Germ.coe_eq] + exact eventually_derivAt_add α (b : Nonpositive G R) (c : Nonpositive G R) + (((ν).mem_filtrationLE_iff _ _).mp b.property) + (((ν).mem_filtrationLE_iff _ _).mp c.property) + +private theorem lowerFiltration_le_filtrationDeriv_ker (α : NatOrdinal.{u}) : + (ν).lowerFiltration (α + 1) ≤ (filtrationDeriv (G := G) (R := R) α).ker := by + intro b hb + change (filtrationDeriv α) b = 0 + change ((fun γ ↦ cantorBendixsonDerivAt α (b : Nonpositive G R) γ) : + Filter.Germ (𝓝[<] (0 : G)) ((ν).Component α)) = 0 + rw [← Filter.Germ.coe_zero, Filter.Germ.coe_eq] + have hble : ν (b : Nonpositive G R) ≤ α := + (degree_lt_succ_iff _ _).mp (((ν).mem_lowerFiltration_iff _ _).mp hb) + filter_upwards [eventually_degree_translatedTruncLE_lt (b : Nonpositive G R) α hble] + with γ hγ + change cantorBendixsonDerivAt α (b : Nonpositive G R) γ = 0 + rw [cantorBendixsonDerivAt_eq _ _ _ hγ.le, (ν).componentMk_eq_zero_iff] + exact hγ + +/-- Translated weak truncation induces an additive map from each successor homogeneous +component to left filter germs in the preceding component. -/ +def cantorBendixsonLayerDeriv (α : NatOrdinal.{u}) : + (ν).Component (α + 1) →+ Filter.Germ (𝓝[<] (0 : G)) ((ν).Component α) := + QuotientAddGroup.lift ((ν).lowerFiltration (α + 1)) (filtrationDeriv α) + (lowerFiltration_le_filtrationDeriv_ker α) + +/-- The map from degree `α + 1` to degree `α` is represented by translated truncation of any +representative. -/ +theorem cantorBendixsonLayerDeriv_componentMk (α : NatOrdinal.{u}) + (b : (ν).filtrationLE (α + 1)) : + cantorBendixsonLayerDeriv α ((ν).componentMk (α + 1) b) = + ((fun γ ↦ cantorBendixsonDerivAt α (b : Nonpositive G R) γ) : + Filter.Germ (𝓝[<] (0 : G)) ((ν).Component α)) := by + rw [cantorBendixsonLayerDeriv, ← (ν).coe_component_eq_componentMk] + rfl + +/-- A successor homogeneous class is detected by its translated truncations near zero. -/ +theorem cantorBendixsonLayerDeriv_injective (α : NatOrdinal.{u}) : + Function.Injective (cantorBendixsonLayerDeriv (G := G) (R := R) α) := by + rw [injective_iff_map_eq_zero] + intro x hx + induction x using MaxAddDegree.componentInductionOn with + | H b => + rw [cantorBendixsonLayerDeriv_componentMk, ← Filter.Germ.coe_zero, + Filter.Germ.coe_eq] at hx + apply ((ν).componentMk_eq_zero_iff _ _).mpr + have hb := ((ν).mem_filtrationLE_iff _ _).mp b.property + apply degree_lt_succ_of_eventually_translatedTruncLE_lt (b : Nonpositive G R) α hb + filter_upwards [hx, eventually_degree_translatedTruncLE_le (b : Nonpositive G R) α hb] + with γ hγ hbound + change cantorBendixsonDerivAt α (b : Nonpositive G R) γ = 0 at hγ + rw [cantorBendixsonDerivAt_eq _ _ _ hbound, (ν).componentMk_eq_zero_iff] at hγ + exact hγ + +/-- **Exact lower-rank attainment.** If a series has degree exactly `α` at zero, then every +degree below `α` is attained exactly by its translated truncations at negative cutoffs +arbitrarily close to zero. Points of each lower exact rank are dense in the corresponding +derivative, and zero lies in that derivative without belonging to the level, so the level +accumulates at zero. No cofinal sequence of cutoffs is chosen. -/ +theorem exists_lt_and_degree_translatedTruncLE_eq (b : Nonpositive G R) (α ρ : NatOrdinal.{u}) + (hb : ν b = (α : WithBot NatOrdinal)) (hρα : ρ < α) {l : G} (hl : l < 0) : + ∃ γ : G, l < γ ∧ γ < 0 ∧ ν (translatedTruncLE γ b) = (ρ : WithBot NatOrdinal) := by + classical + have hmem : (0 : G) ∈ (b : HahnSeries G R).closedSupport := by + by_contra hn + rw [cantorBendixsonDegreeValuation_apply, cantorBendixsonValuation_apply, + cantorBendixsonValue_of_notMem _ (by simpa only [mem_closedSupport] using hn), + NatOrdinal.of_zero, NatOrdinal.cantorDegree_zero] at hb + exact WithBot.bot_ne_coe hb + have hrank : (b : HahnSeries G R).cantorBendixsonRank 0 = α.val := by + rw [cantorBendixsonDegreeValuation_of_mem b hmem, WithBot.coe_eq_coe] at hb + have h := congrArg NatOrdinal.val hb + simpa only [NatOrdinal.val_of] using h + have hρval : ρ.val < α.val := NatOrdinal.of.symm.strictMono hρα + have hrank' : ρ.val ≤ (b : HahnSeries G R).closedSupport.cantorBendixsonRank + (b : HahnSeries G R).closedSupport_isPWO 0 := by + rw [← cantorBendixsonRank_eq, hrank] + exact hρval.le + have h0mem : (0 : G) ∈ + ((b : HahnSeries G R).closedSupport.cantorBendixson ρ.val : Set G) := + ((b : HahnSeries G R).closedSupport.mem_cantorBendixson_iff + (b : HahnSeries G R).closedSupport_isPWO 0 ρ.val).mpr ⟨hmem, hrank'⟩ + have hclosure := (b : HahnSeries G R).closedSupport.closure_rank_level_eq + (b : HahnSeries G R).closedSupport_isPWO ρ.val + have h0cl : (0 : G) ∈ closure {x : G | x ∈ (b : HahnSeries G R).closedSupport ∧ + (b : HahnSeries G R).closedSupport.cantorBendixsonRank + (b : HahnSeries G R).closedSupport_isPWO x = ρ.val} := by + rw [hclosure] + exact h0mem + obtain ⟨p, hp⟩ := exists_ne (0 : G) + obtain ⟨e, he⟩ : ∃ e : G, 0 < e := by + rcases lt_or_gt_of_ne hp with h | h + · exact ⟨-p, neg_pos.mpr h⟩ + · exact ⟨p, h⟩ + obtain ⟨γ, hγmem, hγlevel⟩ := mem_closure_iff.mp h0cl (Ioo l e) isOpen_Ioo ⟨hl, he⟩ + have hγ0 : γ ≤ 0 := closure_minimal b.property isClosed_Iic + ((mem_closedSupport _ _).mp hγlevel.1) + have hrank0 : (b : HahnSeries G R).closedSupport.cantorBendixsonRank + (b : HahnSeries G R).closedSupport_isPWO 0 = α.val := + ((b : HahnSeries G R).cantorBendixsonRank_eq 0).symm.trans hrank + have hγne : γ ≠ 0 := by + intro h0 + rw [h0] at hγlevel + exact absurd (hrank0.symm.trans hγlevel.2) (ne_of_gt hρval) + refine ⟨γ, hγmem.1, lt_of_le_of_ne hγ0 hγne, ?_⟩ + rw [degree_translatedTruncLE_eq, ite_eq_left hγlevel.1, cantorBendixsonRank_eq, hγlevel.2, + NatOrdinal.of_val] + +/-- Below a degree that is a limit ordinal, no eventual bound on the truncation degrees holds: +attainment at the +successor of any proposed bound refutes it. -/ +theorem not_forall_degree_translatedTruncLE_le (b : Nonpositive G R) (α β : NatOrdinal.{u}) + (hb : ν b = (α : WithBot NatOrdinal)) (hβα : (β + 1 : NatOrdinal) < α) {l : G} (hl : l < 0) : + ¬ ∀ γ : G, l < γ → γ < 0 → ν (translatedTruncLE γ b) ≤ (β : WithBot NatOrdinal) := by + intro hbound + obtain ⟨γ, hlγ, hγ0, hγeq⟩ := + exists_lt_and_degree_translatedTruncLE_eq b α (β + 1) hb hβα hl + have hle := hbound γ hlγ hγ0 + rw [hγeq, WithBot.coe_le_coe] at hle + exact absurd hle (not_le_of_gt (lt_add_one β)) + +/-- **Proper cutoffs bound the degree at zero.** If every translated truncation at a strictly +negative cutoff has degree at most `τ`, then the series has degree at most `τ + 1`. The stage +`τ + 1` of the closed support meets only zero, so the next stage is empty. -/ +theorem degree_le_add_one_of_forall_neg_le (b : Nonpositive G R) (τ : NatOrdinal.{u}) + (h : ∀ y : G, y < 0 → ν (translatedTruncLE y b) ≤ (τ : WithBot NatOrdinal)) : + ν b ≤ ((τ + 1 : NatOrdinal) : WithBot NatOrdinal) := by + classical + have hstage : ((b : HahnSeries G R).closedSupport.cantorBendixson (τ.val + 1) : Set G) ⊆ + {0} := by + intro z hz + obtain ⟨hzs, hzr⟩ := ((b : HahnSeries G R).mem_support_derivative_iff z (τ.val + 1)).mp hz + have hz0 : z ≤ 0 := closure_minimal b.property isClosed_Iic hzs + rcases eq_or_lt_of_le hz0 with hz0' | hzneg + · exact Set.mem_singleton_iff.mpr hz0' + · exfalso + have hmem : z ∈ (b : HahnSeries G R).closedSupport := (mem_closedSupport _ _).mpr hzs + have hd := h z hzneg + rw [degree_translatedTruncLE_eq, ite_eq_left hmem, WithBot.coe_le_coe] at hd + have hval := NatOrdinal.of.symm.monotone hd + change NatOrdinal.val (NatOrdinal.of ((b : HahnSeries G R).cantorBendixsonRank z)) ≤ + NatOrdinal.val τ at hval + rw [NatOrdinal.val_of] at hval + exact absurd hzr (not_le_of_gt (lt_of_le_of_lt hval (lt_add_one τ.val))) + have hnext : ((b : HahnSeries G R).closedSupport.cantorBendixson ((τ.val + 1) + 1) : + Set G) = ∅ := by + rw [TopologicalSpace.Closeds.cantorBendixson_add_one] + apply Set.eq_empty_iff_forall_notMem.mpr + intro z hz + rw [TopologicalSpace.Closeds.coe_derived, mem_derivedSet] at hz + exact (Set.finite_singleton (0 : G)).not_infinite + (Set.Infinite.of_accPt (hz.mono (Filter.principal_mono.mpr hstage))) + by_cases hm : 0 ∈ (b : HahnSeries G R).closedSupport + · rw [cantorBendixsonDegreeValuation_of_mem b hm, WithBot.coe_le_coe] + have hrank : (b : HahnSeries G R).cantorBendixsonRank 0 ≤ τ.val + 1 := by + rw [cantorBendixsonRank_eq] + apply TopologicalSpace.Closeds.cantorBendixsonRank_le_of_notMem _ _ 0 + rw [hnext] + exact Set.notMem_empty 0 + have h := NatOrdinal.of.monotone hrank + rw [← NatOrdinal.val_add_one, NatOrdinal.of_val] at h + exact h + · rw [cantorBendixsonDegreeValuation_apply, cantorBendixsonValuation_apply, + cantorBendixsonValue_of_notMem _ (by simpa only [mem_closedSupport] using hm), + NatOrdinal.of_zero, NatOrdinal.cantorDegree_zero] + exact bot_le + +/-- **No uniform degree bound below a nonzero degree.** Let a series have degree exactly `lam`, +and let `sigma` be zero or have every Cantor term at least the last Cantor term of `lam`. Then no +bound strictly below `lam ⊕ sigma` dominates `ν(u^{|γ}) ⊕ sigma` on any left interval: the +ordinal approach lemma produces a degree below `lam` whose shift already reaches the proposed +bound, and exact lower-rank attainment realizes that degree at a cutoff inside the interval. + +This is the obstruction used when the leading-coefficient degree has the required least term. -/ +theorem not_forall_add_lt_of_degree_eq (b : Nonpositive G R) (lam sigma bound : NatOrdinal.{u}) + (hb : ν b = (lam : WithBot NatOrdinal)) (hlam : lam ≠ 0) + (hsigma : sigma = 0 ∨ NatOrdinal.leastTerm lam ≤ NatOrdinal.leastTerm sigma) + (hbound : bound < lam + sigma) {l : G} (hl : l < 0) : + ¬ ∀ γ : G, l < γ → γ < 0 → + ∀ ρ : NatOrdinal.{u}, ν (translatedTruncLE γ b) = (ρ : WithBot NatOrdinal) → + ρ + sigma < bound := by + intro hforall + obtain ⟨ρ, hρlam, hρbound⟩ := + NatOrdinal.exists_lt_le_add_of_lastCantorTerm_le hlam hsigma hbound + obtain ⟨γ, hlγ, hγ0, hγeq⟩ := exists_lt_and_degree_translatedTruncLE_eq b lam ρ hb hρlam hl + exact absurd (hforall γ hlγ hγ0 ρ hγeq) (not_lt.mpr hρbound) + +end HahnSeries.Nonpositive diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/Germ.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/Germ.lean new file mode 100644 index 0000000000..c925ade4c2 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/Germ.lean @@ -0,0 +1,109 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.CantorBendixsonValueMultiplicativity +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.NaturalOrder +public import Mathlib.RingTheory.Valuation.Basic +public import Mathlib.RingTheory.Ideal.Quotient.Basic + +/-! +# Germs at zero and the Cantor–Bendixson valuation + +The Cantor–Bendixson value on nonpositive Hahn series is a Mathlib valuation with natural ordinal +values. Its support ideal consists exactly of series bounded strictly below exponent zero; +quotienting by that ideal therefore gives the ring of germs at zero. The valuation's prime +support makes this quotient a domain. + +The ordered exponent group is assumed Cauchy complete. The characteristic-zero domain hypotheses +are those of the multiplicativity theorem. A domain conclusion alone does not assert factor +primality or polynomiality of the germ ring. +-/ + +public noncomputable section +open Set +universe u v +namespace HahnSeries.Nonpositive +variable {G : Type u} {R : Type v} [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [UniformSpace G] [IsUniformAddGroup G] [OrderTopology G] [Nontrivial G] [CompleteSpace G] + [CommRing R] [NoZeroDivisors R] [CharZero R] + +/-- The natural-ordinal valuation given by the Cantor–Bendixson rank at zero. -/ +def cantorBendixsonValuation : Valuation (Nonpositive G R) NatOrdinal.{u} where + toFun b := NatOrdinal.of (b : HahnSeries G R).cantorBendixsonValue + map_zero' := congrArg NatOrdinal.of cantorBendixsonValue_zero + map_one' := by + apply congrArg NatOrdinal.of + exact cantorBendixsonValue_of_finite_of_coeff_ne_zero (1 : HahnSeries G R) + (by rw [support_one]; exact finite_singleton _) (by simp) + map_mul' b c := cantorBendixsonValue_mul _ _ b.property c.property + map_add_le_max' b c := by + rcases le_max_iff.mp ((b : HahnSeries G R).cantorBendixsonValue_add_le c) with h | h + · exact le_max_of_le_left (NatOrdinal.of.monotone h) + · exact le_max_of_le_right (NatOrdinal.of.monotone h) + +/-- Evaluation agrees with the Cantor–Bendixson value of the Hahn series. -/ +@[simp] +theorem cantorBendixsonValuation_apply (b : Nonpositive G R) : + cantorBendixsonValuation b = NatOrdinal.of (b : HahnSeries G R).cantorBendixsonValue := (rfl) + +/-- Vanishing in the valuation support means being bounded strictly below zero. -/ +theorem mem_cantorBendixsonValuation_supp (b : Nonpositive G R) : + b ∈ (cantorBendixsonValuation (G := G) (R := R)).supp ↔ + ∃ c < (0 : G), (b : HahnSeries G R).support ⊆ Iic c := by + rw [Valuation.mem_supp_iff, cantorBendixsonValuation_apply] + exact cantorBendixsonValue_eq_zero_iff_support_bounded_lt _ b.property + +/-- Two germs agree exactly when their representatives agree above some negative bound. -/ +theorem cantorBendixson_germ_eq_iff (b c : Nonpositive G R) : + Ideal.Quotient.mk (cantorBendixsonValuation (G := G) (R := R)).supp b = + Ideal.Quotient.mk (cantorBendixsonValuation (G := G) (R := R)).supp c ↔ + ∃ e < (0 : G), ∀ g > e, (b : HahnSeries G R).coeff g = (c : HahnSeries G R).coeff g := by + rw [Ideal.Quotient.eq, mem_cantorBendixsonValuation_supp] + constructor + · rintro ⟨e, he, hbc⟩ + refine ⟨e, he, fun g hg ↦ ?_⟩ + have hz : ((b - c : Nonpositive G R) : HahnSeries G R).coeff g = 0 := by + by_contra hn + exact (not_le_of_gt hg) (hbc hn) + change ((b : HahnSeries G R) - (c : HahnSeries G R)).coeff g = 0 at hz + simpa only [coeff_sub, sub_eq_zero] using hz + · rintro ⟨e, he, hbc⟩ + refine ⟨e, he, fun g hg ↦ ?_⟩ + apply le_of_not_gt + intro hge + have hz := hbc g hge + apply hg + change ((b : HahnSeries G R) - (c : HahnSeries G R)).coeff g = 0 + simpa only [coeff_sub, sub_eq_zero] using hz + +/-- A series representing a unit germ has nonzero coefficient at exponent zero. -/ +theorem constantCoeff_ne_zero_of_isUnit_cantorBendixson_germ + {b : Nonpositive G R} + (hb : IsUnit + (Ideal.Quotient.mk (cantorBendixsonValuation (G := G) (R := R)).supp b)) : + constantCoeff b ≠ 0 := by + let J := (cantorBendixsonValuation (G := G) (R := R)).supp + obtain ⟨q, hbq, _⟩ := isUnit_iff_exists.mp hb + obtain ⟨c, rfl⟩ := Ideal.Quotient.mk_surjective q + have heq : Ideal.Quotient.mk J (b * c) = Ideal.Quotient.mk J 1 := by + simpa only [map_mul, map_one] using hbq + obtain ⟨e, he, hcoeff⟩ := (cantorBendixson_germ_eq_iff (b * c) 1).mp heq + have hbc : constantCoeff b * constantCoeff c = 1 := by + have hbc' := hcoeff 0 he + rw [show ((b * c : Nonpositive G R) : HahnSeries G R).coeff 0 = + (b : HahnSeries G R).coeff 0 * (c : HahnSeries G R).coeff 0 from + coeff_zero_mul b c] at hbc' + simpa only [constantCoeff_apply, Subring.coe_one, HahnSeries.coeff_one, ite_eq_left] using hbc' + intro hb0 + rw [hb0, zero_mul] at hbc + exact zero_ne_one hbc + +/-- The germ quotient by series bounded strictly below zero is a domain. -/ +theorem cantorBendixson_germ_isDomain : + IsDomain (Nonpositive G R ⧸ (cantorBendixsonValuation (G := G) (R := R)).supp) := + inferInstance + +end HahnSeries.Nonpositive diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/GlobalCofactors.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/GlobalCofactors.lean new file mode 100644 index 0000000000..1df32a5813 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/GlobalCofactors.lean @@ -0,0 +1,158 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.Derivative +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.Boundary +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.TranslatedTruncationInterpolation + +/-! +# Global cofactors from local data of fixed rank + +Consider a nonpositive Hahn series whose translated truncation at every nonpositive cutoff, +including zero, has degree at most `β`. Its exact rank-`β` cutoffs accumulate nowhere. Suppose a +finite family of homogeneous lifts is given, each with a degree bound and strictly smaller proper +translated truncations, and at every exact rank-`β` cutoff local cofactors are prescribed that +correct the truncation below degree `β`. Interpolating those local cofactors produces global +cofactors with the same pointwise degree bounds, whose combination with the lifts corrects the +series below degree `β` at every nonpositive cutoff simultaneously. The subtracted term is an exact +finite combination of the lifts, so this step preserves membership in the ideal they generate. +-/ + +public noncomputable section + +open Set Filter Topology +open scoped NatOrdinal + +universe u v w + +namespace HahnSeries.Nonpositive + +variable {G : Type u} {R : Type v} [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [UniformSpace G] [IsUniformAddGroup G] [OrderTopology G] [Nontrivial G] [CompleteSpace G] + [CommRing R] [NoZeroDivisors R] [CharZero R] + +local notation "ν" => (cantorBendixsonDegreeValuation (G := G) (R := R)) + +open Classical in +/-- Local cofactors at every exact top-rank cutoff interpolate to global cofactors. They keep the +prescribed pointwise degree bounds, and subtracting their products with the generators leaves a +series whose translated truncations have degree strictly below `β` at every nonpositive cutoff, +including zero. -/ +theorem exists_forall_degree_translatedTruncLE_sub_sum_mul_lt (β : NatOrdinal.{u}) + {ι : Type w} [Fintype ι] (V : ι → Nonpositive G R) (ρ σ : ι → NatOrdinal.{u}) + (hgrade : ∀ j, ρ j + σ j ≤ β) + (hV : ∀ j, ν (V j) ≤ σ j) + (hVcut : ∀ j, ∀ x : G, x < 0 → ν (translatedTruncLE x (V j)) < σ j) + (u : Nonpositive G R) + (hu : ∀ x : G, x ≤ 0 → ν (translatedTruncLE x u) ≤ β) + (w : {x // x ∈ (u : HahnSeries G R).closedSupport ∧ + (u : HahnSeries G R).closedSupport.cantorBendixsonRank + (u : HahnSeries G R).closedSupport_isPWO x = β.val} → ι → Nonpositive G R) + (hw : ∀ i j, ν (w i j) ≤ ρ j) + (hcorr : ∀ i : {x // x ∈ (u : HahnSeries G R).closedSupport ∧ + (u : HahnSeries G R).closedSupport.cantorBendixsonRank + (u : HahnSeries G R).closedSupport_isPWO x = β.val}, + ν (translatedTruncLE (i : G) u - ∑ j, w i j * V j) < β) : + ∃ c : ι → Nonpositive G R, + (∀ j, ∀ x : G, x ≤ 0 → ν (translatedTruncLE x (c j)) ≤ ρ j) ∧ + ∀ x : G, x ≤ 0 → ν (translatedTruncLE x (u - ∑ j, c j * V j)) < β := by + classical + have hassemble : ∀ j : ι, ∃ c : Nonpositive G R, + (∀ i : {x // x ∈ (u : HahnSeries G R).closedSupport ∧ + (u : HahnSeries G R).closedSupport.cantorBendixsonRank + (u : HahnSeries G R).closedSupport_isPWO x = β.val}, + ν (translatedTruncLE (i : G) c - w i j) = ⊥) ∧ + ∀ y : G, y ≤ 0 → + ¬(y ∈ (u : HahnSeries G R).closedSupport ∧ + (u : HahnSeries G R).closedSupport.cantorBendixsonRank + (u : HahnSeries G R).closedSupport_isPWO y = β.val) → + ν (translatedTruncLE y c) < ρ j := fun j ↦ + exists_prescribed_truncations_on_topRankLevel β (ρ j) u hu (fun i ↦ w i j) (fun i ↦ hw i j) + choose c hcenter hnon using hassemble + have hcb : ∀ j, ∀ x : G, x ≤ 0 → ν (translatedTruncLE x (c j)) ≤ ρ j := by + intro j x hx + by_cases hxl : x ∈ (u : HahnSeries G R).closedSupport ∧ + (u : HahnSeries G R).closedSupport.cantorBendixsonRank + (u : HahnSeries G R).closedSupport_isPWO x = β.val + · have hsplit : translatedTruncLE x (c j) = + (translatedTruncLE x (c j) - w ⟨x, hxl⟩ j) + w ⟨x, hxl⟩ j := by abel + rw [hsplit] + refine ((ν).map_add_le_max _ _).trans (max_le ?_ (hw ⟨x, hxl⟩ j)) + rw [hcenter j ⟨x, hxl⟩] + exact bot_le + · exact (hnon j x hx hxl).le + have hbot : (⊥ : WithBot NatOrdinal.{u}) < (β : WithBot NatOrdinal) := WithBot.bot_lt_coe β + have hsep : ∀ j, ∀ θ, θ < σ j → ρ j + θ < β := by + intro j θ hθ + calc + ρ j + θ < ρ j + σ j := add_lt_add_of_le_of_lt le_rfl hθ + _ ≤ β := hgrade j + have hsep' : ∀ j, ∀ θ, θ < ρ j → σ j + θ < β := by + intro j θ hθ + calc + σ j + θ < σ j + ρ j := add_lt_add_of_le_of_lt le_rfl hθ + _ ≤ β := by rw [add_comm]; exact hgrade j + have hbound : ∀ j, ∀ x : G, x ≤ 0 → + ν (translatedTruncLE x (c j * V j) - translatedTruncLE x (c j) * V j) < β := by + intro j x hx + rcases eq_or_lt_of_le hx with hx0 | hxneg + · subst hx0 + simp only [translatedTruncLE_zero, sub_self, (ν).map_zero] + exact hbot + · apply degree_translatedTruncLE_mul_sub_mul_lt_of_pointwise_bounds (c j) (V j) + (ρ j) (σ j) β ?_ ?_ (hVcut j) (hsep j) hxneg + · simpa only [translatedTruncLE_zero] using hcb j 0 le_rfl + · exact fun y hy ↦ hcb j y hy.le + refine ⟨c, hcb, ?_⟩ + intro x hx + by_cases hxl : x ∈ (u : HahnSeries G R).closedSupport ∧ + (u : HahnSeries G R).closedSupport.cantorBendixsonRank + (u : HahnSeries G R).closedSupport_isPWO x = β.val + · have hkey : translatedTruncLE x (u - ∑ j, c j * V j) = + (translatedTruncLE x u - ∑ j, w ⟨x, hxl⟩ j * V j) + - (∑ j, (translatedTruncLE x (c j * V j) - translatedTruncLE x (c j) * V j)) + - (∑ j, (translatedTruncLE x (c j) - w ⟨x, hxl⟩ j) * V j) := by + rw [map_sub, map_sum] + simp only [sub_mul] + rw [Finset.sum_sub_distrib, Finset.sum_sub_distrib] + abel + rw [hkey] + refine ((ν).map_sub_le_max _ _).trans_lt (max_lt (((ν).map_sub_le_max _ _).trans_lt + (max_lt (hcorr ⟨x, hxl⟩) ?_)) ?_) + · exact (ν).map_sum_lt_of_forall_lt _ _ hbot fun j _ ↦ hbound j x hx + · apply (ν).map_sum_lt_of_forall_lt _ _ hbot + intro j _ + apply lt_of_le_of_lt _ hbot + have hmul := (ν).map_mul_le_add (translatedTruncLE x (c j) - w ⟨x, hxl⟩ j) (V j) + rw [hcenter j ⟨x, hxl⟩, WithBot.bot_add] at hmul + exact hmul + · have hu' : ν (translatedTruncLE x u) < β := by + by_cases hxm : x ∈ (u : HahnSeries G R).closedSupport + · refine lt_of_le_of_ne (hu x hx) ?_ + rw [degree_translatedTruncLE_eq, ite_eq_left hxm] + intro he + apply hxl + refine ⟨hxm, ?_⟩ + have hval := congrArg NatOrdinal.val (WithBot.coe_injective he) + rw [NatOrdinal.val_of, cantorBendixsonRank_eq] at hval + exact hval + · rw [degree_translatedTruncLE_eq, ite_eq_right hxm] + exact hbot + rw [map_sub, map_sum] + refine ((ν).map_sub_le_max _ _).trans_lt (max_lt hu' ?_) + apply (ν).map_sum_lt_of_forall_lt _ _ hbot + intro j _ + have hsplit : translatedTruncLE x (c j * V j) = + (translatedTruncLE x (c j * V j) - translatedTruncLE x (c j) * V j) + + translatedTruncLE x (c j) * V j := by abel + rw [hsplit] + refine ((ν).map_add_le_max _ _).trans_lt (max_lt (hbound j x hx) ?_) + rw [mul_comm] + exact degree_mul_lt_of_le_of_lt_of_separated (V j) (translatedTruncLE x (c j)) + (σ j) (ρ j) β (hV j) (hnon j x hx hxl) (hsep' j) + +end HahnSeries.Nonpositive diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/Graded.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/Graded.lean new file mode 100644 index 0000000000..d40bb9014f --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/Graded.lean @@ -0,0 +1,120 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.Germ +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.DegreeAssociatedGradedDomain +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.Degree + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint + +/-! +# The associated graded domain of the Cantor–Bendixson degree + +Taking Cantor degree of the Cantor–Bendixson valuation gives an additive degree with natural +ordinal addition. At zero in the closed support this degree is exactly the support's +Cantor--Bendixson rank; away from the closed support it is bottom. Its kernel is the ideal +of series bounded strictly below zero. + +The associated graded ring has no zero divisors by multiplicativity. The initial form of +one is nonzero, so this is a domain rather than a possibly trivial graded ring. The +construction retains the full ordered exponent group, assumed Cauchy complete, and the +hypotheses on the characteristic-zero coefficient domain. It supplies a graded domain, not a +polynomial presentation. +-/ + +public noncomputable section +open Set +open scoped NatOrdinal +universe u v +namespace HahnSeries.Nonpositive +variable {G : Type u} {R : Type v} [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [UniformSpace G] [IsUniformAddGroup G] [OrderTopology G] [Nontrivial G] [CompleteSpace G] + [CommRing R] [NoZeroDivisors R] [CharZero R] + +/-- The Cantor degree of the Cantor–Bendixson valuation, with bottom on series bounded below +zero. -/ +def cantorBendixsonDegreeValuation : MaxAddDegree (Nonpositive G R) NatOrdinal.{u} where + toFun b := NatOrdinal.cantorDegree (cantorBendixsonValuation b) + map_zero' := by rw [map_zero, NatOrdinal.cantorDegree_zero] + map_one_le_zero' := by + rw [map_one] + rw [NatOrdinal.cantorDegree_eq_ordinalCantorDegree, NatOrdinal.val_one] + exact Ordinal.cantorDegree_one.le + map_neg' b := by rw [Valuation.map_neg] + map_add_le_max' b c := by + simp only [NatOrdinal.cantorDegree_eq_ordinalCantorDegree] + rcases le_max_iff.mp (cantorBendixsonValuation.map_add b c) with h | h + · exact le_max_of_le_left (Ordinal.cantorDegree_mono h) + · exact le_max_of_le_right (Ordinal.cantorDegree_mono h) + map_mul_le_add' b c := by + rw [map_mul, NatOrdinal.cantorDegree_mul] + +/-- Evaluation uses the Cantor degree of the Cantor–Bendixson value. -/ +@[simp] +theorem cantorBendixsonDegreeValuation_apply (b : Nonpositive G R) : + cantorBendixsonDegreeValuation b = + NatOrdinal.cantorDegree (cantorBendixsonValuation b) := (rfl) + +/-- The Cantor--Bendixson degree is multiplicative. -/ +@[blueprint "thm:cantor-bendixson-degree-multiplicative" + (phase := "Cantor–Bendixson ranks of supports") + (title := "Multiplicativity of the Cantor--Bendixson degree") + (statement := /-- + Let $R$ be a characteristic-zero domain and let $G$ be a nontrivial + ordered abelian group equipped with a compatible additive uniformity and + its order topology. Assume that $G$ is Cauchy complete. For all + $b,c\in R((G^{\le0}))$, + \[ + \deg\bigl(V_{\mathrm{CB}}(bc)\bigr) + =\deg\bigl(V_{\mathrm{CB}}(b)\bigr) + \oplus\deg\bigl(V_{\mathrm{CB}}(c)\bigr), + \] + where $\deg$ is Cantor degree, with value $-\infty$ at $0$, and + $\oplus$ is Hessenberg's natural sum. + -/) + (proof := /-- + Take Cantor degree in + \ref{thm:cantor-bendixson-value-multiplicative}. Cantor degree sends + Hessenberg's natural product to Hessenberg's natural sum. + -/)] +theorem cantorBendixsonDegreeValuation_mul (b c : Nonpositive G R) : + cantorBendixsonDegreeValuation (b * c) = + cantorBendixsonDegreeValuation b + cantorBendixsonDegreeValuation c := by + simp only [cantorBendixsonDegreeValuation_apply, map_mul, NatOrdinal.cantorDegree_mul] + +instance : (cantorBendixsonDegreeValuation (G := G) (R := R)).IsMultiplicative := by + constructor + exact cantorBendixsonDegreeValuation_mul + +/-- At a closed-support point zero, the degree is precisely its Cantor--Bendixson rank. -/ +theorem cantorBendixsonDegreeValuation_of_mem (b : Nonpositive G R) + (hb : 0 ∈ (b : HahnSeries G R).closedSupport) : + cantorBendixsonDegreeValuation b = + (NatOrdinal.of ((b : HahnSeries G R).cantorBendixsonRank 0) : WithBot NatOrdinal) := by + rw [cantorBendixsonDegreeValuation_apply, cantorBendixsonValuation_apply, + cantorBendixsonValue_of_mem _ ((mem_closedSupport _ _).mp hb), + NatOrdinal.of_omega0_opow, NatOrdinal.cantorDegree_wpow] + +/-- The bottom degree is exactly the ideal defining germs at zero. -/ +theorem cantorBendixsonDegreeValuation_eq_bot_iff (b : Nonpositive G R) : + cantorBendixsonDegreeValuation b = ⊥ ↔ + ∃ c < (0 : G), (b : HahnSeries G R).support ⊆ Iic c := by + rw [cantorBendixsonDegreeValuation_apply, NatOrdinal.cantorDegree_eq_bot, + ← Valuation.mem_supp_iff, mem_cantorBendixsonValuation_supp] + +/-- The associated graded ring for the Cantor–Bendixson degree is a domain. -/ +theorem cantorBendixson_associatedGraded_isDomain : + IsDomain + (cantorBendixsonDegreeValuation (G := G) (R := R)).AssociatedGraded := by + let ν := cantorBendixsonDegreeValuation (G := G) (R := R) + have h1 : ν 1 ≠ ⊥ := by + rw [cantorBendixsonDegreeValuation_apply, map_one, ne_eq, NatOrdinal.cantorDegree_eq_bot] + exact one_ne_zero + let : Nontrivial ν.AssociatedGraded := + ⟨⟨ν.initialForm 1, 0, ν.initialForm_ne_zero_of_ne_bot h1⟩⟩ + exact NoZeroDivisors.to_isDomain ν.AssociatedGraded + +end HahnSeries.Nonpositive diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/LeadingCoefficient.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/LeadingCoefficient.lean new file mode 100644 index 0000000000..cbc3af1bf9 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/LeadingCoefficient.lean @@ -0,0 +1,243 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.LimitOrdinalEvaluation +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.TruncationPolynomial +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.ScalarLeadingCoefficientAtLimitOrdinal + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint + +/-! +# Leading coefficients when the degree is a limit ordinal + +The polynomial of each proper translated truncation is read through the finite convolution +formula. Its highest coefficient in a maximal variable is the polynomial of the corresponding +truncation of the leading coefficient. The uniform degree drop for the evaluated relation then +contradicts the degrees of sufficiently late translated truncations of that coefficient. + +If the leading coefficient is a scalar, the coefficient one below the top instead combines with +the derivative contribution from the leading power. That branch is proved separately and joined +to the nonconstant branch here. +-/ + +universe u v w + +open scoped NatOrdinal Topology + +open Filter MvPolynomial HahnSeries HahnSeries.Nonpositive + +public noncomputable section + +namespace HahnSeries.Germ + +variable {G : Type u} {K : Type v} +variable [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [UniformSpace G] [IsUniformAddGroup G] [OrderTopology G] [Nontrivial G] [CompleteSpace G] + [Field K] [CharZero K] + +local notation "ν" => (cantorBendixsonDegreeValuation (G := G) (R := K)) + +variable {ι : Type w} {wt : ι → NatOrdinal.{u}} + {xg : ι → (cantorBendixsonDegreeValuation (G := G) (R := K)).AssociatedGraded} +variable (σ : LiftFamily wt xg) +variable (hx : OrdinalGraded.IsMinimalSystem + (DirectSum.rangeLof K (cantorBendixsonDegreeValuation (G := G) (R := K)).Component) wt xg) + +include hx in +open Classical in +/-- A homogeneous relation is impossible when its leading coefficient has nonzero weighted +degree and the least Cantor term of that degree precedes the least term of the maximal weight. -/ +theorem false_of_aeval_eq_zero_of_leastTerm_le_of_ne_zero + (hσ : LiftFamily.HasLowerTruncationDegrees σ) {α : NatOrdinal.{u}} + (hinj : ∀ β < α, OrdinalGraded.InjectiveAt K wt xg β) + {F : MvPolynomial ι K} (hF : IsWeightedHomogeneous wt F α) + (hF0 : aeval xg F = 0) {B₀ : ι} (hB₀ : B₀ ∈ F.vars) + (hmax : ∀ i ∈ F.vars, wt i ≤ wt B₀) (hg : wt B₀ < α) + {degHD : NatOrdinal.{u}} (hdegHD : degHD + degreeOf B₀ F • wt B₀ = α) + (hdegHD0 : degHD ≠ 0) + (hcase : NatOrdinal.leastTerm degHD ≤ NatOrdinal.leastTerm (wt B₀)) : False := by + classical + obtain ⟨D, hDdef⟩ : ∃ D, degreeOf B₀ F = D := ⟨_, rfl⟩ + rw [hDdef] at hdegHD + have hD : 1 ≤ D := by + rw [← hDdef] + exact Nat.one_le_iff_ne_zero.mpr (mem_vars_iff_degreeOf_ne_zero.mp hB₀) + have hFkmem : ∀ k, xCoeff B₀ k F ∈ supported K {B₀}ᶜ := fun k ↦ + xCoeff_mem_supported B₀ k F + have hFkvars : ∀ k, ∀ i ∈ (xCoeff B₀ k F).vars, wt i ≤ wt B₀ := fun k i hi ↦ + hmax i (vars_xCoeff_subset B₀ k F hi) + have hαk : ∀ k ≤ D, (degHD + (D - k) • wt B₀) + k • wt B₀ = α := by + intro k hk + rw [add_assoc, ← add_nsmul, Nat.sub_add_cancel hk] + exact hdegHD + have hFkhom : ∀ k ≤ D, + IsWeightedHomogeneous wt (xCoeff B₀ k F) (degHD + (D - k) • wt B₀) := + fun k hk ↦ xCoeff_isWeightedHomogeneous' B₀ wt hF k (hαk k hk) + have hαklt : ∀ k, 1 ≤ k → k ≤ D → degHD + (D - k) • wt B₀ < α := by + intro k hk1 hk + rw [← hαk k hk] + exact lt_add_of_pos_right _ + (pos_iff_ne_zero.mpr (NatOrdinal.nsmul_ne_zero_of_ne_zero (hx.ne_zero B₀) hk1)) + have hFne : F ≠ 0 := by + rintro rfl + simp at hB₀ + have hFD : xCoeff B₀ D F ≠ 0 := by + rw [← hDdef] + exact xCoeff_degreeOf_ne_zero B₀ hFne + have hFDhom : IsWeightedHomogeneous wt (xCoeff B₀ D F) degHD := by + have h := hFkhom D le_rfl + rwa [Nat.sub_self, zero_smul, add_zero] at h + have hdegHDlt : degHD < α := by + have h := hαklt D hD le_rfl + rwa [Nat.sub_self, zero_smul, add_zero] at h + have hfree : LiftFamily.FreeOfVariable σ hx α B₀ + (aeval σ.lift (xCoeff B₀ D F)) degHD := + LiftFamily.FreeOfVariable.aeval (σ := σ) (hx := hx) hσ hinj hg hFDhom hdegHDlt + (hFkmem D) (hFkvars D) + have hterm : ∀ k ≤ D, HasLowerTruncationDegree + (σ.lift B₀ ^ k * aeval σ.lift (xCoeff B₀ k F)) + (k • wt B₀ + (degHD + (D - k) • wt B₀)) := by + intro k hk + exact (((LiftFamily.hasLowerTruncationDegrees_iff σ).mp hσ B₀).pow k).mul rfl + (σ.hasLowerTruncationDegree_aeval hσ (hFkhom k hk)) + have hGexp : aeval σ.lift F = ∑ k ∈ Finset.range (D + 1), + σ.lift B₀ ^ k * aeval σ.lift (xCoeff B₀ k F) := by + conv_lhs => rw [← sum_xCoeff_mul_X_pow B₀ F] + rw [hDdef, map_sum] + refine Finset.sum_congr rfl fun k _ ↦ ?_ + rw [map_mul, map_pow, aeval_X, mul_comm] + have hα0 : α ≠ 0 := ne_of_gt ((zero_le : (0 : NatOrdinal) ≤ wt B₀).trans_lt hg) + obtain ⟨bound, hboundα, hcuts⟩ := + exists_lt_forall_degree_translatedTruncLE_lt σ hα0 hF hF0 + obtain ⟨l, hl0, hcuts'⟩ := eventually_nhdsLT_iff_exists.mp hcuts + have hcoeffD : ∀ γ : G, γ < 0 → + xCoeff B₀ D (σ.pol hx α (translatedTruncLE γ (aeval σ.lift F))) = + σ.pol hx α (translatedTruncLE γ (aeval σ.lift (xCoeff B₀ D F))) := by + intro γ hγ + rw [hGexp, map_sum, σ.pol_sum hx hinj _ _ (fun k hk ↦ by + have hkD : k ≤ D := Nat.lt_succ_iff.mp (Finset.mem_range.mp hk) + have hdrop := (hterm k hkD).degree_translatedTruncLE_lt hγ + rwa [add_comm (k • wt B₀), hαk k hkD] at hdrop), map_sum] + rw [Finset.sum_range_succ, Finset.sum_eq_zero (fun k hk ↦ ?_), zero_add] + · exact (LiftFamily.FreeOfVariable.xCoeff_pol_translatedTruncLE_lift_pow_mul + (σ := σ) (hx := hx) hσ hinj hg hfree D (by + rw [add_comm] + exact hdegHD.le) hγ).2 + · have hkD : k < D := Finset.mem_range.mp hk + have hkD' : k ≤ D := hkD.le + rcases Nat.eq_zero_or_pos k with rfl | hk1 + · have hF0hom : IsWeightedHomogeneous wt (xCoeff B₀ 0 F) α := by + have h := hFkhom 0 hkD' + rw [Nat.sub_zero, hdegHD] at h + exact h + rw [pow_zero, one_mul, xCoeff_of_mem_supported B₀ + (LiftFamily.FreeOfVariable.pol_translatedTruncLE_aeval_mem_supported + (σ := σ) (hx := hx) hσ hinj hg hF0hom (hFkmem 0) (hFkvars 0) hγ) D, + ite_eq_right (Nat.ne_of_gt hD)] + · have hfreeK := LiftFamily.FreeOfVariable.aeval (σ := σ) (hx := hx) hσ hinj hg + (hFkhom k hkD') (hαklt k hk1 hkD') (hFkmem k) (hFkvars k) + exact (LiftFamily.FreeOfVariable.xCoeff_pol_translatedTruncLE_lift_pow_mul + (σ := σ) (hx := hx) hσ hinj hg hfreeK k (by + rw [add_comm] + exact (hαk k hkD').le) hγ).1 D hkD + have hdegree : ν (aeval σ.lift (xCoeff B₀ D F)) = + (degHD : WithBot NatOrdinal) := by + have hrep := σ.represents_aeval hFDhom + have hgrade : aeval xg (xCoeff B₀ D F) ≠ 0 := by + intro hzero + exact hFD (((OrdinalGraded.injectiveAt_iff degHD).mp (hinj degHD hdegHDlt)) + (xCoeff B₀ D F) hFDhom hzero) + exact hrep.degree_eq hgrade + have hsep : D • wt B₀ = 0 ∨ + NatOrdinal.leastTerm degHD ≤ NatOrdinal.leastTerm (D • wt B₀) := by + right + rw [NatOrdinal.leastTerm_nsmul (hx.ne_zero B₀) hD] + exact hcase + apply σ.false_of_forall_weightedTotalDegree_pol_add_lt hx hdegree hdegHD0 hsep + (by rw [hdegHD]; exact hboundα) hl0 + · intro γ hlγ hγ hp0 + rw [← hcoeffD γ hγ] at hp0 ⊢ + exact LiftFamily.weightedTotalDegree_xCoeff_add_nsmul_lt + (σ.pol_weight_lt_of_degree_lt hx hboundα.le (hcuts' γ hlγ hγ)) B₀ D hp0 + · exact hdegHDlt + +include hx in +/-- A homogeneous relation is impossible when its leading coefficient in a maximal variable is +scalar, or its least Cantor term is no greater than that of the variable's weight. -/ +@[blueprint "lem:cantor-bendixson-leading-coefficient" + (phase := "Algebraic independence in graded rings") + (title := "Leading-coefficient obstruction for homogeneous relations") + (statement := /-- + Let $K$ be a field of characteristic zero and $G$ a nontrivial complete + ordered abelian group with compatible additive uniformity and order + topology. Let $x_i$ be a minimal homogeneous generating system for the + associated graded ring of the degree filtration, of weights $w_i$. Choose + series $b_i$ representing $x_i$ such that + \[ + \deg(b_i)\le w_i, + \qquad \deg(b_i^{\vert y}) (cantorBendixsonDegreeValuation (G := G) (R := K)) + +/-- Every homogeneous class is the class of a series in the corresponding weight filtration. -/ +theorem exists_represents {m : NatOrdinal.{u}} {e : (ν).AssociatedGraded} + (he : e ∈ DirectSum.rangeLof K (ν).Component m) : + ∃ b : Nonpositive G K, Represents b m e := by + obtain ⟨a, ha⟩ := (DirectSum.mem_rangeLof_iff K (ν).Component m e).mp he + rw [DirectSum.lof_eq_of] at ha + induction a using MaxAddDegree.componentInductionOn with + | H p => + refine ⟨(p : Nonpositive G K), represents_iff.mpr + ⟨((ν).mem_filtrationLE_iff m _).mp p.2, ?_⟩⟩ + rw [← ha, MaxAddDegree.homogeneousMk_apply] + +/-- A series bounded strictly below zero has bottom degree. -/ +theorem degree_eq_bot_of_support_subset_Iic {b : Nonpositive G K} {c : G} (hc : c < 0) + (hb : (b : HahnSeries G K).support ⊆ Set.Iic c) : ν b = ⊥ := by + have hclosed : (0 : G) ∉ closure (b : HahnSeries G K).support := by + intro h0 + exact absurd (isClosed_Iic.closure_subset_iff.mpr hb h0) (not_le.mpr hc) + rw [cantorBendixsonDegreeValuation_apply, cantorBendixsonValuation_apply, + cantorBendixsonValue_of_notMem _ hclosed, NatOrdinal.of_zero, NatOrdinal.cantorDegree_zero] + +open Classical in +/-- **Every homogeneous class has a representative with the required truncation bounds.** +Cutting a representative below a negative bound leaves the class unchanged, because the discarded +part is bounded strictly below zero and so has bottom degree. Choose the bound past which every +proper translated truncation already drops. Above it, the chosen drop applies; at or below it, the +truncation is empty. -/ +theorem exists_representative_hasLowerTruncationDegree + {m : NatOrdinal.{u}} {e : (ν).AssociatedGraded} + (he : e ∈ DirectSum.rangeLof K (ν).Component m) : + ∃ b : Nonpositive G K, Represents b m e ∧ HasLowerTruncationDegree b m := by + obtain ⟨a, ha⟩ := (DirectSum.mem_rangeLof_iff K (ν).Component m e).mp he + rw [DirectSum.lof_eq_of] at ha + obtain ⟨d, hd⟩ : ∃ d : G, d < 0 := exists_lt (0 : G) + obtain ⟨w, c, hw, -, hc0, hwa, hdrop⟩ := exists_representative_with_lower_truncation_degree m a hd + -- the part of `w` strictly above the cutoff + obtain ⟨b, hbdef⟩ : ∃ b : Nonpositive G K, + (b : HahnSeries G K) = truncGT c (w : HahnSeries G K) := + ⟨⟨truncGT c (w : HahnSeries G K), fun g hg ↦ w.property (support_truncGT_subset c _ hg)⟩, rfl⟩ + -- what was cut off is bounded strictly below zero + have hcut : ∀ γ : G, c < γ → γ ≤ 0 → + ν (translatedTruncLE γ (w - b)) = ⊥ := by + intro γ hcγ hγ + refine degree_eq_bot_of_support_subset_Iic (c := c - γ) (by + simpa using sub_neg.mpr hcγ) ?_ + intro g hg + have hg' : g + γ ∈ ((w : HahnSeries G K) - (b : HahnSeries G K)).support := by + have hcoe : ((translatedTruncLE γ (w - b) : Nonpositive G K) : HahnSeries G K) = + translate (-γ) (truncLE γ ((w : HahnSeries G K) - (b : HahnSeries G K))) := + coe_translatedTruncLE γ (w - b) + rw [hcoe, mem_support, HahnSeries.coeff_translate, HahnSeries.coeff_truncLE] at hg + split_ifs at hg with hle + · exact (mem_support _ _).mpr (by simpa using hg) + · exact absurd rfl hg + have hcoeff : ((w : HahnSeries G K) - (b : HahnSeries G K)).coeff (g + γ) ≠ 0 := + (mem_support _ _).mp hg' + rw [HahnSeries.coeff_sub, hbdef, HahnSeries.coeff_truncGT] at hcoeff + have hle : g + γ ≤ c := by + by_contra hn + rw [ite_eq_left (not_le.mp hn), sub_self] at hcoeff + exact hcoeff rfl + simpa using sub_le_sub_right hle γ + have hsub : ν ((w : Nonpositive G K) - b) = ⊥ := by + have h := hcut 0 hc0 le_rfl + rwa [translatedTruncLE_zero] at h + have hbw : ν b ≤ m := by + have heq := degree_eq_of_degree_sub_eq_bot hsub + rwa [heq] at hw + refine ⟨b, represents_iff.mpr ⟨hbw, ?_⟩, hasLowerTruncationDegree_iff.mpr ⟨hbw, fun y hy ↦ ?_⟩⟩ + · rw [← ha, ← hwa] + refine (MaxAddDegree.homogeneousMk_apply _ _ _).trans ?_ + congr 1 + refine ((ν).componentMk_eq_componentMk_iff m _ _).mpr ?_ + rw [show ((b : Nonpositive G K) : Nonpositive G K) - (w : Nonpositive G K) = + -((w : Nonpositive G K) - b) by ring, (ν).map_neg, hsub] + exact bot_lt_iff_ne_bot.mpr (by simp) + · by_cases hyc : c < y + · have hdiff := hcut y hyc hy.le + have heq := degree_eq_of_degree_sub_eq_bot (a := translatedTruncLE y (w : Nonpositive G K)) + (b := translatedTruncLE y b) (by rw [← map_sub]; exact hdiff) + rw [← heq] + exact hdrop y hyc hy + · have hzero : translatedTruncLE y b = 0 := by + apply Subtype.ext + ext g + have hcoe : ((translatedTruncLE y b : Nonpositive G K) : HahnSeries G K) = + translate (-y) (truncLE y (b : HahnSeries G K)) := coe_translatedTruncLE y b + rw [hcoe, HahnSeries.coeff_translate, HahnSeries.coeff_truncLE, hbdef, + HahnSeries.coeff_truncGT] + split_ifs with h1 h2 + · exact absurd h2 (not_lt.mpr (le_trans (by simpa using h1) (not_lt.mp hyc))) + · rfl + · rfl + rw [hzero, (ν).map_zero] + exact bot_lt_iff_ne_bot.mpr (by simp) + +variable {ι : Type w} + +/-- Series representing a family of homogeneous classes, each in its own degree. -/ +abbrev LiftFamily (wt : ι → NatOrdinal.{u}) + (x : ι → (cantorBendixsonDegreeValuation (G := G) (R := K)).AssociatedGraded) := + MaxAddDegree.LiftFamily (cantorBendixsonDegreeValuation (G := G) (R := K)) wt x + +variable {wt : ι → NatOrdinal.{u}} + {x : ι → (cantorBendixsonDegreeValuation (G := G) (R := K)).AssociatedGraded} + +/-- Lifts exist for every family of homogeneous classes. -/ +theorem nonempty_liftFamily (hmem : ∀ i, x i ∈ DirectSum.rangeLof K (ν).Component (wt i)) : + Nonempty (LiftFamily wt x) := by + choose b hb using fun i ↦ exists_represents (hmem i) + exact ⟨⟨b, hb⟩⟩ + +namespace LiftFamily + +variable (σ : LiftFamily wt x) + +/-- Evaluating a weighted homogeneous polynomial at the lifts lifts the evaluation at the +classes. -/ +theorem represents_aeval {F : MvPolynomial ι K} {β : NatOrdinal.{u}} + (hF : IsWeightedHomogeneous wt F β) : + Represents (aeval σ.lift F) β (aeval x F) := + Nonpositive.represents_aeval x σ.represents hF + +/-- A relation evaluates at the lifts to a series of degree strictly below its own. -/ +theorem degree_aeval_lt_of_aeval_eq_zero {F : MvPolynomial ι K} {β : NatOrdinal.{u}} + (hF : IsWeightedHomogeneous wt F β) (h : aeval x F = 0) : + ν (aeval σ.lift F) < (β : WithBot NatOrdinal.{u}) := + Represents.degree_lt_of_eq_zero (h ▸ σ.represents_aeval hF) + +/-- Every representative satisfies the degree and proper-truncation bounds assigned to its +class. -/ +def HasLowerTruncationDegrees (σ : LiftFamily wt x) : Prop := + ∀ i, Nonpositive.HasLowerTruncationDegree (σ.lift i) (wt i) + +theorem hasLowerTruncationDegrees_iff (σ : LiftFamily wt x) : + HasLowerTruncationDegrees σ ↔ ∀ i, Nonpositive.HasLowerTruncationDegree (σ.lift i) (wt i) := + Iff.rfl + +/-- Evaluating a weighted homogeneous polynomial preserves the assigned lower-truncation +degree. -/ +theorem hasLowerTruncationDegree_aeval (hσ : HasLowerTruncationDegrees σ) + {F : MvPolynomial ι K} {β : NatOrdinal.{u}} (hF : IsWeightedHomogeneous wt F β) : + Nonpositive.HasLowerTruncationDegree (aeval σ.lift F) β := + Nonpositive.hasLowerTruncationDegree_aeval ((hasLowerTruncationDegrees_iff σ).mp hσ) hF + +/-- A polynomial all of whose monomials have weight below `α` evaluates at the lifts to a series of +degree below `α`. -/ +theorem degree_aeval_lt {F : MvPolynomial ι K} {α : NatOrdinal.{u}} + (hF : ∀ d ∈ F.support, Finsupp.weight wt d < α) : + ν (aeval σ.lift F) < (α : WithBot NatOrdinal.{u}) := + Nonpositive.degree_aeval_lt_of_forall_weight_lt x σ.represents hF + +end LiftFamily + +/-- Every family of homogeneous classes has representatives of the assigned lower-truncation +degrees. -/ +theorem exists_liftFamily_hasLowerTruncationDegrees + (hmem : ∀ i, x i ∈ DirectSum.rangeLof K (ν).Component (wt i)) : + ∃ σ : LiftFamily wt x, LiftFamily.HasLowerTruncationDegrees σ := by + choose b hb hbounds using fun i ↦ exists_representative_hasLowerTruncationDegree (hmem i) + exact ⟨⟨b, hb⟩, hbounds⟩ + +end HahnSeries.Nonpositive + +end diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/Lifts.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/Lifts.lean new file mode 100644 index 0000000000..57e46677a2 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/Lifts.lean @@ -0,0 +1,393 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.Scalar +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.TruncationIntegerPartPrimal +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.DegreeRepresentatives +public import Mathlib.RingTheory.MvPolynomial.WeightedHomogeneous +import Mathlib.Algebra.MvPolynomial.CommRing + +/-! +# Representatives in the associated graded ring of the Cantor–Bendixson degree + +A nonpositive Hahn series represents a homogeneous class in the associated graded ring of the +Cantor–Bendixson degree +when it lies in the weight filtration and its class is that element. Evaluating a weighted +homogeneous polynomial at lifts of homogeneous classes is again such a lift: the evaluation lies +in the filtration of the weighted degree, and its class is the evaluation at the classes in the +associated graded ring. + +Consequently, whenever every homogeneous class of degree below `α` is a homogeneous polynomial in +prescribed classes, every series of degree below `α` agrees, up to a series bounded strictly +below zero, with the evaluation at the lifts of a polynomial all of whose monomials have weight +below `α`. The construction removes leading homogeneous classes along a strictly decreasing +sequence of degrees, so no countability, cofinality, or support-order hypothesis enters. +-/ + +public noncomputable section + +open Set MvPolynomial +open scoped NatOrdinal DirectSum + +universe u v w + +namespace HahnSeries.Nonpositive + +variable {G : Type u} {K : Type v} [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [UniformSpace G] [IsUniformAddGroup G] [OrderTopology G] [Nontrivial G] [CompleteSpace G] + [Field K] [CharZero K] + +local notation "ν" => (cantorBendixsonDegreeValuation (G := G) (R := K)) + +/-- A nonpositive series representing a homogeneous class of specified degree. -/ +abbrev Represents (b : Nonpositive G K) (m : NatOrdinal.{u}) (e : (ν).AssociatedGraded) : Prop := + (ν).Represents b m e + +theorem represents_iff {b : Nonpositive G K} {m : NatOrdinal.{u}} + {e : (ν).AssociatedGraded} : + Represents b m e ↔ + ∃ h : ν b ≤ m, (ν).homogeneousMk m ⟨b, ((ν).mem_filtrationLE_iff m b).mpr h⟩ = e := + MaxAddDegree.represents_iff + +theorem Represents.degree_le {b : Nonpositive G K} {m : NatOrdinal.{u}} + {e : (ν).AssociatedGraded} (h : Represents b m e) : ν b ≤ m := + MaxAddDegree.Represents.degree_le h + +/-- The zero series lifts the zero class in every degree. -/ +theorem represents_zero (m : NatOrdinal.{u}) : + Represents (0 : Nonpositive G K) m 0 := + (ν).represents_zero m + +/-- The identity series lifts the identity class in degree zero. -/ +theorem represents_one : Represents (1 : Nonpositive G K) 0 1 := + (ν).represents_one + +/-- A constant series lifts the corresponding scalar class in degree zero. -/ +theorem represents_algebraMap (k : K) : + Represents (algebraMap K (Nonpositive G K) k) 0 (algebraMap K (ν).AssociatedGraded k) := by + refine ⟨by rw [algebraMap_apply]; exact degree_C_le k, ?_⟩ + rw [cantorBendixson_algebraMap_apply, cantorBendixsonLayerScalarHom_apply, + (ν).homogeneousMk_apply] + exact congrArg (DirectSum.of (ν).Component 0) + (congrArg ((ν).componentMk 0) (Subtype.ext (algebraMap_apply k))) + +/-- Lifts add: the sum of two lifts in a common degree lifts the sum of the classes. -/ +theorem Represents.add {a b : Nonpositive G K} {m : NatOrdinal.{u}} + {e f : (ν).AssociatedGraded} (ha : Represents a m e) (hb : Represents b m f) : + Represents (a + b) m (e + f) := + MaxAddDegree.Represents.add ha hb + +/-- Lifts multiply: the product of two lifts, at the sum of the degrees, lifts the product of +the classes. -/ +theorem Represents.mul {a b : Nonpositive G K} {m n p : NatOrdinal.{u}} + {e f : (ν).AssociatedGraded} (hp : p = m + n) + (ha : Represents a m e) (hb : Represents b n f) : + Represents (a * b) p (e * f) := + MaxAddDegree.Represents.mul hp ha hb + +/-- Powers of a lift, at multiples of the degree, lift the powers of the class. -/ +theorem Represents.pow {b : Nonpositive G K} {m : NatOrdinal.{u}} {e : (ν).AssociatedGraded} + (hb : Represents b m e) (n : ℕ) : Represents (b ^ n) (n • m) (e ^ n) := + MaxAddDegree.Represents.pow hb n + +/-- A finite product of lifts, at the sum of the degrees, lifts the product of the classes. -/ +theorem represents_prod {ι' : Type w} {s : Finset ι'} {a : ι' → Nonpositive G K} + {m : ι' → NatOrdinal.{u}} {e : ι' → (ν).AssociatedGraded} + (h : ∀ i ∈ s, Represents (a i) (m i) (e i)) : + Represents (∏ i ∈ s, a i) (∑ i ∈ s, m i) (∏ i ∈ s, e i) := + (ν).represents_prod h + +/-- A finite sum of lifts in a common degree lifts the sum of the classes. -/ +theorem represents_sum {ι' : Type w} {s : Finset ι'} {a : ι' → Nonpositive G K} + {m : NatOrdinal.{u}} {e : ι' → (ν).AssociatedGraded} + (h : ∀ i ∈ s, Represents (a i) m (e i)) : + Represents (∑ i ∈ s, a i) m (∑ i ∈ s, e i) := + (ν).represents_sum h + +/-- Two lifts of one class in a common degree differ by a series of strictly smaller degree. -/ +theorem Represents.degree_sub_lt {a b : Nonpositive G K} {m : NatOrdinal.{u}} + {e : (ν).AssociatedGraded} (ha : Represents a m e) (hb : Represents b m e) : + ν (a - b) < m := + MaxAddDegree.Represents.degree_sub_lt ha hb + +/-- A series of degree strictly below `m` lifts the zero class in degree `m`. -/ +theorem represents_of_degree_lt {b : Nonpositive G K} {m : NatOrdinal.{u}} + (h : ν b < (m : WithBot NatOrdinal)) : Represents b m 0 := + (ν).represents_zero_of_degree_lt h + +/-- A series lifts at most one class in each degree. -/ +theorem Represents.unique {b : Nonpositive G K} {m : NatOrdinal.{u}} + {e f : (ν).AssociatedGraded} (he : Represents b m e) (hf : Represents b m f) : e = f := + MaxAddDegree.Represents.unique he hf + +/-- A lift of a nonzero class has degree exactly the class degree. -/ +theorem Represents.degree_eq {b : Nonpositive G K} {m : NatOrdinal.{u}} + {e : (ν).AssociatedGraded} (h : Represents b m e) (he : e ≠ 0) : + ν b = (m : WithBot NatOrdinal) := + MaxAddDegree.Represents.degree_eq h he + +variable {ι : Type w} {wt : ι → NatOrdinal.{u}} {V : ι → Nonpositive G K} + +/-- Evaluating a weighted homogeneous polynomial at lifts of homogeneous classes lifts the +evaluation at the classes: it lies in the filtration of the weighted degree, and its class is +the evaluation in the associated graded ring. -/ +theorem represents_aeval (x : ι → (ν).AssociatedGraded) + (hV : ∀ i, Represents (V i) (wt i) (x i)) + {F : MvPolynomial ι K} {β : NatOrdinal.{u}} (hF : IsWeightedHomogeneous wt F β) : + Represents (aeval V F) β (aeval x F) := + (ν).represents_aeval represents_algebraMap hV hF + +/-- The evaluation of a polynomial all of whose monomials have weight strictly below `α` has +degree strictly below `α`. -/ +theorem degree_aeval_lt_of_forall_weight_lt (x : ι → (ν).AssociatedGraded) + (hV : ∀ i, Represents (V i) (wt i) (x i)) + {F : MvPolynomial ι K} {α : NatOrdinal.{u}} + (hF : ∀ d ∈ F.support, (Finsupp.weight wt) d < α) : + ν (aeval V F) < (α : WithBot NatOrdinal) := + (ν).degree_aeval_lt_of_forall_weight_lt represents_algebraMap hV hF + +/-- Evaluation of a polynomial with weights at most `β` lifts the evaluation of its top weighted +homogeneous component. -/ +theorem represents_aeval_weightedHomogeneousComponent (x : ι → (ν).AssociatedGraded) + (hV : ∀ i, Represents (V i) (wt i) (x i)) + {F : MvPolynomial ι K} {β : NatOrdinal.{u}} + (hw : ∀ d ∈ F.support, (Finsupp.weight wt) d ≤ β) : + Represents (aeval V F) β (aeval x (weightedHomogeneousComponent wt β F)) := + (ν).represents_aeval_weightedHomogeneousComponent represents_algebraMap hV hw + +/-- Evaluation at the lifts has degree exactly `β` whenever the evaluation of the top weighted +homogeneous component does not vanish in the associated graded ring. -/ +theorem degree_aeval_eq_of_aeval_weightedHomogeneousComponent_ne_zero + (x : ι → (ν).AssociatedGraded) (hV : ∀ i, Represents (V i) (wt i) (x i)) + {F : MvPolynomial ι K} {β : NatOrdinal.{u}} + (hw : ∀ d ∈ F.support, (Finsupp.weight wt) d ≤ β) + (hne : aeval x (weightedHomogeneousComponent wt β F) ≠ 0) : + ν (aeval V F) = (β : WithBot NatOrdinal) := + (represents_aeval_weightedHomogeneousComponent x hV hw).degree_eq hne + +/-- Under injectivity of the graded evaluation below `α`, a polynomial with weights below `α` +whose evaluation at the lifts is bounded strictly below zero is the zero polynomial. This is the +uniqueness of the polynomial of a series modulo bounded series. -/ +theorem eq_zero_of_forall_weight_lt_of_degree_aeval_eq_bot + (x : ι → (ν).AssociatedGraded) (hV : ∀ i, Represents (V i) (wt i) (x i)) + {α : NatOrdinal.{u}} + (hinj : ∀ (β : NatOrdinal.{u}) (F : MvPolynomial ι K), β < α → + IsWeightedHomogeneous wt F β → aeval x F = 0 → F = 0) + {F : MvPolynomial ι K} (hw : ∀ d ∈ F.support, (Finsupp.weight wt) d < α) + (hbot : ν (aeval V F) = ⊥) : F = 0 := by + classical + suffices H : ∀ β : NatOrdinal.{u}, ∀ F : MvPolynomial ι K, + (∀ d ∈ F.support, (Finsupp.weight wt) d < α) → + (∀ d ∈ F.support, (Finsupp.weight wt) d ≤ β) → + ν (aeval V F) = ⊥ → F = 0 from + H (F.support.sup (Finsupp.weight wt)) F hw (fun _ hd ↦ Finset.le_sup hd) hbot + intro β + induction β using WellFoundedLT.induction with + | _ β ih => + intro F hw hβ hbot + have hcomp0 : weightedHomogeneousComponent wt β F = 0 := by + by_cases hzero : weightedHomogeneousComponent wt β F = 0 + · exact hzero + · obtain ⟨d, hd⟩ := MvPolynomial.ne_zero_iff.mp hzero + rw [coeff_weightedHomogeneousComponent] at hd + by_cases hdw : (Finsupp.weight wt) d = β + · rw [ite_eq_left hdw] at hd + have hβα : β < α := hdw ▸ hw d (MvPolynomial.mem_support_iff.mpr hd) + have hrep := represents_aeval_weightedHomogeneousComponent x hV hβ + have hrep0 : Represents (aeval V F) β 0 := + represents_of_degree_lt (by rw [hbot]; exact WithBot.bot_lt_coe β) + exact absurd (hinj β _ hβα + (weightedHomogeneousComponent_isWeightedHomogeneous (w := wt) (n := β) (φ := F)) + (hrep.unique hrep0)) hzero + · rw [ite_eq_right hdw] at hd + exact absurd rfl hd + have hlt : ∀ d ∈ F.support, (Finsupp.weight wt) d < β := by + intro d hd + refine lt_of_le_of_ne (hβ d hd) fun he ↦ ?_ + have := congrArg (fun p : MvPolynomial ι K => p.coeff d) hcomp0 + rw [coeff_weightedHomogeneousComponent, ite_eq_left he, AddMonoidAlgebra.coeff_zero] at this + exact MvPolynomial.mem_support_iff.mp hd this + rcases eq_or_ne β 0 with rfl | hβ0 + · rw [MvPolynomial.eq_zero_iff] + intro d + by_contra hd + exact absurd (hlt d (MvPolynomial.mem_support_iff.mpr hd)) + (not_lt_of_ge (zero_le (a := (Finsupp.weight wt) d))) + · have hsuplt : F.support.sup (Finsupp.weight wt) < β := + Finset.sup_lt_iff (pos_of_ne_zero hβ0) |>.mpr hlt + exact ih _ hsuplt F hw (fun _ hd ↦ Finset.le_sup hd) hbot + +/-- Under injectivity of the graded evaluation below `α`, every monomial weight of a polynomial +is bounded by the degree of its evaluation at the lifts. -/ +theorem forall_weight_le_degree_aeval_of_injective + (x : ι → (ν).AssociatedGraded) (hV : ∀ i, Represents (V i) (wt i) (x i)) + {α : NatOrdinal.{u}} + (hinj : ∀ (β : NatOrdinal.{u}) (F : MvPolynomial ι K), β < α → + IsWeightedHomogeneous wt F β → aeval x F = 0 → F = 0) + {F : MvPolynomial ι K} (hw : ∀ d ∈ F.support, (Finsupp.weight wt) d < α) : + ∀ d ∈ F.support, (((Finsupp.weight wt) d : NatOrdinal) : WithBot NatOrdinal) ≤ + ν (aeval V F) := by + classical + suffices H : ∀ β : NatOrdinal.{u}, ∀ F : MvPolynomial ι K, + (∀ d ∈ F.support, (Finsupp.weight wt) d < α) → + (∀ d ∈ F.support, (Finsupp.weight wt) d ≤ β) → + ∀ d ∈ F.support, (((Finsupp.weight wt) d : NatOrdinal) : WithBot NatOrdinal) ≤ + ν (aeval V F) from + H (F.support.sup (Finsupp.weight wt)) F hw (fun _ hd ↦ Finset.le_sup hd) + intro β + induction β using WellFoundedLT.induction with + | _ β ih => + intro F hw hβ d hd + by_cases hzero : weightedHomogeneousComponent wt β F = 0 + · have hlt : ∀ e ∈ F.support, (Finsupp.weight wt) e < β := by + intro e he + refine lt_of_le_of_ne (hβ e he) fun heq ↦ ?_ + have hcz := congrArg (fun p : MvPolynomial ι K => p.coeff e) hzero + rw [coeff_weightedHomogeneousComponent, ite_eq_left heq, AddMonoidAlgebra.coeff_zero] at hcz + exact MvPolynomial.mem_support_iff.mp he hcz + rcases eq_or_ne β 0 with rfl | hβ0 + · exact absurd (hlt d hd) (not_lt_of_ge (zero_le (a := (Finsupp.weight wt) d))) + · exact ih (F.support.sup (Finsupp.weight wt)) + (Finset.sup_lt_iff (pos_of_ne_zero hβ0) |>.mpr hlt) F hw + (fun _ he ↦ Finset.le_sup he) d hd + · obtain ⟨e, he⟩ := MvPolynomial.ne_zero_iff.mp hzero + rw [coeff_weightedHomogeneousComponent] at he + by_cases hew : (Finsupp.weight wt) e = β + · have hβα : β < α := hew ▸ hw e (MvPolynomial.mem_support_iff.mpr (by + rwa [ite_eq_left hew] at he)) + have haev : aeval x (weightedHomogeneousComponent wt β F) ≠ 0 := fun h ↦ + hzero (hinj β _ hβα + (weightedHomogeneousComponent_isWeightedHomogeneous (w := wt) (n := β) (φ := F)) h) + rw [(represents_aeval_weightedHomogeneousComponent x hV hβ).degree_eq haev] + exact WithBot.coe_le_coe.mpr (hβ d hd) + · rw [ite_eq_right hew] at he + exact absurd rfl he + +open Classical in +/-- The polynomial of a series modulo bounded series, at arbitrary cofinality. If every +homogeneous class of degree below `α` is a homogeneous polynomial in prescribed classes, then +every series of degree below `α` agrees, up to a series bounded strictly below zero, with the +evaluation at the lifts of a polynomial all of whose monomials have weight below `α`. -/ +theorem exists_forall_weight_lt_and_degree_sub_aeval_eq_bot + (x : ι → (ν).AssociatedGraded) (hV : ∀ i, Represents (V i) (wt i) (x i)) + (α : NatOrdinal.{u}) + (hgen : ∀ β : NatOrdinal.{u}, β < α → ∀ y ∈ DirectSum.rangeLof K (ν).Component β, + ∃ F : MvPolynomial ι K, IsWeightedHomogeneous wt F β ∧ aeval x F = y) + (u : Nonpositive G K) (hu : ν u < (α : WithBot NatOrdinal)) : + ∃ F : MvPolynomial ι K, + (∀ d ∈ F.support, (((Finsupp.weight wt) d : NatOrdinal) : WithBot NatOrdinal) ≤ ν u) ∧ + (∀ d ∈ F.support, (Finsupp.weight wt) d < α) ∧ + ν (u - aeval V F) = ⊥ := by + classical + suffices H : ∀ b : WithBot NatOrdinal.{u}, b < (α : WithBot NatOrdinal) → + ∀ u : Nonpositive G K, ν u = b → + ∃ F : MvPolynomial ι K, + (∀ d ∈ F.support, (((Finsupp.weight wt) d : NatOrdinal) : WithBot NatOrdinal) ≤ ν u) ∧ + (∀ d ∈ F.support, (Finsupp.weight wt) d < α) ∧ + ν (u - aeval V F) = ⊥ from H (ν u) hu u rfl + intro b + induction b using WellFoundedLT.induction with + | _ b ih => + intro hbα u hb + cases b with + | bot => + refine ⟨0, by simp, by simp, ?_⟩ + rw [map_zero, sub_zero, hb] + | coe β => + have hβα : β < α := WithBot.coe_lt_coe.mp hbα + have hle : ν u ≤ β := hb.le + obtain ⟨Fβ, hFβhom, hFβval⟩ := hgen β hβα (DirectSum.of (ν).Component β + ((ν).componentMk β ⟨u, ((ν).mem_filtrationLE_iff β u).mpr hle⟩)) + (DirectSum.of_mem_rangeLof K (ν).Component β _) + have hrepu : Represents u β (DirectSum.of (ν).Component β + ((ν).componentMk β ⟨u, ((ν).mem_filtrationLE_iff β u).mpr hle⟩)) := + ⟨hle, (ν).homogeneousMk_apply β _⟩ + have hrepF : Represents (aeval V Fβ) β (DirectSum.of (ν).Component β + ((ν).componentMk β ⟨u, ((ν).mem_filtrationLE_iff β u).mpr hle⟩)) := by + rw [← hFβval] + exact represents_aeval x hV hFβhom + have hdrop : ν (u - aeval V Fβ) < (β : WithBot NatOrdinal) := + hrepu.degree_sub_lt hrepF + obtain ⟨F', hF'd, hF'w, hF'⟩ := ih (ν (u - aeval V Fβ)) hdrop (hdrop.trans hbα) + (u - aeval V Fβ) rfl + refine ⟨Fβ + F', ?_, ?_, ?_⟩ + · intro d hd + rcases Finset.mem_union.mp (MvPolynomial.support_add hd) with hd | hd + · rw [hFβhom (MvPolynomial.mem_support_iff.mp hd), hb] + · exact (hF'd d hd).trans (hdrop.le.trans hb.ge) + · intro d hd + rcases Finset.mem_union.mp (MvPolynomial.support_add hd) with hd | hd + · rw [hFβhom (MvPolynomial.mem_support_iff.mp hd)] + exact hβα + · exact hF'w d hd + · rw [map_add, show u - (aeval V Fβ + aeval V F') = + u - aeval V Fβ - aeval V F' by ring] + exact hF' + +omit [UniformSpace G] [IsUniformAddGroup G] [OrderTopology G] [Nontrivial G] [CompleteSpace G] + [CharZero K] in +/-- Translated weak truncation is linear over the coefficient field. -/ +theorem translatedTruncLE_smul (γ : G) (k : K) (b : Nonpositive G K) : + translatedTruncLE γ (k • b) = k • translatedTruncLE γ b := by + apply Subtype.ext + rw [coe_translatedTruncLE, coe_smul, coe_smul, coe_translatedTruncLE] + ext g + rw [HahnSeries.coeff_smul, coeff_translate, coeff_translate, HahnSeries.coeff_truncLE, + HahnSeries.coeff_truncLE, HahnSeries.coeff_smul] + by_cases h : g - -γ ≤ γ + · rw [ite_eq_left h, ite_eq_left h] + · rw [ite_eq_right h, ite_eq_right h, smul_zero] + +/-- A lift of the zero class has degree strictly below the class degree. -/ +theorem Represents.degree_lt_of_eq_zero {b : Nonpositive G K} {m : NatOrdinal.{u}} + (h : Represents b m 0) : ν b < (m : WithBot NatOrdinal) := + MaxAddDegree.Represents.degree_lt_of_eq_zero h + +/-- A degree strictly below a nonzero bound admits a natural-ordinal witness. -/ +theorem exists_le_of_degree_lt {b : Nonpositive G K} {m : NatOrdinal.{u}} + (h : ν b < (m : WithBot NatOrdinal)) (hm : m ≠ 0) : + ∃ m₀ : NatOrdinal.{u}, m₀ < m ∧ ν b ≤ (m₀ : WithBot NatOrdinal) := by + by_cases hbot : ν b = ⊥ + · exact ⟨0, pos_iff_ne_zero.mpr hm, by rw [hbot]; exact bot_le⟩ + · obtain ⟨d, hd⟩ := WithBot.ne_bot_iff_exists.mp hbot + rw [← hd] at h ⊢ + exact ⟨d, WithBot.coe_lt_coe.mp h, le_rfl⟩ + +/-- **Lifting a series congruence back to a polynomial identity.** Under injectivity of the graded +evaluation below `α`, two weighted homogeneous polynomials of a common degree below `α` whose +evaluations at the lifts differ by a series of strictly smaller degree are equal. This is how a +relation established among series is returned to the polynomial ring. -/ +theorem eq_of_degree_sub_aeval_lt {ι : Type w} {wt : ι → NatOrdinal.{u}} {V : ι → Nonpositive G K} + (xg : ι → (ν).AssociatedGraded) (hV : ∀ i, Represents (V i) (wt i) (xg i)) + {α : NatOrdinal.{u}} + (hinj : ∀ (β : NatOrdinal.{u}) (F : MvPolynomial ι K), β < α → + IsWeightedHomogeneous wt F β → aeval xg F = 0 → F = 0) + {A B : MvPolynomial ι K} {m : NatOrdinal.{u}} (hm : m < α) + (hA : IsWeightedHomogeneous wt A m) (hB : IsWeightedHomogeneous wt B m) + (h : ν (aeval V A - aeval V B) < (m : WithBot NatOrdinal)) : + A = B := by + have hAB : IsWeightedHomogeneous wt (A - B) m := by + rw [← MvPolynomial.mem_weightedHomogeneousSubmodule] at hA hB ⊢ + exact Submodule.sub_mem _ hA hB + have hcoe : aeval V (A - B) = aeval V A - aeval V B := map_sub _ _ _ + have hzero : Represents (aeval V (A - B)) m 0 := by + rw [hcoe] + exact represents_of_degree_lt h + have hrep : Represents (aeval V (A - B)) m (aeval xg (A - B)) := represents_aeval xg hV hAB + have hclass : aeval xg (A - B) = 0 := hrep.unique hzero + have := hinj m (A - B) hm hAB hclass + exact sub_eq_zero.mp this + +/-- The class a series lifts lies in the corresponding homogeneous component. -/ +theorem Represents.mem_rangeLof {b : Nonpositive G K} {m : NatOrdinal.{u}} + {e : (ν).AssociatedGraded} (h : Represents b m e) : + e ∈ DirectSum.rangeLof K (ν).Component m := by + obtain ⟨hd, he⟩ := h + rw [← he, (ν).homogeneousMk_apply] + exact DirectSum.of_mem_rangeLof K (ν).Component m _ + +end HahnSeries.Nonpositive diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/LimitOrdinalEvaluation.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/LimitOrdinalEvaluation.lean new file mode 100644 index 0000000000..138fb564b7 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/LimitOrdinalEvaluation.lean @@ -0,0 +1,302 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.LimitOrdinalRelationAtCutoff +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MvPolynomial.OrdinalExpansion +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MvPolynomial.RemainderBound + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint + +/-! +# Injectivity when the degree is a limit ordinal + +Evaluation at a minimal system is injective when the degree is a nonzero limit ordinal, provided +it is injective in every smaller degree. + +Suppose not, and take a relation of that degree. Choose a variable of maximal degree. If the +leading coefficient is scalar, or its last Cantor term is no later than the last term of the +maximal weight, the leading-coefficient hypothesis gives a contradiction. Otherwise, translated +truncations of the evaluated relation and the nonlinear terms in the convolution formula admit +uniform smaller-degree bounds. Linearity of the maximal variable and the partial-derivative +identities then give the contradiction. +-/ + +universe u v w + +open scoped NatOrdinal Topology + +open Filter MvPolynomial HahnSeries HahnSeries.Nonpositive + +public noncomputable section + +namespace HahnSeries.Germ + +variable {G : Type u} {K : Type v} +variable [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [UniformSpace G] [IsUniformAddGroup G] [OrderTopology G] [Nontrivial G] [CompleteSpace G] + [Field K] [CharZero K] + +local notation "ν" => (cantorBendixsonDegreeValuation (G := G) (R := K)) + +variable {ι : Type w} {wt : ι → NatOrdinal.{u}} + {xg : ι → (cantorBendixsonDegreeValuation (G := G) (R := K)).AssociatedGraded} +variable (σ : LiftFamily wt xg) + +/-- **The truncations of a relation drop below a degree short of the limit.** The evaluated +relation has degree strictly below the limit, truncation does not raise the degree, and a limit +leaves room for a strict bound in between. -/ +theorem exists_lt_forall_degree_translatedTruncLE_lt {α : NatOrdinal.{u}} (hα0 : α ≠ 0) + {F : MvPolynomial ι K} (hF : IsWeightedHomogeneous wt F α) + (h0 : aeval xg F = 0) : + ∃ α₁ : NatOrdinal.{u}, α₁ < α ∧ + ∀ᶠ γ in 𝓝[<] (0 : G), + ν (translatedTruncLE γ (aeval σ.lift F)) < (α₁ : WithBot NatOrdinal) := by + have hlt := σ.degree_aeval_lt_of_aeval_eq_zero hF h0 + obtain ⟨α₁, hle, hα₁⟩ : ∃ α₁ : NatOrdinal.{u}, + ν (aeval σ.lift F) ≤ (α₁ : WithBot NatOrdinal.{u}) ∧ α₁ < α := by + cases hb : ν (aeval σ.lift F) with + | bot => exact ⟨0, bot_le, pos_iff_ne_zero.mpr hα0⟩ + | coe g => + refine ⟨g, le_rfl, ?_⟩ + rw [hb] at hlt + exact WithBot.coe_lt_coe.mp hlt + exact ⟨α₁, hα₁, eventually_degree_translatedTruncLE_lt _ α₁ hle⟩ + +variable (hx : OrdinalGraded.IsMinimalSystem + (DirectSum.rangeLof K (cantorBendixsonDegreeValuation (G := G) (R := K)).Component) wt xg) +variable {α : NatOrdinal.{u}} +include hx + +/-- Evaluation is injective when the degree is a nonzero limit ordinal. + +Injectivity below the degree enters through three mathematical obligations: exclusion by the +leading coefficient, linearity of a maximal variable, and the partial-derivative identities. -/ +@[blueprint "lem:cantor-bendixson-limit-ordinal-evaluation" + (phase := "Algebraic independence in graded rings") + (title := "Injectivity of evaluation when the degree is a limit ordinal") + (statement := /-- + Let $K$ be a field of characteristic zero and $G$ a nontrivial complete + ordered abelian group equipped with a compatible additive uniformity whose + topology is the order topology. Let $x_i$ be a minimal + homogeneous generating system for the associated graded ring of the + degree filtration, with weights $w_i$, and choose series $b_i$ + representing $x_i$ in degree $w_i$. Let $\alpha\ne0$ have zero constant + Cantor coefficient. + + Assume first that the following leading-coefficient case is impossible. + If $0\ne F\in K[X_i:i\in I]$ is weighted homogeneous of degree $\alpha$, + $F(x)=0$, $X_{B_0}$ has maximal weight among the variables of $F$, and + \[ + \Delta+D w_{B_0}=\alpha, + \qquad D=\deg_{B_0}F, + \] + where $w_{B_0}<\alpha$, then $\Delta=0$ or the last Cantor term of + $\Delta$ being at most the last Cantor term of $w_{B_0}$ gives a + contradiction. + + In the complementary case, suppose the following two conclusions hold + whenever ordinals $\beta,\lambda_0,\alpha_1$ and data + $F,B_0,\Delta,D$ satisfy all of these conditions: + $F\ne0$ is weighted homogeneous of degree $\alpha$ and $F(x)=0$; every + variable $X_i$ of $F$ has $w_i<\alpha$ and zero constant Cantor + coefficient; $X_{B_0}$ has maximal weight; $\Delta+D w_{B_0}=\alpha$; + $\Delta\ne0$ and every Cantor term of $\Delta$ is at least + $\omega^\beta$; the last Cantor term of $w_{B_0}$ is below + $\omega^\beta$; $\lambda_0<\alpha_{<\beta}$; + \[ + \alpha_1\le\alpha_{\ge\beta}\oplus\lambda_0, + \qquad \alpha_1\le\alpha; + \] + near $0$, every translated truncation of $F(b)$ has degree below + $\alpha_1$; and every convolution term $\rho$ using at least two + translated truncations satisfies + $\rho<\alpha_{\ge\beta}\oplus\lambda_0$. + + The two required conclusions are: + + 1. $D=1$. + 2. If $X_{B'}$ occurs in $F$ and + $(w_{B'})_{<\beta}\oplus\eta=\lambda_0$ for some $\eta$, then there + are a finite set $S$ and polynomials $U_B$ such that + \[ + \partial_{B'}F=\sum_{B\in S}(\partial_BF)U_B, + \qquad \partial_{B_0}U_B=0\quad(B\in S), + \] + and every $B\in S$ occurs in $F$ and satisfies either + $(w_B)_{<\beta}=\alpha_{<\beta}$, or + \[ + 0\ne(w_B)_{<\beta}\ne\alpha_{<\beta},\qquad + \nexists\eta,\ (w_B)_{<\beta}\oplus\eta=\lambda_0, + \qquad w_{B'} (cantorBendixsonDegreeValuation (G := G) (R := K)) + +variable {ι : Type w} {wt : ι → NatOrdinal.{u}} + {xg : ι → (cantorBendixsonDegreeValuation (G := G) (R := K)).AssociatedGraded} +variable (σ : LiftFamily wt xg) + +/-- A relation whose degree is a limit ordinal, a variable of maximal degree, a cutoff below every +term of the leading coefficient's degree, and uniform bounds for translated truncations and the +Leibniz remainder. -/ +structure LimitOrdinalRelationAtCutoff (α : NatOrdinal.{u}) where + /-- The relation. -/ + F : MvPolynomial ι K + hom : IsWeightedHomogeneous wt F α + eval_zero : aeval xg F = 0 + ne_zero : F ≠ 0 + vars_lt : ∀ i ∈ F.vars, wt i < α + vars_limit : ∀ i ∈ F.vars, (wt i).constantCoeff = 0 + /-- A variable of maximal degree. -/ + B₀ : ι + mem : B₀ ∈ F.vars + max : ∀ i ∈ F.vars, wt i ≤ wt B₀ + /-- A cutoff exponent `β` such that every term of `deg H_D` is at least `ω^β`. -/ + β : NatOrdinal + /-- The degree `α ⊖ (δ ⊙ D)` of `H_D`, the coefficient of `X_{B₀}^D` in `F`. -/ + degHD : NatOrdinal + hdegHD : degHD + degreeOf B₀ F • wt B₀ = α + degHD_terms : ∀ t ∈ degHD.val.additivePrincipalTerms, (ω^ β).val ≤ t + degHD_ne_zero : degHD ≠ 0 + /-- The degree `δ = deg B₀` has a term below `ω^β`. -/ + term_lt : NatOrdinal.leastTerm (wt B₀) < ω^ β + /-- The bound `λ₀`: the terms of the remainder of the Leibniz rule have degree below + `α_{≥β} ⊕ λ₀`, and the translated truncations of `F(b_𝓑)` have ordinal value below `ω^{α₁}` + with `α₁ ≤ α_{≥β} ⊕ λ₀`. -/ + lam₀ : NatOrdinal + lam₀_lt : lam₀ < NatOrdinal.partLT β α + /-- An upper bound for the degrees of sufficiently late translated truncations of the + relation. -/ + α₁ : NatOrdinal + α₁_le : α₁ ≤ NatOrdinal.partGE β α + lam₀ + α₁_le_α : α₁ ≤ α + truncation_lt : ∀ᶠ γ in 𝓝[<] (0 : G), + cantorBendixsonDegreeValuation (translatedTruncLE γ (aeval σ.lift F)) < + (α₁ : WithBot NatOrdinal) + remainder_lt : ∀ d ∈ F.support, ∀ (k : ℕ) (ρ : NatOrdinal), 2 ≤ k → TermDegree wt d k ρ → + ρ < NatOrdinal.partGE β α + lam₀ + +namespace LimitOrdinalRelationAtCutoff + +variable {σ} {α : NatOrdinal.{u}} (S : LimitOrdinalRelationAtCutoff σ α) +variable (hx : OrdinalGraded.IsMinimalSystem + (DirectSum.rangeLof K + (cantorBendixsonDegreeValuation (G := G) (R := K)).Component) wt xg) + +/-- The part `α_{≥β}` of `α` at or above `β`. -/ +def αGE : NatOrdinal := NatOrdinal.partGE S.β α + +/-- The part `α_{<β}` of `α` below `β`. -/ +def αLT : NatOrdinal := NatOrdinal.partLT S.β α + +/-- The part `(deg B)_{<β}` of the degree of a variable `B` below `β`. -/ +def degLT (i : ι) : NatOrdinal := NatOrdinal.partLT S.β (wt i) + +/-- `H := ∂F/∂X_{B₀}`, the partial derivative of `F` at its variable of maximal degree. -/ +def H : MvPolynomial ι K := pderiv S.B₀ S.F + +/-- The part of `deg B` below `β` equals the part of `α` below `β`. -/ +def LowDegreePartEq (i : ι) : Prop := S.degLT i = S.αLT + +/-- The part of `deg B` below `β` precedes `λ₀` in the algebraic order. -/ +def LowDegreePartAlgebraicLE (i : ι) : Prop := NatOrdinal.AlgebraicLE (S.degLT i) S.lam₀ + +theorem αGE_def : S.αGE = NatOrdinal.partGE S.β α := (rfl) +theorem αLT_def : S.αLT = NatOrdinal.partLT S.β α := (rfl) +theorem degLT_def (i : ι) : S.degLT i = NatOrdinal.partLT S.β (wt i) := (rfl) +theorem H_def : S.H = pderiv S.B₀ S.F := (rfl) +theorem lowDegreePartEq_iff (i : ι) : S.LowDegreePartEq i ↔ S.degLT i = S.αLT := (Iff.rfl) +theorem lowDegreePartAlgebraicLE_iff (i : ι) : + S.LowDegreePartAlgebraicLE i ↔ NatOrdinal.AlgebraicLE (S.degLT i) S.lam₀ := (Iff.rfl) + +theorem αGE_add_αLT : S.αGE + S.αLT = α := NatOrdinal.partGE_add_partLT _ _ + +theorem partGE_add_degLT (i : ι) : NatOrdinal.partGE S.β (wt i) + S.degLT i = wt i := + NatOrdinal.partGE_add_partLT _ _ + +theorem degLT_lt_wpow (i : ι) : S.degLT i < ω^ S.β := NatOrdinal.partLT_lt _ _ + +theorem αLT_lt_wpow : S.αLT < ω^ S.β := NatOrdinal.partLT_lt _ _ + +theorem lam₀_lt_wpow : S.lam₀ < ω^ S.β := S.lam₀_lt.trans S.αLT_lt_wpow + +theorem partGE_αGE_add_lam₀ : + NatOrdinal.partGE S.β (NatOrdinal.partGE S.β α + S.lam₀) = + NatOrdinal.partGE S.β α := by + rw [NatOrdinal.partGE_add, NatOrdinal.partGE_partGE, + NatOrdinal.partGE_eq_zero_of_lt S.lam₀_lt_wpow, add_zero] + +theorem partLT_αGE_add_lam₀ : + NatOrdinal.partLT S.β (NatOrdinal.partGE S.β α + S.lam₀) = S.lam₀ := by + have := NatOrdinal.partGE_add_partLT S.β (NatOrdinal.partGE S.β α + S.lam₀) + rw [S.partGE_αGE_add_lam₀] at this + exact add_left_cancel this + +theorem partLT_degHD : NatOrdinal.partLT S.β S.degHD = 0 := + NatOrdinal.partLT_eq_zero_of_forall_le S.degHD_terms + +theorem αLT_eq_nsmul_degLT : S.αLT = degreeOf S.B₀ S.F • S.degLT S.B₀ := by + have h : NatOrdinal.partLT S.β α = + NatOrdinal.partLT S.β (S.degHD + degreeOf S.B₀ S.F • wt S.B₀) := + congrArg _ S.hdegHD.symm + rw [αLT, h, NatOrdinal.partLT_add, S.partLT_degHD, zero_add, NatOrdinal.partLT_nsmul] + rfl + +/-- In every monomial of `F` the parts below `β` add up to `α_{<β}`. -/ +theorem sum_degLT_eq_αLT {d : ι →₀ ℕ} (hd : d ∈ S.F.support) : + ∑ i ∈ d.support, d i • S.degLT i = S.αLT := by + simpa [degLT, αLT, Finsupp.weight_apply, Finsupp.sum] using + (S.hom.map_weight (NatOrdinal.partLTAddMonoidHom S.β) (mem_support_iff.mp hd)) + +/-- In every monomial of `F` the parts at or above `β` add up to `α_{≥β}`. -/ +theorem sum_partGE_eq_αGE {d : ι →₀ ℕ} (hd : d ∈ S.F.support) : + ∑ i ∈ d.support, d i • NatOrdinal.partGE S.β (wt i) = S.αGE := by + simpa [αGE, Finsupp.weight_apply, Finsupp.sum] using + (S.hom.map_weight (NatOrdinal.partGEAddMonoidHom S.β) (mem_support_iff.mp hd)) + +variable (hxms : OrdinalGraded.IsMinimalSystem + (DirectSum.rangeLof K (cantorBendixsonDegreeValuation (G := G) (R := K)).Component) wt xg) +include hx + +theorem β_ne_zero : S.β ≠ 0 := by + intro h + have hbad := S.term_lt + rw [h, NatOrdinal.wpow_zero] at hbad + exact absurd (NatOrdinal.one_le_leastTerm (hx.ne_zero S.B₀)) (not_le.mpr hbad) + +/-- For every variable `B` of `F`, `(deg B)_{<β}` has finite part `0`. -/ +theorem degLT_constantCoeff {i : ι} (hi : i ∈ S.F.vars) : (S.degLT i).constantCoeff = 0 := by + rw [degLT, NatOrdinal.constantCoeff_partLT (S.β_ne_zero hx)] + exact S.vars_limit i hi + +/-- If `(deg B)_{<β} ≠ 0`, the last term of its Cantor normal form is `ω^e` with `e ≠ 0`. -/ +theorem exists_leastTerm_degLT {i : ι} (hi : i ∈ S.F.vars) (h : S.degLT i ≠ 0) : + ∃ e, e ≠ 0 ∧ NatOrdinal.leastTerm (S.degLT i) = ω^ e := by + obtain ⟨e, he⟩ := NatOrdinal.exists_leastTerm_eq_wpow h + refine ⟨e, fun he0 ↦ ?_, he⟩ + rw [he0, NatOrdinal.wpow_zero, ← NatOrdinal.removeLeastTerm_add_one_eq_self_iff] at he + have := S.degLT_constantCoeff hx hi + rw [← he, show (1 : NatOrdinal) = ((1 : ℕ) : NatOrdinal) by rw [Nat.cast_one], + NatOrdinal.constantCoeff_add_natCast] at this + omega + +/-- `(deg B₀)_{<β} ≠ 0`: the variable of maximal degree has a term below `ω^β`. -/ +theorem degLT_B₀_ne_zero : S.degLT S.B₀ ≠ 0 := by + obtain ⟨e, he⟩ := NatOrdinal.exists_leastTerm_eq_wpow (hx.ne_zero S.B₀) + have hlt : e < S.β := by + have := S.term_lt + rwa [he, NatOrdinal.wpow_lt_wpow] at this + exact NatOrdinal.partLT_ne_zero_of_leastTerm_lt (hx.ne_zero S.B₀) he hlt + +theorem αLT_ne_zero : S.αLT ≠ 0 := by + rw [S.αLT_eq_nsmul_degLT] + exact NatOrdinal.nsmul_ne_zero_of_ne_zero (S.degLT_B₀_ne_zero hx) + (Nat.one_le_iff_ne_zero.mpr (mem_vars_iff_degreeOf_ne_zero.mp S.mem)) + +theorem αLT_constantCoeff : S.αLT.constantCoeff = 0 := by + rw [S.αLT_eq_nsmul_degLT, NatOrdinal.constantCoeff_nsmul, S.degLT_constantCoeff hx S.mem, + mul_zero] + +/-! ### `X_{B₀}` occurs linearly in `F` -/ + +omit hx in +/-- `(deg B₀)_{<β} = α_{<β}`, given that `X_{B₀}` occurs linearly in `F`. + +Linearity is the one step that ordinal arithmetic does not supply. It is the +linear-maximality argument, which each setting proves by its own truncation analysis, so it enters +here as a hypothesis. -/ +theorem degLT_B₀ (hD : degreeOf S.B₀ S.F = 1) : S.degLT S.B₀ = S.αLT := by + rw [S.αLT_eq_nsmul_degLT, hD, one_smul] + +omit hx in +theorem lowDegreePartEq_B₀ (hD : degreeOf S.B₀ S.F = 1) : S.LowDegreePartEq S.B₀ := S.degLT_B₀ hD + +omit hx in +theorem degHD_add (hD : degreeOf S.B₀ S.F = 1) : S.degHD + wt S.B₀ = α := by + have := S.hdegHD + rwa [hD, one_smul] at this + +omit hx in +/-- `H = ∂F/∂X_{B₀}` is homogeneous of degree `α ⊖ δ`. -/ +theorem H_hom (hD : degreeOf S.B₀ S.F = 1) : IsWeightedHomogeneous wt S.H S.degHD := + isWeightedHomogeneous_pderiv wt S.hom S.B₀ (S.degHD_add hD) + +omit hx in +theorem H_ne_zero : S.H ≠ 0 := pderiv_ne_zero_of_mem_vars S.mem + +omit hx in +/-- Every monomial of `F` contains `X_{B₀}` at most once. -/ +theorem apply_B₀_le_one {d : ι →₀ ℕ} (hD : degreeOf S.B₀ S.F = 1) (hd : d ∈ S.F.support) : + d S.B₀ ≤ 1 := by + have := monomial_le_degreeOf S.B₀ hd + rwa [hD] at this + +omit hx in +/-- Every variable `B` of `H` has `(deg B)_{<β} = 0`. -/ +theorem degLT_eq_zero_of_mem_vars_H {i : ι} (hD : degreeOf S.B₀ S.F = 1) (hi : i ∈ S.H.vars) : + S.degLT i = 0 := by + classical + obtain ⟨d', hd', hid'⟩ := (mem_vars_iff_mem_support i).mp hi + obtain ⟨d, hd, hdv, rfl⟩ := exists_mem_support_of_mem_support_pderiv hd' + have hd1 : d S.B₀ = 1 := + le_antisymm (S.apply_B₀_le_one hD hd) (Nat.one_le_iff_ne_zero.mpr hdv) + -- `i ≠ B₀`, since `B₀` occurs once + have hi0 : i ≠ S.B₀ := by + rintro rfl + rw [Finsupp.mem_support_iff, Finsupp.tsub_apply, Finsupp.single_eq_same, hd1] at hid' + exact hid' rfl + have hid : i ∈ d.support := by + rw [Finsupp.mem_support_iff] at hid' ⊢ + rw [Finsupp.tsub_apply, Finsupp.single_apply, ite_eq_right hi0.symm, Nat.sub_zero] at hid' + exact hid' + -- the parts below `β` of `d` add up to `α_{<β} = (deg B₀)_{<β}`, and `B₀` contributes all of it + have hsum := S.sum_degLT_eq_αLT hd + have hB₀d : S.B₀ ∈ d.support := Finsupp.mem_support_iff.mpr hdv + rw [← Finset.add_sum_erase _ _ hB₀d, hd1, one_smul, S.degLT_B₀ hD] at hsum + have hrest : ∑ j ∈ d.support.erase S.B₀, d j • S.degLT j = 0 := add_eq_left.mp hsum + rw [Finset.sum_eq_zero_iff_of_nonneg (fun j _ ↦ zero_le)] at hrest + have := hrest i (Finset.mem_erase.mpr ⟨hi0, hid⟩) + rcases (smul_eq_zero.mp this) with h | h + · exact absurd h (Finsupp.mem_support_iff.mp hid) + · exact h + +/-! ### Two factors with nonzero parts below `β` -/ + +omit hx in +/-- **The bound on a term of the remainder with two truncated factors.** If `d' · X_i · X_j` is a +monomial of `F`, then `(deg d')_{<β} ⊕ ρᵢ ⊕ ρⱼ ≤ λ₀` for all `ρᵢ < S.degLT i`, +`ρⱼ < S.degLT j`. -/ +theorem pair_bound {d' : ι →₀ ℕ} {i j : ι} + (hd : d' + Finsupp.single i 1 + Finsupp.single j 1 ∈ S.F.support) {ρᵢ ρⱼ : NatOrdinal} + (hρᵢ : ρᵢ < S.degLT i) (hρⱼ : ρⱼ < S.degLT j) : + NatOrdinal.partLT S.β (Finsupp.weight wt d') + ρᵢ + ρⱼ ≤ S.lam₀ := + MvPolynomial.pair_bound_of_forall_termDegree_lt S.hom S.lam₀_lt S.remainder_lt hd hρᵢ hρⱼ + +/-! ### Low-degree parts and the generators considered at a variable -/ + +/-- A variable has a proper low-degree part outside the algebraic bound when its part below the +cutoff is nonzero, differs from the low part of `α`, and does not precede the bound in the +algebraic order. -/ +def HasProperLowDegreePartNotAlgebraicLE (i : ι) : Prop := + i ∈ S.F.vars ∧ S.degLT i ≠ 0 ∧ ¬ S.LowDegreePartEq i ∧ ¬ S.LowDegreePartAlgebraicLE i + +omit hx in +theorem hasProperLowDegreePartNotAlgebraicLE_iff (i : ι) : + S.HasProperLowDegreePartNotAlgebraicLE i ↔ + i ∈ S.F.vars ∧ S.degLT i ≠ 0 ∧ ¬ S.LowDegreePartEq i ∧ + ¬ S.LowDegreePartAlgebraicLE i := Iff.rfl + +omit hx in +/-- For every variable `B` of `F`, `(deg B)_{<β} ≼ α_{<β}` in the algebraic order. -/ +theorem degLT_algebraicLE_αLT {i : ι} (hi : i ∈ S.F.vars) : + NatOrdinal.AlgebraicLE (S.degLT i) S.αLT := by + classical + obtain ⟨d, hd, hid⟩ := (mem_vars_iff_mem_support i).mp hi + have hsum := S.sum_degLT_eq_αLT hd + rw [← Finset.add_sum_erase _ _ hid] at hsum + have h1 : d i • S.degLT i = S.degLT i + (d i - 1) • S.degLT i := by + conv_lhs => rw [show d i = d i - 1 + 1 from + (Nat.sub_add_cancel (Nat.one_le_iff_ne_zero.mpr (Finsupp.mem_support_iff.mp hid))).symm] + rw [succ_nsmul'] + rw [h1, add_assoc] at hsum + rw [← hsum] + exact NatOrdinal.algebraicLE_add_right _ _ + +omit hx in +/-- A monomial containing `X_i` twice is `d' · X_i · X_i`. -/ +theorem exists_eq_add_single_add_single_self {d : ι →₀ ℕ} {i : ι} (h : 2 ≤ d i) : + ∃ d' : ι →₀ ℕ, d = d' + Finsupp.single i 1 + Finsupp.single i 1 := by + classical + refine ⟨d - Finsupp.single i 1 - Finsupp.single i 1, ?_⟩ + have h1 : Finsupp.single i 1 ≤ d - Finsupp.single i 1 := by + rw [Finsupp.single_le_iff, Finsupp.tsub_apply, Finsupp.single_eq_same] + omega + have h2 : Finsupp.single i 1 ≤ d := Finsupp.single_le_iff.mpr (by omega) + rw [tsub_add_cancel_of_le h1, tsub_add_cancel_of_le h2] + +omit hx in +/-- A monomial containing distinct variables `X_i` and `X_u` is `d' · X_i · X_u`. -/ +theorem exists_eq_add_single_add_single {d : ι →₀ ℕ} {i u : ι} (hi : i ∈ d.support) + (hu : u ∈ d.support) (hui : u ≠ i) : + ∃ d' : ι →₀ ℕ, d = d' + Finsupp.single i 1 + Finsupp.single u 1 := by + classical + refine ⟨d - Finsupp.single i 1 - Finsupp.single u 1, ?_⟩ + have hdi : 1 ≤ d i := Nat.one_le_iff_ne_zero.mpr (Finsupp.mem_support_iff.mp hi) + have hdu : 1 ≤ d u := Nat.one_le_iff_ne_zero.mpr (Finsupp.mem_support_iff.mp hu) + have h1 : Finsupp.single u 1 ≤ d - Finsupp.single i 1 := by + rw [Finsupp.single_le_iff, Finsupp.tsub_apply, Finsupp.single_apply, ite_eq_right (Ne.symm hui)] + omega + have h2 : Finsupp.single i 1 ≤ d := Finsupp.single_le_iff.mpr hdi + rw [add_right_comm, tsub_add_cancel_of_le h1, tsub_add_cancel_of_le h2] + +omit hx in +/-- For a monomial `d' · X_i · X_u` of `F`, its three low-degree parts sum to `α_{<β}`. -/ +theorem partLT_weight_add_degLT_add_degLT {d' : ι →₀ ℕ} {i u : ι} + (hd : d' + Finsupp.single i 1 + Finsupp.single u 1 ∈ S.F.support) : + NatOrdinal.partLT S.β (Finsupp.weight wt d') + S.degLT i + S.degLT u = S.αLT := by + rw [S.αLT_def, S.degLT_def, S.degLT_def] + exact MvPolynomial.partLT_weight_add_partLT_add_partLT S.hom hd + +/-- A variable whose proper low-degree part does not precede `λ₀` occurs with exponent `1` in every +monomial of `F` that contains it. -/ +theorem apply_eq_one_of_hasProperLowDegreePartNotAlgebraicLE {i : ι} + (hi : S.HasProperLowDegreePartNotAlgebraicLE i) {d : ι →₀ ℕ} + (hd : d ∈ S.F.support) (hid : i ∈ d.support) : d i = 1 := by + obtain ⟨hiv, ht, -, hdiff⟩ := hi + by_contra hne + have h2 : 2 ≤ d i := by + have := Nat.one_le_iff_ne_zero.mpr (Finsupp.mem_support_iff.mp hid) + omega + obtain ⟨d', rfl⟩ := exists_eq_add_single_add_single_self h2 + obtain ⟨e, he, hte⟩ := S.exists_leastTerm_degLT hx hiv ht + have hμ := S.partLT_weight_add_degLT_add_degLT hd + have hlμ : S.lam₀ < S.αLT := S.lam₀_lt + exact hdiff ((S.lowDegreePartAlgebraicLE_iff i).mpr + (NatOrdinal.algebraicLE_of_forall_add_add_le ht ht hte hte he (hμ ▸ hlμ) + fun ρ₁ ρ₂ hρ₁ hρ₂ ↦ S.pair_bound hd hρ₁ hρ₂)) + +/-- If a nonzero low-degree factor occurs with a variable whose proper low-degree part does not +precede `λ₀`, its last Cantor exponent is larger and detects the same high window in `λ₀` and +`α_{<β}`. -/ +theorem lt_and_partGE_eq_of_hasProperLowDegreePartNotAlgebraicLE {i : ι} + (hi : S.HasProperLowDegreePartNotAlgebraicLE i) {d : ι →₀ ℕ} + (hd : d ∈ S.F.support) (hid : i ∈ d.support) {u : ι} (hud : u ∈ d.support) + (hui : u ≠ i) (htu : S.degLT u ≠ 0) {eᵢ eᵤ : NatOrdinal} + (heᵢ : NatOrdinal.leastTerm (S.degLT i) = ω^ eᵢ) + (heᵤ : NatOrdinal.leastTerm (S.degLT u) = ω^ eᵤ) : + eᵢ < eᵤ ∧ NatOrdinal.partGE eᵤ S.lam₀ = NatOrdinal.partGE eᵤ S.αLT := by + obtain ⟨hiv, hti, -, hdiff⟩ := id hi + have hdiff' : ¬ NatOrdinal.AlgebraicLE (S.degLT i) S.lam₀ := + fun h ↦ hdiff ((S.lowDegreePartAlgebraicLE_iff i).mpr h) + have hlμ : S.lam₀ < S.αLT := S.lam₀_lt + have he0 : eᵢ ≠ 0 := by + obtain ⟨e', he', hte'⟩ := S.exists_leastTerm_degLT hx hiv hti + rw [heᵢ, NatOrdinal.wpow_inj] at hte' + exact fun h ↦ he' (hte' ▸ h) + obtain ⟨d', rfl⟩ := exists_eq_add_single_add_single hid hud hui + have hμ := S.partLT_weight_add_degLT_add_degLT hd + have hall : ∀ ρ₁ ρ₂ : NatOrdinal, ρ₁ < S.degLT i → ρ₂ < S.degLT u → + NatOrdinal.partLT S.β (Finsupp.weight wt d') + ρ₁ + ρ₂ ≤ S.lam₀ := + fun ρ₁ ρ₂ hρ₁ hρ₂ ↦ S.pair_bound hd hρ₁ hρ₂ + rw [← hμ] + exact NatOrdinal.lt_and_partGE_eq_of_not_algebraicLE hti htu heᵢ heᵤ he0 (hμ ▸ hlμ) hall + hdiff' + +omit hx in +/-- The last term of a finite sum of nonzero natural ordinals is the last term of a summand. -/ +theorem exists_leastTerm_sum_eq {ι' : Type*} {s : Finset ι'} (hs : s.Nonempty) + (f : ι' → NatOrdinal) (hf : ∀ i ∈ s, f i ≠ 0) : + ∃ i ∈ s, NatOrdinal.leastTerm (∑ j ∈ s, f j) = NatOrdinal.leastTerm (f i) := by + classical + induction hs using Finset.Nonempty.cons_induction with + | singleton a => exact ⟨a, Finset.mem_singleton_self a, by rw [Finset.sum_singleton]⟩ + | cons a s ha hs ih => + obtain ⟨i, hi, hi'⟩ := ih fun j hj ↦ hf j (Finset.mem_cons_of_mem hj) + have hsum : ∑ j ∈ s, f j ≠ 0 := by + have hle : f i ≤ ∑ j ∈ s, f j := Finset.single_le_sum (fun j _ ↦ zero_le) hi + exact (lt_of_lt_of_le (pos_iff_ne_zero.mpr (hf i (Finset.mem_cons_of_mem hi))) hle).ne' + rw [Finset.sum_cons, NatOrdinal.leastTerm_add (hf a (Finset.mem_cons_self a s)) hsum] + rcases min_choice (NatOrdinal.leastTerm (f a)) + (NatOrdinal.leastTerm (∑ j ∈ s, f j)) with h | h + · exact ⟨a, Finset.mem_cons_self a s, h⟩ + · exact ⟨i, Finset.mem_cons_of_mem hi, h.trans hi'⟩ + +/-- For a variable whose proper low-degree part does not precede `λ₀`, the last Cantor exponent of +its complementary low degree detects the same high window in `λ₀` and `α_{<β}`. -/ +theorem partGE_lam₀_eq_of_hasProperLowDegreePartNotAlgebraicLE {i : ι} + (hi : S.HasProperLowDegreePartNotAlgebraicLE i) {c ε : NatOrdinal} + (hc : c + S.degLT i = S.αLT) (hε : NatOrdinal.leastTerm c = ω^ ε) : + NatOrdinal.partGE ε S.lam₀ = NatOrdinal.partGE ε S.αLT := by + classical + obtain ⟨hiv, hti, htop, -⟩ := id hi + obtain ⟨d, hd, hid⟩ := (mem_vars_iff_mem_support i).mp hiv + have hd1 := S.apply_eq_one_of_hasProperLowDegreePartNotAlgebraicLE hx hi hd hid + have hsum := S.sum_degLT_eq_αLT hd + rw [← Finset.add_sum_erase _ _ hid, hd1, one_smul, add_comm] at hsum + have hc' : ∑ j ∈ d.support.erase i, d j • S.degLT j = c := + add_right_cancel (hsum.trans hc.symm) + set s := (d.support.erase i).filter fun j ↦ S.degLT j ≠ 0 with hsdef + have hcs : ∑ j ∈ s, d j • S.degLT j = c := by + rw [← hc', hsdef, Finset.sum_filter] + refine Finset.sum_congr rfl fun j _ ↦ ?_ + split_ifs with h + · rfl + · rw [not_not.mp h, smul_zero] + have hc0 : c ≠ 0 := by + rintro rfl + rw [zero_add] at hc + exact htop ((S.lowDegreePartEq_iff i).mpr hc) + have hs : s.Nonempty := by + rw [Finset.nonempty_iff_ne_empty] + intro h + rw [h, Finset.sum_empty] at hcs + exact hc0 hcs.symm + have hsne : ∀ j ∈ s, d j • S.degLT j ≠ 0 := fun j hj ↦ by + obtain ⟨hj, htj⟩ := Finset.mem_filter.mp hj + exact NatOrdinal.nsmul_ne_zero_of_ne_zero htj + (Nat.one_le_iff_ne_zero.mpr (Finsupp.mem_support_iff.mp (Finset.mem_erase.mp hj).2)) + obtain ⟨u, hus, hu⟩ := exists_leastTerm_sum_eq hs _ hsne + obtain ⟨hu', htu⟩ := Finset.mem_filter.mp hus + obtain ⟨hui, hud⟩ := Finset.mem_erase.mp hu' + rw [hcs, hε, NatOrdinal.leastTerm_nsmul htu + (Nat.one_le_iff_ne_zero.mpr (Finsupp.mem_support_iff.mp hud))] at hu + obtain ⟨eᵢ, -, heᵢ⟩ := S.exists_leastTerm_degLT hx hiv hti + exact + (S.lt_and_partGE_eq_of_hasProperLowDegreePartNotAlgebraicLE + hx hi hd hid hud hui htu heᵢ hu.symm).2 + +/-- A variable contributes to the derivative at `v'` when its low-degree part equals `α_{<β}`, or +when it has strictly larger degree and its proper low-degree part does not precede `λ₀`. -/ +def ContributesToPartialDerivativeAt (v' v : ι) : Prop := + v ∈ S.F.vars ∧ (S.LowDegreePartEq v ∨ (S.HasProperLowDegreePartNotAlgebraicLE v ∧ wt v' < wt v)) + +omit hx in +theorem contributesToPartialDerivativeAt_iff (v' v : ι) : + S.ContributesToPartialDerivativeAt v' v ↔ + v ∈ S.F.vars ∧ + (S.LowDegreePartEq v ∨ (S.HasProperLowDegreePartNotAlgebraicLE v ∧ wt v' < wt v)) := + Iff.rfl + +omit hx in +theorem finite_setOf_contributesToPartialDerivativeAt (v' : ι) : + Finite {v // S.ContributesToPartialDerivativeAt v' v} := + (S.F.vars.finite_toSet.subset fun v + (hv : S.ContributesToPartialDerivativeAt v' v) ↦ hv.1).to_subtype + +/-! ### The configuration does not occur -/ + +/-- The packaged polynomial and cutoff hypotheses imply the partial-derivative contradiction. -/ +theorem false_of_lowDegreePartAlgebraicLE_decomposition (hD : degreeOf S.B₀ S.F = 1) + (hpartials : ∀ v', v' ∈ S.F.vars → S.LowDegreePartAlgebraicLE v' → + ∃ (s : Finset ι) (U : ι → MvPolynomial ι K), + (∀ v ∈ s, S.ContributesToPartialDerivativeAt v' v) ∧ + (∀ v ∈ s, pderiv S.B₀ (U v) = 0) ∧ + pderiv v' S.F = ∑ v ∈ s, pderiv v S.F * U v) : + False := by + classical + refine MvPolynomial.false_of_pderiv_eq_sum_of_partLT_ne_zero (lam₀ := S.lam₀) S.hom + (le_of_eq hD) (S.degLT_B₀ hD) (S.H_hom hD) S.H_ne_zero S.degHD_ne_zero fun v' hv' hdiff ↦ ?_ + have hdiff' : S.LowDegreePartAlgebraicLE v' := hdiff + obtain ⟨s, U, hs, hU, heq⟩ := hpartials v' hv' hdiff' + refine ⟨s, U, fun v hv h0 ↦ ?_, hU, heq⟩ + rcases ((S.contributesToPartialDerivativeAt_iff v' v).mp (hs v hv)).2 with htop | ⟨hL, -⟩ + · exact S.αLT_ne_zero hx (by rw [← (S.lowDegreePartEq_iff v).mp htop]; exact h0) + · exact ((S.hasProperLowDegreePartNotAlgebraicLE_iff v).mp hL).2.1 h0 + +end LimitOrdinalRelationAtCutoff + +end HahnSeries.Germ + +end diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/LinearMaximal.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/LinearMaximal.lean new file mode 100644 index 0000000000..a93f23007f --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/LinearMaximal.lean @@ -0,0 +1,218 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.LimitOrdinalRelationAtCutoff +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.TruncationExpansion + +/-! +# Linear occurrence of a maximal variable + +The differentiated truncation expansion makes all sufficiently high components of the maximal +partial derivative vanish. If that variable occurred at least twice, ordinal separation would +put the cutoff strictly below the derivative's degree. A sufficiently late translated truncation +then has degree above the cutoff, contradicting the vanishing. +-/ + +universe u v w + +open scoped NatOrdinal Topology + +open Filter MvPolynomial HahnSeries HahnSeries.Nonpositive + +public noncomputable section + +namespace HahnSeries.Germ + +variable {G : Type u} {K : Type v} +variable [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [UniformSpace G] [IsUniformAddGroup G] [OrderTopology G] [Nontrivial G] [CompleteSpace G] + [Field K] [CharZero K] + +local notation "ν" => (cantorBendixsonDegreeValuation (G := G) (R := K)) + +variable {ι : Type w} {wt : ι → NatOrdinal.{u}} + {xg : ι → (cantorBendixsonDegreeValuation (G := G) (R := K)).AssociatedGraded} +variable {σ : LiftFamily wt xg} {α : NatOrdinal.{u}} + +namespace LimitOrdinalRelationAtCutoff + +variable (S : LimitOrdinalRelationAtCutoff σ α) +variable (hx : OrdinalGraded.IsMinimalSystem + (DirectSum.rangeLof K (cantorBendixsonDegreeValuation (G := G) (R := K)).Component) wt xg) + +include hx in +/-- Under the cutoff bounds used when the degree is a limit ordinal, a maximal variable occurs +linearly. -/ +@[blueprint "lem:linear-occurrence" + (phase := "Algebraic independence in graded rings") + (title := "Maximal-variable linearity for the Cantor--Bendixson degree") + (statement := /-- + Let $K$ be a field of characteristic zero and $G$ a nontrivial complete + ordered abelian group with compatible additive uniformity and order + topology. Let $x_i$ be a minimal homogeneous generating system for the + associated graded ring of the degree filtration, of weights $w_i$. Choose + series $b_i$ representing $x_i$ such that + \[ + \deg(b_i)\le w_i, + \qquad \deg(b_i^{\vert y}) rw [← NatOrdinal.partGE_add_partLT S.β h] + rw [hhLT] + exact add_lt_add_right hslt _ + have hτα : S.αGE + S.lam₀ ≤ τ + g := by + have htpart : t = NatOrdinal.partLT S.β g := by + rw [htdef, S.degLT_def, hgdef] + have hpart : S.αGE = NatOrdinal.partGE S.β h + NatOrdinal.partGE S.β g := by + have hcongr := congrArg (NatOrdinal.partGE S.β) hhg + rw [NatOrdinal.partGE_add] at hcongr + exact S.αGE_def.trans hcongr.symm + have heq : τ + g = S.αGE + (s + t) := by + calc + τ + g = (NatOrdinal.partGE S.β h + s) + + (NatOrdinal.partGE S.β g + NatOrdinal.partLT S.β g) := by + rw [hτdef, NatOrdinal.partGE_add_partLT] + _ = S.αGE + (s + t) := by rw [hpart, htpart]; abel + rw [heq] + exact add_le_add_right ((lt_add_one S.lam₀).le.trans hs) _ + obtain ⟨l, hl, htrunc⟩ := eventually_nhdsLT_iff_exists.mp S.truncation_lt + have hzero : ∀ γ : G, l < γ → γ < 0 → + componentsGE wt τ (σ.pol hx α + (translatedTruncLE γ (aeval σ.lift Θ))) = 0 := by + intro γ hγ hγ0 + have hτα' : NatOrdinal.partGE S.β α + S.lam₀ ≤ τ + wt S.B₀ := by + rwa [← S.αGE_def, ← hgdef] + have hmem := σ.componentsGE_pol_translatedTruncLE_aeval_pderiv_mem hx hσ hinj S.hom + S.vars_lt S.α₁_le S.α₁_le_α hγ0 (htrunc γ hγ hγ0) S.remainder_lt S.B₀ + (τ := τ) hτα' + rw [← hΘdef] at hmem + have hempty : IsEmpty {j : ι // j ∈ S.F.vars ∧ wt S.B₀ < wt j} := + ⟨fun j ↦ absurd j.2.2 (not_lt.mpr (S.max j.1 j.2.1))⟩ + rwa [Set.range_eq_empty, Ideal.span_empty, Ideal.mem_bot] at hmem + have hbound : τ < h + 0 := by simpa only [add_zero] using hτh + have hh0 : h ≠ 0 := ne_of_gt (zero_le.trans_lt hτh) + apply σ.false_of_forall_weightedTotalDegree_pol_add_lt hx hdegree hh0 + (Or.inl rfl) hbound hl + · intro γ hγ hγ0 hp0 + have hdeglt : weightedTotalDegree wt + (σ.pol hx α (translatedTruncLE γ (aeval σ.lift Θ))) < τ := by + obtain ⟨d, hd, hsup⟩ := Finset.exists_mem_eq_sup _ (support_nonempty.mpr hp0) + (Finsupp.weight wt) + rw [weightedTotalDegree, hsup] + by_contra hnot + have hle : τ ≤ Finsupp.weight wt d := not_lt.mp hnot + have hcoeff := congrArg (fun p : MvPolynomial ι K ↦ p.coeff d) (hzero γ hγ hγ0) + rw [coeff_componentsGE, ite_eq_left hle, AddMonoidAlgebra.coeff_zero] at hcoeff + exact mem_support_iff.mp hd hcoeff + simpa only [add_zero] using hdeglt + · exact hhα + +end LimitOrdinalRelationAtCutoff + +end HahnSeries.Germ + +end diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/LowerTruncationDegree.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/LowerTruncationDegree.lean new file mode 100644 index 0000000000..8522b33ee1 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/LowerTruncationDegree.lean @@ -0,0 +1,959 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MvPolynomial.ComponentsSpan +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.Lifts +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.PairBounds +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.Boundary +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.Convolution +import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.Separation +import LeanPool.ConwayRefinement.ConwayRefinement.Topology.Order.LeftNeighborhood + +/-! +# Lower translated truncations and homogeneous evaluations + +The condition studied here is that a nonpositive series has degree at most `m`, while every proper +translated truncation has degree strictly below `m`. It is preserved by constants, sums, products, +and powers: the finite convolution identity writes a proper truncation of a product as a finite sum +of translated truncation products, and in each summand at least one factor is proper, so every +summand drops. Consequently a weighted homogeneous polynomial evaluated at series satisfying the +corresponding bounds satisfies them at the weighted degree. These estimates are used for the +boundary terms and the cofactors associated with homogeneous ideal generators when the degree is +a limit ordinal. +-/ + +public noncomputable section + +open Set MvPolynomial +open scoped NatOrdinal + +universe u v w + +namespace HahnSeries.Nonpositive + +variable {G : Type u} {K : Type v} [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [UniformSpace G] [IsUniformAddGroup G] [OrderTopology G] [Nontrivial G] [CompleteSpace G] + [Field K] [CharZero K] + +local notation "ν" => (cantorBendixsonDegreeValuation (G := G) (R := K)) + +/-- The degree is at most `m`, and every proper translated truncation has degree strictly below +`m`. -/ +def HasLowerTruncationDegree (b : Nonpositive G K) (m : NatOrdinal.{u}) : Prop := + ν b ≤ m ∧ ∀ y : G, y < 0 → ν (translatedTruncLE y b) < m + +theorem hasLowerTruncationDegree_iff {b : Nonpositive G K} {m : NatOrdinal.{u}} : + HasLowerTruncationDegree b m ↔ + ν b ≤ m ∧ ∀ y : G, y < 0 → ν (translatedTruncLE y b) < m := + (Iff.rfl) + +theorem HasLowerTruncationDegree.degree_le {b : Nonpositive G K} {m : NatOrdinal.{u}} + (h : HasLowerTruncationDegree b m) : ν b ≤ m := + h.1 + +theorem HasLowerTruncationDegree.degree_translatedTruncLE_lt + {b : Nonpositive G K} {m : NatOrdinal.{u}} + (h : HasLowerTruncationDegree b m) {y : G} (hy : y < 0) : ν (translatedTruncLE y b) < m := + h.2 y hy + +/-- If a series satisfies the bounds at `m`, then every nonpositive translated truncation has +degree at most `m`. -/ +theorem HasLowerTruncationDegree.degree_translatedTruncLE_le + {b : Nonpositive G K} {m : NatOrdinal.{u}} + (h : HasLowerTruncationDegree b m) {y : G} (hy : y ≤ 0) : ν (translatedTruncLE y b) ≤ m := by + rcases eq_or_lt_of_le hy with hy0 | hyneg + · subst hy0 + rw [translatedTruncLE_zero] + exact h.1 + · exact (h.2 y hyneg).le + +/-- The zero series satisfies the bounds at every degree. -/ +theorem hasLowerTruncationDegree_zero (m : NatOrdinal.{u}) : + HasLowerTruncationDegree (0 : Nonpositive G K) m := by + constructor + · rw [(ν).map_zero] + exact bot_le + · intro y _ + rw [map_zero, (ν).map_zero] + exact WithBot.bot_lt_coe m + +/-- A constant series satisfies the bounds at degree zero. -/ +theorem hasLowerTruncationDegree_algebraMap (k : K) : + HasLowerTruncationDegree (algebraMap K (Nonpositive G K) k) 0 := by + constructor + · rw [algebraMap_apply] + exact degree_C_le k + · intro y hy + rw [degree_translatedTruncLE_eq, ite_eq_right ?_] + · exact WithBot.bot_lt_coe 0 + · intro hmem + have hclos := (mem_closedSupport _ _).mp hmem + have hsub : ((algebraMap K (Nonpositive G K) k : Nonpositive G K) : + HahnSeries G K).support ⊆ {0} := by + rw [algebraMap_apply, coe_C, HahnSeries.C_apply] + exact HahnSeries.support_single_subset + have hy0 : y ∈ ({0} : Set G) := + closure_minimal hsub isClosed_singleton hclos + exact hy.ne (mem_singleton_iff.mp hy0) + +/-- The identity series satisfies the bounds at degree zero. -/ +theorem hasLowerTruncationDegree_one : HasLowerTruncationDegree (1 : Nonpositive G K) 0 := by + have h := hasLowerTruncationDegree_algebraMap (G := G) (K := K) 1 + rwa [map_one] at h + +/-- Sums preserve the bounds at a common degree. -/ +theorem HasLowerTruncationDegree.add {a b : Nonpositive G K} {m : NatOrdinal.{u}} + (ha : HasLowerTruncationDegree a m) (hb : HasLowerTruncationDegree b m) : + HasLowerTruncationDegree (a + b) m := by + constructor + · exact ((ν).map_add_le_max a b).trans (max_le ha.1 hb.1) + · intro y hy + rw [map_add] + exact ((ν).map_add_le_max _ _).trans_lt (max_lt (ha.2 y hy) (hb.2 y hy)) + +/-- If two series satisfy the bounds at `m` and `n`, their product satisfies them at `m + n`: in +the finite convolution of a proper product truncation, every summand has a proper factor. -/ +theorem HasLowerTruncationDegree.mul {a b : Nonpositive G K} {m n p : NatOrdinal.{u}} + (hp : p = m + n) (ha : HasLowerTruncationDegree a m) + (hb : HasLowerTruncationDegree b n) : HasLowerTruncationDegree (a * b) p := by + subst hp + constructor + · exact ((ν).map_mul_le_add a b).trans (by + rw [WithBot.coe_add] + exact add_le_add ha.1 hb.1) + · intro y hy + classical + have herr : ν (translatedTruncLE y (a * b) - + ∑ q ∈ (a : HahnSeries G K).closedSupportAddFiber (b : HahnSeries G K) y, + translatedTruncLE q.1 a * translatedTruncLE q.2 b) = ⊥ := by + rw [cantorBendixsonDegreeValuation_apply, cantorBendixsonValuation_apply] + have hcoe : ((translatedTruncLE y (a * b) - + ∑ q ∈ (a : HahnSeries G K).closedSupportAddFiber (b : HahnSeries G K) y, + translatedTruncLE q.1 a * translatedTruncLE q.2 b : Nonpositive G K) : + HahnSeries G K) = + translate (-y) (truncLE y ((a : HahnSeries G K) * (b : HahnSeries G K))) - + ∑ q ∈ (a : HahnSeries G K).closedSupportAddFiber (b : HahnSeries G K) y, + translate (-q.1) (truncLE q.1 (a : HahnSeries G K)) * + translate (-q.2) (truncLE q.2 (b : HahnSeries G K)) := by + simp only [AddSubgroupClass.coe_sub, AddSubmonoidClass.coe_finsetSum, + Subring.coe_mul, coe_translatedTruncLE] + rw [hcoe, (a : HahnSeries G K).cantorBendixsonValue_convolution_error + (b : HahnSeries G K) y, NatOrdinal.of_zero, NatOrdinal.cantorDegree_zero] + have hsum : ν (∑ q ∈ (a : HahnSeries G K).closedSupportAddFiber (b : HahnSeries G K) y, + translatedTruncLE q.1 a * translatedTruncLE q.2 b) < (m + n : NatOrdinal) := by + apply (ν).map_sum_lt_of_forall_lt _ _ (WithBot.bot_lt_coe _) + intro q hq + obtain ⟨hq1, hq2, hqsum⟩ := ((a : HahnSeries G K).mem_closedSupportAddFiber + (b : HahnSeries G K) y q).mp hq + have hq1le : q.1 ≤ 0 := closure_minimal a.property isClosed_Iic + ((mem_closedSupport _ _).mp hq1) + have hq2le : q.2 ≤ 0 := closure_minimal b.property isClosed_Iic + ((mem_closedSupport _ _).mp hq2) + have hone : q.1 < 0 ∨ q.2 < 0 := by + rcases lt_or_eq_of_le hq1le with hq1neg | hq1zero + · exact Or.inl hq1neg + · refine Or.inr ?_ + have hq2y : q.2 = y := by + rw [← hqsum, hq1zero, zero_add] + exact hq2y ▸ hy + rcases hone with hq1neg | hq2neg + · rw [mul_comm] + exact degree_mul_lt_of_le_of_lt_of_separated (translatedTruncLE q.2 b) + (translatedTruncLE q.1 a) n m (m + n) (hb.degree_translatedTruncLE_le hq2le) + (ha.2 q.1 hq1neg) (fun θ hθ ↦ by + rw [add_comm m n] + exact add_lt_add_of_le_of_lt le_rfl hθ) + · exact degree_mul_lt_of_le_of_lt_of_separated (translatedTruncLE q.1 a) + (translatedTruncLE q.2 b) m n (m + n) (ha.degree_translatedTruncLE_le hq1le) + (hb.2 q.2 hq2neg) (fun θ hθ ↦ add_lt_add_of_le_of_lt le_rfl hθ) + have hsplit : translatedTruncLE y (a * b) = + (translatedTruncLE y (a * b) - + ∑ q ∈ (a : HahnSeries G K).closedSupportAddFiber (b : HahnSeries G K) y, + translatedTruncLE q.1 a * translatedTruncLE q.2 b) + + ∑ q ∈ (a : HahnSeries G K).closedSupportAddFiber (b : HahnSeries G K) y, + translatedTruncLE q.1 a * translatedTruncLE q.2 b := by + abel + rw [hsplit] + exact ((ν).map_add_le_max _ _).trans_lt + (max_lt (by rw [herr]; exact WithBot.bot_lt_coe _) hsum) + +/-- If a series satisfies the bounds at `m`, its `n`th power satisfies them at `n • m`. -/ +theorem HasLowerTruncationDegree.pow {b : Nonpositive G K} {m : NatOrdinal.{u}} + (hb : HasLowerTruncationDegree b m) (n : ℕ) : HasLowerTruncationDegree (b ^ n) (n • m) := by + induction n with + | zero => + rw [pow_zero, zero_smul] + exact hasLowerTruncationDegree_one + | succ n ih => + rw [pow_succ] + exact ih.mul (succ_nsmul m n) hb + +/-- A finite product satisfies the bounds at the sum of the assigned degrees. -/ +theorem hasLowerTruncationDegree_prod {ι' : Type w} {s : Finset ι'} {a : ι' → Nonpositive G K} + {m : ι' → NatOrdinal.{u}} (h : ∀ i ∈ s, HasLowerTruncationDegree (a i) (m i)) : + HasLowerTruncationDegree (∏ i ∈ s, a i) (∑ i ∈ s, m i) := by + classical + induction s using Finset.cons_induction with + | empty => + rw [Finset.prod_empty, Finset.sum_empty] + exact hasLowerTruncationDegree_one + | cons i s hi ih => + rw [Finset.prod_cons] + exact (h i (Finset.mem_cons_self i s)).mul (Finset.sum_cons hi) + (ih fun j hj ↦ h j (Finset.mem_cons_of_mem hj)) + +variable {ι : Type w} {wt : ι → NatOrdinal.{u}} {V : ι → Nonpositive G K} + +/-- A weighted homogeneous polynomial evaluated at series satisfying the assigned bounds also +satisfies the bounds at its weight. -/ +theorem hasLowerTruncationDegree_aeval (hV : ∀ i, HasLowerTruncationDegree (V i) (wt i)) + {F : MvPolynomial ι K} {β : NatOrdinal.{u}} (hF : IsWeightedHomogeneous wt F β) : + HasLowerTruncationDegree (aeval V F) β := by + classical + induction hF using IsWeightedHomogeneous.induction_on with + | zero => + rw [map_zero] + exact hasLowerTruncationDegree_zero β + | add p q hp hq ihp ihq => + rw [map_add] + exact ihp.add ihq + | monomial d r hr => + rw [← hr, aeval_monomial, Finsupp.weight_apply, Finsupp.sum, Finsupp.prod] + exact (hasLowerTruncationDegree_algebraMap r).mul (zero_add _).symm + (hasLowerTruncationDegree_prod fun i _ ↦ (hV i).pow (d i)) + +/-- **The uniform polynomial window.** If every homogeneous class of degree below `α` is a +homogeneous polynomial in the prescribed classes, then every proper translated truncation of the +evaluation of a weighted homogeneous polynomial of degree `β` at such representatives is +congruent, +modulo series bounded strictly below zero, to the evaluation of a polynomial all of whose +monomial weights are strictly below `β`. The bound is uniform in the cutoff: it does not degrade +as the cutoff approaches zero, and no cofinal sequence of cutoffs is chosen. -/ +theorem exists_forall_weight_lt_and_degree_translatedTruncLE_sub_aeval_eq_bot + (xg : ι → (cantorBendixsonDegreeValuation (G := G) (R := K)).AssociatedGraded) + (hVrep : ∀ i, Represents (V i) (wt i) (xg i)) + (hV : ∀ i, HasLowerTruncationDegree (V i) (wt i)) + (α : NatOrdinal.{u}) + (hgen : ∀ β : NatOrdinal.{u}, β < α → + ∀ y ∈ DirectSum.rangeLof K + (cantorBendixsonDegreeValuation (G := G) (R := K)).Component β, + ∃ F : MvPolynomial ι K, IsWeightedHomogeneous wt F β ∧ MvPolynomial.aeval xg F = y) + {F : MvPolynomial ι K} {β : NatOrdinal.{u}} (hF : IsWeightedHomogeneous wt F β) + (hβα : β < α) {γ : G} (hγ : γ < 0) : + ∃ F' : MvPolynomial ι K, (∀ d ∈ F'.support, (Finsupp.weight wt) d < β) ∧ + ν (translatedTruncLE γ (aeval V F) - aeval V F') = ⊥ := by + have hdrop : ν (translatedTruncLE γ (aeval V F)) < (β : WithBot NatOrdinal) := + (hasLowerTruncationDegree_aeval hV hF).degree_translatedTruncLE_lt hγ + obtain ⟨F', hF'd, -, hF'bot⟩ := + exists_forall_weight_lt_and_degree_sub_aeval_eq_bot xg hVrep α hgen + (translatedTruncLE γ (aeval V F)) (hdrop.trans (WithBot.coe_lt_coe.mpr hβα)) + refine ⟨F', fun d hd ↦ ?_, hF'bot⟩ + exact WithBot.coe_lt_coe.mp ((hF'd d hd).trans_lt hdrop) + +private theorem degree_mul_le_of_lt_of_lt_of_bound {p q : Nonpositive G K} + {σ₁ σ₂ B : NatOrdinal.{u}} (hp : ν p < (σ₁ : WithBot NatOrdinal)) + (hq : ν q < (σ₂ : WithBot NatOrdinal)) + (hB : ∀ θ₁ θ₂ : NatOrdinal.{u}, θ₁ < σ₁ → θ₂ < σ₂ → θ₁ + θ₂ ≤ B) : + ν (p * q) ≤ (B : WithBot NatOrdinal) := by + have hmul := (ν).map_mul_le_add p q + cases hp' : ν p using WithBot.recBotCoe with + | bot => + rw [hp', WithBot.bot_add] at hmul + exact hmul.trans bot_le + | coe θ₁ => + cases hq' : ν q using WithBot.recBotCoe with + | bot => + rw [hq', WithBot.add_bot] at hmul + exact hmul.trans bot_le + | coe θ₂ => + rw [hp', hq', ← WithBot.coe_add] at hmul + refine hmul.trans (WithBot.coe_le_coe.mpr (hB θ₁ θ₂ ?_ ?_)) + · rwa [hp', WithBot.coe_lt_coe] at hp + · rwa [hq', WithBot.coe_lt_coe] at hq + +/-- **The uniform two-truncation window.** For series satisfying the bounds at nonzero degrees, +the Leibniz remainder of a product -- the finite convolution with both boundary terms removed -- +is bounded by a single degree strictly below the product degree, uniformly in the cutoff. Every +interior term of the convolution truncates both factors, so its degree is a natural sum with both +summands lowered, and the ordinal two-summand bound is uniform. -/ +theorem exists_lt_forall_degree_leibnizRemainder_le + {a b : Nonpositive G K} {σ₁ σ₂ : NatOrdinal.{u}} + (ha : HasLowerTruncationDegree a σ₁) (hb : HasLowerTruncationDegree b σ₂) + (hσ₁ : σ₁ ≠ 0) (hσ₂ : σ₂ ≠ 0) : + ∃ μ' : NatOrdinal.{u}, μ' < σ₁ + σ₂ ∧ ∀ γ : G, γ < 0 → + ν (translatedTruncLE γ (a * b) - translatedTruncLE γ a * b - + a * translatedTruncLE γ b) ≤ (μ' : WithBot NatOrdinal) := by + classical + obtain ⟨e₁, he₁⟩ := NatOrdinal.exists_leastTerm_eq_wpow hσ₁ + obtain ⟨e₂, he₂⟩ := NatOrdinal.exists_leastTerm_eq_wpow hσ₂ + obtain ⟨B, hBlt, hBbound⟩ := + NatOrdinal.exists_lt_forall_add_add_le (O := 0) hσ₁ hσ₂ he₁ he₂ + have hBbound' : ∀ θ₁ θ₂ : NatOrdinal.{u}, θ₁ < σ₁ → θ₂ < σ₂ → θ₁ + θ₂ ≤ B := by + intro θ₁ θ₂ h₁ h₂ + have := hBbound θ₁ θ₂ h₁ h₂ + rwa [zero_add] at this + refine ⟨B, by rwa [zero_add] at hBlt, fun γ hγ ↦ ?_⟩ + have hremValue := HahnSeries.cantorBendixsonValue_leibnizRemainder_lt_of_forall + (a : HahnSeries G K) (b : HahnSeries G K) a.property b.property hγ + (ρ := (ω^ (B + 1)).val) (NatOrdinal.wpow_pos (B + 1)) (fun x y _ hx _ hy _ ↦ by + have hprod : ν (translatedTruncLE x a * translatedTruncLE y b) < + ((B + 1 : NatOrdinal) : WithBot NatOrdinal) := + (degree_mul_le_of_lt_of_lt_of_bound (ha.degree_translatedTruncLE_lt hx) + (hb.degree_translatedTruncLE_lt hy) hBbound').trans_lt + (WithBot.coe_lt_coe.mpr (lt_add_one B)) + rw [cantorBendixsonDegreeValuation_apply, cantorBendixsonValuation_apply, + NatOrdinal.cantorDegree_lt_coe_iff] at hprod + exact NatOrdinal.of.lt_iff_lt.mp + (by simpa only [coe_translatedTruncLE, Subring.coe_mul, NatOrdinal.of_val] using hprod)) + have hrem : ν (translatedTruncLE γ (a * b) - translatedTruncLE γ a * b - + a * translatedTruncLE γ b) < ((B + 1 : NatOrdinal) : WithBot NatOrdinal) := by + rw [cantorBendixsonDegreeValuation_apply, cantorBendixsonValuation_apply, + NatOrdinal.cantorDegree_lt_coe_iff] + change NatOrdinal.of (((translatedTruncLE γ (a * b) : Nonpositive G K) : HahnSeries G K) - + (translatedTruncLE γ a : Nonpositive G K) * b - + (a : HahnSeries G K) * translatedTruncLE γ b).cantorBendixsonValue < ω^ (B + 1) + exact NatOrdinal.of.lt_iff_lt.mpr (by + simpa only [coe_translatedTruncLE, Subring.coe_mul, NatOrdinal.val_wpow] using hremValue) + cases hv : ν (translatedTruncLE γ (a * b) - translatedTruncLE γ a * b - + a * translatedTruncLE γ b) using WithBot.recBotCoe with + | bot => exact bot_le + | coe d => + rw [hv, WithBot.coe_lt_coe] at hrem + exact WithBot.coe_le_coe.mpr (Order.lt_add_one_iff.mp hrem) + +/-! ### Congruence modulo series bounded strictly below zero -/ + +theorem degree_mul_eq_bot_of_left {a b : Nonpositive G K} (ha : ν a = ⊥) : ν (a * b) = ⊥ := by + have := (ν).map_mul_le_add a b + rw [ha, WithBot.bot_add] at this + exact le_bot_iff.mp this + +theorem degree_mul_eq_bot_of_right {a b : Nonpositive G K} (hb : ν b = ⊥) : ν (a * b) = ⊥ := by + have := (ν).map_mul_le_add a b + rw [hb, WithBot.add_bot] at this + exact le_bot_iff.mp this + +/-- Congruence modulo series bounded strictly below zero is multiplicative. -/ +theorem degree_sub_eq_bot_mul {a a' b b' : Nonpositive G K} + (ha : ν (a - a') = ⊥) (hb : ν (b - b') = ⊥) : ν (a * b - a' * b') = ⊥ := by + have hsplit : a * b - a' * b' = a * (b - b') + (a - a') * b' := by ring + rw [hsplit] + refine le_bot_iff.mp (((ν).map_add_le_max _ _).trans ?_) + rw [degree_mul_eq_bot_of_right hb, degree_mul_eq_bot_of_left ha, max_self] + +/-- Congruence modulo series bounded strictly below zero is additive over finite sums. -/ +theorem degree_sub_eq_bot_sum {ι' : Type w} (s : Finset ι') (f g : ι' → Nonpositive G K) + (h : ∀ i ∈ s, ν (f i - g i) = ⊥) : + ν ((∑ i ∈ s, f i) - ∑ i ∈ s, g i) = ⊥ := by + classical + rw [← Finset.sum_sub_distrib] + exact le_bot_iff.mp ((ν).map_sum_le_of_forall_le _ _ ⊥ fun i hi ↦ (h i hi).le) + +/-- The finite convolution identity in degree form: a translated truncation of a product agrees, +modulo series bounded strictly below zero, with the finite sum over the closed-support fiber of +the products of translated truncations. -/ +theorem degree_translatedTruncLE_mul_sub_sum_eq_bot (b d : Nonpositive G K) (γ : G) : + ν (translatedTruncLE γ (b * d) - + ∑ q ∈ (b : HahnSeries G K).closedSupportAddFiber (d : HahnSeries G K) γ, + translatedTruncLE q.1 b * translatedTruncLE q.2 d) = ⊥ := by + classical + rw [cantorBendixsonDegreeValuation_apply, cantorBendixsonValuation_apply] + have hcoe : ((translatedTruncLE γ (b * d) - + ∑ q ∈ (b : HahnSeries G K).closedSupportAddFiber (d : HahnSeries G K) γ, + translatedTruncLE q.1 b * translatedTruncLE q.2 d : Nonpositive G K) : + HahnSeries G K) = + translate (-γ) (truncLE γ ((b : HahnSeries G K) * (d : HahnSeries G K))) - + ∑ q ∈ (b : HahnSeries G K).closedSupportAddFiber (d : HahnSeries G K) γ, + translate (-q.1) (truncLE q.1 (b : HahnSeries G K)) * + translate (-q.2) (truncLE q.2 (d : HahnSeries G K)) := by + simp only [AddSubgroupClass.coe_sub, AddSubmonoidClass.coe_finsetSum, + Subring.coe_mul, coe_translatedTruncLE] + rw [hcoe, (b : HahnSeries G K).cantorBendixsonValue_convolution_error + (d : HahnSeries G K) γ, NatOrdinal.of_zero, NatOrdinal.cantorDegree_zero] + +variable {ι : Type w} {wt : ι → NatOrdinal.{u}} {V : ι → Nonpositive G K} + +/-- **The convolution polynomial identity.** If polynomials represent the translated truncations +of two factors at every cutoff, then the convolution sum of those polynomials over the +closed-support fiber represents the translated truncation of the product. No canonical choice of +representing polynomial is needed: any choices work, because congruence modulo series bounded +strictly below zero is a ring congruence. -/ +theorem degree_translatedTruncLE_mul_sub_aeval_sum_eq_bot + (b d : Nonpositive G K) (γ : G) + (Fb Fd : G → MvPolynomial ι K) + (hFb : ∀ x : G, ν (translatedTruncLE x b - aeval V (Fb x)) = ⊥) + (hFd : ∀ y : G, ν (translatedTruncLE y d - aeval V (Fd y)) = ⊥) : + ν (translatedTruncLE γ (b * d) - + aeval V (∑ q ∈ (b : HahnSeries G K).closedSupportAddFiber (d : HahnSeries G K) γ, + Fb q.1 * Fd q.2)) = ⊥ := by + classical + set S := (b : HahnSeries G K).closedSupportAddFiber (d : HahnSeries G K) γ with hS + have hterm : ∀ q ∈ S, ν (translatedTruncLE q.1 b * translatedTruncLE q.2 d - + aeval V (Fb q.1 * Fd q.2)) = ⊥ := by + intro q _ + rw [map_mul] + exact degree_sub_eq_bot_mul (hFb q.1) (hFd q.2) + have hsum : ν ((∑ q ∈ S, translatedTruncLE q.1 b * translatedTruncLE q.2 d) - + ∑ q ∈ S, aeval V (Fb q.1 * Fd q.2)) = ⊥ := + degree_sub_eq_bot_sum S _ _ hterm + have hsplit : translatedTruncLE γ (b * d) - + aeval V (∑ q ∈ S, Fb q.1 * Fd q.2) = + (translatedTruncLE γ (b * d) - + ∑ q ∈ S, translatedTruncLE q.1 b * translatedTruncLE q.2 d) + + ((∑ q ∈ S, translatedTruncLE q.1 b * translatedTruncLE q.2 d) - + ∑ q ∈ S, aeval V (Fb q.1 * Fd q.2)) := by + rw [map_sum] + abel + rw [hsplit] + refine le_bot_iff.mp (((ν).map_add_le_max _ _).trans ?_) + rw [degree_translatedTruncLE_mul_sub_sum_eq_bot b d γ, hsum, max_self] + +/-- **The power Leibniz rule with a uniform remainder.** For a series of nonzero lower-truncation +degree, +the translated truncation of a power differs from the expected single-truncation term by a +remainder bounded by a fixed degree strictly below the power degree, uniformly in the cutoff. +Each step of the induction uses the two-factor window and absorbs the previous remainder. -/ +theorem exists_lt_forall_degree_pow_leibniz_le {a : Nonpositive G K} {m : NatOrdinal.{u}} + (ha : HasLowerTruncationDegree a m) (hm : m ≠ 0) (n : ℕ) : + ∃ lam : NatOrdinal.{u}, lam < (n + 1) • m ∧ ∀ γ : G, γ < 0 → + ν (translatedTruncLE γ (a ^ (n + 1)) - + (n + 1 : ℕ) • (translatedTruncLE γ a * a ^ n)) ≤ (lam : WithBot NatOrdinal) := by + induction n with + | zero => + refine ⟨0, ?_, fun γ _ ↦ ?_⟩ + · simpa only [zero_add, one_smul] using pos_iff_ne_zero.mpr hm + · simp only [zero_add, pow_one, pow_zero, mul_one, one_smul, sub_self] + rw [(ν).map_zero] + exact bot_le + | succ n ih => + obtain ⟨lam, hlam, hbound⟩ := ih + have hpow : HasLowerTruncationDegree (a ^ (n + 1)) ((n + 1) • m) := ha.pow (n + 1) + have hne : ((n + 1) • m : NatOrdinal) ≠ 0 := by + intro h0 + have hle : m ≤ (n + 1) • m := by + have h1 : (1 : ℕ) • m ≤ (n + 1) • m := + nsmul_le_nsmul_left (zero_le (a := m)) (by omega) + simpa only [one_smul] using h1 + exact hm (le_antisymm (h0 ▸ hle) (zero_le (a := m))) + obtain ⟨B, hBlt, hBbound⟩ := + exists_lt_forall_degree_leibnizRemainder_le ha hpow hm hne + have hsucc : (n + 1 + 1) • m = m + (n + 1) • m := by + rw [succ_nsmul, add_comm] + refine ⟨max B (m + lam), ?_, fun γ hγ ↦ ?_⟩ + · rw [hsucc] + exact max_lt hBlt (add_lt_add_of_le_of_lt le_rfl hlam) + · have hsplit : translatedTruncLE γ (a ^ (n + 1 + 1)) - + (n + 1 + 1 : ℕ) • (translatedTruncLE γ a * a ^ (n + 1)) = + (translatedTruncLE γ (a * a ^ (n + 1)) - + translatedTruncLE γ a * a ^ (n + 1) - a * translatedTruncLE γ (a ^ (n + 1))) + + a * (translatedTruncLE γ (a ^ (n + 1)) - + (n + 1 : ℕ) • (translatedTruncLE γ a * a ^ n)) := by + have hpowsucc : a ^ (n + 1 + 1) = a * a ^ (n + 1) := by ring + have hmulsmul : a * ((n + 1 : ℕ) • (translatedTruncLE γ a * a ^ n)) = + (n + 1 : ℕ) • (translatedTruncLE γ a * a ^ (n + 1)) := by + rw [mul_smul_comm] + congr 1 + rw [pow_succ] + ring + rw [hpowsucc, mul_sub, hmulsmul, succ_nsmul, add_smul, one_smul] + abel + rw [hsplit] + refine ((ν).map_add_le_max _ _).trans (max_le ?_ ?_) + · exact (hBbound γ hγ).trans (WithBot.coe_le_coe.mpr (le_max_left _ _)) + · refine ((ν).map_mul_le_add a _).trans ?_ + refine (add_le_add ha.degree_le (hbound γ hγ)).trans ?_ + rw [← WithBot.coe_add] + exact WithBot.coe_le_coe.mpr (le_max_right _ _) + +/-! ### The monomial Leibniz expansion -/ + +open Finsupp in +/-- **The monomial Leibniz expansion with a uniform remainder.** The translated truncation of a +monomial evaluated at series satisfying the assigned bounds differs from the sum of its evaluated +partial derivatives against the truncated variables by a remainder bounded by a fixed degree +strictly below the monomial degree, uniformly in the cutoff. The induction peels one power block +at a time, using the two-factor window to separate it and the power rule inside it. -/ +theorem exists_lt_forall_degree_monomial_leibniz_le + (hV : ∀ i, HasLowerTruncationDegree (V i) (wt i)) (hwt : ∀ i, wt i ≠ 0) (t : Finset ι) : + ∀ d : ι →₀ ℕ, d ≠ 0 → d.support ⊆ t → + ∃ lam : NatOrdinal.{u}, lam < Finsupp.weight wt d ∧ ∀ γ : G, γ < 0 → + ν (translatedTruncLE γ (aeval V (MvPolynomial.monomial d (1 : K))) - + ∑ i ∈ t, aeval V (MvPolynomial.pderiv i (MvPolynomial.monomial d (1 : K))) * + translatedTruncLE γ (V i)) ≤ (lam : WithBot NatOrdinal) := by + classical + intro d + induction d using Finsupp.induction with + | zero => exact fun h ↦ absurd rfl h + | @single_add i b d' hi hb ih => + intro _ hsupp + have hit : i ∈ t := by + apply hsupp + rw [Finsupp.support_add_eq (by + rw [Finsupp.support_single i hb] + exact Finset.disjoint_singleton_left.mpr hi)] + exact Finset.mem_union_left _ (by + rw [Finsupp.support_single i hb] + exact Finset.mem_singleton_self i) + have hweight : Finsupp.weight wt (Finsupp.single i b + d') = + b • wt i + Finsupp.weight wt d' := by + rw [map_add, Finsupp.weight_single] + obtain ⟨n, rfl⟩ : ∃ n, b = n + 1 := ⟨b - 1, by omega⟩ + -- The monomial splits into a power block and the rest. + have hsplit : (MvPolynomial.monomial (Finsupp.single i (n + 1) + d') (1 : K)) = + MvPolynomial.X i ^ (n + 1) * MvPolynomial.monomial d' (1 : K) := + MvPolynomial.monomial_single_add + have hpowBounds : HasLowerTruncationDegree (V i ^ (n + 1)) ((n + 1) • wt i) := + (hV i).pow (n + 1) + have hpowne : ((n + 1) • wt i : NatOrdinal) ≠ 0 := by + intro h0 + have hle : wt i ≤ (n + 1) • wt i := by + have h1 : (1 : ℕ) • wt i ≤ (n + 1) • wt i := + nsmul_le_nsmul_left (zero_le (a := wt i)) (by omega) + simpa only [one_smul] using h1 + exact hwt i (le_antisymm (h0 ▸ hle) (zero_le (a := wt i))) + -- The evaluated partial derivatives of the power block. + have hpderivPow : ∀ j : ι, aeval V (MvPolynomial.pderiv j + (MvPolynomial.X i ^ (n + 1) : MvPolynomial ι K)) = + if j = i then (n + 1 : ℕ) • (V i ^ n) else 0 := by + intro j + rw [MvPolynomial.pderiv_pow, MvPolynomial.pderiv_X] + by_cases hji : j = i + · subst hji + rw [Pi.single_eq_same, ite_eq_left rfl, mul_one, map_mul, map_pow, MvPolynomial.aeval_X, + map_natCast, Nat.add_sub_cancel, nsmul_eq_mul] + · rw [Pi.single_eq_of_ne (Ne.symm hji), ite_eq_right hji, mul_zero, map_zero] + have hA : aeval V (MvPolynomial.monomial (Finsupp.single i (n + 1) + d') (1 : K)) = + V i ^ (n + 1) * aeval V (MvPolynomial.monomial d' (1 : K)) := by + rw [hsplit, map_mul, map_pow, MvPolynomial.aeval_X] + -- The evaluated partial derivatives of the whole monomial split by the Leibniz rule. + have hsum : ∀ γ : G, + ∑ j ∈ t, aeval V (MvPolynomial.pderiv j + (MvPolynomial.monomial (Finsupp.single i (n + 1) + d') (1 : K))) * + translatedTruncLE γ (V j) = + ((n + 1 : ℕ) • (V i ^ n) * aeval V (MvPolynomial.monomial d' (1 : K))) * + translatedTruncLE γ (V i) + + V i ^ (n + 1) * + ∑ j ∈ t, aeval V (MvPolynomial.pderiv j (MvPolynomial.monomial d' (1 : K))) * + translatedTruncLE γ (V j) := by + intro γ + have hterm : ∀ j ∈ t, aeval V (MvPolynomial.pderiv j + (MvPolynomial.monomial (Finsupp.single i (n + 1) + d') (1 : K))) * + translatedTruncLE γ (V j) = + (if j = i then ((n + 1 : ℕ) • (V i ^ n) * + aeval V (MvPolynomial.monomial d' (1 : K))) * translatedTruncLE γ (V i) else 0) + + V i ^ (n + 1) * (aeval V (MvPolynomial.pderiv j + (MvPolynomial.monomial d' (1 : K))) * translatedTruncLE γ (V j)) := by + intro j _ + have e1 : aeval V (MvPolynomial.pderiv j (MvPolynomial.X i ^ (n + 1)) * + MvPolynomial.monomial d' (1 : K)) = + (if j = i then (n + 1 : ℕ) • (V i ^ n) else 0) * + aeval V (MvPolynomial.monomial d' (1 : K)) := by + rw [map_mul, hpderivPow j] + have e2 : aeval V ((MvPolynomial.X i ^ (n + 1) : MvPolynomial ι K) * + MvPolynomial.pderiv j (MvPolynomial.monomial d' (1 : K))) = + V i ^ (n + 1) * aeval V (MvPolynomial.pderiv j + (MvPolynomial.monomial d' (1 : K))) := by + rw [map_mul, map_pow, MvPolynomial.aeval_X] + rw [hsplit, MvPolynomial.pderiv_mul, map_add, e1, e2, add_mul] + congr 1 + · by_cases hji : j = i + · rw [ite_eq_left hji, ite_eq_left hji, hji] + · rw [ite_eq_right hji, ite_eq_right hji, zero_mul, zero_mul] + · ring + rw [Finset.sum_congr rfl hterm, Finset.sum_add_distrib, ← Finset.mul_sum, + Finset.sum_ite_eq' t i (fun _ ↦ ((n + 1 : ℕ) • (V i ^ n) * + aeval V (MvPolynomial.monomial d' (1 : K))) * translatedTruncLE γ (V i)), + ite_eq_left hit] + obtain ⟨lamA, hlamA, hboundA⟩ := + exists_lt_forall_degree_pow_leibniz_le (hV i) (hwt i) n + by_cases hd0 : d' = 0 + · subst hd0 + refine ⟨lamA, ?_, fun γ hγ ↦ ?_⟩ + · rw [hweight, map_zero, add_zero] + exact hlamA + · have hone : aeval V (MvPolynomial.monomial (0 : ι →₀ ℕ) (1 : K)) = 1 := by + simp + have hinner : ∑ j ∈ t, aeval V (MvPolynomial.pderiv j + (MvPolynomial.monomial (0 : ι →₀ ℕ) (1 : K))) * translatedTruncLE γ (V j) = 0 := by + refine Finset.sum_eq_zero fun j _ ↦ ?_ + rw [MvPolynomial.monomial_zero', MvPolynomial.pderiv_C, map_zero, zero_mul] + have hgoal : translatedTruncLE γ + (aeval V (MvPolynomial.monomial (Finsupp.single i (n + 1) + 0) (1 : K))) - + ∑ j ∈ t, aeval V (MvPolynomial.pderiv j + (MvPolynomial.monomial (Finsupp.single i (n + 1) + 0) (1 : K))) * + translatedTruncLE γ (V j) = + translatedTruncLE γ (V i ^ (n + 1)) - + (n + 1 : ℕ) • (translatedTruncLE γ (V i) * V i ^ n) := by + rw [hsum γ, hA, hone, hinner] + ring_nf + rw [hgoal] + exact hboundA γ hγ + · obtain ⟨lamB, hlamB, hboundB⟩ := ih hd0 (fun j hj ↦ hsupp (by + rw [Finsupp.support_add_eq (by + rw [Finsupp.support_single i hb] + exact Finset.disjoint_singleton_left.mpr hi)] + exact Finset.mem_union_right _ hj)) + have hBhom : IsWeightedHomogeneous wt (MvPolynomial.monomial d' (1 : K)) + (Finsupp.weight wt d') := + MvPolynomial.isWeightedHomogeneous_monomial wt d' 1 rfl + have hBBounds : HasLowerTruncationDegree (aeval V (MvPolynomial.monomial d' (1 : K))) + (Finsupp.weight wt d') := hasLowerTruncationDegree_aeval hV hBhom + have hBne : Finsupp.weight wt d' ≠ 0 := by + intro h0 + obtain ⟨j, hj⟩ := Finsupp.support_nonempty_iff.mpr hd0 + have hle : wt j ≤ Finsupp.weight wt d' := + Finsupp.le_weight_of_ne_zero (w := wt) (fun _ ↦ zero_le (a := wt _)) + (Finsupp.mem_support_iff.mp hj) + exact hwt j (le_antisymm (h0 ▸ hle) (zero_le (a := wt j))) + obtain ⟨Bwin, hBwin, hboundWin⟩ := + exists_lt_forall_degree_leibnizRemainder_le hpowBounds hBBounds hpowne hBne + refine ⟨max Bwin (max (lamA + Finsupp.weight wt d') ((n + 1) • wt i + lamB)), ?_, + fun γ hγ ↦ ?_⟩ + · rw [hweight] + exact max_lt hBwin (max_lt (add_lt_add_of_lt_of_le hlamA le_rfl) + (add_lt_add_of_le_of_lt le_rfl hlamB)) + · have hdecomp : translatedTruncLE γ + (aeval V (MvPolynomial.monomial (Finsupp.single i (n + 1) + d') (1 : K))) - + ∑ j ∈ t, aeval V (MvPolynomial.pderiv j + (MvPolynomial.monomial (Finsupp.single i (n + 1) + d') (1 : K))) * + translatedTruncLE γ (V j) = + (translatedTruncLE γ (V i ^ (n + 1) * + aeval V (MvPolynomial.monomial d' (1 : K))) - + translatedTruncLE γ (V i ^ (n + 1)) * + aeval V (MvPolynomial.monomial d' (1 : K)) - + V i ^ (n + 1) * translatedTruncLE γ + (aeval V (MvPolynomial.monomial d' (1 : K)))) + + ((translatedTruncLE γ (V i ^ (n + 1)) - + (n + 1 : ℕ) • (translatedTruncLE γ (V i) * V i ^ n)) * + aeval V (MvPolynomial.monomial d' (1 : K)) + + V i ^ (n + 1) * (translatedTruncLE γ + (aeval V (MvPolynomial.monomial d' (1 : K))) - + ∑ j ∈ t, aeval V (MvPolynomial.pderiv j + (MvPolynomial.monomial d' (1 : K))) * translatedTruncLE γ (V j))) := by + rw [hsum γ, hA] + ring + rw [hdecomp] + refine ((ν).map_add_le_max _ _).trans (max_le ?_ ?_) + · exact (hboundWin γ hγ).trans (WithBot.coe_le_coe.mpr (le_max_left _ _)) + · refine ((ν).map_add_le_max _ _).trans (max_le ?_ ?_) + · refine ((ν).map_mul_le_add _ _).trans ?_ + refine (add_le_add (hboundA γ hγ) hBBounds.degree_le).trans ?_ + rw [← WithBot.coe_add] + exact WithBot.coe_le_coe.mpr ((le_max_left _ _).trans (le_max_right _ _)) + · refine ((ν).map_mul_le_add _ _).trans ?_ + refine (add_le_add hpowBounds.degree_le (hboundB γ hγ)).trans ?_ + rw [← WithBot.coe_add] + exact WithBot.coe_le_coe.mpr ((le_max_right _ _).trans (le_max_right _ _)) + +/-- Scaling by a coefficient does not raise the degree. -/ +theorem degree_smul_le (k : K) (b : Nonpositive G K) : ν (k • b) ≤ ν b := by + have hsm : k • b = C k * b := by + rw [← algebraMap_apply, Algebra.smul_def] + rw [hsm] + refine ((ν).map_mul_le_add _ _).trans ?_ + have h0 : ν (C k : Nonpositive G K) ≤ (0 : NatOrdinal) := degree_C_le k + calc ν (C k : Nonpositive G K) + ν b ≤ ((0 : NatOrdinal) : WithBot NatOrdinal) + ν b := + add_le_add h0 le_rfl + _ = ν b := by + cases hb : ν b using WithBot.recBotCoe with + | bot => rw [WithBot.add_bot] + | coe d => rw [← WithBot.coe_add, zero_add] + +open Finsupp in +/-- **The homogeneous Leibniz expansion with a uniform remainder.** For a weighted homogeneous +polynomial of nonzero degree evaluated at series satisfying the assigned bounds, the translated +truncation differs from the sum of the evaluated partial derivatives against the truncated +variables by a remainder bounded by a fixed degree strictly below the polynomial degree, +uniformly in the cutoff. Each monomial contributes its own bound and the finitely many bounds are +taken together. + +This is the analytic input required by the differentiated relation when the degree is a limit +ordinal. -/ +theorem exists_lt_forall_degree_homogeneous_leibniz_le + (hV : ∀ i, HasLowerTruncationDegree (V i) (wt i)) (hwt : ∀ i, wt i ≠ 0) (t : Finset ι) + {F : MvPolynomial ι K} {c : NatOrdinal.{u}} (hF : IsWeightedHomogeneous wt F c) + (hc : c ≠ 0) (hFt : ∀ d ∈ F.support, d.support ⊆ t) : + ∃ lam : NatOrdinal.{u}, lam < c ∧ ∀ γ : G, γ < 0 → + ν (translatedTruncLE γ (aeval V F) - + ∑ i ∈ t, aeval V (MvPolynomial.pderiv i F) * translatedTruncLE γ (V i)) ≤ + (lam : WithBot NatOrdinal) := by + classical + -- Each monomial of `F` has weight `c`, hence is nonzero, and contributes its own bound. + have hmon : ∀ d ∈ F.support, d ≠ 0 ∧ Finsupp.weight wt d = c := by + intro d hd + have hw : Finsupp.weight wt d = c := hF (MvPolynomial.mem_support_iff.mp hd) + refine ⟨fun h0 ↦ ?_, hw⟩ + rw [h0, map_zero] at hw + exact hc hw.symm + have hchoice : ∀ d ∈ F.support, ∃ lam : NatOrdinal.{u}, lam < c ∧ ∀ γ : G, γ < 0 → + ν (translatedTruncLE γ (aeval V (MvPolynomial.monomial d (1 : K))) - + ∑ i ∈ t, aeval V (MvPolynomial.pderiv i (MvPolynomial.monomial d (1 : K))) * + translatedTruncLE γ (V i)) ≤ (lam : WithBot NatOrdinal) := by + intro d hd + obtain ⟨hd0, hw⟩ := hmon d hd + obtain ⟨lam, hlam, hbound⟩ := + exists_lt_forall_degree_monomial_leibniz_le hV hwt t d hd0 (hFt d hd) + exact ⟨lam, hw ▸ hlam, hbound⟩ + choose lamOf hlamOf hboundOf using hchoice + set L : {d // d ∈ F.support} → NatOrdinal.{u} := fun d ↦ lamOf d.1 d.2 with hL + refine ⟨F.support.attach.sup L, ?_, fun γ hγ ↦ ?_⟩ + · refine Finset.sup_lt_iff (pos_iff_ne_zero.mpr hc) |>.mpr ?_ + intro d _ + exact hlamOf d.1 d.2 + · have hFsum : F = ∑ d ∈ F.support.attach, + MvPolynomial.C (F.coeff d.1) * MvPolynomial.monomial d.1 (1 : K) := by + conv_lhs => rw [F.as_sum] + rw [← Finset.sum_attach F.support + (fun d ↦ MvPolynomial.monomial d (F.coeff d))] + refine Finset.sum_congr rfl fun d _ ↦ ?_ + rw [MvPolynomial.C_mul_monomial, mul_one] + have hleft : translatedTruncLE γ (aeval V F) = + ∑ d ∈ F.support.attach, F.coeff d.1 • + translatedTruncLE γ (aeval V (MvPolynomial.monomial d.1 (1 : K))) := by + conv_lhs => rw [hFsum] + rw [map_sum, map_sum] + refine Finset.sum_congr rfl fun d _ ↦ ?_ + rw [map_mul, MvPolynomial.aeval_C, ← Algebra.smul_def, translatedTruncLE_smul] + have hright : ∑ i ∈ t, aeval V (MvPolynomial.pderiv i F) * translatedTruncLE γ (V i) = + ∑ d ∈ F.support.attach, F.coeff d.1 • + ∑ i ∈ t, aeval V (MvPolynomial.pderiv i + (MvPolynomial.monomial d.1 (1 : K))) * translatedTruncLE γ (V i) := by + have hinner : ∀ i ∈ t, aeval V (MvPolynomial.pderiv i F) * translatedTruncLE γ (V i) = + ∑ d ∈ F.support.attach, F.coeff d.1 • + (aeval V (MvPolynomial.pderiv i (MvPolynomial.monomial d.1 (1 : K))) * + translatedTruncLE γ (V i)) := by + intro i _ + conv_lhs => rw [hFsum] + rw [map_sum, map_sum, Finset.sum_mul] + refine Finset.sum_congr rfl fun d _ ↦ ?_ + rw [MvPolynomial.pderiv_C_mul, map_mul, MvPolynomial.aeval_C, ← Algebra.smul_def, + smul_mul_assoc] + rw [Finset.sum_congr rfl hinner, Finset.sum_comm] + exact Finset.sum_congr rfl fun d _ ↦ (Finset.smul_sum).symm + rw [hleft, hright, ← Finset.sum_sub_distrib] + have hcongr : ∀ d ∈ F.support.attach, + F.coeff d.1 • translatedTruncLE γ + (aeval V (MvPolynomial.monomial d.1 (1 : K))) - + F.coeff d.1 • ∑ i ∈ t, aeval V (MvPolynomial.pderiv i + (MvPolynomial.monomial d.1 (1 : K))) * translatedTruncLE γ (V i) = + F.coeff d.1 • + (translatedTruncLE γ (aeval V (MvPolynomial.monomial d.1 (1 : K))) - + ∑ i ∈ t, aeval V (MvPolynomial.pderiv i + (MvPolynomial.monomial d.1 (1 : K))) * translatedTruncLE γ (V i)) := + fun d _ ↦ (smul_sub _ _ _).symm + rw [Finset.sum_congr rfl hcongr] + refine (ν).map_sum_le_of_forall_le _ _ _ fun d _ ↦ ?_ + refine (degree_smul_le _ _).trans ?_ + exact (hboundOf d.1 d.2 γ hγ).trans + (WithBot.coe_le_coe.mpr (Finset.le_sup (f := L) (Finset.mem_attach _ d))) + +/-- **The differentiated relation.** If a weighted homogeneous polynomial of nonzero degree +evaluates to zero in the associated graded ring, then at all sufficiently late negative cutoffs +the sum of its evaluated partial derivatives against the truncated variables has degree bounded +by a single degree strictly below the polynomial degree. + +The evaluated relation itself has degree strictly below the polynomial degree, so its truncations +eventually drop below a fixed bound; the Leibniz expansion contributes its own fixed bound; and +the two combine. This is the analytic condition required for a relation whose degree is a limit +ordinal, at a chosen cutoff. -/ +theorem exists_lt_forall_degree_differentiatedRelation_le + (xg : ι → (cantorBendixsonDegreeValuation (G := G) (R := K)).AssociatedGraded) + (hVrep : ∀ i, Represents (V i) (wt i) (xg i)) + (hV : ∀ i, HasLowerTruncationDegree (V i) (wt i)) (hwt : ∀ i, wt i ≠ 0) (t : Finset ι) + {F : MvPolynomial ι K} {c : NatOrdinal.{u}} (hF : IsWeightedHomogeneous wt F c) + (hc : c ≠ 0) (hFt : ∀ d ∈ F.support, d.support ⊆ t) + (hrel : MvPolynomial.aeval xg F = 0) : + ∃ lam : NatOrdinal.{u}, lam < c ∧ ∃ l : G, l < 0 ∧ ∀ γ : G, l < γ → γ < 0 → + ν (∑ i ∈ t, aeval V (MvPolynomial.pderiv i F) * translatedTruncLE γ (V i)) ≤ + (lam : WithBot NatOrdinal) := by + classical + -- The evaluated relation is a lift of the zero class, hence has degree below `c`. + have hrep : Represents (aeval V F) c 0 := by + have h := represents_aeval xg hVrep hF + rwa [hrel] at h + obtain ⟨c₀, hc₀lt, hc₀le⟩ := exists_le_of_degree_lt hrep.degree_lt_of_eq_zero hc + -- Its truncations eventually drop below that degree. + obtain ⟨l, hl, hcut⟩ := eventually_nhdsLT_iff_exists.mp + (eventually_degree_translatedTruncLE_lt (aeval V F) c₀ hc₀le) + obtain ⟨lam₁, hlam₁, hbound₁⟩ := + exists_lt_forall_degree_homogeneous_leibniz_le hV hwt t hF hc hFt + refine ⟨max c₀ lam₁, max_lt hc₀lt hlam₁, l, hl, fun γ hlγ hγ0 ↦ ?_⟩ + have hsplit : ∑ i ∈ t, aeval V (MvPolynomial.pderiv i F) * translatedTruncLE γ (V i) = + translatedTruncLE γ (aeval V F) - + (translatedTruncLE γ (aeval V F) - + ∑ i ∈ t, aeval V (MvPolynomial.pderiv i F) * translatedTruncLE γ (V i)) := by + abel + rw [hsplit] + refine ((ν).map_sub_le_max _ _).trans (max_le ?_ ?_) + · exact (hcut γ hlγ hγ0).le.trans (WithBot.coe_le_coe.mpr (le_max_left _ _)) + · exact (hbound₁ γ hγ0).trans (WithBot.coe_le_coe.mpr (le_max_right _ _)) + +/-! ### Separation data for the cofactor construction -/ + +open Classical in +/-- **The differentiated relation in polynomial form.** Replacing each truncated variable by a +polynomial that represents it turns the differentiated relation into a statement about a single +evaluated polynomial: a combination of the partial derivatives of the relation, with cofactors +whose monomials have weight strictly below that of the variable they multiply, evaluates to +something of degree bounded strictly below the degree of the relation. + +The hypotheses on the representatives make every proper truncation drop strictly below its own +weight; the substitution is exact modulo series bounded strictly below zero, which the degree +bound absorbs. This is the form in which the relation can be compared against the graded pieces +of the polynomial ring. -/ +theorem exists_lt_forall_degree_polynomialDifferentiatedRelation_le + (xg : ι → (cantorBendixsonDegreeValuation (G := G) (R := K)).AssociatedGraded) + (hVrep : ∀ i, Represents (V i) (wt i) (xg i)) + (hV : ∀ i, HasLowerTruncationDegree (V i) (wt i)) (hwt : ∀ i, wt i ≠ 0) (t : Finset ι) + {F : MvPolynomial ι K} {c : NatOrdinal.{u}} (hF : IsWeightedHomogeneous wt F c) + (hc : c ≠ 0) (hFt : ∀ d ∈ F.support, d.support ⊆ t) + (hrel : MvPolynomial.aeval xg F = 0) (hwtle : ∀ i ∈ t, wt i ≤ c) + (hgen : ∀ β : NatOrdinal.{u}, β < c → ∀ y ∈ DirectSum.rangeLof K (ν).Component β, + ∃ P : MvPolynomial ι K, IsWeightedHomogeneous wt P β ∧ MvPolynomial.aeval xg P = y) : + ∃ lam : NatOrdinal.{u}, lam < c ∧ ∃ l : G, l < 0 ∧ ∀ γ : G, l < γ → γ < 0 → + ∃ P : ι → MvPolynomial ι K, + (∀ i ∈ t, ∀ d ∈ (P i).support, Finsupp.weight wt d < wt i) ∧ + ν (aeval V (∑ i ∈ t, MvPolynomial.pderiv i F * P i)) ≤ (lam : WithBot NatOrdinal) := by + classical + obtain ⟨lam, hlam, l, hl, hbound⟩ := + exists_lt_forall_degree_differentiatedRelation_le xg hVrep hV hwt t hF hc hFt hrel + refine ⟨lam, hlam, l, hl, fun γ hlγ hγ0 ↦ ?_⟩ + -- a polynomial representing each truncated variable, of weight below that variable's + have hrep : ∀ i ∈ t, ∃ Q : MvPolynomial ι K, + (∀ d ∈ Q.support, Finsupp.weight wt d < wt i) ∧ + ν (translatedTruncLE γ (V i) - aeval V Q) = ⊥ := by + intro i hi + have hlt : ν (translatedTruncLE γ (V i)) < (wt i : WithBot NatOrdinal) := + ((hasLowerTruncationDegree_iff).mp (hV i)).2 γ hγ0 + obtain ⟨Q, -, hQw, hQ⟩ := + exists_forall_weight_lt_and_degree_sub_aeval_eq_bot xg hVrep (wt i) + (fun β hβ y hy ↦ hgen β (lt_of_lt_of_le hβ (hwtle i hi)) y hy) + (translatedTruncLE γ (V i)) hlt + exact ⟨Q, hQw, hQ⟩ + choose Q hQw hQ using hrep + refine ⟨fun i ↦ if hi : i ∈ t then Q i hi else 0, fun i hi ↦ by + simpa only [dite_eq_left hi] using hQw i hi, ?_⟩ + -- substituting is exact modulo series bounded strictly below zero + have hsub : ν ((∑ i ∈ t, aeval V (MvPolynomial.pderiv i F) * translatedTruncLE γ (V i)) - + ∑ i ∈ t, aeval V (MvPolynomial.pderiv i F) * + aeval V (if hi : i ∈ t then Q i hi else 0)) = ⊥ := by + refine degree_sub_eq_bot_sum t _ _ fun i hi ↦ ?_ + rw [dite_eq_left hi] + exact degree_sub_eq_bot_mul (by simp) (hQ i hi) + have hval : aeval V (∑ i ∈ t, MvPolynomial.pderiv i F * + (if hi : i ∈ t then Q i hi else 0)) = + ∑ i ∈ t, aeval V (MvPolynomial.pderiv i F) * + aeval V (if hi : i ∈ t then Q i hi else 0) := by + rw [map_sum] + exact Finset.sum_congr rfl fun i _ ↦ map_mul _ _ _ + rw [hval] + have hsplit : (∑ i ∈ t, aeval V (MvPolynomial.pderiv i F) * + aeval V (if hi : i ∈ t then Q i hi else 0)) = + (∑ i ∈ t, aeval V (MvPolynomial.pderiv i F) * translatedTruncLE γ (V i)) - + ((∑ i ∈ t, aeval V (MvPolynomial.pderiv i F) * translatedTruncLE γ (V i)) - + ∑ i ∈ t, aeval V (MvPolynomial.pderiv i F) * + aeval V (if hi : i ∈ t then Q i hi else 0)) := by ring + rw [hsplit] + refine ((ν).map_sub_le_max _ _).trans ?_ + rw [hsub] + exact max_le (hbound γ hlγ hγ0) bot_le + +/-- **The syzygy carried by the differentiated relation.** With evaluation injective in every +degree below that of the relation, the combination of partial derivatives produced above has all +its monomials of weight bounded strictly below the degree of the relation: in every degree between +that bound and the relation's own, the partial derivatives of the relation satisfy a syzygy. + +The weight bound on the combination is forced by the shapes of its factors -- a monomial of +`∂F/∂X_i` weighs the relation's degree less that of `X_i`, and its cofactor weighs less than `X_i` +-- and injectivity then turns the degree bound on the evaluation into a bound on the weights +themselves. -/ +theorem exists_lt_forall_weight_le_polynomialSyzygy + (xg : ι → (cantorBendixsonDegreeValuation (G := G) (R := K)).AssociatedGraded) + (hVrep : ∀ i, Represents (V i) (wt i) (xg i)) + (hV : ∀ i, HasLowerTruncationDegree (V i) (wt i)) (hwt : ∀ i, wt i ≠ 0) (t : Finset ι) + {F : MvPolynomial ι K} {c : NatOrdinal.{u}} (hF : IsWeightedHomogeneous wt F c) + (hc : c ≠ 0) (hFt : ∀ d ∈ F.support, d.support ⊆ t) + (hrel : MvPolynomial.aeval xg F = 0) (hwtle : ∀ i ∈ t, wt i ≤ c) + (hgen : ∀ β : NatOrdinal.{u}, β < c → ∀ y ∈ DirectSum.rangeLof K (ν).Component β, + ∃ P : MvPolynomial ι K, IsWeightedHomogeneous wt P β ∧ MvPolynomial.aeval xg P = y) + (hinj : ∀ (β : NatOrdinal.{u}) (P : MvPolynomial ι K), β < c → + IsWeightedHomogeneous wt P β → MvPolynomial.aeval xg P = 0 → P = 0) : + ∃ lam : NatOrdinal.{u}, lam < c ∧ ∃ l : G, l < 0 ∧ ∀ γ : G, l < γ → γ < 0 → + ∃ P : ι → MvPolynomial ι K, + (∀ i ∈ t, ∀ d ∈ (P i).support, Finsupp.weight wt d < wt i) ∧ + ∀ d ∈ (∑ i ∈ t, MvPolynomial.pderiv i F * P i).support, + Finsupp.weight wt d ≤ lam := by + classical + obtain ⟨lam, hlam, l, hl, hb⟩ := + exists_lt_forall_degree_polynomialDifferentiatedRelation_le xg hVrep hV hwt t hF hc hFt hrel + hwtle hgen + refine ⟨lam, hlam, l, hl, fun γ hlγ hγ0 ↦ ?_⟩ + obtain ⟨P, hPw, hPd⟩ := hb γ hlγ hγ0 + refine ⟨P, hPw, fun d hd ↦ ?_⟩ + -- every monomial of the combination weighs less than the relation + have hSw : ∀ d ∈ (∑ i ∈ t, MvPolynomial.pderiv i F * P i).support, + Finsupp.weight wt d < c := by + intro d' hd' + obtain ⟨i, hi, hmem⟩ := Finset.mem_biUnion.mp (MvPolynomial.support_sum hd') + obtain ⟨d₁, hd₁, d₂, hd₂, rfl⟩ := Finset.mem_add.mp (MvPolynomial.support_mul _ _ hmem) + obtain ⟨e₀, he₀, hwe⟩ := MvPolynomial.exists_add_eq_weight_of_mem_support_pderiv wt hd₁ + rw [map_add] + calc Finsupp.weight wt d₁ + Finsupp.weight wt d₂ + < Finsupp.weight wt d₁ + wt i := by + exact add_lt_add_of_le_of_lt le_rfl (hPw i hi d₂ hd₂) + _ = Finsupp.weight wt e₀ := hwe + _ = c := hF (MvPolynomial.mem_support_iff.mp he₀) + have hle := forall_weight_le_degree_aeval_of_injective xg hVrep hinj hSw d hd + exact_mod_cast hle.trans hPd + +omit [CharZero K] in +/-- **Syzygy propagation.** At every degree above the bound the syzygy provides, the part of +`(∂F/∂X_{v'}) · P_{v'}` in that degree and higher lies in the ideal generated by the remaining +partial derivatives of the relation. + +The whole combination has no monomials that high, so the term at `v'` is the negative of the rest, +and the rest is visibly a combination of the other partial derivatives. Those are homogeneous, so +passing to the part in high degrees keeps the membership. -/ +theorem componentsGE_mul_mem_span_of_polynomialSyzygy + {t : Finset ι} {F : MvPolynomial ι K} {c : NatOrdinal.{u}} + (hF : IsWeightedHomogeneous wt F c) {P : ι → MvPolynomial ι K} {lam : NatOrdinal.{u}} + (hS : ∀ d ∈ (∑ i ∈ t, MvPolynomial.pderiv i F * P i).support, + Finsupp.weight wt d ≤ lam) + (v' : ι) (hv' : v' ∈ t) {τ : NatOrdinal.{u}} (hτ : lam < τ) : + MvPolynomial.componentsGE wt τ (MvPolynomial.pderiv v' F * P v') ∈ + Ideal.span (Set.range fun j : {j : ι // j ∈ t ∧ j ≠ v'} ↦ MvPolynomial.pderiv j.1 F) := by + classical + -- the whole combination has nothing that high + have hzero : MvPolynomial.componentsGE wt τ (∑ i ∈ t, MvPolynomial.pderiv i F * P i) = 0 := + MvPolynomial.componentsGE_eq_zero_of_forall_lt wt fun d hd ↦ (hS d hd).trans_lt hτ + rw [← Finset.add_sum_erase _ _ hv', MvPolynomial.componentsGE_add] at hzero + have hneg : MvPolynomial.componentsGE wt τ (MvPolynomial.pderiv v' F * P v') = + -MvPolynomial.componentsGE wt τ + (∑ i ∈ t.erase v', MvPolynomial.pderiv i F * P i) := by + rw [eq_neg_iff_add_eq_zero] + exact hzero + rw [hneg] + refine neg_mem ?_ + -- the remaining partial derivatives are homogeneous + have hhom : ∀ j : {j : ι // j ∈ t ∧ j ≠ v'}, + ∃ β, IsWeightedHomogeneous wt (MvPolynomial.pderiv j.1 F) β := by + intro j + by_cases h : ∃ β, β + wt j.1 = c + · obtain ⟨β, hβ⟩ := h + exact ⟨β, MvPolynomial.isWeightedHomogeneous_pderiv wt hF j.1 hβ⟩ + · exact ⟨0, by + rw [MvPolynomial.pderiv_eq_zero_of_isWeightedHomogeneous wt hF j.1 h] + exact MvPolynomial.isWeightedHomogeneous_zero _ _ _⟩ + choose β hβ using hhom + have : Finite {j : ι // j ∈ t ∧ j ≠ v'} := + (t.finite_toSet.subset fun j (hj : j ∈ t ∧ j ≠ v') ↦ hj.1).to_subtype + refine MvPolynomial.componentsGE_mem_span wt hβ ?_ τ + refine Ideal.sum_mem _ fun i hi ↦ ?_ + exact Ideal.mul_mem_right _ _ + (Ideal.subset_span ⟨⟨i, Finset.mem_of_mem_erase hi, Finset.ne_of_mem_erase hi⟩, rfl⟩) + +end HahnSeries.Nonpositive diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/Multiplication.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/Multiplication.lean new file mode 100644 index 0000000000..2ffa194aea --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/Multiplication.lean @@ -0,0 +1,187 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.CantorBendixsonValue +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.Additive +public import LeanPool.ConwayRefinement.ConwayRefinement.Topology.Order.CantorBendixsonAddition +public import Mathlib.RingTheory.HahnSeries.Multiplication +public import LeanPool.ConwayRefinement.CombinatorialGames.NatOrdinal.Pow + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Nonpositive + +/-! +# Upper bounds on Cantor–Bendixson values of Hahn products + +In an ordered uniform exponent group that is Cauchy complete, every derivative point of a product +support lifts to a pair in the closed factor supports with a sufficient natural sum of ranks. For +nonpositive supports the only pair summing to zero is `(0, 0)`, giving submultiplicativity of the +value. +This is an upper bound only; coefficient cancellation is not excluded. +-/ + +public noncomputable section + +open Set Topology TopologicalSpace +open scoped Pointwise + +universe u v + +namespace HahnSeries + +variable {G : Type u} {R : Type v} [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [UniformSpace G] [IsUniformAddGroup G] [OrderTopology G] [Nontrivial G] [CompleteSpace G] + +section Semiring + +variable [NonUnitalNonAssocSemiring R] + +/-- The closed support of a product is contained in the sum of the closed supports. -/ +theorem closedSupport_mul_subset_add (b d : HahnSeries G R) : + ((b * d).closedSupport : Set G) ⊆ (b.closedSupport : Set G) + (d.closedSupport : Set G) := by + rw [coe_closedSupport, coe_closedSupport, coe_closedSupport, + ← b.isPWO_support.closure_add_eq d.isPWO_support] + exact closure_mono support_mul_subset + +/-- A product derivative point lifts to closed-support summands whose ranks bound its stage. -/ +theorem exists_cantorBendixsonRank_add_ge_of_mem_mul_derivative (b d : HahnSeries G R) + (o : Ordinal.{u}) {z : G} (hz : z ∈ ((b * d).closedSupport.cantorBendixson o : Set G)) : + ∃ x ∈ b.closedSupport, ∃ y ∈ d.closedSupport, x + y = z ∧ + o ≤ (NatOrdinal.of (b.cantorBendixsonRank x) + + NatOrdinal.of (d.cantorBendixsonRank y)).val := by + let s : Closeds G := ⟨(b.closedSupport : Set G) + (d.closedSupport : Set G), + b.closedSupport_isPWO.isClosed_add d.closedSupport_isPWO + b.closedSupport.isClosed d.closedSupport.isClosed⟩ + have hsub : (b * d).closedSupport ≤ s := b.closedSupport_mul_subset_add d + have hm : z ∈ (s.cantorBendixson o : Set G) := + Closeds.cantorBendixson_mono hsub o hz + simpa only [cantorBendixsonRank_eq, Set.mem_ofPred_eq] using + b.closedSupport.cantorBendixson_add_subset d.closedSupport + b.closedSupport_isPWO d.closedSupport_isPWO o hm + +/-- For nonpositive supports, the product rank at zero is bounded by the natural sum. -/ +theorem cantorBendixsonRank_mul_le (b d : HahnSeries G R) + (hb : b.support ⊆ Iic 0) (hd : d.support ⊆ Iic 0) + (h : 0 ∈ closure (b * d).support) : + 0 ∈ closure b.support ∧ 0 ∈ closure d.support ∧ + (b * d).cantorBendixsonRank 0 ≤ + (NatOrdinal.of (b.cantorBendixsonRank 0) + + NatOrdinal.of (d.cantorBendixsonRank 0)).val := by + have hm := ((b * d).mem_support_derivative_iff 0 ((b * d).cantorBendixsonRank 0)).mpr ⟨h, le_rfl⟩ + obtain ⟨x, hx, y, hy, hxy, hr⟩ := b.exists_cantorBendixsonRank_add_ge_of_mem_mul_derivative d _ hm + have hx0 : x ≤ 0 := closure_minimal hb isClosed_Iic ((b.mem_closedSupport x).mp hx) + have hy0 : y ≤ 0 := closure_minimal hd isClosed_Iic ((d.mem_closedSupport y).mp hy) + have hxge : 0 ≤ x := by simpa only [hxy, add_zero] using add_le_add_right hy0 x + have hxe : x = 0 := hx0.antisymm hxge + subst x + have hye : y = 0 := by simpa only [zero_add] using hxy + subst y + exact ⟨(b.mem_closedSupport 0).mp hx, (d.mem_closedSupport 0).mp hy, hr⟩ + +/-- The value of a product with nonpositive supports is bounded by the natural product. -/ +@[blueprint "lem:cantor-bendixson-value-product-upper-bound" + (phase := "Cantor–Bendixson ranks of supports") + (title := "Product upper bound for the Cantor--Bendixson value") + (statement := /-- + Let $R$ be a semiring, not necessarily unital or associative, and let $G$ + be a nontrivial ordered abelian group equipped with a compatible additive + uniformity and its order topology. Assume that $G$ is Cauchy complete. If + $b,d\in R((G^{\le0}))$, then + \[ + V_{\mathrm{CB}}(bd) + \le V_{\mathrm{CB}}(b)\odot V_{\mathrm{CB}}(d), + \] + where $\odot$ is Hessenberg's natural product. + -/) + (proof := /-- + By \ref{def:cantor-bendixson-value}, the assertion is trivial if $0$ is + outside the closed support of $bd$; otherwise its value is $\omega$ to + the rank there. The closed support of $bd$ is contained in the sum of + the closed supports of $b$ and $d$. By + \ref{lem:cantor-bendixson-derivative-of-sum}, a point of rank $\alpha$ in + this sum lifts to $x$ and $y$ whose ranks have natural sum at least + $\alpha$. Nonpositivity and $x+y=0$ force $x=y=0$. Exponentiating the + resulting rank inequality by $\omega$ turns natural sum into natural + product and gives the bound. + -/)] +theorem cantorBendixsonValue_mul_le (b d : HahnSeries G R) + (hb : b.support ⊆ Iic 0) (hd : d.support ⊆ Iic 0) : + NatOrdinal.of (b * d).cantorBendixsonValue ≤ + NatOrdinal.of b.cantorBendixsonValue * NatOrdinal.of d.cantorBendixsonValue := by + by_cases hm : 0 ∈ closure (b * d).support + · obtain ⟨hb0, hd0, hr⟩ := b.cantorBendixsonRank_mul_le d hb hd hm + rw [(b * d).cantorBendixsonValue_of_mem hm, b.cantorBendixsonValue_of_mem hb0, + d.cantorBendixsonValue_of_mem hd0, NatOrdinal.of_omega0_opow, + NatOrdinal.of_omega0_opow, NatOrdinal.of_omega0_opow, ← NatOrdinal.wpow_add] + exact NatOrdinal.wpow_le_wpow.mpr hr + · rw [(b * d).cantorBendixsonValue_of_notMem hm] + exact zero_le + +end Semiring + +section Ring + +variable [Ring R] + +/-- A nonnegative integer power is bounded by the natural power of the original value. -/ +theorem cantorBendixsonValue_pow_le (b : HahnSeries G R) (hb : b.support ⊆ Iic 0) (m : ℕ) : + NatOrdinal.of (b ^ m).cantorBendixsonValue ≤ + NatOrdinal.of b.cantorBendixsonValue ^ m := by + induction m with + | zero => + rw [pow_zero, pow_zero] + have hf : (1 : HahnSeries G R).support.Finite := + (finite_singleton _).subset support_single_subset + by_cases hc : (1 : HahnSeries G R).coeff 0 = 0 + · rw [cantorBendixsonValue_of_finite_of_coeff_eq_zero _ hf hc] + exact zero_le + · rw [cantorBendixsonValue_of_finite_of_coeff_ne_zero _ hf hc] + exact le_rfl + | succ m ih => + rw [pow_succ, pow_succ] + exact (cantorBendixsonValue_mul_le _ _ + ((nonpositiveSubring G R).pow_mem hb m) hb).trans (mul_le_mul_left ih _) + + +omit [IsUniformAddGroup G] [Nontrivial G] [CompleteSpace G] in +/-- Multiplication by a nonzero ordinary scalar preserves the value. -/ +theorem cantorBendixsonValue_single_zero_mul [NoZeroDivisors R] + (b : HahnSeries G R) {a : R} (ha : a ≠ 0) : + (single 0 a * b).cantorBendixsonValue = b.cantorBendixsonValue := by + apply cantorBendixsonValue_congr_support + ext x + simp only [mem_support, coeff_single_zero_mul, mul_ne_zero_iff] + exact ⟨And.right, fun hx ↦ ⟨ha, hx⟩⟩ + +/-- A nonpositive factor of value zero makes the product value zero. -/ +theorem cantorBendixsonValue_mul_eq_zero_of_left (b d : HahnSeries G R) + (hb : b.support ⊆ Iic 0) (hd : d.support ⊆ Iic 0) + (hz : b.cantorBendixsonValue = 0) : (b * d).cantorBendixsonValue = 0 := by + have h := b.cantorBendixsonValue_mul_le d hb hd + rw [hz, NatOrdinal.of_zero, zero_mul] at h + exact le_antisymm h zero_le + +/-- A nonpositive factor of value one preserves the other factor's value. -/ +theorem cantorBendixsonValue_mul_of_left_eq_one [NoZeroDivisors R] (b d : HahnSeries G R) + (hb : b.support ⊆ Iic 0) (hd : d.support ⊆ Iic 0) + (hone : b.cantorBendixsonValue = 1) : + (b * d).cantorBendixsonValue = d.cantorBendixsonValue := by + obtain ⟨hcoeff, hz⟩ := (b.cantorBendixsonValue_eq_one_iff).mp hone + have he : (b - single 0 (b.coeff 0)).support ⊆ Iic (0 : G) := by + intro x hx + rcases support_sub_subset _ _ hx with hx | hx + · exact hb hx + · exact (support_single_subset hx : x = 0) ▸ le_rfl + have herr := (b - single 0 (b.coeff 0)).cantorBendixsonValue_mul_eq_zero_of_left d he hd hz + rw [sub_mul] at herr + exact (cantorBendixsonValue_eq_of_sub_value_eq_zero _ _ herr).trans + (d.cantorBendixsonValue_single_zero_mul hcoeff) + +end Ring + +end HahnSeries diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/Obligations.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/Obligations.lean new file mode 100644 index 0000000000..f354477655 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/Obligations.lean @@ -0,0 +1,131 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.DerivationIdeal +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.SyzygyIntegration +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.DirectSum.GermFinitePartIdeal +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.DirectSum.GermSuccessorStep + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint + +/-! +# Integration for the Cantor–Bendixson derivation + +The polynomiality induction over an arbitrary filter takes the integration statements as +hypotheses, because the abstract lowering-derivation interface does not supply them. The +Cantor–Bendixson setting proves them by integrating prescribed homogeneous classes along cofinal +cutoffs, and this file matches those statements to the forms required by the induction. + +The only work is the passage between a degree with positive finite part and its predecessor: the +induction states the hypothesis for a degree whose finite part is positive, and the +Cantor–Bendixson theorem states it for a successor. +-/ + +universe u v w + +open scoped NatOrdinal Topology + +open Filter MvPolynomial HahnSeries HahnSeries.Nonpositive + +public noncomputable section + +namespace HahnSeries.Nonpositive + +variable {G : Type u} {K : Type v} +variable [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [UniformSpace G] [IsUniformAddGroup G] [OrderTopology G] [Nontrivial G] [CompleteSpace G] + [Field K] [CharZero K] + +local notation "ν" => (cantorBendixsonDegreeValuation (G := G) (R := K)) + +/-- Ideal membership from the Cantor–Bendixson derivative germ. A degree with positive finite part +is a successor, so the predecessor form of the integration theorem applies. -/ +theorem hasIdealIntegration {ι' : Type w} [Finite ι'] {q : ι' → (ν).AssociatedGraded} + {c : ι' → NatOrdinal.{u}} + (hq : ∀ j, q j ∈ DirectSum.rangeLof K (ν).Component (c j)) + (hc : ∀ j, (c j).constantCoeff = 0) + {b : NatOrdinal.{u}} (hb : 0 < b.constantCoeff) + {y : (ν).AssociatedGraded} (hy : y ∈ DirectSum.rangeLof K (ν).Component b) + {f : G → (ν).AssociatedGraded} (hf : ∀ t, f t ∈ Ideal.span (Set.range q)) + (hD : cantorBendixsonGradedDerivation y = + (f : Filter.Germ (𝓝[<] (0 : G)) (ν).AssociatedGraded)) : + y ∈ Ideal.span (Set.range q) := by + have hsucc : b.removeNat 1 + 1 = b := by + have hstep := NatOrdinal.removeNat_add_natCast (a := b) (n := 1) hb + rwa [Nat.cast_one] at hstep + refine mem_span_of_cantorBendixsonGradedDerivation_eq_coe hq hc (δ := b.removeNat 1) ?_ hf hD + rwa [hsucc] + +/-- The ideal-integration theorem for the Cantor–Bendixson derivation. -/ +theorem hasIdealIntegrationDerivation {ι' : Type w} [Finite ι'] + {q : ι' → (ν).AssociatedGraded} {c : ι' → NatOrdinal.{u}} + (hq : ∀ j, q j ∈ DirectSum.rangeLof K (ν).Component (c j)) + (hc : ∀ j, (c j).constantCoeff = 0) + {b : NatOrdinal.{u}} (hb : 0 < b.constantCoeff) + {y : (ν).AssociatedGraded} (hy : y ∈ DirectSum.rangeLof K (ν).Component b) + {f : G → (ν).AssociatedGraded} (hf : ∀ t, f t ∈ Ideal.span (Set.range q)) + (hD : cantorBendixsonDerivation y = + (f : Filter.Germ (𝓝[<] (0 : G)) (ν).AssociatedGraded)) : + y ∈ Ideal.span (Set.range q) := + hasIdealIntegration hq hc hb hy hf (cantorBendixsonDerivation_apply y ▸ hD) + +/-- The successor step for the Cantor–Bendixson derivation. -/ +@[blueprint "lem:cantor-bendixson-successor-step" + (phase := "Algebraic independence in graded rings") + (title := "Successor step for Cantor--Bendixson homogeneous evaluation") + (statement := /-- + Let $K$ be a field of characteristic zero, and let $G$ be a nontrivial + ordered abelian group with compatible additive uniformity and order + topology. Assume that $G$ is Cauchy complete, and let $\nu$ be the + Cantor--Bendixson degree on + $K((G^{\le0}))$. Let $(x_i)$ be a minimal homogeneous generating system + of $\operatorname{gr}_\nu$, with weights $w_i$. If the coefficient of + $1=\omega^0$ in the Cantor normal form of $\delta$ is positive and + homogeneous evaluation at $(x_i)$ is injective in every degree below + $\delta$, then it is injective in degree $\delta$. + -/) + (proof := /-- + Suppose a nonzero weighted-homogeneous polynomial $F$ of degree $\delta$ + evaluates to zero. The chain rule for the Cantor--Bendixson lowering + derivation makes the derivative values of each relevant partial derivative + pointwise combinations of the distinguished partial derivatives. By + \ref{lem:successor-ideal-membership-from-cantor-bendixson-derivative}, + these pointwise combinations give ideal membership. Then + \ref{lem:weighted-euler-identity} places $F$ in that ideal. + + By \ref{lem:successor-relation-decomposition}, choose a + finite family of relevant partial derivatives. Their polynomial syzygies + have a finite generating family by \ref{lem:syzygies-finite-variables}. + Homogeneous ideal decomposition expresses every remaining partial + derivative in the chosen family, producing a homogeneous coefficient tuple + whose evaluation is a syzygy. + \ref{lem:simultaneous-cantor-bendixson-derivative-representatives} + supplies representatives that define a polynomial derivation. By + \ref{lem:polynomial-vector-field-lowers-degree}, it lowers the constant + Cantor coefficient. Apply the induction hypothesis to the resulting + lower-degree syzygies, express them in the finite generating family, and + choose homogeneous polynomial representatives by \ref{lem:generate}. + This expresses the evaluated cofactor tuple as a combination of evaluated + syzygies. Consequently its linear part lies in the square of the + positive-degree ideal, contradicting the defining independence of a + minimal homogeneous generating system modulo that square. + -/)] +theorem injectiveAt_of_forall_lt + {ι : Type w} {wt : ι → NatOrdinal.{u}} {x : ι → (ν).AssociatedGraded} + (hx : OrdinalGraded.IsMinimalSystem + (DirectSum.rangeLof K (ν).Component) wt x) + {δ : NatOrdinal.{u}} (hδ : 0 < δ.constantCoeff) + (hinj : ∀ β < δ, OrdinalGraded.InjectiveAt K wt x β) : + OrdinalGraded.InjectiveAt K wt x δ := + OrdinalGraded.injectiveAt_of_forall_lt hx + cantorBendixson_isLoweringDerivation cantorBendixson_gradeZeroScalars + hasIdealIntegrationDerivation + (fun lam ↦ hasSyzygyIntegration lam) hδ hinj + +end HahnSeries.Nonpositive + +end diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/OrderedIntervalCantorBendixson.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/OrderedIntervalCantorBendixson.lean new file mode 100644 index 0000000000..c282ce6e0b --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/OrderedIntervalCantorBendixson.lean @@ -0,0 +1,193 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.CantorBendixsonValue +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrderedIntervalSum +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Translation +public import LeanPool.ConwayRefinement.ConwayRefinement.Topology.Order.OrderedIntervalFamily + +/-! +# Cantor–Bendixson rank of sums over ordered intervals + +Hahn series supported on ordered disjoint intervals can be summed over a partially well-ordered +index of arbitrary cofinality. If the `o`-th derivative of every component is supported at its +center, the `o`-th derivative of the summed support is carried by the closure of the centers. +Local reconstruction then bounds its rank by one successor of `o`. +-/ + +open Set Filter Topology TopologicalSpace + +universe u v w + +public noncomputable section + +namespace HahnSeries + +variable {Γ : Type u} {R : Type v} {ι : Type w} + [LinearOrder Γ] [LinearOrder ι] + +section AddCommMonoid + +variable [AddCommMonoid R] + +/-- The Hahn sum of a family supported in ordered disjoint half-open intervals. -/ +def orderedIntervalHsum (hι : (Set.univ : Set ι).IsPWO) + (f : ι → R⟦Γ⟧) (cut center : ι → Γ) + (hsupp : ∀ i, (f i).support ⊆ Ioc (cut i) (center i)) + (hord : ∀ i j, i < j → center i ≤ cut j) : R⟦Γ⟧ := + (orderedIntervalSummableFamily hι f cut center hsupp hord).hsum + +/-- Ordered interval sums have exactly the union of their component supports. -/ +theorem support_orderedIntervalHsum (hι : (Set.univ : Set ι).IsPWO) + (f : ι → R⟦Γ⟧) (cut center : ι → Γ) + (hsupp : ∀ i, (f i).support ⊆ Ioc (cut i) (center i)) + (hord : ∀ i j, i < j → center i ≤ cut j) : + (orderedIntervalHsum hι f cut center hsupp hord).support = ⋃ i, (f i).support := by + exact support_hsum_orderedIntervalSummableFamily hι f cut center hsupp hord + +end AddCommMonoid + +section AddCommGroup + +variable [AddCommGroup Γ] [IsOrderedAddMonoid Γ] [AddCommGroup R] + +/-- At one interval center, translated weak truncation of the assembled sum differs from that +component only below the interval's left endpoint. -/ +theorem support_translatedTruncLE_orderedIntervalHsum_sub_component_subset + (hι : (Set.univ : Set ι).IsPWO) + (f : ι → R⟦Γ⟧) (cut center : ι → Γ) + (hsupp : ∀ i, (f i).support ⊆ Ioc (cut i) (center i)) + (hord : ∀ i j, i < j → center i ≤ cut j) (i : ι) : + (translate (-center i) (truncLE (center i) + (orderedIntervalHsum hι f cut center hsupp hord)) - + translate (-center i) (f i)).support ⊆ Iic (cut i - center i) := by + intro g hg + rw [mem_support] at hg + apply le_of_not_gt + intro hcgi + apply hg + let x := center i + g + have hx : g - -center i = x := by simp only [x, sub_neg_eq_add, add_comm] + have hxic : cut i < x := by + have h := (sub_lt_iff_lt_add).mp hcgi + simpa only [x, add_comm] using h + rw [coeff_sub, coeff_translate, coeff_translate, hx] + by_cases hg0 : g ≤ 0 + · have hxle : x ≤ center i := by + change center i + g ≤ center i + simpa only [add_zero, add_comm] using add_le_add_left hg0 (center i) + have hcoeff : + (orderedIntervalHsum hι f cut center hsupp hord).coeff x = (f i).coeff x := by + rw [orderedIntervalHsum, SummableFamily.coeff_hsum] + calc + ∑ᶠ j, ((orderedIntervalSummableFamily hι f cut center hsupp hord) j).coeff x = + ((orderedIntervalSummableFamily hι f cut center hsupp hord) i).coeff x := by + apply finsum_eq_single + intro j hji + rw [orderedIntervalSummableFamily_apply] + by_contra hj + have hxj : x ∈ (f j).support := (mem_support _ _).mpr hj + rcases lt_or_gt_of_ne hji with hji | hij + · exact (not_lt_of_ge (hsupp j hxj).2) + ((hord j i hji).trans_lt hxic) + · exact (not_lt_of_ge (hxle.trans (hord i j hij))) (hsupp j hxj).1 + _ = (f i).coeff x := congrArg (fun q : R⟦Γ⟧ ↦ q.coeff x) + (orderedIntervalSummableFamily_apply hι f cut center hsupp hord i) + rw [HahnSeries.coeff_truncLE, ite_eq_left hxle, hcoeff, sub_self] + · have hnot : ¬x ≤ center i := by + change ¬center i + g ≤ center i + exact not_le_of_gt (by + simpa only [add_zero, add_comm] using add_lt_add_left (not_le.mp hg0) (center i)) + have hfi : (f i).coeff x = 0 := by + by_contra h + exact hnot (hsupp i ((mem_support _ _).mpr h)).2 + rw [HahnSeries.coeff_truncLE, ite_eq_right hnot, hfi, sub_zero] + +end AddCommGroup + +variable [AddCommMonoid R] [TopologicalSpace Γ] [OrderTopology Γ] [NoMinOrder Γ] [NoMaxOrder Γ] + +/-- A derivative stage of an ordered interval sum is supported on the closure of its centers when +the same stage of every component is supported at its own center. -/ +theorem cantorBendixson_orderedIntervalHsum_subset_closure_range + (hι : (Set.univ : Set ι).IsPWO) + (f : ι → R⟦Γ⟧) (cut center : ι → Γ) + (hsupp : ∀ i, (f i).support ⊆ Ioc (cut i) (center i)) + (hord : ∀ i j, i < j → center i ≤ cut j) + (o : Ordinal.{u}) + (hstage : ∀ i, ((f i).closedSupport.cantorBendixson o : Set Γ) ⊆ {center i}) : + ((orderedIntervalHsum hι f cut center hsupp hord).closedSupport.cantorBendixson o : + Set Γ) ⊆ closure (Set.range center) := by + let b := orderedIntervalHsum hι f cut center hsupp hord + have hbsupp : b.support = ⋃ i, (f i).support := + support_orderedIntervalHsum hι f cut center hsupp hord + have hbclosed : b.closedSupport = + (⟨closure (⋃ i, (f i).support), isClosed_closure⟩ : Closeds Γ) := by + apply Closeds.ext + simp only [coe_closedSupport, hbsupp] + rfl + rw [hbclosed] + have hstage' : ∀ i, + ((⟨closure (f i).support, isClosed_closure⟩ : Closeds Γ).cantorBendixson o : + Set Γ) ⊆ {center i} := by + intro i + have he : (f i).closedSupport = + (⟨closure (f i).support, isClosed_closure⟩ : Closeds Γ) := by + apply Closeds.ext + simp only [coe_closedSupport] + rfl + rw [← he] + exact hstage i + exact cantorBendixson_ordered_iUnion_subset_closure_range + (fun i ↦ (f i).support) cut center hsupp hord o hstage' + +/-- If the `o`-th derivative of every interval component is supported at its center and the +centers are carried by the `r`-th derivative of `t`, then absence from the next two stages after +`r` bounds the Cantor–Bendixson rank of the assembled support by `o + 1`. -/ +theorem cantorBendixsonRank_orderedIntervalHsum_le_add_one_of_centerStage + (hι : (Set.univ : Set ι).IsPWO) + (f : ι → R⟦Γ⟧) (cut center : ι → Γ) + (hsupp : ∀ i, (f i).support ⊆ Ioc (cut i) (center i)) + (hord : ∀ i j, i < j → center i ≤ cut j) + (o r : Ordinal.{u}) (t : Closeds Γ) + (hstage : ∀ i, ((f i).closedSupport.cantorBendixson o : Set Γ) ⊆ {center i}) + (hcenter : closure (Set.range center) ⊆ (t.cantorBendixson r : Set Γ)) + (x : Γ) (ht : x ∉ (t.cantorBendixson ((r + 1) + 1) : Set Γ)) : + (orderedIntervalHsum hι f cut center hsupp hord).cantorBendixsonRank x ≤ o + 1 := by + let b := orderedIntervalHsum hι f cut center hsupp hord + have hderiv : (b.closedSupport.cantorBendixson o : Set Γ) ⊆ + closure (Set.range center) := by + exact cantorBendixson_orderedIntervalHsum_subset_closure_range + hι f cut center hsupp hord o hstage + change b.cantorBendixsonRank x ≤ o + 1 + rw [cantorBendixsonRank_eq] + apply TopologicalSpace.Closeds.cantorBendixsonRank_le_add_one_of_rankLevel_mapsTo_stage + b.closedSupport t b.closedSupport_isPWO isOpen_univ (by simp) o r + · intro y _ hy hyrank + apply hcenter + apply hderiv + exact (b.closedSupport.cantorBendixsonRank_eq_iff b.closedSupport_isPWO hy o).mp + hyrank |>.1 + · exact ht + +/-- If the `o`-th derivative of every interval component is supported at its center and the +centers are carried by the `o`-th derivative of `t`, then absence from the next two stages of `t` +bounds the Cantor–Bendixson rank of the assembled support by `o + 1`. -/ +theorem cantorBendixsonRank_orderedIntervalHsum_le_add_one + (hι : (Set.univ : Set ι).IsPWO) + (f : ι → R⟦Γ⟧) (cut center : ι → Γ) + (hsupp : ∀ i, (f i).support ⊆ Ioc (cut i) (center i)) + (hord : ∀ i j, i < j → center i ≤ cut j) + (o : Ordinal.{u}) (t : Closeds Γ) + (hstage : ∀ i, ((f i).closedSupport.cantorBendixson o : Set Γ) ⊆ {center i}) + (hcenter : closure (Set.range center) ⊆ (t.cantorBendixson o : Set Γ)) + (x : Γ) (ht : x ∉ (t.cantorBendixson ((o + 1) + 1) : Set Γ)) : + (orderedIntervalHsum hι f cut center hsupp hord).cantorBendixsonRank x ≤ o + 1 := by + exact cantorBendixsonRank_orderedIntervalHsum_le_add_one_of_centerStage + hι f cut center hsupp hord o o t hstage hcenter x ht + +end HahnSeries diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/PartialDerivativeIndices.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/PartialDerivativeIndices.lean new file mode 100644 index 0000000000..2b68c27087 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/PartialDerivativeIndices.lean @@ -0,0 +1,352 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.LimitOrdinalRelationAtCutoff +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MvPolynomial.ComponentsSpan +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.GradedRing.HomogeneousSpan + +/-! +# Indices contributing to a partial derivative + +This file contains the ordinal bookkeeping for partial derivatives at a variable whose part of the +degree below `β` precedes `λ₀` in the algebraic order. It identifies the cofactor degrees and proves +the inequalities needed by the well-founded cofactor construction. The arguments depend only on +the ordinal data of a relation whose degree is a limit ordinal and on the chosen cutoff, not on the +exponent group. +-/ + +universe u v w + +open scoped NatOrdinal Topology + +open MvPolynomial HahnSeries HahnSeries.Nonpositive DirectSum OrdinalGraded + +public noncomputable section + +namespace HahnSeries.Germ + +section Dropping + +variable {σ : Type*} {K : Type v} [Field K] (wt : σ → NatOrdinal) + +/-- If generators outside a subtype contribute to no degree in `[τ, h)`, they may be removed +from an ideal-membership statement for the components at or above `τ`. -/ +theorem componentsGE_mem_span_subtype {ι : Type w} [Finite ι] + {q : ι → MvPolynomial σ K} {c : ι → NatOrdinal} + (hq : ∀ j, IsWeightedHomogeneous wt (q j) (c j)) {P : MvPolynomial σ K} + {τ h : NatOrdinal} (hP : componentsGE wt τ P ∈ Ideal.span (Set.range q)) + (hdeg : ∀ d ∈ P.support, Finsupp.weight wt d < h) (A : ι → Prop) + (hdrop : ∀ j, ¬ A j → ∀ e, τ ≤ e → e < h → ¬ ∃ β, β + c j = e) : + componentsGE wt τ P ∈ Ideal.span (Set.range fun j : {j // A j} ↦ q j.1) := by + classical + cases nonempty_fintype ι + let := weightedGradedAlgebra K wt + have hdec : ∀ (R : MvPolynomial σ K) (e : NatOrdinal), + (DirectSum.decompose (weightedHomogeneousSubmodule K wt) R e : MvPolynomial σ K) = + weightedHomogeneousComponent wt e R := fun R e ↦ by + rw [← decompose'_apply] + rfl + rw [componentsGE_eq_sum_weightedHomogeneousComponent] + refine Ideal.sum_mem _ fun e he ↦ ?_ + obtain ⟨he', hτe⟩ := Finset.mem_filter.mp he + obtain ⟨d, hd, rfl⟩ := Finset.mem_image.mp he' + have heh : Finsupp.weight wt d < h := hdeg d hd + have hmem : weightedHomogeneousComponent wt (Finsupp.weight wt d) P ∈ + Ideal.span (Set.range q) := + weightedHomogeneousComponent_mem_span_of_componentsGE_mem wt hq hP hτe + obtain ⟨a, -, ha0, hsum⟩ := exists_decompose_eq_sum_mul_of_mem_span + (𝒜 := weightedHomogeneousSubmodule K wt) + (fun j ↦ (mem_weightedHomogeneousSubmodule _ _ _ _).mpr (hq j)) hmem + (Finsupp.weight wt d) + rw [hdec] at hsum + have hcomp : weightedHomogeneousComponent wt (Finsupp.weight wt d) + (weightedHomogeneousComponent wt (Finsupp.weight wt d) P) = + weightedHomogeneousComponent wt (Finsupp.weight wt d) P := by + rw [weightedHomogeneousComponent_of_mem + (weightedHomogeneousComponent_mem wt P _), ite_eq_left rfl] + rw [← hcomp, hsum] + rw [← Finset.sum_filter_add_sum_filter_not Finset.univ A] + have hzero : ∑ j ∈ Finset.univ.filter (fun j ↦ ¬ A j), q j * a j = 0 := + Finset.sum_eq_zero fun j hj ↦ by + rw [ha0 j (hdrop j (Finset.mem_filter.mp hj).2 _ hτe heh), mul_zero] + rw [hzero, add_zero] + exact Ideal.sum_mem _ fun j hj ↦ Ideal.mul_mem_right _ _ + (Ideal.subset_span ⟨⟨j, (Finset.mem_filter.mp hj).2⟩, rfl⟩) + +end Dropping + +variable {G : Type u} {K : Type v} +variable [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [UniformSpace G] [IsUniformAddGroup G] [OrderTopology G] [Nontrivial G] [CompleteSpace G] + [Field K] [CharZero K] + +local notation "ν" => (cantorBendixsonDegreeValuation (G := G) (R := K)) + +variable {ι : Type w} {wt : ι → NatOrdinal.{u}} + {xg : ι → (cantorBendixsonDegreeValuation (G := G) (R := K)).AssociatedGraded} +namespace LimitOrdinalRelationAtCutoff + +variable {σ : LiftFamily wt xg} {α : NatOrdinal.{u}} + (S : HahnSeries.Germ.LimitOrdinalRelationAtCutoff σ α) +variable (hx : OrdinalGraded.IsMinimalSystem + (DirectSum.rangeLof K (cantorBendixsonDegreeValuation (G := G) (R := K)).Component) wt xg) + +include S hx + +/-- The relation degree has zero finite part. -/ +theorem α_constantCoeff : α.constantCoeff = 0 := by + have h := congrArg NatOrdinal.constantCoeff S.hdegHD + rw [NatOrdinal.constantCoeff_add, NatOrdinal.constantCoeff_nsmul, S.vars_limit _ S.mem, + mul_zero, add_zero] at h + rw [← h, ← NatOrdinal.partGE_eq_self_of_forall_le S.degHD_terms, + NatOrdinal.constantCoeff_partGE (S.β_ne_zero hx)] + +section Cofactor + +variable {v : ι} (hv : v ∈ S.F.vars) {c : NatOrdinal} (hc : c + wt v = α) +include hv hc + +omit hx in +/-- The degree of the partial derivative at a variable of `F` is nonzero. -/ +theorem cdeg_ne_zero : c ≠ 0 := by + rintro rfl + rw [zero_add] at hc + exact (S.vars_lt v hv).ne hc + +omit hv in +/-- The degree of a partial derivative has zero finite part. -/ +theorem cdeg_constantCoeff : c.constantCoeff = 0 := by + have h := congrArg NatOrdinal.constantCoeff hc + rw [NatOrdinal.constantCoeff_add, S.α_constantCoeff hx] at h + omega + +omit hx hv in +/-- The partial derivative at `v` is homogeneous of complementary degree `c`. -/ +theorem pderiv_hom : IsWeightedHomogeneous wt (pderiv v S.F) c := + isWeightedHomogeneous_pderiv wt S.hom v hc + +omit hx hv in +theorem partLT_cdeg_add_degLT : NatOrdinal.partLT S.β c + S.degLT v = S.αLT := by + have e : NatOrdinal.partLT S.β α = NatOrdinal.partLT S.β (c + wt v) := congrArg _ hc.symm + rw [S.αLT_def, e, NatOrdinal.partLT_add, S.degLT_def] + +omit hx hv in +theorem partGE_cdeg_add : + NatOrdinal.partGE S.β c + NatOrdinal.partGE S.β (wt v) = S.αGE := by + have e : NatOrdinal.partGE S.β α = NatOrdinal.partGE S.β (c + wt v) := congrArg _ hc.symm + rw [S.αGE_def, e, NatOrdinal.partGE_add] + +omit hx hv in +theorem partLT_cdeg_eq_zero_of_lowDegreePartEq (htop : S.LowDegreePartEq v) : + NatOrdinal.partLT S.β c = 0 := by + have h := S.partLT_cdeg_add_degLT hc + rw [(S.lowDegreePartEq_iff v).mp htop] at h + exact add_eq_right.mp h + +omit hx hv in +theorem partGE_cdeg_eq_self_of_lowDegreePartEq (htop : S.LowDegreePartEq v) : + NatOrdinal.partGE S.β c = c := by + have h := NatOrdinal.partGE_add_partLT S.β c + rwa [S.partLT_cdeg_eq_zero_of_lowDegreePartEq hc htop, add_zero] at h + +omit hx hv in +theorem partLT_cdeg_ne_zero (htop : ¬ S.LowDegreePartEq v) : NatOrdinal.partLT S.β c ≠ 0 := by + intro h + have h' := S.partLT_cdeg_add_degLT hc + rw [h, zero_add] at h' + exact htop ((S.lowDegreePartEq_iff v).mpr h') + +end Cofactor + +section Tau + +variable {v' : ι} {h : NatOrdinal} (hh : h + wt v' = α) {lam' : NatOrdinal} + (hlam' : S.degLT v' + lam' = S.lam₀) +include hlam' + +omit hx in +theorem lam'_lt_wpow : lam' < ω^ S.β := + (le_add_of_nonneg_left zero_le).trans_lt (hlam' ▸ S.lam₀_lt_wpow) + +omit hx in +theorem partGE_τ (h : NatOrdinal) : + NatOrdinal.partGE S.β (NatOrdinal.partGE S.β h + lam') = + NatOrdinal.partGE S.β h := by + rw [NatOrdinal.partGE_add, NatOrdinal.partGE_partGE, + NatOrdinal.partGE_eq_zero_of_lt (S.lam'_lt_wpow hlam'), add_zero] + +omit hx in +theorem partLT_τ (h : NatOrdinal) : + NatOrdinal.partLT S.β (NatOrdinal.partGE S.β h + lam') = lam' := by + have h' := NatOrdinal.partGE_add_partLT S.β (NatOrdinal.partGE S.β h + lam') + rw [S.partGE_τ hlam' h] at h' + exact add_left_cancel h' + +include hh + +omit hx hlam' in +theorem partLT_h_add_degLT : NatOrdinal.partLT S.β h + S.degLT v' = S.αLT := + S.partLT_cdeg_add_degLT hh + +omit hx in +theorem lam'_lt_partLT_h : lam' < NatOrdinal.partLT S.β h := by + have h1 := S.partLT_h_add_degLT hh + have h2 : S.degLT v' + lam' < S.degLT v' + NatOrdinal.partLT S.β h := by + rw [hlam', add_comm _ (NatOrdinal.partLT S.β h), h1] + rw [S.αLT_def] + exact S.lam₀_lt + exact lt_of_add_lt_add_left h2 + +/-- The cutoff attached to `v'` lies at least two successor steps below its partial degree. -/ +theorem τ_add_one_lt : NatOrdinal.partGE S.β h + lam' + 1 < h := by + have hlt := S.lam'_lt_partLT_h hh hlam' + have hcc : (NatOrdinal.partLT S.β h).constantCoeff = 0 := by + rw [NatOrdinal.constantCoeff_partLT (S.β_ne_zero hx)] + have h' := congrArg NatOrdinal.constantCoeff hh + rw [NatOrdinal.constantCoeff_add, S.α_constantCoeff hx] at h' + omega + have h1 : lam' + 1 < NatOrdinal.partLT S.β h := by + refine lt_of_le_of_ne (Order.add_one_le_of_lt hlt) fun heq ↦ ?_ + have h' := congrArg NatOrdinal.constantCoeff heq + rw [hcc, show lam' + 1 = lam' + ((1 : ℕ) : NatOrdinal) by rw [Nat.cast_one], + NatOrdinal.constantCoeff_add_natCast] at h' + omega + conv_rhs => rw [← NatOrdinal.partGE_add_partLT S.β h] + rw [add_assoc] + exact add_lt_add_right h1 _ + +omit hx in +theorem αGE_add_lam₀_eq : S.αGE + S.lam₀ = NatOrdinal.partGE S.β h + lam' + wt v' := by + have e : NatOrdinal.partGE S.β α = NatOrdinal.partGE S.β (h + wt v') := + congrArg _ hh.symm + rw [← hlam', S.αGE_def, e, NatOrdinal.partGE_add] + conv_rhs => rw [← S.partGE_add_degLT v'] + abel + +omit hx hh in +theorem partGE_eq_of_τ_le {e : NatOrdinal} + (hτe : NatOrdinal.partGE S.β h + lam' ≤ e) (heh : e < h) : + NatOrdinal.partGE S.β e = NatOrdinal.partGE S.β h := + le_antisymm (NatOrdinal.partGE_mono heh.le) (by + have h' := NatOrdinal.partGE_mono (β := S.β) hτe + rwa [S.partGE_τ hlam' h] at h') + +end Tau + +section PartialDerivativeIndices + +variable {v : ι} (hv : v ∈ S.F.vars) {c : NatOrdinal} (hc : c + wt v = α) + {v' : ι} {h : NatOrdinal} (hh : h + wt v' = α) {lam' : NatOrdinal} + (hlam' : S.degLT v' + lam' = S.lam₀) +include hv hc hh hlam' + +omit hx hh hlam' in +theorem partGE_le_τ_of_lowDegreePartEq (htop : S.LowDegreePartEq v) {ε : NatOrdinal} + (hε : NatOrdinal.leastTerm c = ω^ ε) (h : NatOrdinal) : + NatOrdinal.partGE ε h ≤ NatOrdinal.partGE S.β h + lam' := by + have hβε : S.β ≤ ε := by + have h1 := NatOrdinal.wpow_le_leastTerm_partGE (β := S.β) (a := c) + (by rw [S.partGE_cdeg_eq_self_of_lowDegreePartEq hc htop]; exact S.cdeg_ne_zero hv hc) + rw [S.partGE_cdeg_eq_self_of_lowDegreePartEq hc htop, hε, NatOrdinal.wpow_le_wpow] at h1 + exact h1 + exact (NatOrdinal.partGE_le_partGE_of_le hβε h).trans (le_add_of_nonneg_right zero_le) + +omit hv in +theorem partGE_le_τ_of_hasProperLowDegreePartNotAlgebraicLE + (hL : S.HasProperLowDegreePartNotAlgebraicLE v) {ε : NatOrdinal} + (hε : NatOrdinal.leastTerm (NatOrdinal.partLT S.β c) = ω^ ε) : + NatOrdinal.partGE ε h ≤ NatOrdinal.partGE S.β h + lam' := by + have hεβ : ε ≤ S.β := by + have h1 := NatOrdinal.leastTerm_le + (S.partLT_cdeg_ne_zero hc ((S.hasProperLowDegreePartNotAlgebraicLE_iff v).mp hL).2.2.1) + rw [hε] at h1 + exact (NatOrdinal.wpow_lt_wpow.mp (h1.trans_lt (NatOrdinal.partLT_lt _ _))).le + have h5 := S.partGE_lam₀_eq_of_hasProperLowDegreePartNotAlgebraicLE + hx hL (S.partLT_cdeg_add_degLT hc) hε + have hlamε : NatOrdinal.partGE ε lam' = + NatOrdinal.partGE ε (NatOrdinal.partLT S.β h) := by + have e1 := congrArg (NatOrdinal.partGE ε) hlam' + have e2 := congrArg (NatOrdinal.partGE ε) (S.partLT_h_add_degLT hh) + rw [NatOrdinal.partGE_add] at e1 e2 + rw [h5, ← e2, add_comm (NatOrdinal.partGE ε (NatOrdinal.partLT S.β h))] at e1 + exact add_left_cancel e1 + calc + NatOrdinal.partGE ε h = NatOrdinal.partGE ε (NatOrdinal.partGE S.β h) + + NatOrdinal.partGE ε (NatOrdinal.partLT S.β h) := by + conv_lhs => rw [← NatOrdinal.partGE_add_partLT S.β h] + rw [NatOrdinal.partGE_add] + _ = NatOrdinal.partGE S.β h + NatOrdinal.partGE ε lam' := by + rw [NatOrdinal.partGE_partGE_of_ge hεβ, hlamε] + _ ≤ NatOrdinal.partGE S.β h + lam' := add_le_add_right (NatOrdinal.partGE_le _ _) _ + +omit hx hv hh in +theorem not_algebraicLE_of_lowDegreePartEq_of_not (htop : S.LowDegreePartEq v) + (hdrop : ¬ NatOrdinal.AlgebraicLE c h) {e : NatOrdinal} + (hτe : NatOrdinal.partGE S.β h + lam' ≤ e) (heh : e < h) : + ¬ NatOrdinal.AlgebraicLE c e := by + intro hce + apply hdrop + have h1 := hce.partGE S.β + rw [S.partGE_eq_of_τ_le hlam' hτe heh, + S.partGE_cdeg_eq_self_of_lowDegreePartEq hc htop] at h1 + exact h1.trans (NatOrdinal.algebraicLE_partGE _ _) + +omit hv in +theorem not_algebraicLE_of_hasProperLowDegreePartNotAlgebraicLE_of_not + (hL : S.HasProperLowDegreePartNotAlgebraicLE v) + (hdrop : ¬ NatOrdinal.AlgebraicLE c h) {e : NatOrdinal} + (hτe : NatOrdinal.partGE S.β h + lam' ≤ e) (heh : e < h) : + ¬ NatOrdinal.AlgebraicLE c e := by + intro hce + apply hdrop + have hGE := S.partGE_eq_of_τ_le hlam' hτe heh + have h1 : NatOrdinal.AlgebraicLE (NatOrdinal.partGE S.β c) + (NatOrdinal.partGE S.β h) := by + have h' := hce.partGE S.β + rwa [hGE] at h' + set s := NatOrdinal.partLT S.β e with hsdef + have hlamεs : lam' ≤ s := by + have h2 : NatOrdinal.partGE S.β h + lam' ≤ NatOrdinal.partGE S.β h + s := by + calc + NatOrdinal.partGE S.β h + lam' ≤ e := hτe + _ = NatOrdinal.partGE S.β e + NatOrdinal.partLT S.β e := + (NatOrdinal.partGE_add_partLT S.β e).symm + _ = NatOrdinal.partGE S.β h + s := by rw [hGE] + exact le_of_add_le_add_left h2 + have hsh : s < NatOrdinal.partLT S.β h := + NatOrdinal.partLT_lt_of_lt_of_partGE_eq heh hGE + obtain ⟨ε, hε⟩ := NatOrdinal.exists_leastTerm_eq_wpow + (S.partLT_cdeg_ne_zero hc ((S.hasProperLowDegreePartNotAlgebraicLE_iff v).mp hL).2.2.1) + have h5 := S.partGE_lam₀_eq_of_hasProperLowDegreePartNotAlgebraicLE + hx hL (S.partLT_cdeg_add_degLT hc) hε + have hlamε : NatOrdinal.partGE ε lam' = + NatOrdinal.partGE ε (NatOrdinal.partLT S.β h) := by + have e1 := congrArg (NatOrdinal.partGE ε) hlam' + have e2 := congrArg (NatOrdinal.partGE ε) (S.partLT_h_add_degLT hh) + rw [NatOrdinal.partGE_add] at e1 e2 + rw [h5, ← e2, add_comm (NatOrdinal.partGE ε (NatOrdinal.partLT S.β h))] at e1 + exact add_left_cancel e1 + have hs : NatOrdinal.partGE ε s = NatOrdinal.partGE ε (NatOrdinal.partLT S.β h) := + le_antisymm (NatOrdinal.partGE_mono hsh.le) + (hlamε ▸ NatOrdinal.partGE_mono hlamεs) + have h2 : NatOrdinal.AlgebraicLE (NatOrdinal.partLT S.β c) + (NatOrdinal.partLT S.β h) := by + have h3 := (hce.partLT S.β).partGE ε + rw [NatOrdinal.partGE_eq_self_of_leastTerm_eq + (S.partLT_cdeg_ne_zero hc + ((S.hasProperLowDegreePartNotAlgebraicLE_iff v).mp hL).2.2.1) hε, + ← hsdef, hs] at h3 + exact h3.trans (NatOrdinal.algebraicLE_partGE _ _) + exact NatOrdinal.algebraicLE_of_partGE_of_partLT h1 h2 + +end PartialDerivativeIndices + +end LimitOrdinalRelationAtCutoff + +end HahnSeries.Germ + +end diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/PartialDerivativesAtLimitOrdinal.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/PartialDerivativesAtLimitOrdinal.lean new file mode 100644 index 0000000000..8a489a5e2b --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/PartialDerivativesAtLimitOrdinal.lean @@ -0,0 +1,362 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.PartialDerivativeIndices +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.TruncationExpansion +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.CofactorInduction + +import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Finset.FilterCard +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint + +/-! +# Partial-derivative identities when the degree is a limit ordinal + +When the Cantor terms below a cutoff in one variable's weight add to the chosen ordinal bound, its +partial derivative is generated by partial derivatives at explicitly determined variables. The +differentiated truncation expansion gives ideal membership near zero. A decreasing neighbourhood +basis of open convex subgroups turns that eventual condition into a polynomial identity, and strong +induction on the finite set of larger variables eliminates intervening partial derivatives. +-/ + +universe u v w x + +open scoped NatOrdinal Topology + +open Filter MvPolynomial HahnSeries HahnSeries.Nonpositive + +public noncomputable section + +namespace HahnSeries.Germ + +variable {G : Type u} {K : Type v} +variable [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [UniformSpace G] [IsUniformAddGroup G] [OrderTopology G] [Nontrivial G] [CompleteSpace G] + [Field K] [CharZero K] [DenselyOrdered G] [NoMinOrder G] [NoMaxOrder G] + +local notation "ν" => (cantorBendixsonDegreeValuation (G := G) (R := K)) + +variable {κ : Type x} [LinearOrder κ] [WellFoundedLT κ] +variable (Ubase : κ → AddSubgroup G) +variable (hUmono : ∀ {i j : κ}, i ≤ j → (Ubase j : Set G) ⊆ (Ubase i : Set G)) +variable (hUopen : ∀ i, IsOpen (Ubase i : Set G)) +variable (hUconv : ∀ i, (Ubase i : Set G).OrdConnected) +variable (hUbase : ∀ ε : G, 0 < ε → ∃ i, (Ubase i : Set G) ⊆ Set.Ioo (-ε) ε) + +variable {ι : Type w} {wt : ι → NatOrdinal.{u}} + {xg : ι → (cantorBendixsonDegreeValuation (G := G) (R := K)).AssociatedGraded} +variable {σ : LiftFamily wt xg} {α : NatOrdinal.{u}} (S : LimitOrdinalRelationAtCutoff σ α) +variable (hx : OrdinalGraded.IsMinimalSystem + (DirectSum.rangeLof K (cantorBendixsonDegreeValuation (G := G) (R := K)).Component) wt xg) +variable (hinj : ∀ β < α, OrdinalGraded.InjectiveAt K wt xg β) +variable (hσ : LiftFamily.HasLowerTruncationDegrees σ) + +namespace LimitOrdinalRelationAtCutoff + +omit [DenselyOrdered G] [NoMinOrder G] [NoMaxOrder G] in +private theorem lowDegreePartAlgebraicLE_of_not_proper {j : ι} (hj : j ∈ S.F.vars) + (htop : ¬ S.LowDegreePartEq j) (hL : ¬ S.HasProperLowDegreePartNotAlgebraicLE j) : + S.LowDegreePartAlgebraicLE j := by + by_contra hnd + rcases eq_or_ne (S.degLT j) 0 with ht | ht + · exact hnd ((S.lowDegreePartAlgebraicLE_iff j).mpr (by + rw [ht] + exact NatOrdinal.algebraicLE_zero _)) + · exact hL ((S.hasProperLowDegreePartNotAlgebraicLE_iff j).mpr ⟨hj, ht, htop, hnd⟩) + +include Ubase hUmono hUopen hUconv hUbase S hx hinj hσ + +/-- A partial derivative satisfying the cutoff equation is a finite combination of the designated +partial derivatives, with every cofactor independent of the maximal variable. -/ +@[blueprint "lem:limit-ordinal-partial-derivative-decomposition" + (phase := "Algebraic independence in graded rings") + (title := "Partial-derivative decomposition when the degree is a limit ordinal") + (statement := /-- + Let $K$ be a field of characteristic zero and let $G$ be a nontrivial, + densely ordered abelian group without endpoints, equipped with a compatible + additive uniformity and order topology. Assume that $G$ is Cauchy + complete. Let + $(U_i)_{i\in J}$ be a decreasing family of open convex additive subgroups, + indexed by a well-founded linear order, such that for every $\varepsilon>0$ + some $U_i$ is contained in $(-\varepsilon,\varepsilon)$. + + Let $x_i$ be a minimal homogeneous generating system for the associated + graded ring of the degree filtration, of weights $w_i$. Choose series + $b_i$ representing $x_i$ such that + \[ + \deg(b_i)\le w_i, + \qquad \deg(b_i^{\vert y}) + intro v' hv' hn hdiff + set Θ := pderiv v' S.F with hΘdef + rcases eq_or_ne Θ 0 with hΘ0 | hΘ0 + · exact ⟨∅, fun _ ↦ 0, fun v hv ↦ absurd hv (Finset.notMem_empty v), + fun v hv ↦ absurd hv (Finset.notMem_empty v), by rw [hΘ0, Finset.sum_empty]⟩ + obtain ⟨h, hh⟩ := exists_add_wt_eq_of_mem_vars S.hom hv' + have hhα : h < α := + (lt_add_of_pos_right _ (pos_iff_ne_zero.mpr (hx.ne_zero v'))).trans_eq hh + have hΘhom : IsWeightedHomogeneous wt Θ h := by + rw [hΘdef] + exact S.pderiv_hom hh + obtain ⟨lam', + hlam'⟩ := NatOrdinal.algebraicLE_iff.mp ((S.lowDegreePartAlgebraicLE_iff v').mp hdiff) + set τ := NatOrdinal.partGE S.β h + lam' with hτdef + have hτ : NatOrdinal.partGE S.β α + S.lam₀ ≤ τ + wt v' := by + have heq := S.αGE_add_lam₀_eq hh hlam' + rw [S.αGE_def, ← hτdef] at heq + exact heq.le + have habove : ∀ j ∈ S.F.vars, wt v' < wt j → + pderiv j S.F ∈ + Ideal.span (Set.range fun v : {v // S.ContributesToPartialDerivativeAt v' v} ↦ + pderiv v.1 S.F) := by + intro j hj hlt + by_cases htop : S.LowDegreePartEq j + · exact Ideal.subset_span + ⟨⟨j, (S.contributesToPartialDerivativeAt_iff v' j).mpr ⟨hj, Or.inl htop⟩⟩, rfl⟩ + by_cases hL : S.HasProperLowDegreePartNotAlgebraicLE j + · exact Ideal.subset_span + ⟨⟨j, (S.contributesToPartialDerivativeAt_iff v' j).mpr ⟨hj, Or.inr ⟨hL, hlt⟩⟩⟩, rfl⟩ + have hdj := S.lowDegreePartAlgebraicLE_of_not_proper hj htop hL + have hcard : (S.F.vars.filter fun v ↦ wt j < wt v).card < n := + (ConwayRefinement.card_filter_above_lt wt S.F.vars hj hlt).trans_eq hn + obtain ⟨s, C, hs, -, heq⟩ := ih _ hcard j hj rfl hdj + rw [heq] + refine Ideal.sum_mem _ fun v hv ↦ + Ideal.mul_mem_right _ _ (Ideal.subset_span ⟨⟨v, ?_⟩, rfl⟩) + obtain ⟨hvF, hvkind⟩ := (S.contributesToPartialDerivativeAt_iff j v).mp (hs v hv) + exact (S.contributesToPartialDerivativeAt_iff v' v).mpr + ⟨hvF, hvkind.elim Or.inl fun h' ↦ Or.inr ⟨h'.1, hlt.trans h'.2⟩⟩ + have hlocalAbove : ∀ᶠ γ in 𝓝[<] (0 : G), + componentsGE wt τ (σ.pol hx α + (translatedTruncLE γ (aeval σ.lift Θ))) ∈ + Ideal.span (Set.range fun v : {v // S.ContributesToPartialDerivativeAt v' v} ↦ + pderiv v.1 S.F) := by + filter_upwards [S.truncation_lt, self_mem_nhdsWithin] with γ hrel hγ + have hmem := σ.componentsGE_pol_translatedTruncLE_aeval_pderiv_mem hx hσ hinj S.hom + S.vars_lt S.α₁_le S.α₁_le_α hγ hrel S.remainder_lt v' hτ + rw [← hΘdef] at hmem + refine Ideal.span_le.mpr ?_ hmem + rintro _ ⟨j, rfl⟩ + exact habove j.1 j.2.1 j.2.2 + have : Finite {v // S.ContributesToPartialDerivativeAt v' v} := + S.finite_setOf_contributesToPartialDerivativeAt v' + have hcd : ∀ v : {v // S.ContributesToPartialDerivativeAt v' v}, ∃ c, c + wt v.1 = α := + fun v ↦ exists_add_wt_eq_of_mem_vars S.hom + ((S.contributesToPartialDerivativeAt_iff v' v).mp v.2).1 + choose cd hcd using hcd + have hqG : ∀ v : {v // S.ContributesToPartialDerivativeAt v' v}, + IsWeightedHomogeneous wt (pderiv v.1 S.F) (cd v) := + fun v ↦ S.pderiv_hom (hcd v) + let A : {v // S.ContributesToPartialDerivativeAt v' v} → Prop := + fun v ↦ NatOrdinal.AlgebraicLE (wt v') (wt v.1) + have hAiff : ∀ v, A v ↔ NatOrdinal.AlgebraicLE (wt v') (wt v.1) := fun _ ↦ Iff.rfl + have : Finite {v : {v // S.ContributesToPartialDerivativeAt v' v} // A v} := + Finite.of_injective (fun v ↦ v.1) Subtype.val_injective + have hbA : ∀ v : {v : {v // S.ContributesToPartialDerivativeAt v' v} // A v}, + ∃ b, b + wt v' = wt v.1.1 := fun v ↦ by + obtain ⟨c, hc⟩ := NatOrdinal.algebraicLE_iff.mp ((hAiff v.1).mp v.2) + exact ⟨c, by rw [add_comm]; exact hc⟩ + choose b hb using hbA + have hbc : ∀ v : {v : {v // S.ContributesToPartialDerivativeAt v' v} // A v}, + b v + cd v.1 = h := by + intro v + have h1 : b v + cd v.1 + wt v' = h + wt v' := by + rw [add_right_comm, hb v, add_comm, hcd v.1, hh] + exact add_right_cancel h1 + have hnotA : ∀ v : {v // S.ContributesToPartialDerivativeAt v' v}, ¬ A v → + ¬ NatOrdinal.AlgebraicLE (cd v) h := by + intro v hA hce + obtain ⟨b', hb'⟩ := NatOrdinal.algebraicLE_iff.mp hce + refine hA ((hAiff v).mpr (NatOrdinal.algebraicLE_iff.mpr ⟨b', ?_⟩)) + have h1 : cd v + (b' + wt v') = cd v + wt v.1 := by + rw [← add_assoc, hb', hh, hcd v] + rw [add_comm] + exact add_left_cancel h1 + have hlocal : ∀ᶠ γ in 𝓝[<] (0 : G), + componentsGE wt τ (σ.pol hx α + (translatedTruncLE γ (aeval σ.lift Θ))) ∈ + Ideal.span (Set.range fun v : + {v : {v // S.ContributesToPartialDerivativeAt v' v} // A v} ↦ pderiv v.1.1 S.F) := by + filter_upwards [hlocalAbove, self_mem_nhdsWithin] with γ hmem hγ + refine componentsGE_mem_span_subtype wt hqG (h := h) hmem ?_ A + (fun v hA e hτe heh ⟨β', hβ'⟩ ↦ ?_) + · exact σ.pol_weight_lt_of_degree_lt hx hhα.le + ((σ.hasLowerTruncationDegree_aeval hσ hΘhom).degree_translatedTruncLE_lt hγ) + · have hce : NatOrdinal.AlgebraicLE (cd v) e := + NatOrdinal.algebraicLE_iff.mpr ⟨β', by rw [add_comm]; exact hβ'⟩ + rw [hτdef] at hτe + rcases ((S.contributesToPartialDerivativeAt_iff v' v).mp v.2).2 with htop | ⟨hL, -⟩ + · exact S.not_algebraicLE_of_lowDegreePartEq_of_not (hcd v) hlam' htop + (hnotA v hA) hτe heh hce + · exact S.not_algebraicLE_of_hasProperLowDegreePartNotAlgebraicLE_of_not + hx (hcd v) hh hlam' hL (hnotA v hA) hτe heh hce + have hτh : τ + 1 < h := hτdef ▸ S.τ_add_one_lt hx hh hlam' + have hwin : ∀ v : {v : {v // S.ContributesToPartialDerivativeAt v' v} // A v}, + ∀ ε : NatOrdinal, NatOrdinal.leastTerm (cd v.1) = ω^ ε → + NatOrdinal.partGE ε h ≤ τ := by + intro v ε hε + rw [hτdef] + obtain ⟨hvF, hvkind⟩ := (S.contributesToPartialDerivativeAt_iff v' v.1).mp v.1.2 + rcases hvkind with htop | ⟨hL, -⟩ + · exact S.partGE_le_τ_of_lowDegreePartEq hvF (hcd v.1) htop hε h + · have hne := S.partLT_cdeg_ne_zero (hcd v.1) + ((S.hasProperLowDegreePartNotAlgebraicLE_iff _).mp hL).2.2.1 + rw [NatOrdinal.leastTerm_eq_leastTerm_partLT hne] at hε + exact S.partGE_le_τ_of_hasProperLowDegreePartNotAlgebraicLE hx (hcd v.1) hh hlam' hL hε + have hp : ∀ᶠ γ in 𝓝[<] (0 : G), ∃ P : MvPolynomial ι K, + (∀ d ∈ P.support, Finsupp.weight wt d < α) ∧ + ν (translatedTruncLE γ (aeval σ.lift Θ) - aeval σ.lift P) = ⊥ ∧ + componentsGE wt τ P ∈ + Ideal.span (Set.range fun v : + {v : {v // S.ContributesToPartialDerivativeAt v' v} // A v} ↦ pderiv v.1.1 S.F) := by + filter_upwards [hlocal, self_mem_nhdsWithin] with γ hmem hγ + have hdeg := (σ.hasLowerTruncationDegree_aeval hσ hΘhom).degree_translatedTruncLE_lt hγ + refine ⟨σ.pol hx α (translatedTruncLE γ (aeval σ.lift Θ)), + σ.pol_weight_lt hx _ _, ?_, hmem⟩ + exact σ.degree_sub_aeval_pol_eq_bot hx (hdeg.trans (WithBot.coe_lt_coe.mpr hhα)) + have hgen : ∀ β : NatOrdinal.{u}, β < α → + ∀ z ∈ DirectSum.rangeLof K (ν).Component β, + ∃ P : MvPolynomial ι K, IsWeightedHomogeneous wt P β ∧ aeval xg P = z := + fun β _ ↦ hx.exists_aeval_eq cantorBendixson_gradeZeroScalars β + have hinj' : ∀ (β : NatOrdinal.{u}) (P : MvPolynomial ι K), β < α → + IsWeightedHomogeneous wt P β → aeval xg P = 0 → P = 0 := by + intro β P hβα + exact ((OrdinalGraded.injectiveAt_iff β).mp (hinj β hβα)) P + cases nonempty_fintype {v : {v // S.ContributesToPartialDerivativeAt v' v} // A v} + obtain ⟨C, hChom, hΘeq⟩ := + exists_eq_sum_mul_of_eventually_componentsGE_mem_of_windows Ubase hUmono hUopen hUconv + hUbase xg σ.represents ((σ.hasLowerTruncationDegrees_iff).mp hσ) α hgen hinj' + (fun v : {v : {v // S.ContributesToPartialDerivativeAt v' v} // A v} ↦ pderiv v.1.1 S.F) + (fun v ↦ cd v.1) b (fun v ↦ hqG v.1) τ h hτh hhα + (fun v ↦ S.cdeg_ne_zero + ((S.contributesToPartialDerivativeAt_iff v' v.1.1).mp v.1.2).1 (hcd v.1)) + hbc hwin hΘhom + (σ.hasLowerTruncationDegree_aeval hσ hΘhom) hp + have hCB₀ : ∀ v : {v : {v // S.ContributesToPartialDerivativeAt v' v} // A v}, + pderiv S.B₀ (C v) = 0 := by + intro v + have hbg : b v < wt S.B₀ := by + have h1 : b v < wt v.1.1 := by + rw [← hb v] + exact lt_add_of_pos_right _ (pos_iff_ne_zero.mpr (hx.ne_zero v')) + exact h1.trans_le (S.max _ ((S.contributesToPartialDerivativeAt_iff v' v.1.1).mp v.1.2).1) + exact LiftFamily.pderiv_eq_zero_of_degreeLT_le + ((LiftFamily.degreeLT_iff).mpr + (fun d hd ↦ (hChom v (b v) (hbc v)) (mem_support_iff.mp hd) ▸ hbg)) le_rfl + have hindex : Function.Injective + (fun v : {v : {v // S.ContributesToPartialDerivativeAt v' v} // A v} ↦ v.1.1) := + fun v w hvw ↦ Subtype.ext (Subtype.ext hvw) + refine ⟨Finset.univ.image + (fun v : {v : {v // S.ContributesToPartialDerivativeAt v' v} // A v} ↦ v.1.1), + fun i ↦ if hi : ∃ v : + {v : {v // S.ContributesToPartialDerivativeAt v' v} // A v}, v.1.1 = i then + C (Classical.choose hi) else 0, ?_, ?_, ?_⟩ + · intro i hi + obtain ⟨v, -, rfl⟩ := Finset.mem_image.mp hi + exact v.1.2 + · intro i hi + obtain ⟨v, -, rfl⟩ := Finset.mem_image.mp hi + beta_reduce + rw [dite_eq_left (⟨v, rfl⟩ : + ∃ w : {v : {v // S.ContributesToPartialDerivativeAt v' v} // A v}, w.1.1 = v.1.1)] + exact hCB₀ _ + · rw [hΘeq, Finset.sum_image fun v _ w _ h ↦ hindex h] + refine Finset.sum_congr rfl fun v _ ↦ ?_ + beta_reduce + rw [dite_eq_left (⟨v, rfl⟩ : + ∃ w : {v : {v // S.ContributesToPartialDerivativeAt v' v} // A v}, w.1.1 = v.1.1)] + have hchoice : Classical.choose + (⟨v, rfl⟩ : ∃ w : {v : {v // S.ContributesToPartialDerivativeAt v' v} // A v}, + w.1.1 = v.1.1) = v := hindex (Classical.choose_spec + (⟨v, rfl⟩ : ∃ w : {v : {v // S.ContributesToPartialDerivativeAt v' v} // A v}, + w.1.1 = v.1.1)) + rw [hchoice, mul_comm] + +end LimitOrdinalRelationAtCutoff + +end HahnSeries.Germ + +end diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/Power.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/Power.lean new file mode 100644 index 0000000000..347f5d9248 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/Power.lean @@ -0,0 +1,270 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.Leibniz + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Nonpositive +import LeanPool.ConwayRefinement.ConwayRefinement.Topology.Order.LeftNeighborhood +import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.NaturalPrincipal + +/-! +# Power remainders for the Cantor–Bendixson value + +The product rule for a positive power is valid up to a remainder of strictly smaller value. +The induction also bounds the value of each translated partial product. This supplies the +interior convolution estimates without assuming multiplicativity or knowing the principal +factor of a product. + +The multiplicity is a natural-number scalar in the series ring. The estimates hold in every +characteristic over a commutative coefficient ring. Nonvanishing of this scalar, which is needed +when the main term is to survive cancellation, is a separate assertion. + +In the proofs, V reads the Cantor–Bendixson value in NatOrdinal, and T denotes translated weak +truncation. Products of values are natural ordinal products, while products of series are Hahn +products. The final canonical principal factors determine the comparison hypothesis. +-/ + +public noncomputable section + +open Set Filter Topology + +universe u v + +namespace HahnSeries + +private theorem small_values_mul_lt (B C : Ordinal.AdditivePrincipalAboveOne.{u}) + {a c : NatOrdinal.{u}} (hp : B.principalFactor ≤ C.principalFactor) + (ha : a < NatOrdinal.of B.val) (hc : c < NatOrdinal.of C.val) : + a * c < NatOrdinal.of B.residualFactor * NatOrdinal.of C.val := by + have ha' : a.val < B.residualFactor * B.principalFactor := by + rw [B.residualFactor_mul_principalFactor] + exact ha + have hc' : c.val < C.residualFactor * C.principalFactor := by + rw [C.residualFactor_mul_principalFactor] + exact hc + obtain ⟨x, hx, hxa⟩ := (Ordinal.lt_mul_iff_of_isSuccLimit + B.principalFactor_isInfiniteMultiplicativelyPrincipal.isSuccLimit).mp ha' + obtain ⟨y, hy, hyc⟩ := (Ordinal.lt_mul_iff_of_isSuccLimit + C.principalFactor_isInfiniteMultiplicativelyPrincipal.isSuccLimit).mp hc' + have hρB : 0 < NatOrdinal.of B.residualFactor := + pos_iff_ne_zero.mpr B.residualFactor_isAdditivelyPrincipal.ne_zero + have hρC : 0 < NatOrdinal.of C.residualFactor := + pos_iff_ne_zero.mpr C.residualFactor_isAdditivelyPrincipal.ne_zero + have hfinal := NatOrdinal.naturalMul_mul_lt_of_lt + (ρ₁ := NatOrdinal.of B.residualFactor) (ρ₂ := NatOrdinal.of C.residualFactor) + (π₁ := NatOrdinal.of B.principalFactor) (π₂ := NatOrdinal.of C.principalFactor) + (α₁ := NatOrdinal.of x) (α₂ := NatOrdinal.of y) + C.principalFactor_isMultiplicativelyPrincipal hp hx hy (mul_pos hρB hρC) + rw [mul_assoc, C.naturalResidual_mul_naturalPrincipal] at hfinal + exact (mul_le_mul' (NatOrdinal.of.le_iff_le.mpr hxa.le) + (NatOrdinal.of.le_iff_le.mpr hyc.le)).trans_lt hfinal + +variable {G : Type u} {R : Type v} [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + +section Ring + +variable [Ring R] + +/-- The product-rule error for a positive power times another Hahn series, using weak truncation. -/ +def leibnizPowerRemainder (b d : HahnSeries G R) (m : ℕ) (γ : G) : HahnSeries G R := + translate (-γ) (truncLE γ (b ^ (m + 1) * d)) - + (m + 1) • (translate (-γ) (truncLE γ b) * (b ^ m * d)) - + b ^ (m + 1) * translate (-γ) (truncLE γ d) + +/-- The power remainder is the translated product truncation minus its two product-rule terms. -/ +theorem leibnizPowerRemainder_eq (b d : HahnSeries G R) (m : ℕ) (γ : G) : + leibnizPowerRemainder b d m γ = + translate (-γ) (truncLE γ (b ^ (m + 1) * d)) - + (m + 1) • (translate (-γ) (truncLE γ b) * (b ^ m * d)) - + b ^ (m + 1) * translate (-γ) (truncLE γ d) := (rfl) + +/-- Nonpositive inputs give a power remainder with nonpositive support. -/ +theorem support_leibnizPowerRemainder (b d : HahnSeries G R) + (hb : b.support ⊆ Iic 0) (hd : d.support ⊆ Iic 0) (m : ℕ) (γ : G) : + (leibnizPowerRemainder b d m γ).support ⊆ Iic 0 := by + rw [leibnizPowerRemainder_eq] + apply (nonpositiveSubring G R).sub_mem + · apply (nonpositiveSubring G R).sub_mem + · exact support_translated_truncLE _ _ + · apply (nonpositiveSubring G R).nsmul_mem + exact (nonpositiveSubring G R).mul_mem (support_translated_truncLE _ _) + ((nonpositiveSubring G R).mul_mem ((nonpositiveSubring G R).pow_mem hb m) hd) + · exact (nonpositiveSubring G R).mul_mem ((nonpositiveSubring G R).pow_mem hb (m + 1)) + (support_translated_truncLE _ _) + +end Ring + +variable [UniformSpace G] [IsUniformAddGroup G] [OrderTopology G] + [Nontrivial G] [CompleteSpace G] [CommRing R] + +local notation "V" => (fun b : HahnSeries G R ↦ NatOrdinal.of (cantorBendixsonValue b)) +local notation:max "T" x:arg "," c:arg => translate (-c) (truncLE c x) + +private theorem partial_product_truncation_bound (b c : HahnSeries G R) + (hb : b.support ⊆ Iic 0) (hc : c.support ⊆ Iic 0) + (B C : Ordinal.AdditivePrincipalAboveOne.{u}) + (hB : b.cantorBendixsonValue = B.val) (hC : c.cantorBendixsonValue = C.val) + (hp : B.principalFactor ≤ C.principalFactor) (m : ℕ) + (hP : ∀ᶠ γ in 𝓝[<] (0 : G), V (leibnizPowerRemainder b c m γ) < + NatOrdinal.of B.val ^ m * NatOrdinal.of B.residualFactor * NatOrdinal.of C.val) : + ∀ᶠ γ in 𝓝[<] (0 : G), ∀ t : NatOrdinal.{u}, t < NatOrdinal.of B.val → + t * V (T (b ^ (m + 1) * c), γ) < + NatOrdinal.of B.val ^ (m + 1) * NatOrdinal.of B.residualFactor * NatOrdinal.of C.val := by + have hb0 : b.cantorBendixsonValue ≠ 0 := by rw [hB]; exact B.2.1.ne_zero + have hc0 : c.cantorBendixsonValue ≠ 0 := by rw [hC]; exact C.2.1.ne_zero + filter_upwards [hP, + (b.eventually_value_translated_truncLE_lt hb0).filter_mono nhdsWithin_le_nhds, + (c.eventually_value_translated_truncLE_lt hc0).filter_mono nhdsWithin_le_nhds, + self_mem_nhdsWithin] with γ hP hbγ hcγ hγ t ht + have hbt : V (T b, γ) < NatOrdinal.of B.val := + NatOrdinal.of.lt_iff_lt.mpr (by simpa only [hB] using hbγ (ne_of_lt hγ)) + have hct : V (T c, γ) < NatOrdinal.of C.val := + NatOrdinal.of.lt_iff_lt.mpr (by simpa only [hC] using hcγ (ne_of_lt hγ)) + let v := NatOrdinal.of B.val + let w := NatOrdinal.of C.val + let r := NatOrdinal.of B.residualFactor + have hv : 0 < v := pos_iff_ne_zero.mpr B.2.1.ne_zero + have hw : 0 < w := pos_iff_ne_zero.mpr C.2.1.ne_zero + have hr : 0 < r := pos_iff_ne_zero.mpr B.residualFactor_isAdditivelyPrincipal.ne_zero + have hpows (n : ℕ) : (b ^ n).support ⊆ Iic (0 : G) := + (nonpositiveSubring G R).pow_mem hb n + have hpv (n : ℕ) : V (b ^ n) ≤ v ^ n := by + simpa only [hB] using b.cantorBendixsonValue_pow_le hb n + have hpc : V (b ^ m * c) ≤ v ^ m * w := by + have h := (b ^ m).cantorBendixsonValue_mul_le c (hpows m) hc + rw [hC] at h + exact h.trans (mul_le_mul_left (hpv m) _) + have hA : V ((m + 1) • (T b, γ * (b ^ m * c))) ≤ V (T b, γ) * (v ^ m * w) := + (cantorBendixsonValue_nsmul_le _ _).trans + ((cantorBendixsonValue_mul_le _ _ (b.support_translated_truncLE γ) + ((nonpositiveSubring G R).mul_mem (hpows m) hc)).trans (mul_le_mul_right hpc _)) + have hD : V (b ^ (m + 1) * T c, γ) ≤ v ^ (m + 1) * V (T c, γ) := + (cantorBendixsonValue_mul_le _ _ (hpows (m + 1)) (c.support_translated_truncLE γ)).trans + (mul_le_mul_left (hpv (m + 1)) _) + have hval : V (T (b ^ (m + 1) * c), γ) ≤ + max (max (V (T b, γ) * (v ^ m * w)) (v ^ (m + 1) * V (T c, γ))) + (v ^ m * r * w) := by + have he : T (b ^ (m + 1) * c), γ = + (m + 1) • (T b, γ * (b ^ m * c)) + b ^ (m + 1) * T c, γ + + leibnizPowerRemainder b c m γ := by + rw [leibnizPowerRemainder_eq] + abel + rw [he] + exact (cantorBendixsonValue_add_le _ _).trans + (max_le_max ((cantorBendixsonValue_add_le _ _).trans (max_le_max hA hD)) hP.le) + have h1 : t * (V (T b, γ) * (v ^ m * w)) < v ^ (m + 1) * r * w := by + calc + _ = (t * V (T b, γ)) * (v ^ m * w) := by ring + _ < (r * v) * (v ^ m * w) := + mul_lt_mul_of_pos_right (small_values_mul_lt B B le_rfl ht hbt) + (mul_pos (pow_pos hv m) hw) + _ = _ := by ring + have h2 : t * (v ^ (m + 1) * V (T c, γ)) < v ^ (m + 1) * r * w := by + calc + _ = v ^ (m + 1) * (t * V (T c, γ)) := by ring + _ < v ^ (m + 1) * (r * w) := + mul_lt_mul_of_pos_left (small_values_mul_lt B C hp ht hct) (pow_pos hv (m + 1)) + _ = _ := by ring + have h3 : t * (v ^ m * r * w) < v ^ (m + 1) * r * w := by + calc + _ < v * (v ^ m * r * w) := + mul_lt_mul_of_pos_right ht (mul_pos (mul_pos (pow_pos hv m) hr) hw) + _ = _ := by ring + have hmono : Monotone fun x : NatOrdinal.{u} ↦ t * x := fun _ _ h ↦ mul_le_mul_right h t + apply (mul_le_mul_right hval t).trans_lt + rw [hmono.map_max, hmono.map_max] + exact max_lt (max_lt h1 h2) h3 + +/-- The power-product remainder is eventually below the natural product of the remaining +powers, the first value's residual factor, and the second value. -/ +theorem eventually_cantorBendixsonValue_leibnizPowerRemainder_lt (b c : HahnSeries G R) + (hb : b.support ⊆ Iic 0) (hc : c.support ⊆ Iic 0) + (B C : Ordinal.AdditivePrincipalAboveOne.{u}) + (hB : b.cantorBendixsonValue = B.val) (hC : c.cantorBendixsonValue = C.val) + (hp : B.principalFactor ≤ C.principalFactor) (m : ℕ) : + ∀ᶠ γ in 𝓝[<] (0 : G), NatOrdinal.of (leibnizPowerRemainder b c m γ).cantorBendixsonValue < + NatOrdinal.of B.val ^ m * NatOrdinal.of B.residualFactor * NatOrdinal.of C.val := by + induction m with + | zero => + simpa only [leibnizPowerRemainder_eq, zero_add, pow_one, pow_zero, one_mul, one_nsmul] + using b.eventually_cantorBendixsonValue_leibnizRemainder_lt c hb hc B C hB hC hp + | succ m ih => + have hQ := partial_product_truncation_bound b c hb hc B C hB hC hp m ih + have hb0 : b.cantorBendixsonValue ≠ 0 := by rw [hB]; exact B.2.1.ne_zero + have hcut := (b.eventually_value_translated_truncLE_lt hb0).filter_mono + (nhdsWithin_le_nhds (s := Iio (0 : G))) + obtain ⟨η, hη, hηall⟩ := eventually_nhdsLT_iff_exists.mp (hQ.and (ih.and hcut)) + let d := b ^ (m + 1) * c + have hd : d.support ⊆ Iic (0 : G) := + (nonpositiveSubring G R).mul_mem ((nonpositiveSubring G R).pow_mem hb (m + 1)) hc + let v := NatOrdinal.of B.val + let w := NatOrdinal.of C.val + let r := NatOrdinal.of B.residualFactor + have hv : 0 < v := pos_iff_ne_zero.mpr B.2.1.ne_zero + have hw : 0 < w := pos_iff_ne_zero.mpr C.2.1.ne_zero + have hr : 0 < r := pos_iff_ne_zero.mpr B.residualFactor_isAdditivelyPrincipal.ne_zero + have hbound : 0 < v ^ (m + 1) * r * w := mul_pos (mul_pos (pow_pos hv _) hr) hw + filter_upwards [Ioo_mem_nhdsLT hη] with γ hγ + have herr : V (T (b * d), γ - T b, γ * d - b * T d, γ) < v ^ (m + 1) * r * w := by + apply cantorBendixsonValue_leibnizRemainder_lt_of_forall b d hb hd hγ.2 hbound + intro x y hγx hx hγy hy _ + have htx : V (T b, x) < v := by + apply NatOrdinal.of.lt_iff_lt.mpr + rw [← hB] + exact (hηall x (hγ.1.trans hγx) hx).2.2 hx.ne + exact (cantorBendixsonValue_mul_le _ _ (b.support_translated_truncLE x) + (d.support_translated_truncLE y)).trans_lt + ((hηall y (hγ.1.trans hγy) hy).1 _ htx) + have hprev : V (b * leibnizPowerRemainder b c m γ) < v ^ (m + 1) * r * w := by + have hmul := b.cantorBendixsonValue_mul_le (leibnizPowerRemainder b c m γ) hb + (support_leibnizPowerRemainder b c hb hc m γ) + rw [hB] at hmul + apply hmul.trans_lt + calc + _ < v * (v ^ m * r * w) := + mul_lt_mul_of_pos_left (hηall γ hγ.1 hγ.2).2.1 hv + _ = _ := by ring + have he : leibnizPowerRemainder b c (m + 1) γ = + b * leibnizPowerRemainder b c m γ + + (T (b * d), γ - T b, γ * d - b * T d, γ) := by + rw [leibnizPowerRemainder_eq, leibnizPowerRemainder_eq] + have hpow : b ^ (m + 1 + 1) * c = b * d := by dsimp only [d]; ring + rw [hpow] + dsimp only [d] + simp only [nsmul_eq_mul, Nat.cast_add, Nat.cast_one] + ring + rw [he] + exact (cantorBendixsonValue_add_le _ _).trans_lt (max_lt hprev herr) + +/-- The pure-power remainder has the corresponding strict bound, including exponent one. -/ +theorem eventually_cantorBendixsonValue_powerRemainder_lt (b : HahnSeries G R) + (hb : b.support ⊆ Iic 0) (B : Ordinal.AdditivePrincipalAboveOne.{u}) + (hB : b.cantorBendixsonValue = B.val) (m : ℕ) : + ∀ᶠ γ in 𝓝[<] (0 : G), + NatOrdinal.of (translate (-γ) (truncLE γ (b ^ (m + 1))) - + (m + 1) • (translate (-γ) (truncLE γ b) * b ^ m)).cantorBendixsonValue < + NatOrdinal.of B.val ^ m * NatOrdinal.of B.residualFactor := by + cases m with + | zero => + apply Filter.Eventually.of_forall + intro γ + simp only [zero_add, pow_one, pow_zero, mul_one, one_nsmul, sub_self, + cantorBendixsonValue_zero, NatOrdinal.of_zero, one_mul] + exact pos_iff_ne_zero.mpr B.residualFactor_isAdditivelyPrincipal.ne_zero + | succ m => + filter_upwards [eventually_cantorBendixsonValue_leibnizPowerRemainder_lt + b b hb hb B B hB hB le_rfl m] with γ hγ + have he : T (b ^ (m + 1 + 1)), γ - (m + 1 + 1) • (T b, γ * b ^ (m + 1)) = + leibnizPowerRemainder b b m γ := by + rw [leibnizPowerRemainder_eq, ← pow_succ] + simp only [nsmul_eq_mul, Nat.cast_add, Nat.cast_one] + ring + rw [he] + convert hγ using 1 + ring + +end HahnSeries diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/PrincipalSeries.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/PrincipalSeries.lean new file mode 100644 index 0000000000..341fd0ca94 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/PrincipalSeries.lean @@ -0,0 +1,84 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.CantorBendixsonValue +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.PrincipalAddition +public import LeanPool.ConwayRefinement.ConwayRefinement.Topology.Order.ClosedPWO + +/-! +# Cantor–Bendixson rank of a principal real Hahn series + +For a principal series of Hahn degree `α`, the endpoint zero of its closed support has +Cantor–Bendixson rank `α`. Thus its Cantor–Bendixson value is the same `ω ^ α` that occurs in +the support-order definition of degree. +-/ + +open Set +open scoped HahnSeries NatOrdinal + +universe v + +public noncomputable section + +namespace HahnSeries.Nonpositive + +open HahnSeries + +variable {K : Type v} [Field K] + +/-- A principal real Hahn series of degree `α` has Cantor–Bendixson rank `α` at zero. -/ +theorem IsPrincipal.cantorBendixsonRank_zero_eq_of_degree_eq + {p : Nonpositive ℝ K} (hp : IsPrincipal p) {a : NatOrdinal} + (hdegree : (p : K⟦ℝ⟧).degree = (a : WithBot NatOrdinal)) : + (p : K⟦ℝ⟧).cantorBendixsonRank 0 = a.val := by + rcases eq_or_ne a 0 with rfl | ha + · have hpconst := hp.eq_C_constantCoeff_of_degree_zero hdegree + apply (p : K⟦ℝ⟧).cantorBendixsonRank_of_finite + rw [hpconst, coe_C] + exact (finite_singleton 0).subset HahnSeries.support_single_subset + · have hapos : 0 < a := pos_iff_ne_zero.mpr ha + have hcoeff := hp.constantCoeff_eq_zero_of_degree_pos hdegree hapos + have hzero : 0 ∉ (p : K⟦ℝ⟧).support := by + intro hmem + rw [constantCoeff_apply] at hcoeff + exact (HahnSeries.mem_support _ _).mp hmem hcoeff + have hlub : IsLUB (p : K⟦ℝ⟧).support 0 := + (supportSup_eq_coe_iff.mp hp.supportSup_eq_zero).2 + have htype := hp.supportOrderType_eq_wpow_of_degree_eq hdegree + let S : TopologicalSpace.Closeds ℝ := + ⟨closure (p : K⟦ℝ⟧).support, isClosed_closure⟩ + let hS : (S : Set ℝ).IsPWO := (p : K⟦ℝ⟧).isPWO_support.closure + have hsets : ((p : K⟦ℝ⟧).closedSupport : Set ℝ) = (S : Set ℝ) := + (p : K⟦ℝ⟧).coe_closedSupport + rw [cantorBendixsonRank_eq] + calc + (p : K⟦ℝ⟧).closedSupport.cantorBendixsonRank + (p : K⟦ℝ⟧).closedSupport_isPWO 0 = + S.cantorBendixsonRank hS 0 := + (p : K⟦ℝ⟧).closedSupport.cantorBendixsonRank_congr_on_open S + (p : K⟦ℝ⟧).closedSupport_isPWO hS isOpen_univ + (by simpa only [inter_univ] using hsets) (mem_univ 0) + _ = a.val := by + apply Set.IsPWO.cantorBendixsonRank_closure_eq_of_orderType_eq_opow + (p : K⟦ℝ⟧).isPWO_support hlub hzero + · exact NatOrdinal.val.injective.ne ha + · simpa only [HahnSeries.supportOrderType_eq_setOrderType, + NatOrdinal.val_wpow] using htype + +/-- A principal real Hahn series of degree `α` has Cantor–Bendixson value `ω ^ α`. -/ +theorem IsPrincipal.cantorBendixsonValue_eq_wpow_of_degree_eq + {p : Nonpositive ℝ K} (hp : IsPrincipal p) {a : NatOrdinal} + (hdegree : (p : K⟦ℝ⟧).degree = (a : WithBot NatOrdinal)) : + (p : K⟦ℝ⟧).cantorBendixsonValue = (Ordinal.omega0 ^ a.val) := by + have hmem : 0 ∈ closure (p : K⟦ℝ⟧).support := by + have hlub : IsLUB (p : K⟦ℝ⟧).support 0 := + (supportSup_eq_coe_iff.mp hp.supportSup_eq_zero).2 + exact hlub.mem_closure (HahnSeries.support_nonempty_iff.mpr (by simpa using hp.ne_zero)) + rw [(p : K⟦ℝ⟧).cantorBendixsonValue_of_mem hmem, + hp.cantorBendixsonRank_zero_eq_of_degree_eq hdegree] + +end HahnSeries.Nonpositive diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/Scalar.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/Scalar.lean new file mode 100644 index 0000000000..5e3b703f65 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/Scalar.lean @@ -0,0 +1,376 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.Derivation +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.Residue +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.DirectSum.InternalGrading +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.DirectSum.GermChainRule +import Mathlib.Tactic.Abel + +/-! +# Coefficients in the associated graded ring of the Cantor–Bendixson degree + +For a coefficient field `K`, constant Hahn series have degree zero. Projection to the +zero homogeneous component is a bijective ring homomorphism: a degree-zero representative +differs from its ordinary coefficient by a series bounded strictly below zero. This identifies +the zero component with `K`, gives every component its canonical vector-space structure, and +makes the associated graded ring a graded `K`-algebra. + +The additive truncation map is linear for this action and satisfies the Leibniz rule, so it is a +derivation from the associated graded ring to germs of associated-graded-valued functions. It +vanishes on components indexed by limit ordinals and is injective from degree `α + 1` to degree `α`. +The exponent group remains arbitrary, complete, and ordered; no real-exponent reduction is used. +-/ + +public noncomputable section +open Set Filter Topology +open scoped DirectSum NatOrdinal +universe u v w +namespace HahnSeries.Nonpositive +variable {G : Type u} {K : Type v} [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [UniformSpace G] [IsUniformAddGroup G] [OrderTopology G] [Nontrivial G] [CompleteSpace G] + [Field K] [CharZero K] + +local notation "ν" => (cantorBendixsonDegreeValuation (G := G) (R := K)) + +/-- A nonzero constant series has degree exactly zero. -/ +theorem degree_C_of_ne (k : K) (hk : k ≠ 0) : + ν (C k) = (0 : NatOrdinal) := by + rw [cantorBendixsonDegreeValuation_apply, cantorBendixsonValuation_apply, + coe_C, cantorBendixsonValue_of_finite_of_coeff_ne_zero (HahnSeries.C k) + ((finite_singleton (0 : G)).subset support_single_subset) (by simpa using hk), + NatOrdinal.of_one, NatOrdinal.cantorDegree_eq_ordinalCantorDegree, + NatOrdinal.val_one, Ordinal.cantorDegree_one, WithBot.coe_zero] + +/-- Every constant series has degree at most zero. -/ +theorem degree_C_le (k : K) : ν (C k) ≤ (0 : NatOrdinal) := by + by_cases hk : k = 0 + · subst k + simp + · rw [degree_C_of_ne k hk] + +private def constantToNonpositiveDegree (k : K) : (ν).nonpositiveSubring := + ⟨C k, ((ν).mem_nonpositiveSubring_iff _).mpr (by + by_cases hk : k = 0 + · subst k + simp + · rw [degree_C_of_ne k hk] + exact le_rfl)⟩ + +private theorem constantToNonpositiveDegree_zero : + constantToNonpositiveDegree (G := G) (K := K) 0 = 0 := by + apply Subtype.ext + exact map_zero C + +private theorem constantToNonpositiveDegree_add (k l : K) : + constantToNonpositiveDegree (G := G) (k + l) = + constantToNonpositiveDegree k + constantToNonpositiveDegree l := by + apply Subtype.ext + exact map_add C k l + +private theorem constantToNonpositiveDegree_one : + constantToNonpositiveDegree (G := G) (K := K) 1 = 1 := by + apply Subtype.ext + exact map_one C + +private theorem constantToNonpositiveDegree_mul (k l : K) : + constantToNonpositiveDegree (G := G) (k * l) = + constantToNonpositiveDegree k * constantToNonpositiveDegree l := by + apply Subtype.ext + exact map_mul C k l + +private def constantToNonpositiveDegreeHom : K →+* (ν).nonpositiveSubring where + toFun := constantToNonpositiveDegree + map_zero' := constantToNonpositiveDegree_zero + map_add' := constantToNonpositiveDegree_add + map_one' := constantToNonpositiveDegree_one + map_mul' := constantToNonpositiveDegree_mul + +/-- The coefficient field mapped isomorphically to the grade-zero component. -/ +def cantorBendixsonLayerScalarHom : K →+* (ν).ResidueRing := + (ν).residueMap.comp constantToNonpositiveDegreeHom + +/-- A coefficient maps to the grade-zero class of its constant Hahn series. -/ +theorem cantorBendixsonLayerScalarHom_apply (k : K) : + cantorBendixsonLayerScalarHom (G := G) k = + (ν).componentMk 0 ⟨C k, ((ν).mem_filtrationLE_iff _ _).mpr (by + by_cases hk : k = 0 + · subst k + simp + · rw [degree_C_of_ne k hk])⟩ := by + rw [cantorBendixsonLayerScalarHom, RingHom.comp_apply, (ν).residueMap_apply] + apply congrArg ((ν).componentMk 0) + apply Subtype.ext + rw [(ν).coe_nonpositiveEquivFiltrationLEZero] + rfl + +/-- Distinct coefficients give distinct grade-zero classes. -/ +theorem cantorBendixsonLayerScalarHom_injective : + Function.Injective (cantorBendixsonLayerScalarHom (G := G) (K := K)) := by + intro k l hkl + have hsub : cantorBendixsonLayerScalarHom (G := G) (k - l) = 0 := by + rw [map_sub, hkl, sub_self] + rw [cantorBendixsonLayerScalarHom_apply, (ν).componentMk_eq_zero_iff] at hsub + by_contra hne + rw [degree_C_of_ne _ (sub_ne_zero.mpr hne)] at hsub + exact (lt_irrefl (0 : WithBot NatOrdinal)) hsub + +omit [UniformSpace G] [IsUniformAddGroup G] [OrderTopology G] [Nontrivial G] + [CompleteSpace G] [CharZero K] in +private theorem coe_C_eq_single (k : K) : + ((C k : Nonpositive G K) : HahnSeries G K) = HahnSeries.single 0 k := by + ext g + simp [coe_C] + +/-- Every grade-zero class has a unique constant representative modulo strict lower degree. -/ +theorem cantorBendixsonLayerScalarHom_surjective : + Function.Surjective (cantorBendixsonLayerScalarHom (G := G) (K := K)) := by + intro a + induction a using QuotientAddGroup.induction_on with + | H b => + let k := constantCoeff (b : Nonpositive G K) + refine ⟨k, ?_⟩ + rw [cantorBendixsonLayerScalarHom_apply, (ν).coe_component_eq_componentMk] + apply ((ν).componentMk_eq_componentMk_iff _ _ _).mpr + change ν (C k - (b : Nonpositive G K)) < (0 : NatOrdinal) + have hb := ((ν).mem_filtrationLE_iff _ _).mp b.property + have hv : (b : HahnSeries G K).cantorBendixsonValue = 0 ∨ + (b : HahnSeries G K).cantorBendixsonValue = 1 := by + by_cases hm : 0 ∈ (b : HahnSeries G K).closedSupport + · right + have hr : (b : HahnSeries G K).cantorBendixsonRank 0 = 0 := by + rw [cantorBendixsonDegreeValuation_of_mem _ hm, WithBot.coe_le_coe] at hb + exact le_zero_iff.mp hb + rw [cantorBendixsonValue_of_mem _ ((mem_closedSupport _ _).mp hm), hr, + Ordinal.opow_zero] + · left + exact cantorBendixsonValue_of_notMem _ + (by simpa only [mem_closedSupport] using hm) + rcases hv with hv | hv + · have hk : k = 0 := by + dsimp [k] + rw [constantCoeff_apply] + apply not_ne_iff.mp + intro hn + have hmem : 0 ∈ (b : HahnSeries G K).support := hn + rw [cantorBendixsonValue_of_mem _ (subset_closure hmem)] at hv + exact Ordinal.opow_ne_zero _ Ordinal.omega0_ne_zero hv + rw [hk, map_zero, zero_sub, (ν).map_neg, + cantorBendixsonDegreeValuation_apply, cantorBendixsonValuation_apply, hv, + NatOrdinal.of_zero, NatOrdinal.cantorDegree_zero] + exact WithBot.bot_lt_coe 0 + · have hz := (cantorBendixsonValue_eq_one_iff (b : HahnSeries G K)).mp hv |>.2 + rw [show C k - (b : Nonpositive G K) = + -((b : Nonpositive G K) - C k) by abel, (ν).map_neg, + cantorBendixsonDegreeValuation_apply, cantorBendixsonValuation_apply] + change NatOrdinal.cantorDegree + (NatOrdinal.of (((b : HahnSeries G K) - (C k : Nonpositive G K)).cantorBendixsonValue)) < 0 + have hz' : ((b : HahnSeries G K) - (C k : Nonpositive G K)).cantorBendixsonValue = 0 := by + simpa only [coe_C_eq_single, k, constantCoeff_apply] using hz + rw [hz', NatOrdinal.of_zero, NatOrdinal.cantorDegree_zero] + exact WithBot.bot_lt_coe 0 + +/-- Every homogeneous component is a vector space over the coefficient field. -/ +noncomputable instance cantorBendixsonComponentModule (α : NatOrdinal.{u}) : + Module K ((ν).Component α) := + Module.compHom ((ν).Component α) (cantorBendixsonLayerScalarHom (G := G) (K := K)) + +/-- The componentwise coefficient action on the associated graded ring. -/ +instance cantorBendixsonGAlgebra : DirectSum.GAlgebra K (ν).Component where + toFun := (cantorBendixsonLayerScalarHom (G := G) (K := K)).toAddMonoidHom + map_one := map_one (cantorBendixsonLayerScalarHom (G := G) (K := K)) + map_mul k l := by + change GradedMonoid.mk 0 (cantorBendixsonLayerScalarHom (G := G) (k * l)) = _ + rw [map_mul] + exact GradedMonoid.mk_zero_smul _ _ + commutes _ x := DirectSum.GCommSemiring.mul_comm _ x + smul_def k x := GradedMonoid.mk_zero_smul + (cantorBendixsonLayerScalarHom (G := G) k) x.2 + +/-- The associated graded ring as an algebra over its coefficient field. -/ +instance cantorBendixsonAlgebra : Algebra K (ν).AssociatedGraded := inferInstance + +/-- Coefficients embed in grade zero. -/ +@[simp] +theorem cantorBendixson_algebraMap_apply (k : K) : + algebraMap K (ν).AssociatedGraded k = + DirectSum.of (ν).Component 0 (cantorBendixsonLayerScalarHom (G := G) k) := + DirectSum.algebraMap_apply K (ν).Component k + +/-- The graded derivation vanishes on the coefficient field. -/ +theorem cantorBendixsonGradedDerivation_algebraMap (k : K) : + cantorBendixsonGradedDerivation + (algebraMap K (ν).AssociatedGraded k) = 0 := by + rw [cantorBendixson_algebraMap_apply, cantorBendixsonGradedDerivation_of, + cantorBendixsonHomogeneousDerivation_limit 0 NatOrdinal.constantCoeff_zero, + AddMonoidHom.zero_apply] + +private def cantorBendixsonDerivationLinearMap : + (ν).AssociatedGraded →ₗ[K] + Filter.Germ (𝓝[<] (0 : G)) (ν).AssociatedGraded where + toFun := cantorBendixsonGradedDerivation + map_add' := map_add cantorBendixsonGradedDerivation + map_smul' k x := by + rw [Algebra.smul_def, cantorBendixsonGradedDerivation_mul, + cantorBendixsonGradedDerivation_algebraMap, zero_mul, zero_add] + generalize cantorBendixsonGradedDerivation x = f + induction f using Filter.Germ.inductionOn with + | h f => + rw [← Filter.Germ.coe_smul] + exact Filter.EventuallyEq.germ_eq (Filter.Eventually.of_forall fun γ ↦ by + change algebraMap K (ν).AssociatedGraded k * f γ = k • f γ + rw [Algebra.smul_def]) + +private theorem cantorBendixsonDerivationLinearMap_apply (x : (ν).AssociatedGraded) : + cantorBendixsonDerivationLinearMap x = cantorBendixsonGradedDerivation x := (rfl) + +private theorem germ_smul_eq_const_mul + (x : (ν).AssociatedGraded) + (f : Filter.Germ (𝓝[<] (0 : G)) (ν).AssociatedGraded) : + x • f = (x : Filter.Germ (𝓝[<] (0 : G)) (ν).AssociatedGraded) * f := by + induction f using Filter.Germ.inductionOn with + | h f => rfl + +/-- The translated-truncation map as a derivation on the associated graded ring. -/ +def cantorBendixsonDerivation : + Derivation K (ν).AssociatedGraded + (Filter.Germ (𝓝[<] (0 : G)) (ν).AssociatedGraded) := + Derivation.mk' cantorBendixsonDerivationLinearMap fun x y => by + rw [cantorBendixsonDerivationLinearMap_apply, + cantorBendixsonGradedDerivation_mul] + rw [germ_smul_eq_const_mul, germ_smul_eq_const_mul] + ac_rfl + +/-- The derivation has the same values as the additive translated-truncation map. -/ +@[simp] +theorem cantorBendixsonDerivation_apply (x : (ν).AssociatedGraded) : + cantorBendixsonDerivation x = cantorBendixsonGradedDerivation x := (rfl) + +/-- The derivation is injective on every successor homogeneous component. -/ +theorem cantorBendixsonDerivation_injective_on_successor (α : NatOrdinal.{u}) : + Function.Injective (fun a : (ν).Component (α + 1) ↦ + cantorBendixsonDerivation + (DirectSum.of (ν).Component (α + 1) a)) := + cantorBendixsonGradedDerivation_injective_on_successor α + +/-- The Cantor–Bendixson derivation lowers successor degrees, vanishes on degrees that are limit +ordinals, and is +injective on successor grades. -/ +theorem cantorBendixson_isLoweringDerivation : + GermPolynomial.IsLoweringDerivation + (DirectSum.rangeLof K (ν).Component) + (cantorBendixsonDerivation (G := G) (K := K)) where + mem_lower {α} hα {x} hx := by + obtain ⟨a, rfl⟩ := (DirectSum.mem_rangeLof_iff K (ν).Component α x).mp hx + rw [DirectSum.lof_eq_of] + have hsucc : α.removeNat 1 + 1 = α := by + simpa only [Nat.cast_one] using NatOrdinal.removeNat_add_natCast hα + let a' : (ν).Component (α.removeNat 1 + 1) := + AddEquiv.cast (M := (ν).Component) hsucc.symm a + have ha' : DirectSum.of (ν).Component (α.removeNat 1 + 1) a' = + DirectSum.of (ν).Component α a := by + apply DirectSum.of_eq_of_gradedMonoid_eq + apply Sigma.ext hsucc + change a' ≍ a + exact cast_heq (congrArg (ν).Component hsucc.symm) a + rw [← ha', GermPolynomial.mem_germSubmodule_iff] + have hf : cantorBendixsonDerivation + (DirectSum.of (ν).Component (α.removeNat 1 + 1) a') = + Filter.Germ.map (DirectSum.of (ν).Component (α.removeNat 1)) + (cantorBendixsonLayerDeriv (α.removeNat 1) a') := by + induction a' using MaxAddDegree.componentInductionOn with + | H b => + change cantorBendixsonGradedDerivation + (DirectSum.of (ν).Component (α.removeNat 1 + 1) + ((ν).componentMk (α.removeNat 1 + 1) b)) = _ + rw [← (ν).homogeneousMk_apply, + cantorBendixsonGradedDerivation_homogeneousMk_succ _ rfl, + cantorBendixsonLayerDeriv_componentMk] + rfl + rw [hf] + induction cantorBendixsonLayerDeriv (α.removeNat 1) a' using Filter.Germ.inductionOn with + | h f => + rw [Filter.Germ.map_coe, Filter.Germ.liftPred_coe] + exact Filter.Eventually.of_forall fun t ↦ + DirectSum.of_mem_rangeLof K (ν).Component _ (f t) + eq_zero {α} hα {x} hx := by + obtain ⟨a, rfl⟩ := (DirectSum.mem_rangeLof_iff K (ν).Component α x).mp hx + rw [DirectSum.lof_eq_of] + change cantorBendixsonGradedDerivation (DirectSum.of (ν).Component α a) = 0 + rw [cantorBendixsonGradedDerivation_of, + cantorBendixsonHomogeneousDerivation_limit α hα, AddMonoidHom.zero_apply] + injective {α} hα {x} hx hx0 := by + obtain ⟨a, rfl⟩ := (DirectSum.mem_rangeLof_iff K (ν).Component α x).mp hx + rw [DirectSum.lof_eq_of] at hx0 ⊢ + have hsucc : α.removeNat 1 + 1 = α := by + simpa only [Nat.cast_one] using NatOrdinal.removeNat_add_natCast hα + let a' : (ν).Component (α.removeNat 1 + 1) := + AddEquiv.cast (M := (ν).Component) hsucc.symm a + have ha' : DirectSum.of (ν).Component (α.removeNat 1 + 1) a' = + DirectSum.of (ν).Component α a := by + apply DirectSum.of_eq_of_gradedMonoid_eq + apply Sigma.ext hsucc + change a' ≍ a + exact cast_heq (congrArg (ν).Component hsucc.symm) a + rw [← ha'] at hx0 ⊢ + have ha0 : a' = 0 := + cantorBendixsonDerivation_injective_on_successor (α.removeNat 1) (by simpa using hx0) + rw [ha0, map_zero] + +/-- The internal grade-zero component consists exactly of coefficient scalars. -/ +theorem cantorBendixson_gradeZeroScalars : + GermPolynomial.GradeZeroScalars (DirectSum.rangeLof K (ν).Component) := by + rw [GermPolynomial.gradeZeroScalars_iff] + intro x hx + obtain ⟨a, rfl⟩ := + (DirectSum.mem_rangeLof_iff K (ν).Component 0 x).mp hx + rw [DirectSum.lof_eq_of] + obtain ⟨k, hk⟩ := cantorBendixsonLayerScalarHom_surjective (G := G) (K := K) a + refine ⟨k, ?_⟩ + rw [cantorBendixson_algebraMap_apply, hk] + +/-- Every minimal homogeneous system in the finite-degree components is algebraically +independent over the coefficient field. -/ +theorem cantorBendixson_minimalSystem_aeval_injective + {ι : Type w} (wt : ι → ℕ) (x : ι → (ν).AssociatedGraded) + (hx : GermPolynomial.IsMinimalSystem + (DirectSum.rangeLof K (ν).Component) wt x) : + Function.Injective (MvPolynomial.aeval x : + MvPolynomial ι K →ₐ[K] (ν).AssociatedGraded) := by + classical + let : Nontrivial ((ν).Component 0) := + Function.Injective.nontrivial + (cantorBendixsonLayerScalarHom_injective (G := G) (K := K)) + let : Nontrivial (ν).AssociatedGraded := + Function.Injective.nontrivial (DirectSum.of_injective 0) + have hc := hx.isHomogeneousCoordinates cantorBendixson_gradeZeroScalars + exact hc.aeval_injective cantorBendixson_isLoweringDerivation + +/-- An ordinal minimal system generates the associated graded ring of the Cantor–Bendixson +degree. -/ +theorem cantorBendixson_ordinalMinimalSystem_aeval_surjective + {ι : Type w} (wt : ι → NatOrdinal.{u}) + (x : ι → (ν).AssociatedGraded) + (hx : OrdinalGraded.IsMinimalSystem + (DirectSum.rangeLof K (ν).Component) wt x) : + Function.Surjective (MvPolynomial.aeval x : + MvPolynomial ι K →ₐ[K] (ν).AssociatedGraded) := + hx.aeval_surjective cantorBendixson_gradeZeroScalars + +/-- Every ordinal minimal system has pointwise polynomial representatives for the +Cantor–Bendixson derivative of each generator. -/ +theorem cantorBendixson_ordinalMinimalSystem_exists_derivativeRep + {ι : Type w} (wt : ι → NatOrdinal.{u}) + (x : ι → (ν).AssociatedGraded) + (hx : OrdinalGraded.IsMinimalSystem + (DirectSum.rangeLof K (ν).Component) wt x) : + ∃ g : ι → G → MvPolynomial ι K, + OrdinalGraded.DerivativeRep wt x + (cantorBendixsonDerivation (G := G) (K := K)) g := + OrdinalGraded.IsMinimalSystem.exists_derivativeRep hx cantorBendixson_isLoweringDerivation + cantorBendixson_gradeZeroScalars + +end HahnSeries.Nonpositive diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/ScalarLeadingCoefficientAtLimitOrdinal.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/ScalarLeadingCoefficientAtLimitOrdinal.lean new file mode 100644 index 0000000000..650ad3fc8d --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/ScalarLeadingCoefficientAtLimitOrdinal.lean @@ -0,0 +1,239 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.LimitOrdinalEvaluation +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.TruncationPolynomial +import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.GradedRing.OrdinalGenerators + +/-! +# Scalar leading coefficients when the degree is a limit ordinal + +When the leading coefficient in a maximal variable is a nonzero scalar, the coefficient one +below the top combines with the derivative contribution from the leading power. The resulting +nonzero homogeneous polynomial has the maximal variable's weight. The finite convolution formula +then contradicts the degrees of sufficiently late translated truncations. +-/ + +universe u v w + +open scoped NatOrdinal Topology + +open Filter MvPolynomial HahnSeries HahnSeries.Nonpositive + +public noncomputable section + +namespace HahnSeries.Germ + +variable {G : Type u} {K : Type v} +variable [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [UniformSpace G] [IsUniformAddGroup G] [OrderTopology G] [Nontrivial G] [CompleteSpace G] + [Field K] [CharZero K] + +local notation "ν" => (cantorBendixsonDegreeValuation (G := G) (R := K)) + +variable {ι : Type w} {wt : ι → NatOrdinal.{u}} + {xg : ι → (cantorBendixsonDegreeValuation (G := G) (R := K)).AssociatedGraded} +variable (σ : LiftFamily wt xg) +variable (hx : OrdinalGraded.IsMinimalSystem + (DirectSum.rangeLof K (cantorBendixsonDegreeValuation (G := G) (R := K)).Component) wt xg) + +include hx in +open Classical in +/-- The first limit configuration is impossible when its leading coefficient has weighted degree +zero. -/ +theorem false_of_aeval_eq_zero_of_leadingCoefficientDegree_eq_zero + (hσ : LiftFamily.HasLowerTruncationDegrees σ) {α : NatOrdinal.{u}} + (hinj : ∀ β < α, OrdinalGraded.InjectiveAt K wt xg β) + {F : MvPolynomial ι K} (hF : IsWeightedHomogeneous wt F α) + (hF0 : aeval xg F = 0) {B₀ : ι} (hB₀ : B₀ ∈ F.vars) + (hmax : ∀ i ∈ F.vars, wt i ≤ wt B₀) (hg : wt B₀ < α) + {degHD : NatOrdinal.{u}} (hdegHD : degHD + degreeOf B₀ F • wt B₀ = α) + (hdegHD0 : degHD = 0) : False := by + classical + obtain ⟨D, hDdef⟩ : ∃ D, degreeOf B₀ F = D := ⟨_, rfl⟩ + rw [hDdef, hdegHD0, zero_add] at hdegHD + have hD : 1 ≤ D := by + rw [← hDdef] + exact Nat.one_le_iff_ne_zero.mpr (mem_vars_iff_degreeOf_ne_zero.mp hB₀) + have hD2 : 2 ≤ D := by + by_contra h + have hD1 : D = 1 := by omega + rw [hD1, one_smul] at hdegHD + exact hg.ne hdegHD + obtain ⟨D', rfl⟩ : ∃ D', D = D' + 1 := ⟨D - 1, by omega⟩ + have hD'1 : 1 ≤ D' := by omega + have hFkmem : ∀ k, xCoeff B₀ k F ∈ supported K {B₀}ᶜ := fun k ↦ + xCoeff_mem_supported B₀ k F + have hFkvars : ∀ k, ∀ i ∈ (xCoeff B₀ k F).vars, wt i ≤ wt B₀ := fun k i hi ↦ + hmax i (vars_xCoeff_subset B₀ k F hi) + have hαk : ∀ k ≤ D' + 1, ((D' + 1 - k) • wt B₀) + k • wt B₀ = α := by + intro k hk + rw [← add_nsmul, Nat.sub_add_cancel hk] + exact hdegHD + have hFkhom : ∀ k ≤ D' + 1, + IsWeightedHomogeneous wt (xCoeff B₀ k F) ((D' + 1 - k) • wt B₀) := + fun k hk ↦ xCoeff_isWeightedHomogeneous' B₀ wt hF k (hαk k hk) + have hFne : F ≠ 0 := by + rintro rfl + simp at hB₀ + have hFD : xCoeff B₀ (D' + 1) F ≠ 0 := by + rw [← hDdef] + exact xCoeff_degreeOf_ne_zero B₀ hFne + have hFDhom : IsWeightedHomogeneous wt (xCoeff B₀ (D' + 1) F) 0 := by + have h := hFkhom (D' + 1) le_rfl + rwa [Nat.sub_self, zero_smul] at h + have hFDC : xCoeff B₀ (D' + 1) F = + MvPolynomial.C ((xCoeff B₀ (D' + 1) F).coeff 0) := + OrdinalGraded.eq_C_of_isWeightedHomogeneous_zero hx.ne_zero hFDhom + let c := (xCoeff B₀ (D' + 1) F).coeff 0 + have hc0 : c ≠ 0 := fun hc ↦ hFD (by + rw [hFDC] + change MvPolynomial.C c = 0 + rw [hc, map_zero]) + have hDc : ((D' + 1 : ℕ) : K) * c ≠ 0 := + mul_ne_zero (Nat.cast_ne_zero.mpr (by omega)) hc0 + let hpoly := xCoeff B₀ D' F + + MvPolynomial.C (((D' + 1 : ℕ) : K) * c) * X B₀ + have hFD'hom : IsWeightedHomogeneous wt (xCoeff B₀ D' F) (wt B₀) := by + have h := hFkhom D' (by omega) + rwa [Nat.add_sub_cancel_left, one_smul] at h + have hhhom : IsWeightedHomogeneous wt hpoly (wt B₀) := by + refine hFD'hom.add ?_ + have h := (isWeightedHomogeneous_C wt (((D' + 1 : ℕ) : K) * c)).mul + (isWeightedHomogeneous_X K wt B₀) + rwa [zero_add] at h + have hhne : hpoly ≠ 0 := by + intro h + have hc := congrArg (fun p : MvPolynomial ι K ↦ p.coeff (Finsupp.single B₀ 1)) h + rw [AddMonoidAlgebra.coeff_add, Finsupp.add_apply, MvPolynomial.coeff_C_mul, + MvPolynomial.coeff_X, + ite_eq_left rfl, mul_one, AddMonoidAlgebra.coeff_zero] at hc + have hleft : (xCoeff B₀ D' F).coeff (Finsupp.single B₀ 1) = 0 := by + by_contra hne + exact (mem_supported.mp (hFkmem D')) + ((mem_vars_iff_mem_support B₀).mpr + ⟨Finsupp.single B₀ 1, mem_support_iff.mpr hne, by simp⟩) rfl + rw [hleft, zero_add] at hc + exact hDc hc + have hdegree : ν (aeval σ.lift hpoly) = (wt B₀ : WithBot NatOrdinal) := by + have hrep := σ.represents_aeval hhhom + have hgrade : aeval xg hpoly ≠ 0 := by + intro hzero + exact hhne (((OrdinalGraded.injectiveAt_iff (wt B₀)).mp (hinj _ hg)) + hpoly hhhom hzero) + exact hrep.degree_eq hgrade + have hterm : ∀ k ≤ D' + 1, HasLowerTruncationDegree + (σ.lift B₀ ^ k * aeval σ.lift (xCoeff B₀ k F)) + (k • wt B₀ + (D' + 1 - k) • wt B₀) := by + intro k hk + exact (((LiftFamily.hasLowerTruncationDegrees_iff σ).mp hσ B₀).pow k).mul rfl + (σ.hasLowerTruncationDegree_aeval hσ (hFkhom k hk)) + have hGexp : aeval σ.lift F = ∑ k ∈ Finset.range (D' + 2), + σ.lift B₀ ^ k * aeval σ.lift (xCoeff B₀ k F) := by + conv_lhs => rw [← sum_xCoeff_mul_X_pow B₀ F] + rw [hDdef, map_sum] + refine Finset.sum_congr rfl fun k _ ↦ ?_ + rw [map_mul, map_pow, aeval_X, mul_comm] + have hα0 : α ≠ 0 := ne_of_gt ((zero_le : (0 : NatOrdinal) ≤ wt B₀).trans_lt hg) + obtain ⟨bound, hboundα, hcuts⟩ := + exists_lt_forall_degree_translatedTruncLE_lt σ hα0 hF hF0 + obtain ⟨l, hl0, hcuts'⟩ := eventually_nhdsLT_iff_exists.mp hcuts + have hcoeffD' : ∀ γ : G, γ < 0 → + xCoeff B₀ D' (σ.pol hx α (translatedTruncLE γ (aeval σ.lift F))) = + σ.pol hx α (translatedTruncLE γ (aeval σ.lift hpoly)) := by + intro γ hγ + rw [hGexp, map_sum, σ.pol_sum hx hinj _ _ (fun k hk ↦ by + have hkD : k ≤ D' + 1 := Nat.lt_succ_iff.mp (Finset.mem_range.mp hk) + have hdrop := (hterm k hkD).degree_translatedTruncLE_lt hγ + rwa [add_comm, hαk k hkD] at hdrop), map_sum] + rw [Finset.sum_range_succ, Finset.sum_range_succ, + Finset.sum_eq_zero (fun k hk ↦ ?_), zero_add] + · have hfreeD' := LiftFamily.FreeOfVariable.aeval (σ := σ) (hx := hx) hσ hinj hg + hFD'hom hg (hFkmem D') (hFkvars D') + rw [(LiftFamily.FreeOfVariable.xCoeff_pol_translatedTruncLE_lift_pow_mul + (σ := σ) (hx := hx) hσ hinj hg hfreeD' D' (by + rw [add_comm] + rw [← hdegHD, succ_nsmul, add_comm]) hγ).2] + have htopterm : σ.lift B₀ ^ (D' + 1) * + aeval σ.lift (xCoeff B₀ (D' + 1) F) = c • σ.lift B₀ ^ (D' + 1) := by + rw [hFDC, aeval_C, Algebra.smul_def] + change σ.lift B₀ ^ (D' + 1) * algebraMap K (Nonpositive G K) c = + algebraMap K (Nonpositive G K) c * σ.lift B₀ ^ (D' + 1) + exact mul_comm _ _ + have hpowdrop : ν (translatedTruncLE γ (σ.lift B₀ ^ (D' + 1))) < + (α : WithBot NatOrdinal) := by + have h := (((LiftFamily.hasLowerTruncationDegrees_iff σ).mp hσ B₀).pow + (D' + 1)).degree_translatedTruncLE_lt hγ + rwa [hdegHD] at h + rw [htopterm, translatedTruncLE_smul, σ.pol_smul hx hinj c hpowdrop] + rw [(xCoeff B₀ D').map_smul, LiftFamily.FreeOfVariable.xCoeff_pol_translatedTruncLE_lift_pow + (σ := σ) (hx := hx) hσ hinj hg D' hdegHD.le hγ] + rw [smul_eq_C_mul, nsmul_eq_mul, ← C_eq_coe_nat] + have hC : (MvPolynomial.C c : MvPolynomial ι K) * + MvPolynomial.C ((D' + 1 : ℕ) : K) = + MvPolynomial.C (((D' + 1 : ℕ) : K) * c) := by + rw [← map_mul, mul_comm c] + rw [← mul_assoc, hC] + rw [show aeval σ.lift hpoly = aeval σ.lift (xCoeff B₀ D' F) + + (((D' + 1 : ℕ) : K) * c) • σ.lift B₀ by + rw [map_add, map_mul, aeval_C, aeval_X, Algebra.smul_def, + HahnSeries.Nonpositive.algebraMap_apply]] + rw [map_add, translatedTruncLE_smul, σ.pol_add hx hinj, + σ.pol_smul hx hinj, smul_eq_C_mul] + all_goals first + | have hdrop := + HasLowerTruncationDegree.degree_translatedTruncLE_lt + ((LiftFamily.hasLowerTruncationDegrees_iff σ).mp hσ B₀) hγ + exact hdrop.trans (WithBot.coe_lt_coe.mpr hg) + | exact + (σ.hasLowerTruncationDegree_aeval hσ hFD'hom).degree_translatedTruncLE_lt hγ + |>.trans + (WithBot.coe_lt_coe.mpr hg) + | have hdrop := + HasLowerTruncationDegree.degree_translatedTruncLE_lt + ((LiftFamily.hasLowerTruncationDegrees_iff σ).mp hσ B₀) hγ + exact (degree_smul_le _ _).trans_lt (hdrop.trans (WithBot.coe_lt_coe.mpr hg)) + · have hkD' : k < D' := Finset.mem_range.mp hk + have hkD : k ≤ D' + 1 := by omega + rcases Nat.eq_zero_or_pos k with rfl | hk1 + · have hF0hom : IsWeightedHomogeneous wt (xCoeff B₀ 0 F) α := by + have h := hFkhom 0 hkD + rw [Nat.sub_zero, hdegHD] at h + exact h + rw [pow_zero, one_mul, xCoeff_of_mem_supported B₀ + (LiftFamily.FreeOfVariable.pol_translatedTruncLE_aeval_mem_supported + (σ := σ) (hx := hx) hσ hinj hg hF0hom (hFkmem 0) (hFkvars 0) hγ) D', + ite_eq_right (Nat.ne_of_gt hD'1)] + · have hmk : (D' + 1 - k) • wt B₀ < α := by + rw [← hαk k hkD] + exact lt_add_of_pos_right _ + (pos_iff_ne_zero.mpr (NatOrdinal.nsmul_ne_zero_of_ne_zero (hx.ne_zero B₀) hk1)) + have hfreeK := LiftFamily.FreeOfVariable.aeval (σ := σ) (hx := hx) hσ hinj hg + (hFkhom k hkD) hmk (hFkmem k) (hFkvars k) + exact (LiftFamily.FreeOfVariable.xCoeff_pol_translatedTruncLE_lift_pow_mul + (σ := σ) (hx := hx) hσ hinj hg hfreeK k (by + rw [add_comm] + exact (hαk k hkD).le) hγ).1 D' hkD' + have hsep : D' • wt B₀ = 0 ∨ + NatOrdinal.leastTerm (wt B₀) ≤ NatOrdinal.leastTerm (D' • wt B₀) := by + right + rw [NatOrdinal.leastTerm_nsmul (hx.ne_zero B₀) hD'1] + apply σ.false_of_forall_weightedTotalDegree_pol_add_lt hx + (lam := wt B₀) (sigma := D' • wt B₀) (bound := bound) + hdegree (hx.ne_zero B₀) hsep (by + have ha : α = wt B₀ + D' • wt B₀ := by + rw [← hdegHD, succ_nsmul, add_comm] + exact hboundα.trans_eq ha) hl0 + · intro γ hlγ hγ hp0 + rw [← hcoeffD' γ hγ] at hp0 ⊢ + exact LiftFamily.weightedTotalDegree_xCoeff_add_nsmul_lt + (σ.pol_weight_lt_of_degree_lt hx hboundα.le (hcuts' γ hlγ hγ)) B₀ D' hp0 + · exact hg + +end HahnSeries.Germ + +end diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/SeparatedPieceCantorBendixson.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/SeparatedPieceCantorBendixson.lean new file mode 100644 index 0000000000..c8c4a97dfc --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/SeparatedPieceCantorBendixson.lean @@ -0,0 +1,274 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.SeparatedPieceSum +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.Derivative +public import LeanPool.ConwayRefinement.ConwayRefinement.Topology.Order.SeparatedPieceFamily +import Mathlib.Topology.DerivedSet + +/-! +# Cantor–Bendixson ranks of sums on separated pieces + +Hahn series carried by pairwise disjoint ordered open convex pieces, each bounded above by a +center inside its own piece, combine into one Hahn sum. Inside a piece the weak truncation of the +sum differs from the truncation of that piece only at or below any piece element under the cutoff, +so their local germs agree. When the centers accumulate nowhere, the Cantor–Bendixson ranks of the +summed supports are bounded by the piece stages: no successor loss occurs anywhere, including at +zero. This supplies the rank bound used by the well-founded cofactor induction at arbitrary +cofinality. +-/ + +public noncomputable section + +open Set Filter Topology TopologicalSpace +open scoped NatOrdinal + +universe u v w + +namespace HahnSeries + +variable {G : Type u} {K : Type v} [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + +section Locality + +variable [AddCommGroup K] + +omit [AddCommGroup G] [IsOrderedAddMonoid G] in +/-- Inside a piece, the weak truncation of the sum differs from the truncation of that piece +only at or below any element of the piece below the cutoff. -/ +theorem support_truncLE_separatedHsum_sub_piece_subset + {X : Type w} [LinearOrder X] (hX : (Set.univ : Set X).IsPWO) + (C : X → Set G) (f : X → K⟦G⟧) + (hfC : ∀ x, (f x).support ⊆ C x) + (hord : ∀ x y : X, x < y → ∀ a ∈ C x, ∀ b ∈ C y, a < b) + (hsep : ∀ i j, i < j → ∀ a ∈ (f i).support, ∀ b ∈ (f j).support, a < b) + (x : X) {y : G} (hy : y ∈ C x) {c : G} (hc : c ∈ C x) : + (truncLE y (separatedHsum hX f hsep) - truncLE y (f x)).support ⊆ Iic c := by + intro g hg + rw [mem_support] at hg + by_contra hgc + apply hg + rw [HahnSeries.coeff_sub, HahnSeries.coeff_truncLE, HahnSeries.coeff_truncLE] + by_cases hgy : g ≤ y + · rw [ite_eq_left hgy, ite_eq_left hgy, coeff_separatedHsum_eq hX f hsep x g ?_, sub_self] + intro j hji hgj + have hgCj : g ∈ C j := hfC j hgj + rcases lt_or_gt_of_ne hji with hj | hj + · exact hgc ((hord j x hj g hgCj c hc).le) + · exact absurd (hord x j hj y hy g hgCj) (not_lt.mpr hgy) + · rw [ite_eq_right hgy, ite_eq_right hgy, sub_self] + +omit [AddCommGroup G] [IsOrderedAddMonoid G] in +/-- Removing the part of a series outside a convex piece changes its weak truncations only at or +below any piece element, provided the removed support lies entirely below the piece. -/ +theorem support_truncLE_sub_truncLE_setRestrict_subset + (C : Set G) [DecidablePred (· ∈ C)] (b : K⟦G⟧) (y : G) {c : G} + (hb : ∀ p ∈ b.support, p ∉ C → p ≤ y → p ≤ c) : + (truncLE y b - truncLE y (setRestrict C b)).support ⊆ Iic c := by + intro g hg + rw [mem_support] at hg + by_contra hgc + apply hg + rw [HahnSeries.coeff_sub, HahnSeries.coeff_truncLE, HahnSeries.coeff_truncLE, + coeff_setRestrict] + by_cases hgy : g ≤ y + · rw [ite_eq_left hgy, ite_eq_left hgy] + by_cases hgC : g ∈ C + · rw [ite_eq_left hgC, sub_self] + · rw [ite_eq_right hgC] + have hgb : g ∉ b.support := fun hgb ↦ hgc (hb g hgb hgC hgy) + rw [not_not.mp fun h ↦ hgb ((mem_support _ _).mpr h), sub_zero] + · rw [ite_eq_right hgy, ite_eq_right hgy, sub_self] + +open Classical in +/-- Inside a piece, translating the difference between the truncated sum and the truncated +source moves its support below the corresponding translated piece element. -/ +theorem support_translate_truncLE_separatedHsum_sub_source_subset + {X : Type w} [LinearOrder X] (hX : (Set.univ : Set X).IsPWO) + (C : X → Set G) (f : X → K⟦G⟧) + (hfC : ∀ x, (f x).support ⊆ C x) + (hord : ∀ x y : X, x < y → ∀ a ∈ C x, ∀ b ∈ C y, a < b) + (hsep : ∀ i j, i < j → ∀ a ∈ (f i).support, ∀ b ∈ (f j).support, a < b) + (x : X) {y c : G} (hy : y ∈ C x) (hc : c ∈ C x) + (b : K⟦G⟧) (hpiece : f x = setRestrict (C x) b) + (hb : ∀ p ∈ b.support, p ∉ C x → p ≤ y → p ≤ c) : + (translate (-y) (truncLE y (separatedHsum hX f hsep)) - + translate (-y) (truncLE y b)).support ⊆ Iic (c - y) := by + rw [← map_sub, support_translate] + rintro _ ⟨q, hq, rfl⟩ + have hsplit : truncLE y (separatedHsum hX f hsep) - truncLE y b = + (truncLE y (separatedHsum hX f hsep) - truncLE y (f x)) - + (truncLE y b - truncLE y (setRestrict (C x) b)) := by + rw [hpiece] + exact (sub_sub_sub_cancel_right _ _ _).symm + have hq1 := support_truncLE_separatedHsum_sub_piece_subset hX C f hfC hord hsep x hy hc + have hq2 := support_truncLE_sub_truncLE_setRestrict_subset (C x) b y hb + rw [hsplit, sub_eq_add_neg] at hq + rcases support_add_subset _ _ hq with h | h + · exact mem_Iic.mpr (by + have := hq1 h + simpa only [mem_Iic, sub_eq_add_neg, add_comm] using sub_le_sub_right this y) + · rw [support_neg] at h + exact mem_Iic.mpr (by + have := hq2 h + simpa only [mem_Iic, sub_eq_add_neg, add_comm] using sub_le_sub_right this y) + +end Locality + +section ConvexClosure + +variable [TopologicalSpace G] [OrderTopology G] + +omit [AddCommGroup G] [IsOrderedAddMonoid G] in +/-- The closure of a partially well-ordered subset of a convex piece bounded by a piece element +stays inside the piece: well-ordered sets accumulate only from below. -/ +theorem closure_subset_of_isPWO_of_ordConnected {C : Set G} (hC : C.OrdConnected) + {s : Set G} (hs : s.IsPWO) (hsC : s ⊆ C) + {x : G} (hx : x ∈ C) (hsx : ∀ p ∈ s, p ≤ x) : + closure s ⊆ C := by + intro z hz + have hzx : z ≤ x := closure_minimal (fun p hp ↦ hsx p hp) isClosed_Iic hz + obtain ⟨p, hps, hpz⟩ := ((mem_closure_iff_frequently.mp hz).and_eventually + (hs.eventually_le z)).exists + exact hC.out (hsC hps) hx ⟨hpz hps, hzx⟩ + +end ConvexClosure + +section Rank + +variable [TopologicalSpace G] [OrderTopology G] [NoMinOrder G] [NoMaxOrder G] [AddCommGroup K] + +omit [AddCommGroup G] [IsOrderedAddMonoid G] in +/-- With nowhere-accumulating centers, the Cantor–Bendixson ranks of the summed supports are +bounded by the piece stages: at most the stage everywhere, and strictly below it away from the +centers. -/ +theorem cantorBendixsonRank_separatedHsum_bounds + {X : Type w} [LinearOrder X] (hX : (Set.univ : Set X).IsPWO) + (C : X → Set G) (cen : X → G) (f : X → K⟦G⟧) + (hfC : ∀ x, (f x).support ⊆ C x) + (hfle : ∀ x, ∀ p ∈ (f x).support, p ≤ cen x) + (hcen : ∀ x, cen x ∈ C x) + (hCopen : ∀ x, IsOpen (C x)) + (hdisj : ∀ x y : X, x ≠ y → Disjoint (C x) (C y)) + (hord : ∀ x y : X, x < y → ∀ a ∈ C x, ∀ b ∈ C y, a < b) + (hsep : ∀ i j, i < j → ∀ a ∈ (f i).support, ∀ b ∈ (f j).support, a < b) + (hdiscrete : ∀ z : G, ¬ AccPt z (𝓟 (Set.range cen))) + (o : Ordinal.{u}) + (hstage : ∀ x, (((f x).closedSupport).cantorBendixson o : Set G) ⊆ {cen x}) : + (∀ z : G, (separatedHsum hX f hsep).cantorBendixsonRank z ≤ o) ∧ + ∀ z : G, z ∉ Set.range cen → + z ∉ (((separatedHsum hX f hsep).closedSupport).cantorBendixson o : Set G) := by + classical + have hclosure : closure (Set.range cen) = Set.range cen := by + rw [closure_eq_self_union_derivedSet] + have hder : derivedSet (Set.range cen) = ∅ := by + ext z + simp only [mem_derivedSet, Set.mem_empty_iff_false, iff_false] + exact hdiscrete z + rw [hder, Set.union_empty] + have hstage' : ∀ x, ((⟨closure (f x).support, isClosed_closure⟩ : + Closeds G).cantorBendixson o : Set G) ⊆ {cen x} := by + intro x + have he : (f x).closedSupport = (⟨closure (f x).support, isClosed_closure⟩ : Closeds G) := by + apply Closeds.ext + simp only [coe_closedSupport] + rfl + rw [← he] + exact hstage x + have hsupp : (separatedHsum hX f hsep).support = ⋃ x, (f x).support := + support_separatedHsum hX f hsep + have hbclosed : (separatedHsum hX f hsep).closedSupport = + (⟨closure (⋃ x, (f x).support), isClosed_closure⟩ : Closeds G) := by + apply Closeds.ext + simp only [coe_closedSupport, hsupp] + rfl + have hderiv : (((separatedHsum hX f hsep).closedSupport).cantorBendixson o : Set G) ⊆ + Set.range cen := by + rw [hbclosed, ← hclosure] + exact cantorBendixson_separated_iUnion_subset_closure_range + (fun x ↦ (f x).support) C cen (fun x ↦ hfC x) (fun x ↦ hfle x) hcen hCopen + (fun x y hxy ↦ hdisj x y hxy) hord o hstage' + have hnext : (((separatedHsum hX f hsep).closedSupport).cantorBendixson (o + 1) : + Set G) = ∅ := by + rw [Closeds.cantorBendixson_add_one] + apply Set.eq_empty_iff_forall_notMem.mpr + intro z hz + rw [Closeds.coe_derived, mem_derivedSet] at hz + exact hdiscrete z (hz.mono (Filter.principal_mono.mpr hderiv)) + refine ⟨?_, ?_⟩ + · intro z + rw [cantorBendixsonRank_eq] + exact Closeds.cantorBendixsonRank_le_of_notMem _ _ z (by + rw [hnext] + exact Set.notMem_empty z) + · intro z hz hmem + exact hz (hderiv hmem) + +omit [AddCommGroup G] [IsOrderedAddMonoid G] in +/-- **Sums with strict local stages.** If every piece already has an empty stage `o` and the +centers accumulate only at points outside the open region carrying them, then the assembled stage +`o` is carried by that boundary accumulation alone, and the assembled Cantor–Bendixson rank is at +most `o` everywhere. In particular the assembled degree at a boundary accumulation point does not +gain the successor that a nonstrict local bound would cost. -/ +theorem cantorBendixsonRank_separatedHsum_le_of_stage_empty + {X : Type w} [LinearOrder X] (hX : (Set.univ : Set X).IsPWO) + (C : X → Set G) (cen : X → G) (f : X → K⟦G⟧) + (hfC : ∀ x, (f x).support ⊆ C x) + (hfle : ∀ x, ∀ p ∈ (f x).support, p ≤ cen x) + (hcen : ∀ x, cen x ∈ C x) + (hCopen : ∀ x, IsOpen (C x)) + (hdisj : ∀ x y : X, x ≠ y → Disjoint (C x) (C y)) + (hord : ∀ x y : X, x < y → ∀ a ∈ C x, ∀ b ∈ C y, a < b) + (hsep : ∀ i j, i < j → ∀ a ∈ (f i).support, ∀ b ∈ (f j).support, a < b) + (o : Ordinal.{u}) + (hstage : ∀ x, (((f x).closedSupport).cantorBendixson o : Set G) = ∅) + (z₀ : G) (hcl : closure (Set.range cen) ⊆ Set.range cen ∪ {z₀}) : + ∀ z : G, (separatedHsum hX f hsep).cantorBendixsonRank z ≤ o := by + classical + have hstage' : ∀ x, ((⟨closure (f x).support, isClosed_closure⟩ : + Closeds G).cantorBendixson o : Set G) = ∅ := by + intro x + have he : (f x).closedSupport = (⟨closure (f x).support, isClosed_closure⟩ : Closeds G) := by + apply Closeds.ext + simp only [coe_closedSupport] + rfl + rw [← he] + exact hstage x + have hsupp : (separatedHsum hX f hsep).support = ⋃ x, (f x).support := + support_separatedHsum hX f hsep + have hbclosed : (separatedHsum hX f hsep).closedSupport = + (⟨closure (⋃ x, (f x).support), isClosed_closure⟩ : Closeds G) := by + apply Closeds.ext + simp only [coe_closedSupport, hsupp] + rfl + have hderiv : (((separatedHsum hX f hsep).closedSupport).cantorBendixson o : Set G) ⊆ + {z₀} := by + rw [hbclosed] + intro z hz + have hz' := cantorBendixson_separated_iUnion_subset_of_stage_empty + (fun x ↦ (f x).support) C cen (fun x ↦ hfC x) (fun x ↦ hfle x) hcen hCopen + (fun x y hxy ↦ hdisj x y hxy) hord o hstage' hz + rcases hcl hz'.1 with h | h + · exact absurd h hz'.2 + · exact h + have hnext : (((separatedHsum hX f hsep).closedSupport).cantorBendixson (o + 1) : + Set G) = ∅ := by + rw [Closeds.cantorBendixson_add_one] + apply Set.eq_empty_iff_forall_notMem.mpr + intro z hz + rw [Closeds.coe_derived, mem_derivedSet] at hz + have hacc := hz.mono (Filter.principal_mono.mpr hderiv) + exact (Set.finite_singleton z₀).not_infinite (Set.Infinite.of_accPt hacc) + intro z + rw [cantorBendixsonRank_eq] + exact Closeds.cantorBendixsonRank_le_of_notMem _ _ z (by + rw [hnext] + exact Set.notMem_empty z) + +end Rank + +end HahnSeries diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/SuccessorLeibniz.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/SuccessorLeibniz.lean new file mode 100644 index 0000000000..349c318899 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/SuccessorLeibniz.lean @@ -0,0 +1,198 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.Derivative +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.Leibniz +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.FinitePart +import Mathlib.Tactic.Abel + +/-! +# Product rule for translated truncations of homogeneous representatives + +The finite convolution remainder has strictly smaller Cantor–Bendixson rank than the homogeneous +component immediately below a successor product. When both grades are successors, both +translated truncation terms survive in that component. If the second grade has zero finite +Cantor coefficient (including grade zero), its term vanishes there. + +These are eventual equalities in the associated graded ring, retaining arbitrary complete +ordered exponent groups. They use the Cantor–Bendixson convolution bound, not the real-exponent +ordinal-value product theorem. +-/ + +public noncomputable section +open Set Filter Topology +open scoped NatOrdinal +universe u v +namespace HahnSeries.Nonpositive +variable {G : Type u} {R : Type v} [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [UniformSpace G] [IsUniformAddGroup G] [OrderTopology G] [Nontrivial G] [CompleteSpace G] + [CommRing R] [NoZeroDivisors R] [CharZero R] + +local notation "ν" => (cantorBendixsonDegreeValuation (G := G) (R := R)) + +private theorem value_le_wpow_of_degree_le (b : Nonpositive G R) (α : NatOrdinal.{u}) + (hb : ν b ≤ α) : cantorBendixsonValuation b ≤ ω^ α := by + by_cases hm : 0 ∈ (b : HahnSeries G R).closedSupport + · rw [cantorBendixsonDegreeValuation_of_mem _ hm, WithBot.coe_le_coe] at hb + rw [cantorBendixsonValuation_apply, + cantorBendixsonValue_of_mem _ ((mem_closedSupport _ _).mp hm), + NatOrdinal.of_omega0_opow] + exact NatOrdinal.wpow_le_wpow.mpr hb + · rw [cantorBendixsonValuation_apply, + cantorBendixsonValue_of_notMem _ (by simpa only [mem_closedSupport] using hm), + NatOrdinal.of_zero] + exact zero_le + +/-- The translated product remainder lies strictly below the lowered product degree near zero. -/ +theorem eventually_degree_leibnizRemainder_lt (b c : Nonpositive G R) + (α β : NatOrdinal.{u}) (hb : ν b ≤ (α + 1 : NatOrdinal)) (hc : ν c ≤ β) : + ∀ᶠ γ in 𝓝[<] (0 : G), + ν (translatedTruncLE γ (b * c) - translatedTruncLE γ b * c - + b * translatedTruncLE γ c) < (α + β : NatOrdinal) := by + have h := eventually_cantorBendixsonValue_leibnizRemainder_lt_of_le_wpow + (b : HahnSeries G R) c b.property c.property α β + (by simpa only [cantorBendixsonValuation_apply] using value_le_wpow_of_degree_le b _ hb) + (by simpa only [cantorBendixsonValuation_apply] using value_le_wpow_of_degree_le c _ hc) + filter_upwards [h] with γ hγ + rw [cantorBendixsonDegreeValuation_apply, cantorBendixsonValuation_apply, + NatOrdinal.cantorDegree_lt_coe_iff] + change NatOrdinal.of (((translatedTruncLE γ (b * c) : HahnSeries G R) - + (translatedTruncLE γ b : HahnSeries G R) * c - + (b : HahnSeries G R) * translatedTruncLE γ c)).cantorBendixsonValue < _ + simpa only [coe_translatedTruncLE, Subring.coe_mul] using hγ + +private theorem homogeneousMk_eq_add_of_sub_sub_lt (δ : NatOrdinal.{u}) + (a b c : (ν).filtrationLE δ) + (h : ν ((a : Nonpositive G R) - b - c) < δ) : + (ν).homogeneousMk δ a = (ν).homogeneousMk δ b + (ν).homogeneousMk δ c := by + rw [← map_add, (ν).homogeneousMk_apply, (ν).homogeneousMk_apply] + apply congrArg (DirectSum.of (ν).Component δ) + apply ((ν).componentMk_eq_componentMk_iff _ _ _).mpr + simpa only [AddSubgroup.coe_add, sub_add_eq_sub_sub] using h + +private theorem homogeneousMk_congr {α β : NatOrdinal.{u}} (h : α = β) + (a : (ν).filtrationLE α) (b : (ν).filtrationLE β) + (hab : (a : Nonpositive G R) = b) : + (ν).homogeneousMk α a = (ν).homogeneousMk β b := by + subst β + exact congrArg ((ν).homogeneousMk α) (Subtype.ext hab) + +/-- Both successor factors contribute to the homogeneous product rule near zero. -/ +theorem eventually_homogeneousDerivAt_mul_succ (α β : NatOrdinal.{u}) + (b : (ν).filtrationLE (α + 1)) (c : (ν).filtrationLE (β + 1)) : + ∀ᶠ γ in 𝓝[<] (0 : G), + DirectSum.of (ν).Component (α + β + 1) + (cantorBendixsonDerivAt (α + β + 1) ((b : Nonpositive G R) * c) γ) = + DirectSum.of (ν).Component α (cantorBendixsonDerivAt α b γ) * + (ν).homogeneousMk (β + 1) c + + (ν).homogeneousMk (α + 1) b * + DirectSum.of (ν).Component β (cantorBendixsonDerivAt β c γ) := by + have hb := ((ν).mem_filtrationLE_iff _ _).mp b.property + have hc := ((ν).mem_filtrationLE_iff _ _).mp c.property + have hbc : ν ((b : Nonpositive G R) * c) ≤ (α + β + 1 + 1 : NatOrdinal) := by + have h := MaxAddDegree.degree_mul_le_add hb hc + simpa only [← WithBot.coe_add, add_assoc, add_left_comm, add_comm] using h + filter_upwards [eventually_degree_translatedTruncLE_le (b : Nonpositive G R) α hb, + eventually_degree_translatedTruncLE_le (c : Nonpositive G R) β hc, + eventually_degree_translatedTruncLE_le ((b : Nonpositive G R) * (c : Nonpositive G R)) + (α + β + 1) hbc, + eventually_degree_leibnizRemainder_lt (b : Nonpositive G R) (c : Nonpositive G R) + α (β + 1) hb hc] + with γ hbg hcg hbcg hrem + rw [cantorBendixsonDerivAt_eq _ _ _ hbg, cantorBendixsonDerivAt_eq _ _ _ hcg, + cantorBendixsonDerivAt_eq _ _ _ hbcg, ← (ν).homogeneousMk_apply, + ← (ν).homogeneousMk_apply, ← (ν).homogeneousMk_apply, + (ν).homogeneousMk_mul, (ν).homogeneousMk_mul] + let x : (ν).filtrationLE (α + β + 1) := + ⟨translatedTruncLE γ (b : Nonpositive G R) * (c : Nonpositive G R), + ((ν).mem_filtrationLE_iff _ _).mpr (by + simpa only [← WithBot.coe_add, add_assoc] using MaxAddDegree.degree_mul_le_add hbg hc)⟩ + let y : (ν).filtrationLE (α + β + 1) := + ⟨(b : Nonpositive G R) * translatedTruncLE γ (c : Nonpositive G R), + ((ν).mem_filtrationLE_iff _ _).mpr (by + simpa only [← WithBot.coe_add, add_assoc, add_left_comm, add_comm] using + MaxAddDegree.degree_mul_le_add hb hcg)⟩ + have hx : (ν).homogeneousMk (α + (β + 1)) + ((ν).mulFiltrationLE ⟨translatedTruncLE γ (b : Nonpositive G R), + ((ν).mem_filtrationLE_iff _ _).mpr hbg⟩ c) = + (ν).homogeneousMk (α + β + 1) x := + homogeneousMk_congr (by ac_rfl) _ _ (by rw [(ν).coe_mulFiltrationLE]) + have hy : (ν).homogeneousMk (α + 1 + β) + ((ν).mulFiltrationLE b ⟨translatedTruncLE γ (c : Nonpositive G R), + ((ν).mem_filtrationLE_iff _ _).mpr hcg⟩) = + (ν).homogeneousMk (α + β + 1) y := + homogeneousMk_congr (by ac_rfl) _ _ (by rw [(ν).coe_mulFiltrationLE]) + rw [hx, hy] + apply homogeneousMk_eq_add_of_sub_sub_lt + simpa only [add_assoc] using hrem + +private theorem add_succ_lt_add_of_constantCoeff_eq_zero + (α : NatOrdinal.{u}) {β β' : NatOrdinal.{u}} + (hβ : β.constantCoeff = 0) (hlt : β' < β) : α + 1 + β' < α + β := by + have h := ((NatOrdinal.isSuccPrelimit_iff_constantCoeff_eq_zero β).mpr hβ).add_one_lt hlt + simpa only [add_assoc, add_left_comm, add_comm] using add_lt_add_left h α + +/-- A factor with zero finite Cantor coefficient contributes no term in the lowered degree. -/ +theorem eventually_degree_mul_translatedTruncLE_lt_limit (α β : NatOrdinal.{u}) + (hβ : β.constantCoeff = 0) (b c : Nonpositive G R) + (hb : ν b ≤ (α + 1 : NatOrdinal)) (hc : ν c ≤ β) : + ∀ᶠ γ in 𝓝[<] (0 : G), + ν (b * translatedTruncLE γ c) < (α + β : NatOrdinal) := by + filter_upwards [eventually_degree_translatedTruncLE_lt c β hc] with γ hγ + have hm := (ν).map_mul_le_add b (translatedTruncLE γ c) + cases he : ν (translatedTruncLE γ c) using WithBot.recBotCoe with + | bot => + rw [he, WithBot.add_bot] at hm + exact hm.trans_lt (WithBot.bot_lt_coe _) + | coe β' => + have hlt : β' < β := by simpa only [he, WithBot.coe_lt_coe] using hγ + apply hm.trans_lt + have hle := add_le_add hb (le_rfl : (↑β' : WithBot NatOrdinal) ≤ ↑β') + rw [he] + apply hle.trans_lt + rw [← WithBot.coe_add, WithBot.coe_lt_coe] + exact add_succ_lt_add_of_constantCoeff_eq_zero α hβ hlt + +/-- If the second grade is zero or a limit, only the first truncation term survives. -/ +theorem eventually_homogeneousDerivAt_mul_limit (α β : NatOrdinal.{u}) + (hβ : β.constantCoeff = 0) + (b : (ν).filtrationLE (α + 1)) (c : (ν).filtrationLE β) : + ∀ᶠ γ in 𝓝[<] (0 : G), + DirectSum.of (ν).Component (α + β) + (cantorBendixsonDerivAt (α + β) ((b : Nonpositive G R) * (c : Nonpositive G R)) γ) = + DirectSum.of (ν).Component α (cantorBendixsonDerivAt α b γ) * + (ν).homogeneousMk β c := by + have hb := ((ν).mem_filtrationLE_iff _ _).mp b.property + have hc := ((ν).mem_filtrationLE_iff _ _).mp c.property + have hbc : ν ((b : Nonpositive G R) * (c : Nonpositive G R)) ≤ (α + β + 1 : NatOrdinal) := by + have h := MaxAddDegree.degree_mul_le_add hb hc + simpa only [← WithBot.coe_add, add_assoc, add_left_comm, add_comm] using h + filter_upwards [eventually_degree_translatedTruncLE_le (b : Nonpositive G R) α hb, + eventually_degree_translatedTruncLE_le ((b : Nonpositive G R) * (c : Nonpositive G R)) + (α + β) hbc, + eventually_degree_leibnizRemainder_lt (b : Nonpositive G R) (c : Nonpositive G R) + α β hb hc, + eventually_degree_mul_translatedTruncLE_lt_limit α β hβ + (b : Nonpositive G R) (c : Nonpositive G R) hb hc] + with γ hbg hbcg hrem hlimit + rw [cantorBendixsonDerivAt_eq _ _ _ hbg, cantorBendixsonDerivAt_eq _ _ _ hbcg, + ← (ν).homogeneousMk_apply, ← (ν).homogeneousMk_apply, (ν).homogeneousMk_mul, + (ν).homogeneousMk_apply, (ν).homogeneousMk_apply] + apply congrArg (DirectSum.of (ν).Component (α + β)) + apply ((ν).componentMk_eq_componentMk_iff _ _ _).mpr + rw [(ν).coe_mulFiltrationLE] + change ν (translatedTruncLE γ ((b : Nonpositive G R) * (c : Nonpositive G R)) - + translatedTruncLE γ (b : Nonpositive G R) * (c : Nonpositive G R)) < (α + β : NatOrdinal) + have hs : translatedTruncLE γ ((b : Nonpositive G R) * (c : Nonpositive G R)) - + translatedTruncLE γ (b : Nonpositive G R) * (c : Nonpositive G R) = + (translatedTruncLE γ ((b : Nonpositive G R) * (c : Nonpositive G R)) - + translatedTruncLE γ (b : Nonpositive G R) * (c : Nonpositive G R) - + (b : Nonpositive G R) * translatedTruncLE γ (c : Nonpositive G R)) + + (b : Nonpositive G R) * translatedTruncLE γ (c : Nonpositive G R) := by abel + rw [hs] + exact ((ν).map_add_le_max _ _).trans_lt (max_lt hrem hlimit) + +end HahnSeries.Nonpositive diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/SyzygyIntegration.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/SyzygyIntegration.lean new file mode 100644 index 0000000000..9c1abe9324 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/SyzygyIntegration.lean @@ -0,0 +1,210 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.DirectSum.GermSyzygy +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.DerivationSet +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.LiftFamily +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.CantorBendixsonRankLevels +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.FinitePWOUnion + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint + +/-! +# Successor syzygy integration for the Cantor–Bendixson derivation + +The abstract successor induction asks for a pointwise representative of the derivative of a +finite homogeneous tuple, supported on one set on which arbitrary homogeneous functions can be +integrated. For the Cantor–Bendixson derivation the set is the finite union, above a common negative +cutoff, of the exact-rank levels of representatives of the tuple entries. + +That union is discrete and partially well ordered. Near zero its closure adds no points, so the +integration theorem for discrete cutoff sets realizes arbitrary homogeneous values on it. Tuple +coordinates with no positive forced degree have zero derivative and need no level. +-/ + +universe u v w + +open scoped NatOrdinal Topology + +open Filter Set HahnSeries + +public noncomputable section + +namespace HahnSeries.Nonpositive + +variable {G : Type u} {K : Type v} +variable [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [UniformSpace G] [IsUniformAddGroup G] [OrderTopology G] [Nontrivial G] [CompleteSpace G] + [Field K] [CharZero K] + +local notation "ν" => (cantorBendixsonDegreeValuation (G := G) (R := K)) + +/-- Successor syzygy integration for the Cantor–Bendixson derivation. -/ +@[blueprint "lem:simultaneous-cantor-bendixson-derivative-representatives" + (phase := "Algebraic independence in graded rings") + (title := "Simultaneous Cantor--Bendixson derivatives of homogeneous tuples") + (statement := /-- + Let $B$ be finite, let $\lambda_b$ be ordinal weights, and let $(u_b)$ be + homogeneous of total degree $d$, where the constant Cantor coefficient of + $d$ is positive. There are a set $S\subseteq G$ and functions + $D_b:G\to\operatorname{gr}_\nu$ such that: + \begin{enumerate} + \item the derivative of $u_b$ agrees near $0$ with $D_b$; + \item for every $\gamma$, $(D_b(\gamma))_b$ is homogeneous of total + degree $d'$, where $d'+1=d$; + \item every $D_b$ vanishes outside $S$; + \item for every homogeneous function $a:G\to\operatorname{gr}_\nu$ of + degree $\rho$, some homogeneous class of degree $\rho+1$ has derivative + equal near $0$ to $a$ on $S$ and to zero outside $S$. + \end{enumerate} + -/) + (proof := /-- + Choose a series representative for each active coordinate of the tuple. + Its derivative is supported near $0$ on one exact-rank set. By + \ref{lem:discrete-finite-union-cantor-bendixson-rank-sets}, after one + common negative cutoff the union $S$ of these finitely many sets is + discrete. The pointwise derivative tuple has predecessor degree $d'$ and + vanishes outside $S$; the operator used here is a derivation by + \ref{lem:cantor-bendixson-derivation-leibniz}. The union is partially + well ordered and agrees near $0$ with its closure, so + \ref{lem:prescribed-cantor-bendixson-derivative-discrete-set} realizes + every homogeneous prescription on $S$ in degree one higher. + -/)] +theorem hasSyzygyIntegration {B : Type w} [Finite B] (lam : B → NatOrdinal.{u}) : + OrdinalGraded.HasSyzygyIntegration + (DirectSum.rangeLof K (ν).Component) cantorBendixsonDerivation lam (T := G) := by + classical + rw [OrdinalGraded.hasSyzygyIntegration_iff] + intro d hd u hu + let active : Set B := {b | ∃ β, β + lam b = d ∧ 0 < β.constantCoeff} + have hdegree : ∀ b : ↥active, ∃ β, β + lam b = d ∧ 0 < β.constantCoeff := + fun b ↦ b.property + choose β hβ hβpos using hdegree + have hlift : ∀ b : ↥active, ∃ p : Nonpositive G K, Represents p (β b) (u b) := + fun b ↦ exists_represents (hu.mem (hβ b)) + choose p hp using hlift + let ρ : ↥active → NatOrdinal.{u} := fun b ↦ (β b).removeNat 1 + have hρsucc : ∀ b, ρ b + 1 = β b := fun b ↦ by + simpa only [ρ, Nat.cast_one] using NatOrdinal.removeNat_add_natCast (hβpos b) + obtain ⟨η, hη0, hdisc⟩ := exists_isDiscrete_iUnion_rankLevelSet p ρ (fun b ↦ by + rw [hρsucc] + exact hp b |>.degree_le) + let S : Set G := ⋃ b : ↥active, rankLevelSet (p b) (ρ b) ∩ Ioo η 0 + let D : B → G → (ν).AssociatedGraded := fun b γ ↦ + if hb : b ∈ active then + if γ ∈ S then DirectSum.of (ν).Component (ρ ⟨b, hb⟩) + (cantorBendixsonDerivAt (ρ ⟨b, hb⟩) (p ⟨b, hb⟩) γ) else 0 + else 0 + refine ⟨S, D, ?_, ?_, ?_, ?_⟩ + · intro b + by_cases hb : b ∈ active + · let b' : ↥active := ⟨b, hb⟩ + obtain ⟨hpdeg, hpu⟩ := represents_iff.mp (hp b') + rw [← hpu, cantorBendixsonDerivation_apply, + cantorBendixsonGradedDerivation_homogeneousMk_succ (ρ b') (hρsucc b').symm] + rw [Filter.Germ.coe_eq] + have hIoo : ∀ᶠ γ in nhdsWithin (0 : G) (Iio 0), γ ∈ Ioo η 0 := + eventually_nhdsLT_iff_exists.mpr ⟨η, hη0, fun γ hγη hγ0 ↦ ⟨hγη, hγ0⟩⟩ + filter_upwards [hIoo, + eventually_degree_translatedTruncLE_le (p b') (ρ b') (by + rw [hρsucc] + exact hpdeg)] with γ hγI hγdeg + simp only [D, dite_eq_left hb] + by_cases hne : cantorBendixsonDerivAt (ρ b') (p b') γ ≠ 0 + · rw [ite_eq_left] + refine mem_iUnion_of_mem b' ⟨?_, hγI⟩ + rw [mem_rankLevelSet_iff, ← cantorBendixsonRank_eq] + exact (cantorBendixsonDerivAt_ne_zero_iff _ _ _ hγdeg).mp hne + · have hz : cantorBendixsonDerivAt (ρ b') (p b') γ = 0 := not_ne_iff.mp hne + rw [hz, map_zero] + split <;> rfl + · have hDzero : D b = 0 := by + funext γ + simp only [D, dite_eq_right hb, Pi.zero_apply] + rw [hDzero, Filter.Germ.coe_zero] + by_cases hex : ∃ β, β + lam b = d + · obtain ⟨β', hβ'⟩ := hex + have hβ'zero : β'.constantCoeff = 0 := by + by_contra hn + exact hb ⟨β', hβ', pos_iff_ne_zero.mpr hn⟩ + rw [cantorBendixsonDerivation_apply] + exact cantorBendixsonGradedDerivation_eq_zero_of_constantCoeff_eq_zero + hβ'zero (hu.mem hβ') + · rw [hu.eq_zero hex, map_zero] + · intro γ + rw [OrdinalGraded.isHomogeneousTuple_iff] + intro b + refine ⟨fun κ hκ ↦ ?_, fun hn ↦ ?_⟩ + · by_cases hb : b ∈ active + · let b' : ↥active := ⟨b, hb⟩ + have hρ : ρ b' = κ := by + apply add_right_cancel (b := lam b) + have hleft : ρ b' + lam b = d.removeNat 1 := by + rw [← NatOrdinal.removeNat_add_right (β b') (lam b) (hβpos b'), hβ] + exact hleft.trans hκ.symm + simp only [D, dite_eq_left hb] + split + · rw [← hρ] + exact DirectSum.of_mem_rangeLof K (ν).Component (ρ b') _ + · exact zero_mem _ + · simp only [D, dite_eq_right hb] + exact zero_mem _ + · by_cases hb : b ∈ active + · exact (hn ⟨ρ ⟨b, hb⟩, by + rw [← NatOrdinal.removeNat_add_right (β ⟨b, hb⟩) (lam b) (hβpos ⟨b, hb⟩), hβ]⟩).elim + · simp only [D, dite_eq_right hb] + · intro b γ hγ + simp only [D] + split <;> rfl + · intro τ a ha + have hSneg : S ⊆ Iic (0 : G) := by + rintro γ hγ + obtain ⟨b, hb⟩ := mem_iUnion.mp hγ + exact hb.2.2.le + have hSpwo : (Set.univ : Set ↥S).IsPWO := by + have hunion : S.IsPWO := Set.IsPWO.iUnion_of_finite + (fun b : ↥active ↦ rankLevelSet (p b) (ρ b) ∩ Ioo η 0) (fun b ↦ + (p b : HahnSeries G K).closedSupport_isPWO.mono fun γ hγ ↦ + ((mem_rankLevelSet_iff (p := p b) (α := ρ b)).mp hγ.1).1) + rw [Set.isPWO_iff_exists_monotone_subseq] + intro f _ + obtain ⟨g, hg⟩ := hunion.exists_monotone_subseq fun n ↦ (f n).2 + exact ⟨g, fun i j hij ↦ Subtype.coe_le_coe.mp (hg hij)⟩ + have hnear : ∀ᶠ γ in nhdsWithin (0 : G) (Iio 0), γ ∈ closure S → γ ∈ S := by + change ∀ᶠ γ in nhdsWithin (0 : G) (Iio 0), + γ ∈ closure (⋃ b : ↥active, rankLevelSet (p b) (ρ b) ∩ Ioo η 0) → + γ ∈ ⋃ b : ↥active, rankLevelSet (p b) (ρ b) ∩ Ioo η 0 + rw [closure_iUnion_of_finite] + have hall : ∀ᶠ γ in nhdsWithin (0 : G) (Iio 0), ∀ b : ↥active, + γ ∈ closure (rankLevelSet (p b) (ρ b) ∩ Ioo η 0) → + γ ∈ rankLevelSet (p b) (ρ b) ∩ Ioo η 0 := by + rw [Filter.eventually_all] + intro b + have hIoo : ∀ᶠ γ in nhdsWithin (0 : G) (Iio 0), γ ∈ Ioo η 0 := + eventually_nhdsLT_iff_exists.mpr + ⟨η, hη0, fun γ hγη hγ0 ↦ ⟨hγη, hγ0⟩⟩ + filter_upwards [eventually_mem_rankLevelSet_of_mem_closure (p b) (ρ b) (by + rw [hρsucc] + exact hp b |>.degree_le), + hIoo] with γ hrank hγIoo hclose + exact ⟨hrank (closure_mono inter_subset_left hclose), hγIoo⟩ + filter_upwards [hall] with γ hγ hclose + obtain ⟨b, hb⟩ := mem_iUnion.mp hclose + exact mem_iUnion_of_mem b (hγ b hb) + obtain ⟨s, hs, hderiv⟩ := exists_derivation_eq_of_isDiscrete τ S hSneg hSpwo + (by simpa only [S] using hdisc) hnear a ha + refine ⟨s, hs, fun γ ↦ if γ ∈ S then a γ else 0, ?_, ?_, ?_⟩ + · rw [cantorBendixsonDerivation_apply] + exact hderiv + · intro γ hγ + simp only [ite_eq_left hγ] + · intro γ hγ + simp only [ite_eq_right hγ] + +end HahnSeries.Nonpositive + +end diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/TranslatedTruncationInterpolation.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/TranslatedTruncationInterpolation.lean new file mode 100644 index 0000000000..1f6dcb0b19 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/TranslatedTruncationInterpolation.lean @@ -0,0 +1,530 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.OrderedIntervalCantorBendixson +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.Derivative +public import LeanPool.ConwayRefinement.ConwayRefinement.Topology.Order.LeftNeighborhood + +/-! +# Interpolation of translated truncations + +The series `translateTruncGT w c center` translates the strict upper truncation of `w` to a chosen +center. Its support lies in one half-open interval. If every proper translated truncation of `w` +inside that interval has degree below `α`, then the `α`-th derivative of the translated support is +contained in the singleton consisting of its center. +-/ + +open Set Filter Topology TopologicalSpace +open scoped NatOrdinal + +universe u v w + +public noncomputable section + +namespace HahnSeries.Nonpositive + +variable {G : Type u} {R : Type v} [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [CommRing R] + +/-- Place the exponents above `c` of `w` at `center`. -/ +def translateTruncGT (w : Nonpositive G R) (c center : G) : R⟦G⟧ := + translate center (truncGT c (w : HahnSeries G R)) + +/-- A translated strict upper truncation is supported in its designated half-open interval. -/ +theorem support_translateTruncGT_subset (w : Nonpositive G R) (c center : G) : + (translateTruncGT w c center).support ⊆ Ioc (center + c) center := by + rw [translateTruncGT, support_translate, support_truncGT] + rintro x ⟨y, ⟨hy, hcy⟩, rfl⟩ + exact ⟨by simpa [add_comm] using add_lt_add_left hcy center, + by simpa using add_le_add_left (w.property hy) center⟩ + +variable [UniformSpace G] [IsUniformAddGroup G] [OrderTopology G] [Nontrivial G] + [CompleteSpace G] [NoZeroDivisors R] [CharZero R] + +local notation "ν" => (cantorBendixsonDegreeValuation (G := G) (R := R)) + +/-- If every proper translated truncation above `c` has degree below `α`, then the `α`-th +derivative of the translated strict upper truncation is supported at its center. -/ +theorem cantorBendixson_translateTruncGT_subset_singleton + (w : Nonpositive G R) (c center : G) (α : NatOrdinal.{u}) + (hcut : ∀ η, c < η → η < 0 → ν (translatedTruncLE η w) < α) : + ((translateTruncGT w c center).closedSupport.cantorBendixson α.val : Set G) ⊆ {center} := by + intro y hy + have hys : y ∈ (translateTruncGT w c center).closedSupport := + (translateTruncGT w c center).closedSupport.cantorBendixson_le α.val hy + have hybounds : y ∈ Icc (center + c) center := + closure_minimal + ((support_translateTruncGT_subset w c center).trans Ioc_subset_Icc_self) isClosed_Icc + ((mem_closedSupport _ _).mp hys) + by_cases hyc : y = center + · exact hyc ▸ Set.mem_singleton center + have hleft : center + c ∉ (translateTruncGT w c center).closedSupport := by + intro hm + have hm' : c ∈ (truncGT c (w : HahnSeries G R)).closedSupport := by + apply ((truncGT c (w : HahnSeries G R)).mem_closedSupport_translate center c).mp + exact hm + exact (w : HahnSeries G R).notMem_closedSupport_truncGT c hm' + have hlefty : center + c < y := lt_of_le_of_ne hybounds.1 fun he ↦ + hleft (he ▸ hys) + let η := -center + y + have hcη : c < η := by + dsimp only [η] + have h := add_lt_add_left hlefty (-center) + simpa [add_assoc, add_comm, add_left_comm] using h + have hη0 : η < 0 := by + dsimp only [η] + have h := add_lt_add_left (lt_of_le_of_ne hybounds.2 hyc) (-center) + simpa [add_assoc, add_comm, add_left_comm] using h + have hyη : center + η = y := by simp only [η, add_neg_cancel_left] + have hrank : (translateTruncGT w c center).cantorBendixsonRank y = + (w : HahnSeries G R).cantorBendixsonRank η := by + rw [translateTruncGT, ← hyη, (truncGT c (w : HahnSeries G R)).cantorBendixsonRank_translate, + (w : HahnSeries G R).cantorBendixsonRank_truncGT_of_lt hcη] + have hyrank : α.val ≤ (translateTruncGT w c center).cantorBendixsonRank y := + ((translateTruncGT w c center).mem_support_derivative_iff y α.val).mp hy |>.2 + have hηmem : η ∈ (w : HahnSeries G R).closedSupport := by + have hm : η ∈ (truncGT c (w : HahnSeries G R)).closedSupport := by + apply ((truncGT c (w : HahnSeries G R)).mem_closedSupport_translate center η).mp + rw [hyη] + exact hys + apply (mem_closedSupport _ _).mpr + exact closure_mono (support_truncGT_subset c (w : HahnSeries G R)) + ((mem_closedSupport _ _).mp hm) + have hzero : 0 ∈ (translatedTruncLE η w : Nonpositive G R).1.closedSupport := by + have hm := ((truncLE η (w : HahnSeries G R)).mem_closedSupport_translate (-η) η).mpr + ((w : HahnSeries G R).mem_closedSupport_truncLE η |>.mpr hηmem) + apply (mem_closedSupport _ _).mpr + rw [coe_translatedTruncLE] + exact (mem_closedSupport _ _).mp (by simpa only [neg_add_cancel] using hm) + have hdegree := hcut η hcη hη0 + rw [cantorBendixsonDegreeValuation_of_mem (translatedTruncLE η w) hzero, + WithBot.coe_lt_coe] at hdegree + have hsr : ((translatedTruncLE η w : Nonpositive G R).1).cantorBendixsonRank 0 = + (w : HahnSeries G R).cantorBendixsonRank η := by + simpa only [coe_translatedTruncLE] using + (w : HahnSeries G R).cantorBendixsonRank_translated_truncLE η + rw [hsr] at hdegree + exact ((not_le_of_gt (NatOrdinal.of.lt_iff_lt.mp hdegree)) (hrank ▸ hyrank)).elim + +/-- Every homogeneous class has a representative and a negative cutoff above any fixed negative +lower bound such that all proper translated truncations above the cutoff have lower degree. -/ +theorem exists_representative_with_lower_truncation_degree (α : NatOrdinal.{u}) + (a : (cantorBendixsonDegreeValuation (G := G) (R := R)).Component α) + {d : G} (hd : d < 0) : + ∃ w : Nonpositive G R, ∃ c : G, + ∃ hw : cantorBendixsonDegreeValuation w ≤ α, + d ≤ c ∧ c < 0 ∧ + (cantorBendixsonDegreeValuation (G := G) (R := R)).componentMk α + ⟨w, ((cantorBendixsonDegreeValuation (G := G) (R := R)).mem_filtrationLE_iff α w).mpr + hw⟩ = a ∧ + ∀ η, c < η → η < 0 → + cantorBendixsonDegreeValuation (translatedTruncLE η w) < α := by + induction a using MaxAddDegree.componentInductionOn with + | H b => + have hb : cantorBendixsonDegreeValuation (b : Nonpositive G R) ≤ α := + ((cantorBendixsonDegreeValuation (G := G) (R := R)).mem_filtrationLE_iff α + (b : Nonpositive G R)).mp b.property + obtain ⟨l, hl, hcut⟩ := eventually_nhdsLT_iff_exists.mp + (eventually_degree_translatedTruncLE_lt (b : Nonpositive G R) α hb) + let c := max l d + have hdc : d ≤ c := le_max_right _ _ + have hc0 : c < 0 := max_lt hl hd + refine ⟨(b : Nonpositive G R), c, hb, hdc, hc0, ?_, ?_⟩ + · rfl + · intro η hcη hη0 + exact hcut η ((le_max_left l d).trans_lt hcη) hη0 + +variable {ι : Type w} [LinearOrder ι] + +omit [UniformSpace G] [IsUniformAddGroup G] [OrderTopology G] [Nontrivial G] [CompleteSpace G] + [NoZeroDivisors R] [CharZero R] in +/-- At one center, the translated weak truncation of the entire ordered interval sum differs from +the source of that translated strict upper truncation only at or below its cutoff. -/ +theorem support_translatedTruncLE_orderedIntervalHsum_sub_source_subset + (hι : (Set.univ : Set ι).IsPWO) + (f : ι → R⟦G⟧) (cut center : ι → G) + (hsupp : ∀ i, (f i).support ⊆ Ioc (cut i) (center i)) + (hord : ∀ i j, i < j → center i ≤ cut j) + (i : ι) (w : Nonpositive G R) (c : G) + (hcut : cut i = center i + c) (hfi : f i = translateTruncGT w c (center i)) : + (translate (-center i) (truncLE (center i) + (orderedIntervalHsum hι f cut center hsupp hord)) - (w : HahnSeries G R)).support ⊆ + Iic c := by + have hown : translate (-center i) (f i) = truncGT c (w : HahnSeries G R) := by + rw [hfi, translateTruncGT, translate_neg_apply] + have hfirst : (translate (-center i) (truncLE (center i) + (orderedIntervalHsum hι f cut center hsupp hord)) - + translate (-center i) (f i)).support ⊆ Iic c := by + have h := HahnSeries.support_translatedTruncLE_orderedIntervalHsum_sub_component_subset + hι f cut center hsupp hord i + rw [hcut] at h + simpa only [add_sub_cancel_left] using h + have hsecond : (translate (-center i) (f i) - (w : HahnSeries G R)).support ⊆ Iic c := by + rw [hown] + have he : truncGT c (w : HahnSeries G R) - (w : HahnSeries G R) = + -truncLE c (w : HahnSeries G R) := by + calc + truncGT c (w : HahnSeries G R) - (w : HahnSeries G R) = + truncGT c (w : HahnSeries G R) - + (truncLE c (w : HahnSeries G R) + truncGT c (w : HahnSeries G R)) := + (congrArg (fun z : HahnSeries G R ↦ truncGT c (w : HahnSeries G R) - z) + (truncLE_add_truncGT c (w : HahnSeries G R))).symm + _ = -truncLE c (w : HahnSeries G R) := by abel + rw [he, support_neg, support_truncLE] + exact inter_subset_right + have he : translate (-center i) (truncLE (center i) + (orderedIntervalHsum hι f cut center hsupp hord)) - (w : HahnSeries G R) = + (translate (-center i) (truncLE (center i) + (orderedIntervalHsum hι f cut center hsupp hord)) - translate (-center i) (f i)) + + (translate (-center i) (f i) - (w : HahnSeries G R)) := by + abel + rw [he] + exact (support_add_subset _ _).trans (union_subset hfirst hsecond) + +/-- At its center, one translated strict upper truncation represents the translated truncation of +the entire ordered sum in the same homogeneous component. All other intervals and the discarded +lower part contribute only a series bounded strictly below zero. -/ +theorem componentMk_centered_orderedIntervalHsum_eq + (α : NatOrdinal.{u}) (hι : (Set.univ : Set ι).IsPWO) + (f : ι → R⟦G⟧) (cut center : ι → G) + (hsupp : ∀ i, (f i).support ⊆ Ioc (cut i) (center i)) + (hord : ∀ i j, i < j → center i ≤ cut j) + (i : ι) (w : Nonpositive G R) (c : G) + (hc : c < 0) (hcut : cut i = center i + c) + (hfi : f i = translateTruncGT w c (center i)) + (hw : ν w ≤ α) : + let q : Nonpositive G R := + ⟨translate (-center i) (truncLE (center i) + (orderedIntervalHsum hι f cut center hsupp hord)), support_translated_truncLE _ _⟩ + ∃ hq : ν q ≤ α, + (ν).componentMk α ⟨q, ((ν).mem_filtrationLE_iff α q).mpr hq⟩ = + (ν).componentMk α ⟨w, ((ν).mem_filtrationLE_iff α w).mpr hw⟩ := by + dsimp only + let q : Nonpositive G R := + ⟨translate (-center i) (truncLE (center i) + (orderedIntervalHsum hι f cut center hsupp hord)), support_translated_truncLE _ _⟩ + have herr : ((q : HahnSeries G R) - (w : HahnSeries G R)).support ⊆ Iic c := + support_translatedTruncLE_orderedIntervalHsum_sub_source_subset + hι f cut center hsupp hord i w c hcut hfi + let e : Nonpositive G R := + ⟨(q : HahnSeries G R) - w, herr.trans (Iic_subset_Iic.mpr hc.le)⟩ + have hedeg : ν e = ⊥ := (cantorBendixsonDegreeValuation_eq_bot_iff e).mpr ⟨c, hc, herr⟩ + have hqe : q = e + w := by + apply Subtype.ext + change (q : HahnSeries G R) = ((q : HahnSeries G R) - w) + w + abel + have hq : ν q ≤ α := by + rw [hqe] + exact ((ν).map_add_le_max e w).trans (max_le (by rw [hedeg]; exact bot_le) hw) + refine ⟨hq, ((ν).componentMk_eq_componentMk_iff α _ _).mpr ?_⟩ + change ν e < α + rw [hedeg] + exact WithBot.bot_lt_coe α + +open Classical in +/-- Prescribed homogeneous classes on one exact rank level can be assembled at arbitrary +cofinality into a successor-filtered Hahn series. Its translated truncation at every rank-level +center has the prescribed lower homogeneous class. -/ +theorem exists_prescribed_components_on_rankLevel (α β : NatOrdinal.{u}) + (p : Nonpositive G R) (hp : ν p ≤ (α + 1 : NatOrdinal)) + (a : {x // x ∈ (p : HahnSeries G R).closedSupport ∧ + (p : HahnSeries G R).closedSupport.cantorBendixsonRank + (p : HahnSeries G R).closedSupport_isPWO x = α.val} → (ν).Component β) : + ∃ b : Nonpositive G R, ∃ hb : ν b ≤ (β + 1 : NatOrdinal), + (∀ i : {x // x ∈ (p : HahnSeries G R).closedSupport ∧ + (p : HahnSeries G R).closedSupport.cantorBendixsonRank + (p : HahnSeries G R).closedSupport_isPWO x = α.val}, + ∃ hi : ν (translatedTruncLE (i : G) b) ≤ β, + (ν).componentMk β + ⟨translatedTruncLE (i : G) b, + ((ν).mem_filtrationLE_iff β _).mpr hi⟩ = a i) ∧ + cantorBendixsonLayerDeriv β + ((ν).componentMk (β + 1) + ⟨b, ((ν).mem_filtrationLE_iff (β + 1) b).mpr hb⟩) = + ((fun γ ↦ if h : γ ∈ (p : HahnSeries G R).closedSupport ∧ + (p : HahnSeries G R).closedSupport.cantorBendixsonRank + (p : HahnSeries G R).closedSupport_isPWO γ = α.val then + a ⟨γ, h⟩ else 0) : + Filter.Germ (𝓝[<] (0 : G)) ((ν).Component β)) := by + classical + let I := {x // x ∈ (p : HahnSeries G R).closedSupport ∧ + (p : HahnSeries G R).closedSupport.cantorBendixsonRank + (p : HahnSeries G R).closedSupport_isPWO x = α.val} + have hI : (Set.univ : Set I).IsPWO := + (p : HahnSeries G R).closedSupport.rankLevel_univ_isPWO + (p : HahnSeries G R).closedSupport_isPWO α.val + obtain ⟨z, hzlt, _, hzord⟩ := + (p : HahnSeries G R).closedSupport.exists_rankLevel_leftCuts + (p : HahnSeries G R).closedSupport_isPWO α.val + have hd (i : I) : z i - (i : G) < 0 := sub_neg.mpr (hzlt i) + choose w c hw hdc hc hcomp hproper using fun i : I ↦ + exists_representative_with_lower_truncation_degree β (a i) (hd i) + let center : I → G := fun i ↦ i + let cut : I → G := fun i ↦ (i : G) + c i + let f : I → R⟦G⟧ := fun i ↦ translateTruncGT (w i) (c i) (i : G) + have hsupp : ∀ i, (f i).support ⊆ Ioc (cut i) (center i) := by + intro i + exact support_translateTruncGT_subset (w i) (c i) i + have hord : ∀ i j : I, i < j → center i ≤ cut j := by + intro i j hij + have hzj : z j ≤ (j : G) + c j := by + calc + z j = (j : G) + (z j - (j : G)) := by abel + _ ≤ (j : G) + c j := by + simpa only [add_comm] using add_le_add_left (hdc j) (j : G) + exact (hzord i j hij).trans hzj + let B : R⟦G⟧ := orderedIntervalHsum hI f cut center hsupp hord + have hBsupport : B.support ⊆ Iic 0 := by + change (orderedIntervalHsum hI f cut center hsupp hord).support ⊆ Iic 0 + rw [support_orderedIntervalHsum] + intro g hg + rw [Set.mem_iUnion] at hg + obtain ⟨i, hgi⟩ := hg + exact (hsupp i hgi).2.trans (closure_minimal p.property isClosed_Iic + ((mem_closedSupport _ _).mp i.property.1)) + let b : Nonpositive G R := ⟨B, hBsupport⟩ + have hstage : ∀ i, ((f i).closedSupport.cantorBendixson β.val : Set G) ⊆ + {center i} := by + intro i + exact cantorBendixson_translateTruncGT_subset_singleton (w i) (c i) i β (hproper i) + have hcenter : closure (Set.range center) ⊆ + ((p : HahnSeries G R).closedSupport.cantorBendixson α.val : Set G) := by + have hrange : Set.range center = + {x | x ∈ (p : HahnSeries G R).closedSupport ∧ + (p : HahnSeries G R).closedSupport.cantorBendixsonRank + (p : HahnSeries G R).closedSupport_isPWO x = α.val} := by + ext x + constructor + · rintro ⟨i, rfl⟩ + exact i.property + · intro hx + exact ⟨⟨x, hx⟩, rfl⟩ + rw [hrange, + (p : HahnSeries G R).closedSupport.closure_rank_level_eq + (p : HahnSeries G R).closedSupport_isPWO α.val] + have hpRank : (p : HahnSeries G R).cantorBendixsonRank 0 ≤ α.val + 1 := by + by_cases hm : 0 ∈ (p : HahnSeries G R).closedSupport + · rw [cantorBendixsonDegreeValuation_of_mem p hm, WithBot.coe_le_coe] at hp + have h := NatOrdinal.of.symm.monotone hp + change NatOrdinal.val (NatOrdinal.of ((p : HahnSeries G R).cantorBendixsonRank 0)) ≤ + NatOrdinal.val (α + 1) at h + simpa only [NatOrdinal.val_of, NatOrdinal.val_add_one] using h + · rw [cantorBendixsonRank_eq, + (p : HahnSeries G R).closedSupport.cantorBendixsonRank_of_notMem + (p : HahnSeries G R).closedSupport_isPWO hm] + exact zero_le + have hpnext : 0 ∉ + ((p : HahnSeries G R).closedSupport.cantorBendixson + ((α.val + 1) + 1) : Set G) := by + intro hm + have hr := ((p : HahnSeries G R).mem_support_derivative_iff 0 _).mp hm |>.2 + exact (not_le_of_gt (hpRank.trans_lt (lt_add_one _))) hr + have hBrank : B.cantorBendixsonRank 0 ≤ β.val + 1 := by + exact cantorBendixsonRank_orderedIntervalHsum_le_add_one_of_centerStage + hI f cut center hsupp hord β.val α.val + (p : HahnSeries G R).closedSupport hstage hcenter 0 hpnext + have hb : ν b ≤ (β + 1 : NatOrdinal) := by + by_cases hm : 0 ∈ (b : HahnSeries G R).closedSupport + · rw [cantorBendixsonDegreeValuation_of_mem b hm, WithBot.coe_le_coe] + have h := NatOrdinal.of.monotone hBrank + have hbB : (b : HahnSeries G R) = B := rfl + rw [hbB] + exact h.trans_eq (by rw [← NatOrdinal.val_add_one, NatOrdinal.of_val]) + · rw [cantorBendixsonDegreeValuation_apply, cantorBendixsonValuation_apply, + cantorBendixsonValue_of_notMem _ (by simpa only [mem_closedSupport] using hm), + NatOrdinal.of_zero, NatOrdinal.cantorDegree_zero] + exact bot_le + have hpoint : ∀ i : I, ∃ hi : ν (translatedTruncLE (i : G) b) ≤ β, + (ν).componentMk β + ⟨translatedTruncLE (i : G) b, ((ν).mem_filtrationLE_iff β _).mpr hi⟩ = a i := by + intro i + have hlocal := componentMk_centered_orderedIntervalHsum_eq β hI f cut center hsupp hord + i (w i) (c i) (hc i) rfl rfl (hw i) + dsimp only [b, B] at hlocal + obtain ⟨hi, heq⟩ := hlocal + let q : Nonpositive G R := + ⟨translate (-(i : G)) (truncLE (i : G) + (orderedIntervalHsum hI f cut center hsupp hord)), support_translated_truncLE _ _⟩ + have hqt : q = translatedTruncLE (i : G) b := by + apply Subtype.ext + rw [coe_translatedTruncLE] + rw [← hqt] + exact ⟨hi, heq.trans (hcomp i)⟩ + have hBderiv : (B.closedSupport.cantorBendixson β.val : Set G) ⊆ + closure (Set.range center) := by + exact cantorBendixson_orderedIntervalHsum_subset_closure_range + hI f cut center hsupp hord β.val hstage + have hgerm : cantorBendixsonLayerDeriv β + ((ν).componentMk (β + 1) + ⟨b, ((ν).mem_filtrationLE_iff (β + 1) b).mpr hb⟩) = + ((fun γ ↦ if h : γ ∈ (p : HahnSeries G R).closedSupport ∧ + (p : HahnSeries G R).closedSupport.cantorBendixsonRank + (p : HahnSeries G R).closedSupport_isPWO γ = α.val then + a ⟨γ, h⟩ else 0) : + Filter.Germ (𝓝[<] (0 : G)) ((ν).Component β)) := by + rw [cantorBendixsonLayerDeriv_componentMk, Filter.Germ.coe_eq] + filter_upwards [eventually_degree_translatedTruncLE_le p α hp, + eventually_degree_translatedTruncLE_le b β hb] with γ hpγ hbγ + by_cases hs : γ ∈ (p : HahnSeries G R).closedSupport ∧ + (p : HahnSeries G R).closedSupport.cantorBendixsonRank + (p : HahnSeries G R).closedSupport_isPWO γ = α.val + · rw [dite_eq_left hs, cantorBendixsonDerivAt_eq β b γ hbγ] + exact (hpoint ⟨γ, hs⟩).choose_spec + · rw [dite_eq_right hs] + by_contra hne + have hbexact := (cantorBendixsonDerivAt_ne_zero_iff β b γ hbγ).mp hne + have hbB : (b : HahnSeries G R) = B := rfl + have hbclosed : γ ∈ B.closedSupport := by + rw [← hbB] + exact hbexact.1 + have hbmem : γ ∈ (B.closedSupport.cantorBendixson β.val : Set G) := by + apply (B.mem_support_derivative_iff γ β.val).mpr + refine ⟨(mem_closedSupport _ _).mp hbclosed, ?_⟩ + simpa only [cantorBendixsonRank_eq, hbB] using hbexact.2.ge + have hpmem := ((p : HahnSeries G R).mem_support_derivative_iff γ α.val).mp + (hcenter (hBderiv hbmem)) + apply hs + refine ⟨(mem_closedSupport _ _).mpr hpmem.1, ?_⟩ + rw [← cantorBendixsonRank_eq] + exact cantorBendixsonRank_eq_of_mem_derivative_of_degree_translatedTruncLE_le + α p γ ((mem_closedSupport _ _).mpr hpmem.1) hpmem.2 hpγ + exact ⟨b, hb, hpoint, hgerm⟩ + +open Classical in +/-- Prescribed nonpositive series at every exact top-rank point assemble with literal pointwise +degree bounds. When every translated truncation of `p`, including the one at cutoff zero, has +degree at most `β`, the exact rank-`β` points of its closed support accumulate nowhere, so the +assembly loses no stage at any cutoff. The assembled series matches each prescription at its +center up to a series bounded strictly below zero, and its translated truncation at every other +nonpositive cutoff, including zero, has degree strictly below `ρ`. -/ +theorem exists_prescribed_truncations_on_topRankLevel (β ρ : NatOrdinal.{u}) + (p : Nonpositive G R) + (hp : ∀ x : G, x ≤ 0 → ν (translatedTruncLE x p) ≤ β) + (w : {x // x ∈ (p : HahnSeries G R).closedSupport ∧ + (p : HahnSeries G R).closedSupport.cantorBendixsonRank + (p : HahnSeries G R).closedSupport_isPWO x = β.val} → Nonpositive G R) + (hw : ∀ i, ν (w i) ≤ ρ) : + ∃ c : Nonpositive G R, + (∀ i : {x // x ∈ (p : HahnSeries G R).closedSupport ∧ + (p : HahnSeries G R).closedSupport.cantorBendixsonRank + (p : HahnSeries G R).closedSupport_isPWO x = β.val}, + ν (translatedTruncLE (i : G) c - w i) = ⊥) ∧ + ∀ y : G, y ≤ 0 → + ¬(y ∈ (p : HahnSeries G R).closedSupport ∧ + (p : HahnSeries G R).closedSupport.cantorBendixsonRank + (p : HahnSeries G R).closedSupport_isPWO y = β.val) → + ν (translatedTruncLE y c) < ρ := by + classical + let I := {x // x ∈ (p : HahnSeries G R).closedSupport ∧ + (p : HahnSeries G R).closedSupport.cantorBendixsonRank + (p : HahnSeries G R).closedSupport_isPWO x = β.val} + have hI : (Set.univ : Set I).IsPWO := + (p : HahnSeries G R).closedSupport.rankLevel_univ_isPWO + (p : HahnSeries G R).closedSupport_isPWO β.val + obtain ⟨z, hzlt, -, hzord⟩ := + (p : HahnSeries G R).closedSupport.exists_rankLevel_leftCuts + (p : HahnSeries G R).closedSupport_isPWO β.val + have hcuts : ∀ i : I, ∃ ci : G, z i - (i : G) ≤ ci ∧ ci < 0 ∧ + ∀ η, ci < η → η < 0 → ν (translatedTruncLE η (w i)) < ρ := by + intro i + obtain ⟨l, hl, hcut⟩ := eventually_nhdsLT_iff_exists.mp + (eventually_degree_translatedTruncLE_lt (w i) ρ (hw i)) + refine ⟨max l (z i - (i : G)), le_max_right _ _, + max_lt hl (sub_neg.mpr (hzlt i)), fun η hlη hη0 ↦ ?_⟩ + exact hcut η ((le_max_left _ _).trans_lt hlη) hη0 + choose cc hdc hcneg hccut using hcuts + let center : I → G := fun i ↦ i + let cut : I → G := fun i ↦ (i : G) + cc i + let f : I → R⟦G⟧ := fun i ↦ translateTruncGT (w i) (cc i) (i : G) + have hsupp : ∀ i, (f i).support ⊆ Ioc (cut i) (center i) := fun i ↦ + support_translateTruncGT_subset (w i) (cc i) i + have hord : ∀ i j : I, i < j → center i ≤ cut j := by + intro i j hij + have hzj : z j ≤ (j : G) + cc j := by + calc + z j = (j : G) + (z j - (j : G)) := by abel + _ ≤ (j : G) + cc j := by + simpa only [add_comm] using add_le_add_left (hdc j) (j : G) + exact (hzord i j hij).trans hzj + let B : R⟦G⟧ := orderedIntervalHsum hI f cut center hsupp hord + have hBsupport : B.support ⊆ Iic 0 := by + change (orderedIntervalHsum hI f cut center hsupp hord).support ⊆ Iic 0 + rw [support_orderedIntervalHsum] + intro g hg + rw [Set.mem_iUnion] at hg + obtain ⟨i, hgi⟩ := hg + exact (hsupp i hgi).2.trans (closure_minimal p.property isClosed_Iic + ((mem_closedSupport _ _).mp i.property.1)) + let c : Nonpositive G R := ⟨B, hBsupport⟩ + refine ⟨c, ?_, ?_⟩ + · intro i + have herr := support_translatedTruncLE_orderedIntervalHsum_sub_source_subset + hI f cut center hsupp hord i (w i) (cc i) rfl rfl + apply (cantorBendixsonDegreeValuation_eq_bot_iff _).mpr + refine ⟨cc i, hcneg i, ?_⟩ + have hcoe : ((translatedTruncLE (i : G) c - w i : Nonpositive G R) : HahnSeries G R) = + translate (-(i : G)) (truncLE (i : G) B) - (w i : HahnSeries G R) := by + rw [AddSubgroupClass.coe_sub, coe_translatedTruncLE] + rw [hcoe] + exact herr + · intro y hy0 hyn + have hstage : ∀ i, ((f i).closedSupport.cantorBendixson ρ.val : Set G) ⊆ {center i} := + fun i ↦ cantorBendixson_translateTruncGT_subset_singleton (w i) (cc i) i ρ (hccut i) + have hderiv : ((orderedIntervalHsum hI f cut center hsupp hord).closedSupport.cantorBendixson + ρ.val : Set G) ⊆ closure (Set.range center) := + cantorBendixson_orderedIntervalHsum_subset_closure_range hI f cut center hsupp hord + ρ.val hstage + have hrange : Set.range center = {x : G | x ∈ (p : HahnSeries G R).closedSupport ∧ + (p : HahnSeries G R).closedSupport.cantorBendixsonRank + (p : HahnSeries G R).closedSupport_isPWO x = β.val} := by + ext x + constructor + · rintro ⟨i, rfl⟩ + exact i.property + · intro hx + exact ⟨⟨x, hx⟩, rfl⟩ + have hlevel : ∀ x : G, + x ∈ ((p : HahnSeries G R).closedSupport.cantorBendixson β.val : Set G) → + x ∈ (p : HahnSeries G R).closedSupport ∧ + (p : HahnSeries G R).closedSupport.cantorBendixsonRank + (p : HahnSeries G R).closedSupport_isPWO x = β.val := by + intro x hx + obtain ⟨hxs, hxr⟩ := ((p : HahnSeries G R).closedSupport.mem_cantorBendixson_iff + (p : HahnSeries G R).closedSupport_isPWO x β.val).mp hx + have hx0 : x ≤ 0 := closure_minimal p.property isClosed_Iic + ((mem_closedSupport _ _).mp hxs) + have hd := hp x hx0 + rw [degree_translatedTruncLE_eq, ite_eq_left hxs, WithBot.coe_le_coe] at hd + have hval := NatOrdinal.of.symm.monotone hd + change NatOrdinal.val (NatOrdinal.of ((p : HahnSeries G R).cantorBendixsonRank x)) ≤ + NatOrdinal.val β at hval + rw [NatOrdinal.val_of, cantorBendixsonRank_eq] at hval + exact ⟨hxs, le_antisymm hval hxr⟩ + have hclosure : closure (Set.range center) ⊆ + {x : G | x ∈ (p : HahnSeries G R).closedSupport ∧ + (p : HahnSeries G R).closedSupport.cantorBendixsonRank + (p : HahnSeries G R).closedSupport_isPWO x = β.val} := by + rw [hrange, (p : HahnSeries G R).closedSupport.closure_rank_level_eq + (p : HahnSeries G R).closedSupport_isPWO β.val] + exact hlevel + have hcB : (c : HahnSeries G R) = orderedIntervalHsum hI f cut center hsupp hord := rfl + have hyd : y ∉ ((c : HahnSeries G R).closedSupport.cantorBendixson ρ.val : Set G) := by + rw [hcB] + exact fun hyd ↦ hyn (hclosure (hderiv hyd)) + rw [degree_translatedTruncLE_eq] + by_cases hym : y ∈ (c : HahnSeries G R).closedSupport + · rw [ite_eq_left hym] + have hrlt : (c : HahnSeries G R).cantorBendixsonRank y < ρ.val := by + by_contra hge + exact hyd (((c : HahnSeries G R).mem_support_derivative_iff y ρ.val).mpr + ⟨(mem_closedSupport _ _).mp hym, not_lt.mp hge⟩) + rw [WithBot.coe_lt_coe, ← NatOrdinal.of_val ρ] + exact NatOrdinal.of.lt_iff_lt.mpr hrlt + · rw [ite_eq_right hym] + exact WithBot.bot_lt_coe ρ + +end HahnSeries.Nonpositive diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/TranslatedTruncationInterpolationOnSets.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/TranslatedTruncationInterpolationOnSets.lean new file mode 100644 index 0000000000..9df5040efc --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/TranslatedTruncationInterpolationOnSets.lean @@ -0,0 +1,196 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.TranslatedTruncationInterpolation + +/-! +# Interpolation of translated truncations on a set + +The construction places a prescribed homogeneous class at each point of an exact-rank set. +Nothing requires those points to come from a single series: the proof only uses that they are +partially well ordered, sit at or below zero, admit ordered disjoint left cuts, and are carried by +some derivative stage of a closed set at which the origin has already dropped out. + +This file gives the interpolation theorem over such a set. The level of one series is one case; +finite unions of levels give the version needed for a family of prescriptions. + +The one condition that is not merely structural is that the set be recovered from its closure near +zero: a point of the closure that is not in the set must not occur arbitrarily close to zero. For a +rank level that holds because the truncations eventually drop, and it is what stops the assembled +derivative from being nonzero away from the prescribed points. +-/ + +universe u v w + +open scoped NatOrdinal Topology + +open Filter Set TopologicalSpace HahnSeries + +public noncomputable section + +namespace HahnSeries.Nonpositive + +variable {G : Type u} {R : Type v} +variable [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [UniformSpace G] [IsUniformAddGroup G] [OrderTopology G] [Nontrivial G] [CompleteSpace G] + [CommRing R] [NoZeroDivisors R] [CharZero R] + +local notation "ν" => (cantorBendixsonDegreeValuation (G := G) (R := R)) + +open Classical in +/-- Prescribed homogeneous classes on a partially well ordered, nonpositive, left-separated set +carried by a derivative stage assemble into one class a degree higher whose derivative germ is the +prescribed function, provided the set is recovered from its closure near zero. -/ +theorem exists_prescribed_components_on_set (β : NatOrdinal.{u}) (S : Set G) + (hSneg : S ⊆ Iic 0) + (hSpwo : (Set.univ : Set ↥S).IsPWO) + (z : ↥S → G) (hzlt : ∀ i : ↥S, z i < (i : G)) + (hzord : ∀ i j : ↥S, (i : G) < (j : G) → (i : G) ≤ z j) + (t : Closeds G) (r : Ordinal.{u}) + (hcarry : closure S ⊆ (t.cantorBendixson r : Set G)) + (hdrop : (0 : G) ∉ (t.cantorBendixson ((r + 1) + 1) : Set G)) + (hnear : ∀ᶠ γ in 𝓝[<] (0 : G), γ ∈ closure S → γ ∈ S) + (a : ↥S → (ν).Component β) : + ∃ b : Nonpositive G R, ∃ hb : ν b ≤ (β + 1 : NatOrdinal), + (∀ i : ↥S, ∃ hi : ν (translatedTruncLE (i : G) b) ≤ β, + (ν).componentMk β + ⟨translatedTruncLE (i : G) b, ((ν).mem_filtrationLE_iff β _).mpr hi⟩ = a i) ∧ + cantorBendixsonLayerDeriv β + ((ν).componentMk (β + 1) ⟨b, ((ν).mem_filtrationLE_iff (β + 1) b).mpr hb⟩) = + ((fun γ ↦ if h : γ ∈ S then a ⟨γ, h⟩ else 0) : + Filter.Germ (𝓝[<] (0 : G)) ((ν).Component β)) := by + classical + have hd (i : ↥S) : z i - (i : G) < 0 := sub_neg.mpr (hzlt i) + choose w c hw hdc hc hcomp hproper using fun i : ↥S ↦ + exists_representative_with_lower_truncation_degree β (a i) (hd i) + set center : ↥S → G := fun i ↦ i with hcenterdef + set cut : ↥S → G := fun i ↦ (i : G) + c i with hcutdef + set f : ↥S → R⟦G⟧ := fun i ↦ translateTruncGT (w i) (c i) (i : G) with hfdef + have hsupp : ∀ i, (f i).support ⊆ Ioc (cut i) (center i) := fun i ↦ + support_translateTruncGT_subset (w i) (c i) i + have hord : ∀ i j : ↥S, i < j → center i ≤ cut j := by + intro i j hij + have hzj : z j ≤ (j : G) + c j := by + calc + z j = (j : G) + (z j - (j : G)) := by abel + _ ≤ (j : G) + c j := by simpa only [add_comm] using add_le_add_left (hdc j) (j : G) + exact (hzord i j hij).trans hzj + set B : R⟦G⟧ := orderedIntervalHsum hSpwo f cut center hsupp hord with hBdef + have hBsupport : B.support ⊆ Iic 0 := by + rw [hBdef, support_orderedIntervalHsum] + intro g hg + rw [Set.mem_iUnion] at hg + obtain ⟨i, hgi⟩ := hg + exact (hsupp i hgi).2.trans (hSneg i.property) + set b : Nonpositive G R := ⟨B, hBsupport⟩ with hbdef + have hstage : ∀ i, ((f i).closedSupport.cantorBendixson β.val : Set G) ⊆ {center i} := fun i ↦ + cantorBendixson_translateTruncGT_subset_singleton (w i) (c i) i β (hproper i) + have hrange : Set.range center = S := by + ext x + exact ⟨by rintro ⟨i, rfl⟩; exact i.property, fun hx ↦ ⟨⟨x, hx⟩, rfl⟩⟩ + have hcenter : closure (Set.range center) ⊆ (t.cantorBendixson r : Set G) := by + rw [hrange]; exact hcarry + have hBrank : B.cantorBendixsonRank 0 ≤ β.val + 1 := + cantorBendixsonRank_orderedIntervalHsum_le_add_one_of_centerStage + hSpwo f cut center hsupp hord β.val r t hstage hcenter 0 hdrop + have hb : ν b ≤ (β + 1 : NatOrdinal) := by + by_cases hm : 0 ∈ (b : HahnSeries G R).closedSupport + · rw [cantorBendixsonDegreeValuation_of_mem b hm, WithBot.coe_le_coe] + have h := NatOrdinal.of.monotone hBrank + have hbB : (b : HahnSeries G R) = B := rfl + rw [hbB] + exact h.trans_eq (by rw [← NatOrdinal.val_add_one, NatOrdinal.of_val]) + · rw [cantorBendixsonDegreeValuation_apply, cantorBendixsonValuation_apply, + cantorBendixsonValue_of_notMem _ (by simpa only [mem_closedSupport] using hm), + NatOrdinal.of_zero, NatOrdinal.cantorDegree_zero] + exact bot_le + have hpoint : ∀ i : ↥S, ∃ hi : ν (translatedTruncLE (i : G) b) ≤ β, + (ν).componentMk β + ⟨translatedTruncLE (i : G) b, ((ν).mem_filtrationLE_iff β _).mpr hi⟩ = a i := by + intro i + have hlocal := componentMk_centered_orderedIntervalHsum_eq β hSpwo f cut center hsupp hord + i (w i) (c i) (hc i) rfl rfl (hw i) + dsimp only [hbdef, hBdef] at hlocal + obtain ⟨hi, heq⟩ := hlocal + set q : Nonpositive G R := + ⟨translate (-(i : G)) (truncLE (i : G) + (orderedIntervalHsum hSpwo f cut center hsupp hord)), support_translated_truncLE _ _⟩ + with hqdef + have hqt : q = translatedTruncLE (i : G) b := by + apply Subtype.ext + rw [coe_translatedTruncLE] + rw [← hqt] + exact ⟨hi, heq.trans (hcomp i)⟩ + have hBderiv : (B.closedSupport.cantorBendixson β.val : Set G) ⊆ closure (Set.range center) := + cantorBendixson_orderedIntervalHsum_subset_closure_range + hSpwo f cut center hsupp hord β.val hstage + refine ⟨b, hb, hpoint, ?_⟩ + rw [cantorBendixsonLayerDeriv_componentMk, Filter.Germ.coe_eq] + filter_upwards [eventually_degree_translatedTruncLE_le b β hb, hnear] with γ hbγ hnearγ + by_cases hs : γ ∈ S + · rw [dite_eq_left hs, cantorBendixsonDerivAt_eq β b γ hbγ] + exact (hpoint ⟨γ, hs⟩).choose_spec + · rw [dite_eq_right hs] + by_contra hne + have hbexact := (cantorBendixsonDerivAt_ne_zero_iff β b γ hbγ).mp hne + have hbB : (b : HahnSeries G R) = B := rfl + have hbclosed : γ ∈ B.closedSupport := by rw [← hbB]; exact hbexact.1 + have hbmem : γ ∈ (B.closedSupport.cantorBendixson β.val : Set G) := by + apply (B.mem_support_derivative_iff γ β.val).mpr + refine ⟨(mem_closedSupport _ _).mp hbclosed, ?_⟩ + simpa only [cantorBendixsonRank_eq, hbB] using hbexact.2.ge + exact hs (hnearγ (by rw [← hrange]; exact hBderiv hbmem)) + +open Classical in +/-- **Interpolation over a discrete set of centers.** A discrete set whose closure adds nothing +near zero carries its own derivative bookkeeping. Its accumulation points avoid a neighbourhood of +zero, so zero is not an accumulation point of them, and the second derivative stage of its closure +misses zero. Prescribed classes at its points therefore assemble with no further hypotheses. -/ +theorem exists_prescribed_components_on_set_of_isDiscrete (β : NatOrdinal.{u}) (S : Set G) + (hSneg : S ⊆ Iic 0) (hSpwo : (Set.univ : Set ↥S).IsPWO) (hSdisc : IsDiscrete S) + (hnear : ∀ᶠ γ in 𝓝[<] (0 : G), γ ∈ closure S → γ ∈ S) + (a : ↥S → (ν).Component β) : + ∃ b : Nonpositive G R, ∃ hb : ν b ≤ (β + 1 : NatOrdinal), + (∀ i : ↥S, ∃ hi : ν (translatedTruncLE (i : G) b) ≤ β, + (ν).componentMk β + ⟨translatedTruncLE (i : G) b, ((ν).mem_filtrationLE_iff β _).mpr hi⟩ = a i) ∧ + cantorBendixsonLayerDeriv β + ((ν).componentMk (β + 1) ⟨b, ((ν).mem_filtrationLE_iff (β + 1) b).mpr hb⟩) = + ((fun γ ↦ if h : γ ∈ S then a ⟨γ, h⟩ else 0) : + Filter.Germ (𝓝[<] (0 : G)) ((ν).Component β)) := by + classical + obtain ⟨z, hzlt, -, hzord⟩ := TopologicalSpace.Closeds.exists_leftCuts_of_isDiscrete S hSdisc + obtain ⟨η, hη, hcut⟩ := eventually_nhdsLT_iff_exists.mp hnear + set t : Closeds G := ⟨closure S, isClosed_closure⟩ with htdef + have hcarry : closure S ⊆ (t.cantorBendixson (0 : Ordinal.{u}) : Set G) := by + rw [TopologicalSpace.Closeds.cantorBendixson_zero] + exact subset_rfl + -- the accumulation points of the centers avoid a whole left neighbourhood of zero + have hacc : ∀ γ : G, η < γ → γ < 0 → γ ∉ derivedSet S := by + intro γ hηγ hγ0 hγ + have hγS : γ ∈ S := hcut γ hηγ hγ0 (derivedSet_subset_closure S hγ) + rw [isDiscrete_iff_nhdsNE] at hSdisc + exact (mem_derivedSet.mp hγ).ne (hSdisc γ hγS) + have hderived : ((t.derived : Closeds G) : Set G) = derivedSet S := by + rw [TopologicalSpace.Closeds.coe_derived] + exact derivedSet_closure S + have hdrop : (0 : G) ∉ (t.cantorBendixson ((0 : Ordinal.{u}) + 1 + 1) : Set G) := by + rw [TopologicalSpace.Closeds.cantorBendixson_add_one, + TopologicalSpace.Closeds.cantorBendixson_add_one, + TopologicalSpace.Closeds.cantorBendixson_zero, + TopologicalSpace.Closeds.coe_derived, mem_derivedSet, accPt_iff_nhds] + intro hacc0 + obtain ⟨y, hy, hyne⟩ := hacc0 (Ioi η) ((isOpen_Ioi).mem_nhds hη) + have hyd : y ∈ derivedSet S := by rw [← hderived]; exact hy.2 + have hyle : y ≤ 0 := + closure_minimal hSneg isClosed_Iic (derivedSet_subset_closure S hyd) + exact hacc y hy.1 (lt_of_le_of_ne hyle hyne) hyd + exact exists_prescribed_components_on_set β S hSneg hSpwo z hzlt hzord t 0 hcarry hdrop hnear a + +end HahnSeries.Nonpositive + +end diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/Truncation.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/Truncation.lean new file mode 100644 index 0000000000..e0d954067c --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/Truncation.lean @@ -0,0 +1,275 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.CantorBendixsonValue + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Translation +public import LeanPool.ConwayRefinement.ConwayRefinement.Topology.CantorBendixsonReconstruction +public import Mathlib.Topology.Algebra.Group.Basic + +import LeanPool.ConwayRefinement.ConwayRefinement.Topology.Order.LeftNeighborhood + +/-! +# Cantor–Bendixson ranks under translated truncation + +A weak lower truncation preserves the closed support locally at its cutoff, since a well-ordered +support has a gap immediately to the right. Translation preserves point ranks. Consequently, +the value of the translated weak truncation at `c` reads the original point rank at `c`, +with value zero exactly when `c` is outside the original closed support. + +The reconstruction statement lifts local lower bounds on exact-rank points to a lower bound +at the target point. Truncation uses `i ≤ c`, retaining the cutoff coefficient, and translation +by `-c` sends that exponent to zero. No multiplication identity is assumed. +-/ + +public noncomputable section + +open Set Filter Topology TopologicalSpace + +universe u v + +namespace HahnSeries + +variable {G : Type u} {R : Type v} [LinearOrder G] [TopologicalSpace G] + [OrderTopology G] + +section Zero + +variable [Zero R] + +/-- Weak lower truncation preserves the closed support in a neighborhood of its cutoff. -/ +theorem closedSupport_truncLE_locally_eq (b : HahnSeries G R) (c : G) : + ∃ U : Set G, IsOpen U ∧ c ∈ U ∧ + ((truncLE c b).closedSupport : Set G) ∩ U = (b.closedSupport : Set G) ∩ U := by + obtain ⟨U, hU, hUo, hcU⟩ := mem_nhds_iff.mp (b.isPWO_support.eventually_le c) + refine ⟨U, hUo, hcU, ?_⟩ + rw [coe_closedSupport, coe_closedSupport] + apply hUo.closure_congr + rw [support_truncLE] + ext y + exact ⟨fun h ↦ ⟨h.1.1, h.2⟩, fun h ↦ ⟨⟨h.1, hU h.2 h.1⟩, h.2⟩⟩ + +/-- Weak lower truncation preserves the Cantor–Bendixson rank at its cutoff. -/ +theorem cantorBendixsonRank_truncLE (b : HahnSeries G R) (c : G) : + (truncLE c b).cantorBendixsonRank c = b.cantorBendixsonRank c := by + obtain ⟨U, hU, hc, he⟩ := b.closedSupport_truncLE_locally_eq c + rw [cantorBendixsonRank_eq, cantorBendixsonRank_eq] + exact (truncLE c b).closedSupport.cantorBendixsonRank_congr_on_open b.closedSupport + (truncLE c b).closedSupport_isPWO b.closedSupport_isPWO hU he hc + +/-- A strict upper truncation preserves the closed support locally at every point strictly above +its cutoff. -/ +theorem closedSupport_truncGT_locally_eq_of_lt (b : HahnSeries G R) {c x : G} + (hcx : c < x) : + ∃ U : Set G, IsOpen U ∧ x ∈ U ∧ + ((truncGT c b).closedSupport : Set G) ∩ U = (b.closedSupport : Set G) ∩ U := by + refine ⟨Ioi c, isOpen_Ioi, hcx, ?_⟩ + rw [coe_closedSupport, coe_closedSupport] + apply isOpen_Ioi.closure_congr + rw [support_truncGT] + ext y + simp only [mem_inter_iff, Set.mem_ofPred_eq, mem_Ioi] + tauto + +/-- A strict upper truncation preserves Cantor–Bendixson rank strictly above its cutoff. -/ +theorem cantorBendixsonRank_truncGT_of_lt (b : HahnSeries G R) {c x : G} (hcx : c < x) : + (truncGT c b).cantorBendixsonRank x = b.cantorBendixsonRank x := by + obtain ⟨U, hU, hx, he⟩ := b.closedSupport_truncGT_locally_eq_of_lt hcx + rw [cantorBendixsonRank_eq, cantorBendixsonRank_eq] + exact (truncGT c b).closedSupport.cantorBendixsonRank_congr_on_open b.closedSupport + (truncGT c b).closedSupport_isPWO b.closedSupport_isPWO hU he hx + +/-- The strict cutoff itself is outside the closed support of a strict upper truncation. -/ +theorem notMem_closedSupport_truncGT (b : HahnSeries G R) (c : G) : + c ∉ (truncGT c b).closedSupport := by + rw [mem_closedSupport] + intro hc + obtain ⟨U, hU, hUopen, hcU⟩ := mem_nhds_iff.mp (b.isPWO_support.eventually_le c) + obtain ⟨y, hyU, hy⟩ := mem_closure_iff.mp hc U hUopen hcU + rw [support_truncGT] at hy + exact (not_le_of_gt hy.2) (hU hyU hy.1) + +/-- The cutoff belongs to the truncated closed support exactly when it belongs to the original. -/ +theorem mem_closedSupport_truncLE (b : HahnSeries G R) (c : G) : + c ∈ (truncLE c b).closedSupport ↔ c ∈ b.closedSupport := by + obtain ⟨U, _, hc, he⟩ := b.closedSupport_truncLE_locally_eq c + exact ⟨fun h ↦ ((Set.ext_iff.mp he c).mp ⟨h, hc⟩).1, + fun h ↦ ((Set.ext_iff.mp he c).mpr ⟨h, hc⟩).1⟩ + +/-- Local bounds at points of exact rank reconstruct a Cantor–Bendixson rank bound at the target. -/ +theorem cantorBendixsonRank_reconstruction (b d : HahnSeries G R) + {U : Set G} (hU : IsOpen U) {x : G} (hxU : x ∈ U) + (a c r : Ordinal.{u}) (hx : x ∈ closure b.support) (hr : a + r ≤ b.cantorBendixsonRank x) + (hlevel : ∀ y ∈ U, y ∈ closure b.support → b.cantorBendixsonRank y = a → + y ∈ closure d.support ∧ c ≤ d.cantorBendixsonRank y) : + x ∈ closure d.support ∧ c + r ≤ d.cantorBendixsonRank x := by + apply (d.mem_support_derivative_iff x (c + r)).mp + apply b.closedSupport.cantorBendixson_reconstruction d.closedSupport + b.closedSupport_isPWO hU a c r _ ⟨(b.mem_support_derivative_iff x _).mpr ⟨hx, hr⟩, hxU⟩ + intro y hyU hys hy + apply (d.mem_support_derivative_iff y c).mpr + exact hlevel y hyU ((b.mem_closedSupport y).mp hys) ((b.cantorBendixsonRank_eq y).trans hy) + +end Zero + +section Translation + +variable [AddCommGroup G] [IsOrderedAddMonoid G] [IsTopologicalAddGroup G] [AddMonoid R] + +omit [TopologicalSpace G] [OrderTopology G] [IsTopologicalAddGroup G] in +/-- A translated weak lower truncation always has nonpositive support. -/ +theorem support_translated_truncLE (b : HahnSeries G R) (c : G) : + (translate (-c) (truncLE c b)).support ⊆ Iic 0 := by + rw [support_translate] + rintro x ⟨y, hy, rfl⟩ + rw [support_truncLE] at hy + simpa only [mem_Iic, neg_add_cancel] using add_le_add_right hy.2 (-c) + +/-- Translating the exponents and the target point together preserves Cantor–Bendixson rank. -/ +theorem cantorBendixsonRank_translate (b : HahnSeries G R) (a x : G) : + (translate a b).cantorBendixsonRank (a + x) = b.cantorBendixsonRank x := by + rw [cantorBendixsonRank_eq, cantorBendixsonRank_eq] + apply (Homeomorph.addLeft a).cantorBendixsonRank_eq b.closedSupport (translate a b).closedSupport + b.closedSupport_isPWO (translate a b).closedSupport_isPWO + rw [coe_closedSupport, coe_closedSupport, support_translate] + exact (Homeomorph.addLeft a).image_closure _ + +omit [OrderTopology G] in +/-- Translation transports membership in the closed support. -/ +theorem mem_closedSupport_translate (b : HahnSeries G R) (a x : G) : + a + x ∈ (translate a b).closedSupport ↔ x ∈ b.closedSupport := by + rw [mem_closedSupport, mem_closedSupport, support_translate] + have he : (a + ·) '' closure b.support = closure ((a + ·) '' b.support) := + (Homeomorph.addLeft a).image_closure b.support + rw [← he] + constructor + · rintro ⟨y, hy, he⟩ + exact (add_left_cancel he : y = x) ▸ hy + · exact fun hx ↦ ⟨x, hx, rfl⟩ + +/-- The rank at zero after translated weak truncation is the original rank at the cutoff. -/ +theorem cantorBendixsonRank_translated_truncLE (b : HahnSeries G R) (c : G) : + (translate (-c) (truncLE c b)).cantorBendixsonRank 0 = b.cantorBendixsonRank c := by + simpa only [neg_add_cancel] using + ((truncLE c b).cantorBendixsonRank_translate (-c) c).trans (b.cantorBendixsonRank_truncLE c) + +open Classical in +/-- The translated weak truncation value reads the Cantor–Bendixson rank at the cutoff. -/ +theorem cantorBendixsonValue_translated_truncLE (b : HahnSeries G R) (c : G) : + (translate (-c) (truncLE c b)).cantorBendixsonValue = + if c ∈ b.closedSupport then Ordinal.omega0 ^ b.cantorBendixsonRank c else 0 := by + have hm : (0 : G) ∈ (translate (-c) (truncLE c b)).closedSupport ↔ c ∈ b.closedSupport := by + simpa only [neg_add_cancel] using + ((truncLE c b).mem_closedSupport_translate (-c) c).trans (b.mem_closedSupport_truncLE c) + by_cases hc : c ∈ b.closedSupport + · rw [ite_eq_left hc, cantorBendixsonValue_of_mem _ ((mem_closedSupport _ _).mp (hm.mpr hc)), + cantorBendixsonRank_translated_truncLE] + · rw [ite_eq_right hc] + apply cantorBendixsonValue_of_notMem + intro hh + exact hc (hm.mp ((mem_closedSupport _ _).mpr hh)) + +/-- Nearby proper translated truncations have strictly smaller value when the value is nonzero. -/ +theorem eventually_value_translated_truncLE_lt (b : HahnSeries G R) + (hb : b.cantorBendixsonValue ≠ 0) : + ∀ᶠ c in 𝓝 (0 : G), c ≠ 0 → + (translate (-c) (truncLE c b)).cantorBendixsonValue < b.cantorBendixsonValue := by + classical + have hb0 : 0 ∈ closure b.support := + not_not.mp (mt (b.cantorBendixsonValue_eq_zero_iff).mpr hb) + filter_upwards [b.closedSupport.cantorBendixsonRank_locally_lt b.closedSupport_isPWO 0] + with c hc hne + rw [b.cantorBendixsonValue_translated_truncLE, b.cantorBendixsonValue_of_mem hb0] + by_cases hmem : c ∈ b.closedSupport + · rw [ite_eq_left hmem] + apply (Ordinal.opow_lt_opow_iff_right Ordinal.one_lt_omega0).mpr + simpa only [cantorBendixsonRank_eq] using hc hmem hne + · rw [ite_eq_right hmem] + exact Ordinal.opow_pos _ Ordinal.omega0_pos + +variable [Nontrivial G] + +/-- Bounds at translated cutoffs of an exact lower rank reconstruct the ordinary rank sum at zero. +Only an eventual left-neighborhood bound is required; no product formula is assumed. -/ +@[blueprint "lem:cantor-bendixson-rank-reconstruction" + (phase := "Cantor–Bendixson ranks of supports") + (title := "Reconstruction from translated truncations of fixed rank") + (statement := /-- + Let $R$ be an additive monoid, let $G$ be a nontrivial ordered + topological abelian group with its order topology, and let + $b,d\in R((G))$. Suppose + $\operatorname{supp}(b)\subseteq G^{\le0}$. + Let $a,c,r$ be ordinals with $r>0$ and + \[ + V_{\mathrm{CB}}(b)=\omega^{a+r}. + \] + Suppose that, for every $\gamma<0$ sufficiently close to $0$, + \[ + V_{\mathrm{CB}}(b^{\vert\gamma})=\omega^a + \quad\Longrightarrow\quad + V_{\mathrm{CB}}(d^{\vert\gamma})\ge\omega^c. + \] + Then + \[ + V_{\mathrm{CB}}(d)\ge\omega^{c+r}. + \] + -/) + (proof := /-- + By \ref{def:cantor-bendixson-value}, the hypothesis on $b$ says that $0$ + has Cantor--Bendixson rank $a+r$ in its closed support. At every nearby + point of exact rank $a$, the translated-truncation hypothesis places that + point in the $c$-th derivative of the closed support of $d$. + Cantor--Bendixson + reconstruction therefore places $0$ in its $(c+r)$-th derivative, which + is the stated value bound. + -/)] +theorem cantorBendixsonValue_reconstruction (b d : HahnSeries G R) (hb : b.support ⊆ Iic 0) + (a c r : Ordinal.{u}) (hr : 0 < r) + (hbv : b.cantorBendixsonValue = Ordinal.omega0 ^ (a + r)) + (hlevel : ∀ᶠ γ in 𝓝[<] (0 : G), + (translate (-γ) (truncLE γ b)).cantorBendixsonValue = Ordinal.omega0 ^ a → + Ordinal.omega0 ^ c ≤ (translate (-γ) (truncLE γ d)).cantorBendixsonValue) : + Ordinal.omega0 ^ (c + r) ≤ d.cantorBendixsonValue := by + classical + have hb0 : 0 ∈ closure b.support := by + by_contra h + rw [b.cantorBendixsonValue_of_notMem h] at hbv + exact (Ordinal.opow_ne_zero _ Ordinal.omega0_ne_zero) hbv.symm + have hbr : b.cantorBendixsonRank 0 = a + r := by + rw [b.cantorBendixsonValue_of_mem hb0] at hbv + exact (Ordinal.opow_right_inj Ordinal.one_lt_omega0).mp hbv + obtain ⟨l, hl, hlevel⟩ := eventually_nhdsLT_iff_exists.mp hlevel + obtain ⟨hd0, hdr⟩ := b.cantorBendixsonRank_reconstruction d isOpen_Ioi hl a c r hb0 + (le_of_eq hbr.symm) (by + intro y hy hys hyr + have hy0 : y ≤ 0 := closure_minimal hb isClosed_Iic hys + have hyne : y ≠ 0 := by + intro he + subst y + rw [hbr] at hyr + exact (ne_of_gt (lt_add_of_pos_right _ hr)) hyr + have hylt : y < 0 := lt_of_le_of_ne hy0 hyne + have hval : (translate (-y) (truncLE y b)).cantorBendixsonValue = + Ordinal.omega0 ^ a := by + rw [b.cantorBendixsonValue_translated_truncLE, ite_eq_left ((b.mem_closedSupport y).mpr + hys), + hyr] + have h := hlevel y hy hylt hval + rw [d.cantorBendixsonValue_translated_truncLE] at h + by_cases hym : y ∈ d.closedSupport + · rw [ite_eq_left hym] at h + exact ⟨(d.mem_closedSupport y).mp hym, + (Ordinal.opow_le_opow_iff_right Ordinal.one_lt_omega0).mp h⟩ + · rw [ite_eq_right hym] at h + exact ((Ordinal.opow_pos _ Ordinal.omega0_pos).not_ge h).elim) + rw [d.cantorBendixsonValue_of_mem hd0] + exact Ordinal.opow_le_opow_right Ordinal.omega0_pos hdr + +end Translation + +end HahnSeries diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/TruncationExpansion.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/TruncationExpansion.lean new file mode 100644 index 0000000000..1c2ba6a026 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Germ/AlgebraicIndependence/TruncationExpansion.lean @@ -0,0 +1,633 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.TruncationPolynomial +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MvPolynomial.TermDegree +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MvPolynomial.ComponentsSpan + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint + +/-! +# The translated-truncation Leibniz expansion in representing polynomials + +The finite closed-support convolution formula expands a proper translated truncation of a +monomial in series representatives satisfying the assigned degree and proper-truncation bounds. +Its two boundary terms +give the usual first-order Leibniz sum; every interior term contains at least two proper +truncations. This file records the resulting polynomial identity and tracks the weight of every +remainder monomial by `TermDegree`. +-/ + +universe u v w + +open scoped NatOrdinal Topology + +open MvPolynomial HahnSeries + +public noncomputable section + +namespace HahnSeries.Nonpositive + +variable {G : Type u} {K : Type v} +variable [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [UniformSpace G] [IsUniformAddGroup G] [OrderTopology G] [Nontrivial G] [CompleteSpace G] + [Field K] [CharZero K] + +local notation "ν" => (cantorBendixsonDegreeValuation (G := G) (R := K)) + +variable {ι : Type w} {wt : ι → NatOrdinal.{u}} + {xg : ι → (cantorBendixsonDegreeValuation (G := G) (R := K)).AssociatedGraded} + +namespace LiftFamily + +variable (σ : LiftFamily wt xg) +variable (hx : OrdinalGraded.IsMinimalSystem + (DirectSum.rangeLof K (cantorBendixsonDegreeValuation (G := G) (R := K)).Component) wt xg) + +/-- Every monomial of a polynomial has weight strictly below the given ordinal. -/ +def DegreeLT (wt : ι → NatOrdinal.{u}) (P : MvPolynomial ι K) (α : NatOrdinal.{u}) : Prop := + ∀ d ∈ P.support, Finsupp.weight wt d < α + +omit [CharZero K] in +theorem degreeLT_iff {P : MvPolynomial ι K} {α : NatOrdinal.{u}} : + DegreeLT wt P α ↔ ∀ d ∈ P.support, Finsupp.weight wt d < α := + Iff.rfl + +variable (wt) in +/-- A polynomial remainder for a monomial: every monomial has the degree of an expansion term +with at least two truncated factors. -/ +def IsRemainder (d : ι →₀ ℕ) (E : MvPolynomial ι K) : Prop := + ∀ d' ∈ E.support, ∃ k, 2 ≤ k ∧ TermDegree wt d k (Finsupp.weight wt d') + +omit [CharZero K] in +theorem isRemainder_zero (d : ι →₀ ℕ) : + IsRemainder wt d (0 : MvPolynomial ι K) := by + intro d' hd' + rw [MvPolynomial.support_zero] at hd' + exact absurd hd' (Finset.notMem_empty d') + +omit [CharZero K] in +theorem IsRemainder.add {d : ι →₀ ℕ} {E E' : MvPolynomial ι K} + (hE : IsRemainder wt d E) (hE' : IsRemainder wt d E') : + IsRemainder wt d (E + E') := by + classical + intro d' hd' + rcases Finset.mem_union.mp (support_add hd') with h | h + · exact hE d' h + · exact hE' d' h + +omit [CharZero K] in +theorem IsRemainder.sum {κ : Type*} {d : ι →₀ ℕ} (s : Finset κ) + (E : κ → MvPolynomial ι K) (hE : ∀ j ∈ s, IsRemainder wt d (E j)) : + IsRemainder wt d (∑ j ∈ s, E j) := by + classical + induction s using Finset.induction_on with + | empty => + rw [Finset.sum_empty] + exact isRemainder_zero d + | insert a s ha ih => + rw [Finset.sum_insert ha] + exact (hE a (Finset.mem_insert_self a s)).add + (ih fun j hj ↦ hE j (Finset.mem_insert_of_mem hj)) + +/-- Multiplication by an untruncated variable preserves the number of truncated factors. -/ +theorem IsRemainder.mul_X {d : ι →₀ ℕ} {E : MvPolynomial ι K} + (hE : IsRemainder wt d E) (i : ι) : + IsRemainder wt (d + Finsupp.single i 1) (E * X i) := by + classical + intro d' hd' + obtain ⟨d₁, hd₁, d₂, hd₂, hw⟩ := exists_add_eq_weight_of_mem_support_mul (wt := wt) hd' + obtain ⟨k, hk, hT⟩ := hE d₁ hd₁ + rw [X, support_monomial, ite_eq_right one_ne_zero, Finset.mem_singleton] at hd₂ + subst d₂ + rw [Finsupp.weight_single, one_smul] at hw + exact ⟨k, hk, hw ▸ TermDegree.untrunc i hT⟩ + +omit [CharZero K] in +/-- Multiplying an expansion with a truncated factor by another proper truncation produces a +remainder with at least two truncated factors. -/ +theorem isRemainder_mul_of_degreeLT {d : ι →₀ ℕ} {P Q : MvPolynomial ι K} + (hP : ∀ d' ∈ P.support, ∃ k, 1 ≤ k ∧ TermDegree wt d k (Finsupp.weight wt d')) + {i : ι} (hQ : DegreeLT wt Q (wt i)) : + IsRemainder wt (d + Finsupp.single i 1) (P * Q) := by + classical + intro d' hd' + obtain ⟨d₁, hd₁, d₂, hd₂, hw⟩ := exists_add_eq_weight_of_mem_support_mul (wt := wt) hd' + obtain ⟨k, hk, hT⟩ := hP d₁ hd₁ + exact ⟨k + 1, by omega, + hw ▸ TermDegree.trunc i ((degreeLT_iff).mp hQ d₂ hd₂) hT⟩ + +omit [CharZero K] in +/-- The first-order expansion terms of a monomial have exactly one designated truncated factor. -/ +theorem forall_termDegree_sum_mul_pderiv_monomial (d : ι →₀ ℕ) + (T : ι → MvPolynomial ι K) (hT : ∀ j ∈ d.support, DegreeLT wt (T j) (wt j)) : + ∀ d' ∈ (∑ j ∈ d.support, T j * pderiv j (monomial d (1 : K))).support, + ∃ k, 1 ≤ k ∧ TermDegree wt d k (Finsupp.weight wt d') := by + classical + intro d' hd' + obtain ⟨j, hj, hd'j⟩ := Finset.mem_biUnion.mp (support_sum hd') + obtain ⟨d₁, hd₁, d₂, hd₂, hw⟩ := exists_add_eq_weight_of_mem_support_mul (wt := wt) hd'j + rw [pderiv_monomial, support_monomial] at hd₂ + split_ifs at hd₂ with hzero + · exact absurd hd₂ (Finset.notMem_empty d₂) + · rw [Finset.mem_singleton] at hd₂ + subst d₂ + have hdj : d - Finsupp.single j 1 + Finsupp.single j 1 = d := + Finsupp.sub_add_single_one_cancel (Finsupp.mem_support_iff.mp hj) + refine ⟨1, le_rfl, ?_⟩ + have hterm := TermDegree.trunc_left j ((degreeLT_iff).mp (hT j hj) d₁ hd₁) + (termDegree_weight wt (d - Finsupp.single j 1)) + rw [add_comm (Finsupp.single j 1), hdj] at hterm + rwa [← hw] + +omit [CharZero K] in +/-- Splitting one variable from a monomial. -/ +theorem monomial_add_single_one (d : ι →₀ ℕ) (i : ι) : + monomial (d + Finsupp.single i 1) (1 : K) = monomial d 1 * X i := by + rw [X, MvPolynomial.monomial_mul_monomial, mul_one] + +omit [CharZero K] in +/-- The first-order Leibniz sum after splitting one variable from a monomial. -/ +theorem sum_mul_pderiv_monomial_add_single (d : ι →₀ ℕ) (i : ι) + (T : ι → MvPolynomial ι K) : + ∑ j ∈ (d + Finsupp.single i 1).support, + T j * pderiv j (monomial (d + Finsupp.single i 1) 1) = + (∑ j ∈ d.support, T j * pderiv j (monomial d (1 : K))) * X i + + T i * monomial d 1 := by + classical + have hmem : i ∈ (d + Finsupp.single i 1).support := by + rw [Finsupp.mem_support_iff, Finsupp.add_apply, Finsupp.single_eq_same] + omega + have hsub : d.support ⊆ (d + Finsupp.single i 1).support := fun j hj ↦ by + rw [Finsupp.mem_support_iff] at hj ⊢ + rw [Finsupp.add_apply] + omega + simp only [monomial_add_single_one, pderiv_mul, mul_add, Finset.sum_add_distrib] + congr 1 + · rw [Finset.sum_mul, ← Finset.sum_subset hsub] + · exact Finset.sum_congr rfl fun j _ ↦ by ring + · intro j _ hj + rw [pderiv_monomial, Finsupp.notMem_support_iff.mp hj, Nat.cast_zero, mul_zero, + monomial_zero, zero_mul, mul_zero] + · rw [Finset.sum_eq_single i] + · rw [pderiv_X_self, mul_one] + · intro j _ hji + rw [pderiv_X_of_ne (Ne.symm hji), mul_zero, mul_zero] + · intro h + exact absurd hmem h + +omit [CharZero K] in +/-- Split a finite sum at two distinct members. -/ +private theorem sum_eq_add_add_sum_erase {κ : Type*} [DecidableEq κ] + {S : Finset κ} {a b : κ} (ha : a ∈ S) (hb : b ∈ S) (hne : b ≠ a) + (f : κ → MvPolynomial ι K) : + ∑ q ∈ S, f q = f a + f b + ∑ q ∈ (S.erase a).erase b, f q := by + rw [add_assoc, Finset.add_sum_erase _ _ (Finset.mem_erase.mpr ⟨hne, hb⟩), + Finset.add_sum_erase _ _ ha] + +include hx in +/-- The translated-truncation Leibniz expansion for a monomial. At every negative cutoff, the +representing polynomial of a translated truncation is its first-order Leibniz sum plus a +remainder whose monomials contain at least two truncated factors. -/ +theorem exists_pol_translatedTruncLE_aeval_monomial + (hσ : HasLowerTruncationDegrees σ) {α : NatOrdinal.{u}} + (hinj : ∀ β < α, OrdinalGraded.InjectiveAt K wt xg β) + (d : ι →₀ ℕ) (hd : Finsupp.weight wt d ≤ α) + (hvars : ∀ i ∈ d.support, wt i < α) {γ : G} (hγ : γ < 0) : + ∃ E : MvPolynomial ι K, IsRemainder wt d E ∧ + σ.pol hx α (translatedTruncLE γ (aeval σ.lift (monomial d (1 : K)))) = + ∑ j ∈ d.support, σ.pol hx α (translatedTruncLE γ (σ.lift j)) * + pderiv j (monomial d 1) + E := by + classical + suffices h : ∀ n : ℕ, ∀ d : ι →₀ ℕ, Finsupp.degree d = n → + Finsupp.weight wt d ≤ α → (∀ i ∈ d.support, wt i < α) → + ∀ {γ : G}, γ < 0 → + ∃ E : MvPolynomial ι K, IsRemainder wt d E ∧ + σ.pol hx α (translatedTruncLE γ (aeval σ.lift (monomial d (1 : K)))) = + ∑ j ∈ d.support, σ.pol hx α (translatedTruncLE γ (σ.lift j)) * + pderiv j (monomial d 1) + E by + exact h _ d rfl hd hvars hγ + intro n + induction n using Nat.strong_induction_on with + | _ n ih => + intro d hdn hd hvars γ hγ + rcases eq_or_ne d 0 with rfl | hd0 + · refine ⟨0, isRemainder_zero 0, ?_⟩ + have htr : translatedTruncLE γ (1 : Nonpositive G K) = 0 := + FreeOfVariable.translatedTruncLE_one hγ + have hone : aeval σ.lift (monomial (0 : ι →₀ ℕ) (1 : K)) = + (1 : Nonpositive G K) := by simp + rw [hone, htr, σ.pol_eq_zero_of_degree_eq_bot hx (by rw [(ν).map_zero]), + Finsupp.support_zero, Finset.sum_empty, add_zero] + · obtain ⟨i, hi⟩ := Finsupp.support_nonempty_iff.mpr hd0 + set d' := d - Finsupp.single i 1 with hd'def + have hdd' : d' + Finsupp.single i 1 = d := + Finsupp.sub_add_single_one_cancel (Finsupp.mem_support_iff.mp hi) + have hwd : Finsupp.weight wt d' + wt i = Finsupp.weight wt d := by + rw [← hdd', map_add, Finsupp.weight_single, one_smul] + have hdeg : Finsupp.degree d' < n := by + rw [← hdn, ← hdd', map_add, Finsupp.degree_single] + omega + have hwi : wt i < α := hvars i hi + have hwd'α : Finsupp.weight wt d' < α := by + have hlt : Finsupp.weight wt d' < Finsupp.weight wt d' + wt i := + lt_add_of_pos_right _ (pos_iff_ne_zero.mpr (hx.ne_zero i)) + exact hlt.trans_le (hwd ▸ hd) + have hsub : d'.support ⊆ d.support := by + rw [hd'def] + exact Finsupp.support_tsub + have ih' : ∀ {y : G}, y < 0 → + ∃ E : MvPolynomial ι K, IsRemainder wt d' E ∧ + σ.pol hx α (translatedTruncLE y (aeval σ.lift (monomial d' (1 : K)))) = + ∑ j ∈ d'.support, σ.pol hx α (translatedTruncLE y (σ.lift j)) * + pderiv j (monomial d' 1) + E := + ih _ hdeg d' rfl hwd'α.le (fun j hj ↦ hvars j (hsub hj)) + set a : Nonpositive G K := aeval σ.lift (monomial d' (1 : K)) with hadef + have ha : HasLowerTruncationDegree a (Finsupp.weight wt d') := by + rw [hadef] + exact σ.hasLowerTruncationDegree_aeval hσ + (isWeightedHomogeneous_monomial wt d' 1 rfl) + have hb : HasLowerTruncationDegree (σ.lift i) (wt i) := + (hasLowerTruncationDegrees_iff σ).mp hσ i + have hconv := σ.pol_translatedTruncLE_mul_boundary hx hinj ha hb hwd'α hwi + (hwd ▸ hd) hγ + set S := insert (0, γ) (insert (γ, 0) + ((a : HahnSeries G K).closedSupportAddFiber (σ.lift i : HahnSeries G K) γ)) with hS + set f : G × G → MvPolynomial ι K := fun q ↦ + σ.pol hx α (translatedTruncLE q.1 a) * + σ.pol hx α (translatedTruncLE q.2 (σ.lift i)) with hf + have h0S : (0, γ) ∈ S := Finset.mem_insert_self _ _ + have hγS : (γ, 0) ∈ S := Finset.mem_insert_of_mem (Finset.mem_insert_self _ _) + have hne : (γ, 0) ≠ (0, γ) := fun h ↦ hγ.ne (congrArg Prod.fst h) + have hsplit : ∑ q ∈ S, f q = f (0, γ) + f (γ, 0) + + ∑ q ∈ (S.erase (0, γ)).erase (γ, 0), f q := + sum_eq_add_add_sum_erase h0S hγS hne f + have hf0 : f (0, γ) = monomial d' 1 * + σ.pol hx α (translatedTruncLE γ (σ.lift i)) := by + change σ.pol hx α (translatedTruncLE 0 a) * + σ.pol hx α (translatedTruncLE γ (σ.lift i)) = _ + rw [translatedTruncLE_zero, hadef, + σ.pol_aeval hx hinj (fun e he ↦ by + rw [support_monomial, ite_eq_right one_ne_zero, Finset.mem_singleton] at he + rwa [he])] + have hfγ : f (γ, 0) = + σ.pol hx α (translatedTruncLE γ a) * X i := by + change σ.pol hx α (translatedTruncLE γ a) * + σ.pol hx α (translatedTruncLE 0 (σ.lift i)) = _ + rw [translatedTruncLE_zero, σ.pol_lift hx hinj hwi] + have hinterior : ∀ q ∈ (S.erase (0, γ)).erase (γ, 0), + q.1 < 0 ∧ q.2 < 0 := by + intro q hq + have hqneγ : q ≠ (γ, 0) := (Finset.mem_erase.mp hq).1 + have hqne0 : q ≠ (0, γ) := + (Finset.mem_erase.mp (Finset.mem_erase.mp hq).2).1 + have hqmemS : q ∈ S := (Finset.mem_erase.mp (Finset.mem_erase.mp hq).2).2 + have hqmem : q ∈ (a : HahnSeries G K).closedSupportAddFiber + (σ.lift i : HahnSeries G K) γ := by + rw [hS] at hqmemS + rcases Finset.mem_insert.mp hqmemS with hqeq | hqmemS + · exact (hqne0 hqeq).elim + rcases Finset.mem_insert.mp hqmemS with hqeq | hqmemS + · exact (hqneγ hqeq).elim + · exact hqmemS + obtain ⟨hq1mem, hq2mem, hsum⟩ := + ((a : HahnSeries G K).mem_closedSupportAddFiber + (σ.lift i : HahnSeries G K) γ q).mp hqmem + have hq1le : q.1 ≤ 0 := closure_minimal a.property isClosed_Iic + ((mem_closedSupport _ _).mp hq1mem) + have hq2le : q.2 ≤ 0 := closure_minimal (σ.lift i).property isClosed_Iic + ((mem_closedSupport _ _).mp hq2mem) + have hq1ne : q.1 ≠ 0 := fun hq10 ↦ hqne0 (Prod.ext hq10 (by + simpa [hq10] using hsum)) + have hq2ne : q.2 ≠ 0 := fun hq20 ↦ hqneγ (Prod.ext (by + simpa [hq20] using hsum) hq20) + exact ⟨lt_of_le_of_ne hq1le hq1ne, lt_of_le_of_ne hq2le hq2ne⟩ + choose Eq hEqrem hEq using fun q (hq : q ∈ (S.erase (0, γ)).erase (γ, 0)) ↦ + ih' (hinterior q hq).1 + set R : MvPolynomial ι K := ∑ q ∈ (S.erase (0, γ)).erase (γ, 0), + f q with hRdef + have hR : IsRemainder wt d R := by + rw [← hdd', hRdef] + refine IsRemainder.sum _ _ fun q hq ↦ ?_ + change IsRemainder wt (d' + Finsupp.single i 1) + (σ.pol hx α (translatedTruncLE q.1 a) * + σ.pol hx α (translatedTruncLE q.2 (σ.lift i))) + rw [hEq q hq] + have hleft : IsRemainder (K := K) wt (d' + Finsupp.single i 1) + ((∑ j ∈ d'.support, σ.pol hx α (translatedTruncLE q.1 (σ.lift j)) * + pderiv j (monomial d' 1)) * + σ.pol hx α (translatedTruncLE q.2 (σ.lift i))) := by + exact isRemainder_mul_of_degreeLT (wt := wt) + (forall_termDegree_sum_mul_pderiv_monomial (wt := wt) d' _ fun j hj ↦ + fun e he ↦ σ.pol_weight_lt_of_degree_lt hx (hvars j (hsub hj)).le + (((hasLowerTruncationDegrees_iff σ).mp hσ j).degree_translatedTruncLE_lt + (hinterior q hq).1) e he) + (fun e he ↦ σ.pol_weight_lt_of_degree_lt hx hwi.le + (hb.degree_translatedTruncLE_lt (hinterior q hq).2) e he) + have hright : IsRemainder (K := K) wt (d' + Finsupp.single i 1) + (Eq q hq * σ.pol hx α (translatedTruncLE q.2 (σ.lift i))) := by + exact isRemainder_mul_of_degreeLT (wt := wt) + (fun e he ↦ by + obtain ⟨k, hk, hterm⟩ := hEqrem q hq e he + exact ⟨k, by omega, hterm⟩) + (fun e he ↦ σ.pol_weight_lt_of_degree_lt hx hwi.le + (hb.degree_translatedTruncLE_lt (hinterior q hq).2) e he) + rw [add_mul] + exact hleft.add hright + obtain ⟨E', hE', hEq'⟩ := ih' hγ + refine ⟨E' * X i + R, (hdd' ▸ hE'.mul_X i).add hR, ?_⟩ + have hprod : a * σ.lift i = aeval σ.lift (monomial d (1 : K)) := by + rw [hadef, ← hdd', monomial_add_single_one, map_mul, aeval_X] + rw [← hprod, hconv, hsplit, hf0, hfγ, hEq', ← hdd', + sum_mul_pderiv_monomial_add_single, hRdef] + ring + +include hx in +/-- The translated-truncation Leibniz expansion for a polynomial. At every negative cutoff, the +representing polynomial of a translated truncation is its first-order Leibniz sum plus a +remainder coming from at least two truncated factors of a monomial of the original polynomial. -/ +theorem exists_pol_translatedTruncLE_aeval + (hσ : HasLowerTruncationDegrees σ) {α : NatOrdinal.{u}} + (hinj : ∀ β < α, OrdinalGraded.InjectiveAt K wt xg β) + (H : MvPolynomial ι K) (hH : ∀ d ∈ H.support, Finsupp.weight wt d ≤ α) + (hvars : ∀ i ∈ H.vars, wt i < α) {γ : G} (hγ : γ < 0) : + ∃ E : MvPolynomial ι K, + (∀ d' ∈ E.support, ∃ d ∈ H.support, ∃ k, 2 ≤ k ∧ + TermDegree wt d k (Finsupp.weight wt d')) ∧ + σ.pol hx α (translatedTruncLE γ (aeval σ.lift H)) = + ∑ j ∈ H.vars, σ.pol hx α (translatedTruncLE γ (σ.lift j)) * pderiv j H + E := by + classical + have hmono : ∀ d ∈ H.support, + ∃ E : MvPolynomial ι K, IsRemainder wt d E ∧ + σ.pol hx α (translatedTruncLE γ (aeval σ.lift (monomial d (1 : K)))) = + ∑ j ∈ d.support, σ.pol hx α (translatedTruncLE γ (σ.lift j)) * + pderiv j (monomial d 1) + E := fun d hd ↦ + σ.exists_pol_translatedTruncLE_aeval_monomial hx hσ hinj d (hH d hd) + (fun i hi ↦ hvars i ((mem_vars_iff_mem_support i).mpr ⟨d, hd, hi⟩)) hγ + choose E hE hEq using hmono + have hmonomialBounds : ∀ d ∈ H.support, + HasLowerTruncationDegree (aeval σ.lift (monomial d (1 : K))) (Finsupp.weight wt d) := + fun d _ ↦ σ.hasLowerTruncationDegree_aeval hσ (isWeightedHomogeneous_monomial wt d 1 rfl) + have hdegree : ∀ d ∈ H.support, + ν (translatedTruncLE γ (aeval σ.lift (monomial d (1 : K)))) < + (α : WithBot NatOrdinal) := fun d hd ↦ + (hmonomialBounds d hd).degree_translatedTruncLE_lt hγ |>.trans_le + (WithBot.coe_le_coe.mpr (hH d hd)) + refine ⟨∑ d ∈ H.support.attach, MvPolynomial.C (H.coeff d.1) * E d.1 d.2, + ?_, ?_⟩ + · intro d' hd' + obtain ⟨d, _, hd'd⟩ := Finset.mem_biUnion.mp (support_sum hd') + have hd'E : d' ∈ (E d.1 d.2).support := by + rw [C_mul'] at hd'd + exact support_smul hd'd + obtain ⟨k, hk, hterm⟩ := hE d.1 d.2 d' hd'E + exact ⟨d.1, d.2, k, hk, hterm⟩ + have hmonomial : ∀ d, monomial d (H.coeff d) = + MvPolynomial.C (H.coeff d) * monomial d (1 : K) := fun d ↦ by + rw [C_mul_monomial, mul_one] + have hleft : σ.pol hx α (translatedTruncLE γ (aeval σ.lift H)) = + ∑ d ∈ H.support.attach, + MvPolynomial.C (H.coeff d.1) * + σ.pol hx α (translatedTruncLE γ (aeval σ.lift (monomial d.1 (1 : K)))) := by + conv_lhs => rw [H.as_sum] + rw [map_sum, map_sum, ← Finset.sum_attach H.support] + have hterm : ∀ d ∈ H.support.attach, + translatedTruncLE γ (aeval σ.lift + (monomial d.1 (H.coeff d.1))) = + H.coeff d.1 • translatedTruncLE γ + (aeval σ.lift (monomial d.1 (1 : K))) := by + intro d _ + rw [hmonomial, map_mul, aeval_C, ← Algebra.smul_def, translatedTruncLE_smul] + rw [Finset.sum_congr rfl hterm, + σ.pol_sum hx hinj _ _ (fun d hd ↦ by + exact (degree_smul_le _ _).trans_lt (hdegree d.1 d.2))] + refine Finset.sum_congr rfl fun d _ ↦ ?_ + rw [σ.pol_smul hx hinj _ (hdegree d.1 d.2), C_mul'] + rw [hleft] + have hsub : ∀ d ∈ H.support, d.support ⊆ H.vars := fun d hd j hj ↦ + (mem_vars_iff_mem_support j).mpr ⟨d, hd, hj⟩ + have hsupp : ∀ d : ι →₀ ℕ, ∀ j, j ∉ d.support → + pderiv j (monomial d (1 : K)) = 0 := fun d j hj ↦ by + rw [pderiv_monomial, Finsupp.notMem_support_iff.mp hj, Nat.cast_zero, mul_zero, + monomial_zero] + have hpd : ∀ j, pderiv j H = + ∑ d ∈ H.support.attach, MvPolynomial.C (H.coeff d.1) * + pderiv j (monomial d.1 1) := fun j ↦ by + conv_lhs => rw [H.as_sum, map_sum, ← Finset.sum_attach H.support] + exact Finset.sum_congr rfl fun d _ ↦ by rw [hmonomial, pderiv_C_mul] + rw [Finset.sum_congr rfl (fun d _ ↦ congrArg + (MvPolynomial.C (H.coeff d.1) * ·) (hEq d.1 d.2))] + simp only [mul_add, Finset.sum_add_distrib] + congr 1 + simp only [hpd, Finset.mul_sum] + rw [Finset.sum_comm] + refine Finset.sum_congr rfl fun d _ ↦ ?_ + have heq : ∑ j ∈ d.1.support, + σ.pol hx α (translatedTruncLE γ (σ.lift j)) * pderiv j (monomial d.1 1) = + ∑ j ∈ H.vars, + σ.pol hx α (translatedTruncLE γ (σ.lift j)) * pderiv j (monomial d.1 1) := + Finset.sum_subset (hsub d.1 d.2) fun j _ hj ↦ by + rw [hsupp d.1 j hj, mul_zero] + rw [← Finset.mul_sum] + conv_lhs => rw [heq] + rw [Finset.mul_sum] + exact Finset.sum_congr rfl fun j _ ↦ by + exact mul_left_comm + (MvPolynomial.C (H.coeff d.1)) + (σ.pol hx α (translatedTruncLE γ (σ.lift j))) _ + +include hx in +/-- The differentiated translated-truncation Leibniz expansion. Differentiating the expansion of `F` +and comparing it with the expansion of `∂F/∂X_v` expresses the latter using the partials of `F` +and two `TermDegree`-controlled remainders. -/ +theorem exists_pol_translatedTruncLE_aeval_pderiv + (hσ : HasLowerTruncationDegrees σ) {α : NatOrdinal.{u}} + (hinj : ∀ β < α, OrdinalGraded.InjectiveAt K wt xg β) + (F : MvPolynomial ι K) (hF : ∀ d ∈ F.support, Finsupp.weight wt d ≤ α) + (hvars : ∀ i ∈ F.vars, wt i < α) (v : ι) {γ : G} (hγ : γ < 0) : + ∃ E E' : MvPolynomial ι K, + (∀ d' ∈ E.support, ∃ d ∈ F.support, ∃ k, 2 ≤ k ∧ + TermDegree wt d k (Finsupp.weight wt d')) ∧ + (∀ d' ∈ E'.support, ∃ d ∈ (pderiv v F).support, ∃ k, 2 ≤ k ∧ + TermDegree wt d k (Finsupp.weight wt d')) ∧ + σ.pol hx α (translatedTruncLE γ (aeval σ.lift (pderiv v F))) = + pderiv v (σ.pol hx α (translatedTruncLE γ (aeval σ.lift F))) - + ∑ j ∈ F.vars, + pderiv v (σ.pol hx α (translatedTruncLE γ (σ.lift j))) * pderiv j F - + pderiv v E + E' := by + classical + have hΘ : ∀ d ∈ (pderiv v F).support, Finsupp.weight wt d ≤ α := fun d' hd' ↦ by + obtain ⟨d, hd, hw⟩ := exists_add_eq_weight_of_mem_support_pderiv wt hd' + exact (NatOrdinal.le_add_right.trans hw.le).trans (hF d hd) + have hvarsΘ : ∀ i ∈ (pderiv v F).vars, wt i < α := + fun i hi ↦ hvars i (vars_pderiv_subset v F hi) + obtain ⟨E, hE, hexpF⟩ := + σ.exists_pol_translatedTruncLE_aeval hx hσ hinj F hF hvars hγ + obtain ⟨E', hE', hexpΘ⟩ := + σ.exists_pol_translatedTruncLE_aeval hx hσ hinj (pderiv v F) hΘ hvarsΘ hγ + refine ⟨E, E', hE, hE', ?_⟩ + set T : ι → MvPolynomial ι K := fun j ↦ + σ.pol hx α (translatedTruncLE γ (σ.lift j)) with hTdef + have hdF : pderiv v (σ.pol hx α (translatedTruncLE γ (aeval σ.lift F))) = + ∑ j ∈ F.vars, pderiv v (T j) * pderiv j F + + ∑ j ∈ F.vars, T j * pderiv j (pderiv v F) + pderiv v E := by + rw [hexpF, map_add, map_sum, ← Finset.sum_add_distrib] + congr 1 + exact Finset.sum_congr rfl fun j _ ↦ by rw [pderiv_mul, pderiv_pderiv_comm] + have hexpΘ' : σ.pol hx α (translatedTruncLE γ (aeval σ.lift (pderiv v F))) = + ∑ j ∈ F.vars, T j * pderiv j (pderiv v F) + E' := by + rw [hexpΘ] + congr 1 + exact Finset.sum_subset (vars_pderiv_subset v F) fun j _ hj ↦ by + rw [pderiv_eq_zero_of_notMem_vars hj, mul_zero] + rw [hexpΘ', hdF] + ring + +omit [CharZero K] in +/-- A monomial of a partial derivative regains a monomial of the original polynomial after +restoring the differentiated variable. -/ +theorem add_single_mem_support_of_mem_support_pderiv {i : ι} + {P : MvPolynomial ι K} {d' : ι →₀ ℕ} (hd' : d' ∈ (pderiv i P).support) : + d' + Finsupp.single i 1 ∈ P.support := by + obtain ⟨d, hd, hdi, rfl⟩ := exists_mem_support_of_mem_support_pderiv hd' + rwa [tsub_add_cancel_of_le + (Finsupp.single_le_iff.mpr (Nat.one_le_iff_ne_zero.mpr hdi))] + +omit [CharZero K] in +/-- A polynomial whose monomials have degree below `g ≤ wt v` has zero derivative at `v`. -/ +theorem pderiv_eq_zero_of_degreeLT_le {P : MvPolynomial ι K} {g : NatOrdinal.{u}} + (hP : DegreeLT wt P g) {v : ι} (hg : g ≤ wt v) : pderiv v P = 0 := by + by_contra h + obtain ⟨d', hd'⟩ := support_nonempty.mpr h + have hmem := add_single_mem_support_of_mem_support_pderiv hd' + have hlt := hP _ hmem + rw [map_add, Finsupp.weight_single, one_smul] at hlt + have hle : wt v ≤ Finsupp.weight wt d' + wt v := by + rw [add_comm] + exact NatOrdinal.le_add_right + exact absurd (hg.trans hle) (not_le.mpr hlt) + +include hx in +/-- **Local ideal membership for a truncated partial derivative.** If the represented +translated truncation of `F` and all two-truncation remainder terms lie below `α''`, then above +any `τ` with `α'' ≤ τ + wt v'`, the truncated partial derivative lies in the ideal generated by +partials at variables of strictly larger weight. -/ +@[blueprint "lem:local-jacobian-ideal-membership" + (phase := "Algebraic independence in graded rings") + (title := "Local Jacobian ideal membership for translated partial derivatives") + (statement := /-- + Let $F$ be weighted homogeneous of degree $\alpha$, evaluated at series + $b_i$ representing a minimal homogeneous generating system of weights + $w_i$. Assume + \[ + \deg(b_i)\le w_i, + \qquad \deg(b_i^{\vert y}) (cantorBendixsonDegreeValuation (G := G) (R := K)) + +variable {ι : Type w} {wt : ι → NatOrdinal.{u}} + {xg : ι → (cantorBendixsonDegreeValuation (G := G) (R := K)).AssociatedGraded} + +namespace LiftFamily + +variable (σ : LiftFamily wt xg) +variable (hx : OrdinalGraded.IsMinimalSystem + (DirectSum.rangeLof K (cantorBendixsonDegreeValuation (G := G) (R := K)).Component) wt xg) + +include hx in +/-- A series of degree below `α` has a polynomial representative modulo series bounded away from +zero, with every monomial weight bounded by the degree of the series. -/ +theorem exists_polynomial {α : NatOrdinal.{u}} (u : Nonpositive G K) + (hu : ν u < (α : WithBot NatOrdinal)) : + ∃ F : MvPolynomial ι K, + (∀ d ∈ F.support, (((Finsupp.weight wt) d : NatOrdinal) : WithBot NatOrdinal) ≤ ν u) ∧ + (∀ d ∈ F.support, Finsupp.weight wt d < α) ∧ + ν (u - aeval σ.lift F) = ⊥ := + exists_forall_weight_lt_and_degree_sub_aeval_eq_bot xg σ.represents α + (fun β _ y hy ↦ OrdinalGraded.IsMinimalSystem.exists_aeval_eq hx + cantorBendixson_gradeZeroScalars β y hy) u hu + +/-- The polynomial representing `u` modulo series bounded away from zero, among polynomials with +monomial weights below `α`; it is zero when `u` does not have degree below `α`. -/ +def pol (α : NatOrdinal.{u}) (u : Nonpositive G K) : MvPolynomial ι K := by + by_cases hu : ν u < (α : WithBot NatOrdinal) + · exact Classical.choose (σ.exists_polynomial hx u hu) + · exact 0 + +include hx in +/-- Every monomial of the chosen polynomial has weight below its cutoff. -/ +theorem pol_weight_lt (α : NatOrdinal.{u}) (u : Nonpositive G K) : + ∀ d ∈ (σ.pol hx α u).support, Finsupp.weight wt d < α := by + classical + unfold pol + split_ifs with hu + · exact (Classical.choose_spec (σ.exists_polynomial hx u hu)).2.1 + · simp + +include hx in +/-- Every monomial weight is bounded by the degree of the represented series. -/ +theorem pol_weight_le_degree {α : NatOrdinal.{u}} {u : Nonpositive G K} + (hu : ν u < (α : WithBot NatOrdinal)) : + ∀ d ∈ (σ.pol hx α u).support, + (((Finsupp.weight wt) d : NatOrdinal) : WithBot NatOrdinal) ≤ ν u := by + classical + unfold pol + rw [dite_eq_left hu] + exact (Classical.choose_spec (σ.exists_polynomial hx u hu)).1 + +include hx in +/-- The chosen polynomial evaluates to the original series modulo series bounded away from zero. -/ +theorem degree_sub_aeval_pol_eq_bot {α : NatOrdinal.{u}} {u : Nonpositive G K} + (hu : ν u < (α : WithBot NatOrdinal)) : + ν (u - aeval σ.lift (σ.pol hx α u)) = ⊥ := by + classical + unfold pol + rw [dite_eq_left hu] + exact (Classical.choose_spec (σ.exists_polynomial hx u hu)).2.2 + +include hx in +/-- Below `α`, graded injectivity makes the polynomial representative unique. -/ +theorem pol_eq_of_degree_sub_aeval_eq_bot {α : NatOrdinal.{u}} + (hinj : ∀ β < α, OrdinalGraded.InjectiveAt K wt xg β) + {u : Nonpositive G K} (hu : ν u < (α : WithBot NatOrdinal)) + {F : MvPolynomial ι K} (hF : ∀ d ∈ F.support, Finsupp.weight wt d < α) + (h : ν (u - aeval σ.lift F) = ⊥) : σ.pol hx α u = F := by + classical + rw [← sub_eq_zero] + have hinj' : ∀ β < α, ∀ P : MvPolynomial ι K, + IsWeightedHomogeneous wt P β → aeval xg P = 0 → P = 0 := by + intro β hβα + rw [← OrdinalGraded.injectiveAt_iff] + exact hinj β hβα + apply eq_zero_of_forall_weight_lt_of_degree_aeval_eq_bot xg σ.represents + (fun β P hβα hP hP0 ↦ hinj' β hβα P hP hP0) (fun d hd ↦ by + have hdne : (σ.pol hx α u - F).coeff d ≠ 0 := mem_support_iff.mp hd + rw [MvPolynomial.coeff_sub ι] at hdne + by_cases hdpol : d ∈ (σ.pol hx α u).support + · exact σ.pol_weight_lt hx α u d hdpol + · have hdpol0 := notMem_support_iff.mp hdpol + rw [hdpol0, zero_sub, neg_ne_zero] at hdne + exact hF d (mem_support_iff.mpr hdne)) + rw [map_sub] + have hpol := σ.degree_sub_aeval_pol_eq_bot hx hu + have hsplit : aeval σ.lift (σ.pol hx α u) - aeval σ.lift F = + -(u - aeval σ.lift (σ.pol hx α u)) + (u - aeval σ.lift F) := by ring + rw [hsplit] + refine le_bot_iff.mp (((ν).map_add_le_max _ _).trans ?_) + rw [(ν).map_neg, hpol, h, max_self] + +include hx in +/-- The polynomial of a series of degree below `α' ≤ α` has every monomial weight below `α'`. -/ +theorem pol_weight_lt_of_degree_lt {α α' : NatOrdinal.{u}} (hα' : α' ≤ α) + {u : Nonpositive G K} (hu : ν u < (α' : WithBot NatOrdinal)) : + ∀ d ∈ (σ.pol hx α u).support, Finsupp.weight wt d < α' := by + intro d hd + exact WithBot.coe_lt_coe.mp ((σ.pol_weight_le_degree hx + (hu.trans_le (WithBot.coe_le_coe.mpr hα'))) d hd |>.trans_lt hu) + +include hx in +/-- Evaluation of a polynomial of weights below `α` is recovered by `pol`. -/ +theorem pol_aeval {α : NatOrdinal.{u}} + (hinj : ∀ β < α, OrdinalGraded.InjectiveAt K wt xg β) + {F : MvPolynomial ι K} (hF : ∀ d ∈ F.support, Finsupp.weight wt d < α) : + σ.pol hx α (aeval σ.lift F) = F := by + apply σ.pol_eq_of_degree_sub_aeval_eq_bot hx hinj + (σ.degree_aeval_lt hF) hF + rw [sub_self, (ν).map_zero] + +include hx in +/-- `pol` is additive on series below the cutoff. -/ +theorem pol_add {α : NatOrdinal.{u}} + (hinj : ∀ β < α, OrdinalGraded.InjectiveAt K wt xg β) + {u v : Nonpositive G K} (hu : ν u < (α : WithBot NatOrdinal)) + (hv : ν v < (α : WithBot NatOrdinal)) : + σ.pol hx α (u + v) = σ.pol hx α u + σ.pol hx α v := by + have huv : ν (u + v) < (α : WithBot NatOrdinal) := + ((ν).map_add_le_max u v).trans_lt (max_lt hu hv) + apply σ.pol_eq_of_degree_sub_aeval_eq_bot hx hinj huv (fun d hd ↦ by + have hdne : (σ.pol hx α u + σ.pol hx α v).coeff d ≠ 0 := + mem_support_iff.mp hd + rw [AddMonoidAlgebra.coeff_add, Finsupp.add_apply] at hdne + by_cases hdu : d ∈ (σ.pol hx α u).support + · exact σ.pol_weight_lt hx α u d hdu + · have hdu0 := notMem_support_iff.mp hdu + rw [hdu0, zero_add] at hdne + exact σ.pol_weight_lt hx α v d (mem_support_iff.mpr hdne)) + have hu' := σ.degree_sub_aeval_pol_eq_bot hx hu + have hv' := σ.degree_sub_aeval_pol_eq_bot hx hv + rw [map_add] + have hsplit : u + v - (aeval σ.lift (σ.pol hx α u) + + aeval σ.lift (σ.pol hx α v)) = + (u - aeval σ.lift (σ.pol hx α u)) + + (v - aeval σ.lift (σ.pol hx α v)) := by ring + rw [hsplit] + refine le_bot_iff.mp (((ν).map_add_le_max _ _).trans ?_) + rw [hu', hv', max_self] + +include hx in +/-- `pol` commutes with finite sums of series below the cutoff. -/ +theorem pol_sum {α : NatOrdinal.{u}} + (hinj : ∀ β < α, OrdinalGraded.InjectiveAt K wt xg β) + {κ : Type*} (s : Finset κ) (f : κ → Nonpositive G K) + (h : ∀ i ∈ s, ν (f i) < (α : WithBot NatOrdinal)) : + σ.pol hx α (∑ i ∈ s, f i) = ∑ i ∈ s, σ.pol hx α (f i) := by + classical + induction s using Finset.induction_on with + | empty => + rw [Finset.sum_empty, Finset.sum_empty] + exact σ.pol_aeval hx hinj (F := 0) (by simp) + | @insert a s ha ih => + rw [Finset.sum_insert ha, Finset.sum_insert ha, + σ.pol_add hx hinj (h a (Finset.mem_insert_self a s)) + ((ν).map_sum_lt_of_forall_lt s f (WithBot.bot_lt_coe α) + fun i hi ↦ h i (Finset.mem_insert_of_mem hi)), + ih fun i hi ↦ h i (Finset.mem_insert_of_mem hi)] + +include hx in +/-- `pol` commutes with scalar multiplication on series below the cutoff. -/ +theorem pol_smul {α : NatOrdinal.{u}} + (hinj : ∀ β < α, OrdinalGraded.InjectiveAt K wt xg β) + (k : K) {u : Nonpositive G K} (hu : ν u < (α : WithBot NatOrdinal)) : + σ.pol hx α (k • u) = k • σ.pol hx α u := by + have hku : ν (k • u) < (α : WithBot NatOrdinal) := + (degree_smul_le k u).trans_lt hu + apply σ.pol_eq_of_degree_sub_aeval_eq_bot hx hinj hku + · intro d hd + have hdne : (k • σ.pol hx α u).coeff d ≠ 0 := + mem_support_iff.mp hd + rw [MvPolynomial.coeff_smul] at hdne + exact σ.pol_weight_lt hx α u d + (mem_support_iff.mpr fun hzero ↦ hdne (by rw [hzero, smul_zero])) + · rw [map_smul] + have herror := σ.degree_sub_aeval_pol_eq_bot hx hu + have heq : k • u - k • aeval σ.lift (σ.pol hx α u) = + k • (u - aeval σ.lift (σ.pol hx α u)) := by module + rw [heq] + exact le_bot_iff.mp ((degree_smul_le k _).trans_eq herror) + +omit [CharZero K] in +open Classical in +/-- If a polynomial has all monomial weights below `bound`, then a nonzero coefficient of +`X B₀ ^ k` has weight, after restoring that power, below `bound`. -/ +theorem weightedTotalDegree_xCoeff_add_nsmul_lt + {Q : MvPolynomial ι K} {bound : NatOrdinal.{u}} + (hQ : ∀ d ∈ Q.support, Finsupp.weight wt d < bound) + (B₀ : ι) (k : ℕ) (h : xCoeff B₀ k Q ≠ 0) : + weightedTotalDegree wt (xCoeff B₀ k Q) + k • wt B₀ < bound := by + classical + obtain ⟨d, hd, hsup⟩ := Finset.exists_mem_eq_sup _ (support_nonempty.mpr h) + (Finsupp.weight wt) + have hmem : d + Finsupp.single B₀ k ∈ (xCoeff B₀ k Q * X B₀ ^ k).support := by + rw [mem_support_iff, X_pow_eq_monomial, coeff_mul_monomial', ite_eq_left le_add_self, + add_tsub_cancel_right, mul_one] + exact mem_support_iff.mp hd + have hlt := hQ _ (support_xCoeff_mul_X_pow_subset B₀ k Q hmem) + rw [map_add, Finsupp.weight_single] at hlt + rwa [weightedTotalDegree, hsup] + +include hx in +/-- The chosen polynomial of a series of non-bottom degree is nonzero. -/ +theorem pol_ne_zero_of_degree_eq {α ρ : NatOrdinal.{u}} {u : Nonpositive G K} + (hu : ν u = (ρ : WithBot NatOrdinal)) (hρα : ρ < α) : σ.pol hx α u ≠ 0 := by + intro hzero + have hsub := σ.degree_sub_aeval_pol_eq_bot hx (hu.trans_lt (WithBot.coe_lt_coe.mpr hρα)) + rw [hzero, map_zero, sub_zero, hu] at hsub + exact WithBot.coe_ne_bot hsub + +include hx in +/-- A series of bottom degree has zero representing polynomial. -/ +theorem pol_eq_zero_of_degree_eq_bot {α : NatOrdinal.{u}} {u : Nonpositive G K} + (hu : ν u = ⊥) : σ.pol hx α u = 0 := by + classical + unfold pol + rw [dite_eq_left (by rw [hu]; exact WithBot.bot_lt_coe α)] + have hspec := Classical.choose_spec (σ.exists_polynomial hx u + (by rw [hu]; exact WithBot.bot_lt_coe α)) + apply MvPolynomial.eq_zero_iff.mpr + intro d + by_contra hd + have hdmem := mem_support_iff.mpr hd + exact WithBot.not_coe_le_bot _ ((hspec.1 d hdmem).trans_eq hu) + +include hx in +/-- At exact non-bottom degree `ρ`, the chosen polynomial has weighted total degree `ρ`. -/ +theorem weightedTotalDegree_pol_eq_of_degree_eq {α ρ : NatOrdinal.{u}} + {u : Nonpositive G K} (hu : ν u = (ρ : WithBot NatOrdinal)) (hρα : ρ < α) : + weightedTotalDegree wt (σ.pol hx α u) = ρ := by + have hne := σ.pol_ne_zero_of_degree_eq hx hu hρα + obtain ⟨d, hd, hsup⟩ := Finset.exists_mem_eq_sup _ (support_nonempty.mpr hne) + (Finsupp.weight wt) + have hle : weightedTotalDegree wt (σ.pol hx α u) ≤ ρ := by + rw [weightedTotalDegree, hsup] + exact WithBot.coe_le_coe.mp (σ.pol_weight_le_degree hx + (hu.trans_lt (WithBot.coe_lt_coe.mpr hρα)) d hd |>.trans_eq hu) + refine le_antisymm hle ?_ + by_contra hnot + have hlt : weightedTotalDegree wt (σ.pol hx α u) < ρ := lt_of_not_ge hnot + have heval : ν (aeval σ.lift (σ.pol hx α u)) < (ρ : WithBot NatOrdinal) := + σ.degree_aeval_lt (fun d' hd' ↦ by + exact (le_weightedTotalDegree wt hd').trans_lt hlt) + have hsub := σ.degree_sub_aeval_pol_eq_bot hx + (hu.trans_lt (WithBot.coe_lt_coe.mpr hρα)) + have hdegree := degree_eq_of_degree_sub_eq_bot hsub + rw [hu] at hdegree + exact heval.ne (hdegree.symm) + +include hx in +/-- A fixed upper bound on the chosen polynomials of proper truncations contradicts exact degree +and the approach theorem for Cantor–Bendixson ranks whenever the shifted degree exceeds it. -/ +theorem false_of_forall_weightedTotalDegree_pol_add_lt {α lam sigma bound : NatOrdinal.{u}} + {u : Nonpositive G K} (hu : ν u = (lam : WithBot NatOrdinal)) (hlam : lam ≠ 0) + (hσ : sigma = 0 ∨ NatOrdinal.leastTerm lam ≤ NatOrdinal.leastTerm sigma) + (hbound : bound < lam + sigma) {l : G} (hl : l < 0) + (hwin : ∀ γ : G, l < γ → γ < 0 → σ.pol hx α (translatedTruncLE γ u) ≠ 0 → + weightedTotalDegree wt (σ.pol hx α (translatedTruncLE γ u)) + sigma < bound) + (hlamα : lam < α) : False := by + obtain ⟨ρ, hρlam, hρbound⟩ := + NatOrdinal.exists_lt_le_add_of_lastCantorTerm_le hlam hσ hbound + obtain ⟨γ, hlγ, hγ0, hγeq⟩ := exists_lt_and_degree_translatedTruncLE_eq + u lam ρ hu hρlam hl + have hρα : ρ < α := hρlam.trans hlamα + have hp0 := σ.pol_ne_zero_of_degree_eq hx hγeq hρα + have hdeg := σ.weightedTotalDegree_pol_eq_of_degree_eq hx hγeq hρα + exact absurd (hwin γ hlγ hγ0 hp0) (not_lt.mpr (hdeg ▸ hρbound)) + +include hx in +/-- Multiplication of represented polynomials computes the polynomial of a product when the +product polynomial still has all weights below the cutoff. -/ +theorem pol_mul {α : NatOrdinal.{u}} + (hinj : ∀ β < α, OrdinalGraded.InjectiveAt K wt xg β) + {u v : Nonpositive G K} (hu : ν u < (α : WithBot NatOrdinal)) + (hv : ν v < (α : WithBot NatOrdinal)) + (hprod : ∀ d ∈ (σ.pol hx α u * σ.pol hx α v).support, Finsupp.weight wt d < α) : + ν (u * v) < (α : WithBot NatOrdinal) ∧ + σ.pol hx α (u * v) = σ.pol hx α u * σ.pol hx α v := by + have hcongr := degree_sub_eq_bot_mul + (σ.degree_sub_aeval_pol_eq_bot hx hu) (σ.degree_sub_aeval_pol_eq_bot hx hv) + rw [← map_mul] at hcongr + have heval : ν (aeval σ.lift (σ.pol hx α u * σ.pol hx α v)) < + (α : WithBot NatOrdinal) := σ.degree_aeval_lt hprod + have hdegree : ν (u * v) = ν (aeval σ.lift (σ.pol hx α u * σ.pol hx α v)) := + degree_eq_of_degree_sub_eq_bot hcongr + refine ⟨hdegree ▸ heval, ?_⟩ + exact σ.pol_eq_of_degree_sub_aeval_eq_bot hx hinj (hdegree ▸ heval) hprod hcongr + +include hx in +/-- The finite Cantor–Bendixson convolution formula in the representing polynomial ring. -/ +theorem pol_translatedTruncLE_mul {α m n : NatOrdinal.{u}} + (hinj : ∀ β < α, OrdinalGraded.InjectiveAt K wt xg β) + {a b : Nonpositive G K} (ha : Nonpositive.HasLowerTruncationDegree a m) + (hb : Nonpositive.HasLowerTruncationDegree b n) + (hm : m < α) (hn : n < α) (hmn : m + n ≤ α) {γ : G} (hγ : γ < 0) : + σ.pol hx α (translatedTruncLE γ (a * b)) = + ∑ q ∈ (a : HahnSeries G K).closedSupportAddFiber (b : HahnSeries G K) γ, + σ.pol hx α (translatedTruncLE q.1 a) * σ.pol hx α (translatedTruncLE q.2 b) := by + classical + set S := (a : HahnSeries G K).closedSupportAddFiber (b : HahnSeries G K) γ with hS + have hq : ∀ q ∈ S, q.1 ≤ 0 ∧ q.2 ≤ 0 ∧ (q.1 < 0 ∨ q.2 < 0) := by + intro q hq + obtain ⟨hq1, hq2, hsum⟩ := ((a : HahnSeries G K).mem_closedSupportAddFiber + (b : HahnSeries G K) γ q).mp hq + have hq1le : q.1 ≤ 0 := closure_minimal a.property isClosed_Iic + ((mem_closedSupport _ _).mp hq1) + have hq2le : q.2 ≤ 0 := closure_minimal b.property isClosed_Iic + ((mem_closedSupport _ _).mp hq2) + refine ⟨hq1le, hq2le, ?_⟩ + rcases lt_or_eq_of_le hq1le with hq1neg | hq1zero + · exact Or.inl hq1neg + · right + have : q.2 = γ := by rw [← hsum, hq1zero, zero_add] + exact this ▸ hγ + have hterm : ∀ q ∈ S, ∀ d ∈ + (σ.pol hx α (translatedTruncLE q.1 a) * + σ.pol hx α (translatedTruncLE q.2 b)).support, + Finsupp.weight wt d < α := by + intro q hqS d hd + obtain ⟨d₁, hd₁, d₂, hd₂, rfl⟩ := Finset.mem_add.mp + (MvPolynomial.support_mul _ _ hd) + rw [map_add] + obtain ⟨hq1le, hq2le, hproper⟩ := hq q hqS + rcases hproper with hq1neg | hq2neg + · have h1 := σ.pol_weight_lt_of_degree_lt hx hm.le + (ha.degree_translatedTruncLE_lt hq1neg) d₁ hd₁ + have h2 := σ.pol_weight_le_degree hx + ((ha.degree_translatedTruncLE_lt hq1neg).trans + (WithBot.coe_lt_coe.mpr hm)) d₁ hd₁ + have h2' := σ.pol_weight_le_degree hx + ((hb.degree_translatedTruncLE_le hq2le).trans_lt + (WithBot.coe_lt_coe.mpr hn)) d₂ hd₂ + have h2n : Finsupp.weight wt d₂ ≤ n := + WithBot.coe_le_coe.mp (h2'.trans (hb.degree_translatedTruncLE_le hq2le)) + exact (add_lt_add_of_lt_of_le h1 h2n).trans_le hmn + · have h1m : Finsupp.weight wt d₁ ≤ m := WithBot.coe_le_coe.mp + ((σ.pol_weight_le_degree hx + ((ha.degree_translatedTruncLE_le hq1le).trans_lt + (WithBot.coe_lt_coe.mpr hm)) d₁ hd₁).trans + (ha.degree_translatedTruncLE_le hq1le)) + have h2 := σ.pol_weight_lt_of_degree_lt hx hn.le + (hb.degree_translatedTruncLE_lt hq2neg) d₂ hd₂ + exact (add_lt_add_of_le_of_lt h1m h2).trans_le hmn + have hsumw : ∀ d ∈ (∑ q ∈ S, + σ.pol hx α (translatedTruncLE q.1 a) * + σ.pol hx α (translatedTruncLE q.2 b)).support, + Finsupp.weight wt d < α := by + intro d hd + obtain ⟨q, hqS, hdq⟩ := Finset.mem_biUnion.mp (MvPolynomial.support_sum hd) + exact hterm q hqS d hdq + have hdeg : ν (translatedTruncLE γ (a * b)) < (α : WithBot NatOrdinal) := + ((ha.mul rfl hb).degree_translatedTruncLE_lt hγ).trans_le + (WithBot.coe_le_coe.mpr hmn) + have haall : ∀ q : G, ν (translatedTruncLE q a) < (α : WithBot NatOrdinal) := by + intro q + rcases le_total q 0 with hq | hq + · exact (ha.degree_translatedTruncLE_le hq).trans_lt (WithBot.coe_lt_coe.mpr hm) + · by_cases hq0 : q = 0 + · subst q + rw [translatedTruncLE_zero] + exact ha.degree_le.trans_lt (WithBot.coe_lt_coe.mpr hm) + rw [degree_translatedTruncLE_of_pos (lt_of_le_of_ne hq (Ne.symm hq0))] + exact WithBot.bot_lt_coe α + have hball : ∀ q : G, ν (translatedTruncLE q b) < (α : WithBot NatOrdinal) := by + intro q + rcases le_total q 0 with hq | hq + · exact (hb.degree_translatedTruncLE_le hq).trans_lt (WithBot.coe_lt_coe.mpr hn) + · by_cases hq0 : q = 0 + · subst q + rw [translatedTruncLE_zero] + exact hb.degree_le.trans_lt (WithBot.coe_lt_coe.mpr hn) + rw [degree_translatedTruncLE_of_pos (lt_of_le_of_ne hq (Ne.symm hq0))] + exact WithBot.bot_lt_coe α + apply σ.pol_eq_of_degree_sub_aeval_eq_bot hx hinj hdeg hsumw + simpa only [hS, map_sum, map_mul] using + degree_translatedTruncLE_mul_sub_aeval_sum_eq_bot a b γ + (fun q ↦ σ.pol hx α (translatedTruncLE q a)) + (fun q ↦ σ.pol hx α (translatedTruncLE q b)) + (fun q ↦ σ.degree_sub_aeval_pol_eq_bot hx (haall q)) + (fun q ↦ σ.degree_sub_aeval_pol_eq_bot hx (hball q)) + +include hx in +/-- The convolution identity remains true after adjoining the two boundary pairs `(0, γ)` and +`(γ, 0)`: a missing boundary point contributes a bottom-degree truncation and hence zero. -/ +theorem pol_translatedTruncLE_mul_boundary {α m n : NatOrdinal.{u}} + (hinj : ∀ β < α, OrdinalGraded.InjectiveAt K wt xg β) + {a b : Nonpositive G K} (ha : Nonpositive.HasLowerTruncationDegree a m) + (hb : Nonpositive.HasLowerTruncationDegree b n) + (hm : m < α) (hn : n < α) (hmn : m + n ≤ α) {γ : G} (hγ : γ < 0) : + σ.pol hx α (translatedTruncLE γ (a * b)) = + ∑ q ∈ insert (0, γ) (insert (γ, 0) + ((a : HahnSeries G K).closedSupportAddFiber (b : HahnSeries G K) γ)), + σ.pol hx α (translatedTruncLE q.1 a) * σ.pol hx α (translatedTruncLE q.2 b) := by + rw [σ.pol_translatedTruncLE_mul hx hinj ha hb hm hn hmn hγ] + classical + refine Finset.sum_subset (by + intro q hq + exact Finset.mem_insert_of_mem (Finset.mem_insert_of_mem hq)) ?_ + intro q hq hqnot + rcases Finset.mem_insert.mp hq with hq | hq + · subst q + have hnot : ¬(0 ∈ (a : HahnSeries G K).closedSupport ∧ + γ ∈ (b : HahnSeries G K).closedSupport) := by + intro h + exact hqnot ((a : HahnSeries G K).mem_closedSupportAddFiber + (b : HahnSeries G K) γ (0, γ) |>.mpr ⟨h.1, h.2, zero_add γ⟩) + by_cases h0a : 0 ∈ (a : HahnSeries G K).closedSupport + · have hγb : γ ∉ (b : HahnSeries G K).closedSupport := fun h ↦ hnot ⟨h0a, h⟩ + have hbot : ν (translatedTruncLE γ b) = ⊥ := by + rw [degree_translatedTruncLE_eq, ite_eq_right hγb] + rw [σ.pol_eq_zero_of_degree_eq_bot hx hbot, mul_zero] + · have hbot : ν a = ⊥ := by + rw [cantorBendixsonDegreeValuation_apply, cantorBendixsonValuation_apply, + cantorBendixsonValue_of_notMem (a : HahnSeries G K) + (by simpa only [mem_closedSupport] using h0a), NatOrdinal.of_zero, + NatOrdinal.cantorDegree_zero] + rw [translatedTruncLE_zero, σ.pol_eq_zero_of_degree_eq_bot hx hbot, zero_mul] + · rcases Finset.mem_insert.mp hq with hq | hq + · subst q + have hnot : ¬(γ ∈ (a : HahnSeries G K).closedSupport ∧ + 0 ∈ (b : HahnSeries G K).closedSupport) := by + intro h + exact hqnot ((a : HahnSeries G K).mem_closedSupportAddFiber + (b : HahnSeries G K) γ (γ, 0) |>.mpr ⟨h.1, h.2, add_zero γ⟩) + by_cases hγa : γ ∈ (a : HahnSeries G K).closedSupport + · have h0b : 0 ∉ (b : HahnSeries G K).closedSupport := fun h ↦ hnot ⟨hγa, h⟩ + have hbot : ν b = ⊥ := by + rw [cantorBendixsonDegreeValuation_apply, cantorBendixsonValuation_apply, + cantorBendixsonValue_of_notMem (b : HahnSeries G K) + (by simpa only [mem_closedSupport] using h0b), NatOrdinal.of_zero, + NatOrdinal.cantorDegree_zero] + rw [translatedTruncLE_zero, σ.pol_eq_zero_of_degree_eq_bot hx hbot, mul_zero] + · have hbot : ν (translatedTruncLE γ a) = ⊥ := by + rw [degree_translatedTruncLE_eq, ite_eq_right hγa] + rw [σ.pol_eq_zero_of_degree_eq_bot hx hbot, zero_mul] + · exact absurd hq hqnot + +include hx in +/-- The polynomial representing an untruncated lifted generator is its variable. -/ +theorem pol_lift {α : NatOrdinal.{u}} + (hinj : ∀ β < α, OrdinalGraded.InjectiveAt K wt xg β) + {i : ι} (hi : wt i < α) : σ.pol hx α (σ.lift i) = X i := by + rw [← (aeval_X (R := K) σ.lift i)] + apply σ.pol_aeval hx hinj + intro d hd + rw [support_X, Finset.mem_singleton] at hd + rwa [hd, Finsupp.weight_single, one_smul] + +include hx in +/-- The polynomial representing a power of a lifted generator is the corresponding variable +power, while its weight stays below the cutoff. -/ +theorem pol_lift_pow {α : NatOrdinal.{u}} + (hinj : ∀ β < α, OrdinalGraded.InjectiveAt K wt xg β) + {i : ι} (e : ℕ) (he : e • wt i < α) : + σ.pol hx α (σ.lift i ^ e) = X i ^ e := by + classical + have hpow : σ.lift i ^ e = aeval σ.lift (X i ^ e : MvPolynomial ι K) := by + rw [map_pow, aeval_X] + rw [hpow] + apply σ.pol_aeval hx hinj + intro d hd + rw [X_pow_eq_monomial, support_monomial, ite_eq_right one_ne_zero, + Finset.mem_singleton] at hd + rw [hd, Finsupp.weight_single] + exact he + +include hx in +/-- A proper truncation of a lifted generator does not involve any variable of at least its +weight. -/ +theorem pol_translatedTruncLE_lift_mem_supported {α : NatOrdinal.{u}} + (hσ : HasLowerTruncationDegrees σ) {i B₀ : ι} (hi : wt i < α) (hle : wt i ≤ wt B₀) + {γ : G} (hγ : γ < 0) : + σ.pol hx α (translatedTruncLE γ (σ.lift i)) ∈ supported K {B₀}ᶜ := by + apply mem_supported_of_forall_weight_lt B₀ wt + intro d hd + exact (σ.pol_weight_lt_of_degree_lt hx hi.le + (((hasLowerTruncationDegrees_iff σ).mp hσ i).degree_translatedTruncLE_lt hγ) d hd).trans_le hle + +variable (α : NatOrdinal.{u}) (B₀ : ι) in +/-- A series satisfying the degree and proper-truncation bounds whose polynomial, and the +polynomial of every proper truncation, omit `X_{B₀}`. -/ +structure FreeOfVariable (u : Nonpositive G K) (m : NatOrdinal.{u}) : Prop where + lowerTruncationDegree : Nonpositive.HasLowerTruncationDegree u m + degree_lt : m < α + pol_mem : σ.pol hx α u ∈ supported K {B₀}ᶜ + trunc_mem : ∀ {γ : G}, γ < 0 → + σ.pol hx α (translatedTruncLE γ u) ∈ supported K {B₀}ᶜ + +namespace FreeOfVariable + +variable {σ hx} + +/-- The polynomial at any nonpositive cutoff omits the distinguished variable. -/ +theorem pol_trunc_mem_nonpos {α : NatOrdinal.{u}} {B₀ : ι} {u : Nonpositive G K} + {m : NatOrdinal.{u}} (hu : FreeOfVariable σ hx α B₀ u m) {γ : G} (hγ : γ ≤ 0) : + σ.pol hx α (translatedTruncLE γ u) ∈ supported K {B₀}ᶜ := by + rcases eq_or_lt_of_le hγ with rfl | hγ + · rw [translatedTruncLE_zero] + exact hu.pol_mem + · exact hu.trunc_mem hγ + +/-- A lifted generator distinct from `B₀` and of no greater weight is free of `B₀`. -/ +theorem lift (hσ : HasLowerTruncationDegrees σ) {α : NatOrdinal.{u}} {B₀ i : ι} + (hinj : ∀ β < α, OrdinalGraded.InjectiveAt K wt xg β) + (hi : i ≠ B₀) (hile : wt i ≤ wt B₀) (hB₀ : wt B₀ < α) : + FreeOfVariable σ hx α B₀ (σ.lift i) (wt i) where + lowerTruncationDegree := (hasLowerTruncationDegrees_iff σ).mp hσ i + degree_lt := hile.trans_lt hB₀ + pol_mem := by + rw [σ.pol_lift hx hinj (hile.trans_lt hB₀)] + exact X_mem_supported.mpr hi + trunc_mem := fun hγ ↦ + σ.pol_translatedTruncLE_lift_mem_supported hx hσ (hile.trans_lt hB₀) hile hγ + +/-- Sums of series free of `B₀` at a common degree remain free. -/ +theorem add {α : NatOrdinal.{u}} {B₀ : ι} {a b : Nonpositive G K} {m : NatOrdinal.{u}} + (hinj : ∀ β < α, OrdinalGraded.InjectiveAt K wt xg β) + (ha : FreeOfVariable σ hx α B₀ a m) (hb : FreeOfVariable σ hx α B₀ b m) : + FreeOfVariable σ hx α B₀ (a + b) m where + lowerTruncationDegree := ha.lowerTruncationDegree.add hb.lowerTruncationDegree + degree_lt := ha.degree_lt + pol_mem := by + rw [σ.pol_add hx hinj + (ha.lowerTruncationDegree.degree_le.trans_lt (WithBot.coe_lt_coe.mpr ha.degree_lt)) + (hb.lowerTruncationDegree.degree_le.trans_lt (WithBot.coe_lt_coe.mpr hb.degree_lt))] + exact Subalgebra.add_mem _ ha.pol_mem hb.pol_mem + trunc_mem := by + intro γ hγ + rw [map_add, σ.pol_add hx hinj + (ha.lowerTruncationDegree.degree_translatedTruncLE_lt hγ |>.trans + (WithBot.coe_lt_coe.mpr ha.degree_lt)) + (hb.lowerTruncationDegree.degree_translatedTruncLE_lt hγ |>.trans + (WithBot.coe_lt_coe.mpr hb.degree_lt))] + exact Subalgebra.add_mem _ (ha.trunc_mem hγ) (hb.trunc_mem hγ) + +/-- Scalar multiples of a series free of `B₀` remain free. -/ +theorem smul {α : NatOrdinal.{u}} {B₀ : ι} (k : K) {a : Nonpositive G K} + {m : NatOrdinal.{u}} (hinj : ∀ β < α, OrdinalGraded.InjectiveAt K wt xg β) + (ha : FreeOfVariable σ hx α B₀ a m) : FreeOfVariable σ hx α B₀ (k • a) m where + lowerTruncationDegree := by + rw [Nonpositive.hasLowerTruncationDegree_iff] + constructor + · exact (degree_smul_le k a).trans ha.lowerTruncationDegree.degree_le + · intro γ hγ + rw [translatedTruncLE_smul] + exact (degree_smul_le k _).trans_lt + (ha.lowerTruncationDegree.degree_translatedTruncLE_lt hγ) + degree_lt := ha.degree_lt + pol_mem := by + rw [σ.pol_smul hx hinj k + (ha.lowerTruncationDegree.degree_le.trans_lt (WithBot.coe_lt_coe.mpr ha.degree_lt))] + exact Subalgebra.smul_mem _ ha.pol_mem k + trunc_mem := by + intro γ hγ + rw [translatedTruncLE_smul, σ.pol_smul hx hinj k + (ha.lowerTruncationDegree.degree_translatedTruncLE_lt hγ |>.trans + (WithBot.coe_lt_coe.mpr ha.degree_lt))] + exact Subalgebra.smul_mem _ (ha.trunc_mem hγ) k + +/-- The zero series is free at every degree below `α`. -/ +theorem zero {α : NatOrdinal.{u}} {B₀ : ι} {m : NatOrdinal.{u}} (hm : m < α) : + FreeOfVariable σ hx α B₀ (0 : Nonpositive G K) m where + lowerTruncationDegree := hasLowerTruncationDegree_zero m + degree_lt := hm + pol_mem := by + rw [σ.pol_eq_zero_of_degree_eq_bot hx (by rw [(ν).map_zero])] + exact Subalgebra.zero_mem _ + trunc_mem := by + intro γ _ + rw [map_zero, σ.pol_eq_zero_of_degree_eq_bot hx (by rw [(ν).map_zero])] + exact Subalgebra.zero_mem _ + +open Classical in +/-- The identity series is free of every variable when `0 < α`. -/ +theorem one {α : NatOrdinal.{u}} {B₀ : ι} (hα : 0 < α) + (hinj : ∀ β < α, OrdinalGraded.InjectiveAt K wt xg β) : + FreeOfVariable σ hx α B₀ (1 : Nonpositive G K) 0 where + lowerTruncationDegree := hasLowerTruncationDegree_one + degree_lt := hα + pol_mem := by + have hone : σ.pol hx α (1 : Nonpositive G K) = 1 := by + rw [← map_one (MvPolynomial.aeval (R := K) σ.lift)] + exact σ.pol_aeval hx hinj (F := 1) (by + intro d hd + have hdne : (1 : MvPolynomial ι K).coeff d ≠ 0 := + mem_support_iff.mp hd + rw [MvPolynomial.coeff_one] at hdne + split_ifs at hdne with hd0 + · subst d + simpa only [map_zero] using hα + · exact absurd rfl hdne) + rw [hone] + exact Subalgebra.one_mem _ + trunc_mem := by + intro γ hγ + have hzero : translatedTruncLE γ (1 : Nonpositive G K) = 0 := by + apply Subtype.ext + ext g + rw [coe_translatedTruncLE, HahnSeries.coeff_translate, HahnSeries.coeff_truncLE, + show ((1 : Nonpositive G K) : HahnSeries G K) = HahnSeries.C 1 by rfl, + HahnSeries.C_apply, HahnSeries.coeff_single] + split_ifs with hle heq + · exact absurd (heq ▸ hle) (not_le.mpr hγ) + · rfl + · rfl + rw [hzero, σ.pol_eq_zero_of_degree_eq_bot hx (by rw [(ν).map_zero])] + exact Subalgebra.zero_mem _ + +omit [UniformSpace G] [IsUniformAddGroup G] [OrderTopology G] [Nontrivial G] [CompleteSpace G] + [CharZero K] in +/-- A proper translated truncation of the identity series is zero. -/ +theorem translatedTruncLE_one {γ : G} (hγ : γ < 0) : + translatedTruncLE γ (1 : Nonpositive G K) = 0 := by + apply Subtype.ext + ext g + rw [coe_translatedTruncLE, HahnSeries.coeff_translate, HahnSeries.coeff_truncLE, + show ((1 : Nonpositive G K) : HahnSeries G K) = HahnSeries.C 1 by rfl, + HahnSeries.C_apply, HahnSeries.coeff_single] + split_ifs with hle heq + · exact absurd (heq ▸ hle) (not_le.mpr hγ) + · rfl + · rfl + +/-- A finite sum of series free of `B₀` at a common degree remains free. -/ +theorem sum {α : NatOrdinal.{u}} {B₀ : ι} {κ : Type*} {m : NatOrdinal.{u}} + (hinj : ∀ β < α, OrdinalGraded.InjectiveAt K wt xg β) + (hm : m < α) (s : Finset κ) (f : κ → Nonpositive G K) + (h : ∀ i ∈ s, FreeOfVariable σ hx α B₀ (f i) m) : + FreeOfVariable σ hx α B₀ (∑ i ∈ s, f i) m := by + classical + induction s using Finset.induction_on with + | empty => simpa using zero (σ := σ) (hx := hx) (B₀ := B₀) hm + | @insert a s ha ih => + rw [Finset.sum_insert ha] + exact (h a (Finset.mem_insert_self a s)).add hinj + (ih fun i hi ↦ h i (Finset.mem_insert_of_mem hi)) + +/-- Products of series free of `B₀` remain free when their degree sum stays below `α`. -/ +theorem mul {α : NatOrdinal.{u}} {B₀ : ι} {a b : Nonpositive G K} {m n : NatOrdinal.{u}} + (hinj : ∀ β < α, OrdinalGraded.InjectiveAt K wt xg β) + (ha : FreeOfVariable σ hx α B₀ a m) (hb : FreeOfVariable σ hx α B₀ b n) + (hmn : m + n < α) : FreeOfVariable σ hx α B₀ (a * b) (m + n) where + lowerTruncationDegree := ha.lowerTruncationDegree.mul rfl hb.lowerTruncationDegree + degree_lt := hmn + pol_mem := by + classical + have hprod : ∀ d ∈ (σ.pol hx α a * σ.pol hx α b).support, + Finsupp.weight wt d < α := by + intro d hd + obtain ⟨d₁, hd₁, d₂, hd₂, rfl⟩ := Finset.mem_add.mp + (MvPolynomial.support_mul _ _ hd) + rw [map_add] + have h1m : Finsupp.weight wt d₁ ≤ m := WithBot.coe_le_coe.mp + ((σ.pol_weight_le_degree hx + (ha.lowerTruncationDegree.degree_le.trans_lt + (WithBot.coe_lt_coe.mpr ha.degree_lt)) d₁ hd₁).trans + ha.lowerTruncationDegree.degree_le) + have h2n : Finsupp.weight wt d₂ ≤ n := WithBot.coe_le_coe.mp + ((σ.pol_weight_le_degree hx + (hb.lowerTruncationDegree.degree_le.trans_lt + (WithBot.coe_lt_coe.mpr hb.degree_lt)) d₂ hd₂).trans + hb.lowerTruncationDegree.degree_le) + exact (add_le_add h1m h2n).trans_lt hmn + have haα : ν a < (α : WithBot NatOrdinal) := + ha.lowerTruncationDegree.degree_le.trans_lt (WithBot.coe_lt_coe.mpr ha.degree_lt) + have hbα : ν b < (α : WithBot NatOrdinal) := + hb.lowerTruncationDegree.degree_le.trans_lt (WithBot.coe_lt_coe.mpr hb.degree_lt) + rw [(σ.pol_mul hx hinj haα hbα hprod).2] + exact Subalgebra.mul_mem _ ha.pol_mem hb.pol_mem + trunc_mem := by + intro γ hγ + rw [σ.pol_translatedTruncLE_mul hx hinj ha.lowerTruncationDegree hb.lowerTruncationDegree + ha.degree_lt hb.degree_lt hmn.le hγ] + refine Subalgebra.sum_mem _ fun q hq ↦ Subalgebra.mul_mem _ ?_ ?_ + · exact ha.pol_trunc_mem_nonpos (closure_minimal a.property isClosed_Iic + ((mem_closedSupport _ _).mp (((a : HahnSeries G K).mem_closedSupportAddFiber + (b : HahnSeries G K) γ q).mp hq).1)) + · exact hb.pol_trunc_mem_nonpos (closure_minimal b.property isClosed_Iic + ((mem_closedSupport _ _).mp (((a : HahnSeries G K).mem_closedSupportAddFiber + (b : HahnSeries G K) γ q).mp hq).2.1)) + +/-- Powers of a free series remain free when their weighted degree stays below `α`. -/ +theorem pow {α : NatOrdinal.{u}} {B₀ : ι} {a : Nonpositive G K} {m : NatOrdinal.{u}} + (hinj : ∀ β < α, OrdinalGraded.InjectiveAt K wt xg β) + (ha : FreeOfVariable σ hx α B₀ a m) (n : ℕ) (hn : n • m < α) : + FreeOfVariable σ hx α B₀ (a ^ n) (n • m) := by + induction n with + | zero => + classical + rw [pow_zero, zero_smul] + refine ⟨hasLowerTruncationDegree_one, hn, ?_, ?_⟩ + · have hone : σ.pol hx α (1 : Nonpositive G K) = 1 := by + rw [← map_one (aeval (R := K) σ.lift)] + exact σ.pol_aeval hx hinj (F := 1) (by + intro d hd + have hdne : (1 : MvPolynomial ι K).coeff d ≠ 0 := + mem_support_iff.mp hd + rw [MvPolynomial.coeff_one] at hdne + split_ifs at hdne with hd0 + · subst d + simpa only [map_zero, zero_smul] using hn + · exact absurd rfl hdne) + rw [hone] + exact Subalgebra.one_mem _ + · intro γ hγ + have hzero : translatedTruncLE γ (1 : Nonpositive G K) = 0 := by + apply Subtype.ext + ext g + rw [coe_translatedTruncLE, HahnSeries.coeff_translate, HahnSeries.coeff_truncLE, + show ((1 : Nonpositive G K) : HahnSeries G K) = HahnSeries.C 1 by rfl, + HahnSeries.C_apply, HahnSeries.coeff_single] + split_ifs with hle heq + · exact absurd (heq ▸ hle) (not_le.mpr hγ) + · rfl + · rfl + rw [hzero, σ.pol_eq_zero_of_degree_eq_bot hx (by rw [(ν).map_zero])] + exact Subalgebra.zero_mem _ + | succ n ih => + rw [pow_succ] + have hsucc : (n + 1) • m = n • m + m := by + rw [add_nsmul, one_nsmul] + rw [hsucc] at hn ⊢ + have hn' : n • m < α := by + exact NatOrdinal.le_add_right.trans_lt hn + apply (ih hn').mul hinj ha + exact hn + +/-- A finite product of free series is free when the sum of their degrees stays below `α`. -/ +theorem prod {α : NatOrdinal.{u}} {B₀ : ι} {κ : Type*} (hα : 0 < α) + (hinj : ∀ β < α, OrdinalGraded.InjectiveAt K wt xg β) + (s : Finset κ) (f : κ → Nonpositive G K) (m : κ → NatOrdinal.{u}) + (h : ∀ i ∈ s, FreeOfVariable σ hx α B₀ (f i) (m i)) + (hsum : ∑ i ∈ s, m i < α) : + FreeOfVariable σ hx α B₀ (∏ i ∈ s, f i) (∑ i ∈ s, m i) := by + classical + induction s using Finset.induction_on with + | empty => + rw [Finset.prod_empty, Finset.sum_empty] + exact (hasLowerTruncationDegree_one |> fun hp ↦ + ⟨hp, hα, by + have hone : σ.pol hx α (1 : Nonpositive G K) = 1 := by + rw [← map_one (aeval (R := K) σ.lift)] + exact σ.pol_aeval hx hinj (F := 1) (by + intro d hd + have hdne : (1 : MvPolynomial ι K).coeff d ≠ 0 := + mem_support_iff.mp hd + rw [MvPolynomial.coeff_one] at hdne + split_ifs at hdne with hd0 + · subst d + simpa only [map_zero] using hα + · exact absurd rfl hdne) + rw [hone] + exact Subalgebra.one_mem _, fun {γ} hγ ↦ by + have hzero : translatedTruncLE γ (1 : Nonpositive G K) = 0 := by + apply Subtype.ext + ext g + rw [coe_translatedTruncLE, HahnSeries.coeff_translate, + HahnSeries.coeff_truncLE, + show ((1 : Nonpositive G K) : HahnSeries G K) = HahnSeries.C 1 by rfl, + HahnSeries.C_apply, HahnSeries.coeff_single] + split_ifs with hle heq + · exact absurd (heq ▸ hle) (not_le.mpr hγ) + · rfl + · rfl + rw [hzero, σ.pol_eq_zero_of_degree_eq_bot hx (by rw [(ν).map_zero])] + exact Subalgebra.zero_mem _⟩) + | @insert a s ha ih => + rw [Finset.prod_insert ha, Finset.sum_insert ha] + have hs : ∑ i ∈ s, m i < α := by + rw [Finset.sum_insert ha] at hsum + exact NatOrdinal.le_add_left.trans_lt hsum + rw [Finset.sum_insert ha] at hsum + exact (h a (Finset.mem_insert_self a s)).mul hinj + (ih (fun i hi ↦ h i (Finset.mem_insert_of_mem hi)) hs) hsum + +/-- Evaluating a monomial not involving `B₀`, in variables of weight at most `wt B₀`, gives a +series free of `B₀`. -/ +theorem aeval_monomial (hσ : HasLowerTruncationDegrees σ) {α : NatOrdinal.{u}} {B₀ : ι} + (hinj : ∀ β < α, OrdinalGraded.InjectiveAt K wt xg β) + (hB₀ : wt B₀ < α) (d : ι →₀ ℕ) (hd : d B₀ = 0) + (hle : ∀ i ∈ d.support, wt i ≤ wt B₀) (hdegree : Finsupp.weight wt d < α) : + FreeOfVariable σ hx α B₀ + (aeval σ.lift (monomial d (1 : K))) (Finsupp.weight wt d) := by + rw [MvPolynomial.aeval_monomial, map_one, one_mul, Finsupp.prod] + rw [Finsupp.weight_apply, Finsupp.sum] at hdegree ⊢ + apply prod (zero_le.trans_lt hdegree) hinj d.support (fun i ↦ σ.lift i ^ d i) + (fun i ↦ d i • wt i) + · intro i hi + have hiB₀ : i ≠ B₀ := fun h ↦ (Finsupp.mem_support_iff.mp hi) (h ▸ hd) + have hiterm : d i • wt i < α := (Finset.single_le_sum + (f := fun i ↦ d i • wt i) (fun _ _ ↦ zero_le) hi).trans_lt hdegree + exact (lift hσ hinj hiB₀ (hle i hi) hB₀).pow hinj (d i) hiterm + · exact hdegree + +/-- Evaluating a homogeneous polynomial which omits `B₀` and uses no heavier variable gives a +series free of `B₀`. -/ +theorem aeval (hσ : HasLowerTruncationDegrees σ) {α : NatOrdinal.{u}} {B₀ : ι} + (hinj : ∀ β < α, OrdinalGraded.InjectiveAt K wt xg β) + (hB₀ : wt B₀ < α) {F : MvPolynomial ι K} {m : NatOrdinal.{u}} + (hF : IsWeightedHomogeneous wt F m) (hm : m < α) + (hmem : F ∈ supported K {B₀}ᶜ) (hle : ∀ i ∈ F.vars, wt i ≤ wt B₀) : + FreeOfVariable σ hx α B₀ (aeval σ.lift F) m := by + classical + conv => rw [F.as_sum] + rw [map_sum] + apply sum hinj hm F.support + intro d hd + have hdw : Finsupp.weight wt d = m := hF (mem_support_iff.mp hd) + have hd0 : d B₀ = 0 := by + by_contra h0 + have hv : B₀ ∈ F.vars := + (mem_vars_iff_mem_support B₀).mpr ⟨d, hd, Finsupp.mem_support_iff.mpr h0⟩ + exact (mem_supported.mp hmem) hv rfl + have hwt : ∀ i ∈ d.support, wt i ≤ wt B₀ := fun i hi ↦ + hle i ((mem_vars_iff_mem_support i).mpr ⟨d, hd, hi⟩) + have hmono : (monomial d (F.coeff d) : MvPolynomial ι K) = + MvPolynomial.C (F.coeff d) * monomial d 1 := by + rw [C_mul_monomial, mul_one] + rw [hmono, map_mul, aeval_C, Algebra.algebraMap_eq_smul_one, smul_mul_assoc, one_mul] + rw [← hdw] + exact (aeval_monomial (σ := σ) (hx := hx) hσ hinj hB₀ d hd0 hwt + (hdw ▸ hm)).smul (F.coeff d) hinj + +/-- Multiplying a free series by a power of the distinguished lift is represented by the +corresponding variable power. -/ +theorem pol_lift_pow_mul (hσ : HasLowerTruncationDegrees σ) {α : NatOrdinal.{u}} {B₀ : ι} + (hinj : ∀ β < α, OrdinalGraded.InjectiveAt K wt xg β) + {u : Nonpositive G K} {m : NatOrdinal.{u}} (hu : FreeOfVariable σ hx α B₀ u m) + (e : ℕ) (he : e • wt B₀ + m < α) : + σ.pol hx α (σ.lift B₀ ^ e * u) = X B₀ ^ e * σ.pol hx α u := by + classical + have hpow : Nonpositive.HasLowerTruncationDegree (σ.lift B₀ ^ e) (e • wt B₀) := + ((hasLowerTruncationDegrees_iff σ).mp hσ B₀).pow e + have hpowα : ν (σ.lift B₀ ^ e) < (α : WithBot NatOrdinal) := + hpow.degree_le.trans_lt (WithBot.coe_lt_coe.mpr (NatOrdinal.le_add_right.trans_lt he)) + have huα : ν u < (α : WithBot NatOrdinal) := + hu.lowerTruncationDegree.degree_le.trans_lt (WithBot.coe_lt_coe.mpr hu.degree_lt) + have hprod : ∀ d ∈ (σ.pol hx α (σ.lift B₀ ^ e) * σ.pol hx α u).support, + Finsupp.weight wt d < α := by + intro d hd + obtain ⟨d₁, hd₁, d₂, hd₂, rfl⟩ := Finset.mem_add.mp + (MvPolynomial.support_mul _ _ hd) + rw [map_add] + have h1 : Finsupp.weight wt d₁ ≤ e • wt B₀ := WithBot.coe_le_coe.mp + ((σ.pol_weight_le_degree hx hpowα d₁ hd₁).trans hpow.degree_le) + have h2 : Finsupp.weight wt d₂ ≤ m := WithBot.coe_le_coe.mp + ((σ.pol_weight_le_degree hx huα d₂ hd₂).trans hu.lowerTruncationDegree.degree_le) + exact (add_le_add h1 h2).trans_lt he + rw [(σ.pol_mul hx hinj hpowα huα hprod).2, + σ.pol_lift_pow hx hinj e (NatOrdinal.le_add_right.trans_lt he)] + +omit [CharZero K] in +/-- Split a finite sum at two distinct members. -/ +private theorem sum_eq_add_add_sum_erase {κ : Type*} [DecidableEq κ] + {S : Finset κ} {a b : κ} (ha : a ∈ S) (hb : b ∈ S) (hne : b ≠ a) + (f : κ → MvPolynomial ι K) : + ∑ q ∈ S, f q = f a + f b + ∑ q ∈ (S.erase a).erase b, f q := by + rw [add_assoc, Finset.add_sum_erase _ _ (Finset.mem_erase.mpr ⟨hne, hb⟩), + Finset.add_sum_erase _ _ ha] + +open Classical in +/-- For `u` free of `B₀`, the polynomial of a proper truncation of `lift B₀ ^ e * u` has no +coefficient above `e`, and its coefficient at `e` is the polynomial of the same truncation of +`u`. -/ +theorem xCoeff_pol_translatedTruncLE_lift_pow_mul + (hσ : HasLowerTruncationDegrees σ) {α : NatOrdinal.{u}} + (hinj : ∀ β < α, OrdinalGraded.InjectiveAt K wt xg β) + {B₀ : ι} {u : Nonpositive G K} {m : NatOrdinal.{u}} + (hB₀ : wt B₀ < α) (hu : FreeOfVariable σ hx α B₀ u m) (e : ℕ) + (he : e • wt B₀ + m ≤ α) {γ : G} (hγ : γ < 0) : + (∀ k, e < k → + xCoeff B₀ k (σ.pol hx α (translatedTruncLE γ (σ.lift B₀ ^ e * u))) = 0) ∧ + xCoeff B₀ e (σ.pol hx α (translatedTruncLE γ (σ.lift B₀ ^ e * u))) = + σ.pol hx α (translatedTruncLE γ u) := by + classical + induction e generalizing γ with + | zero => + rw [pow_zero, one_mul] + exact ⟨fun k hk ↦ by + rw [xCoeff_of_mem_supported B₀ (hu.trunc_mem hγ) k, ite_eq_right (Nat.ne_of_gt hk)], + by rw [xCoeff_of_mem_supported B₀ (hu.trunc_mem hγ) 0, ite_eq_left rfl]⟩ + | succ e ih => + have hg0 : wt B₀ ≠ 0 := hx.ne_zero B₀ + have hstep : e • wt B₀ + m < (e + 1) • wt B₀ + m := by + rw [succ_nsmul, add_right_comm] + exact lt_add_of_pos_right _ (pos_iff_ne_zero.mpr hg0) + have he' : e • wt B₀ + m < α := hstep.trans_le he + have ih' := ih he'.le hγ + have hright : Nonpositive.HasLowerTruncationDegree + (σ.lift B₀ ^ e * u) (e • wt B₀ + m) := + (((hasLowerTruncationDegrees_iff σ).mp hσ B₀).pow e).mul rfl + hu.lowerTruncationDegree + have hconv := σ.pol_translatedTruncLE_mul_boundary hx hinj + ((hasLowerTruncationDegrees_iff σ).mp hσ B₀) hright hB₀ he' (by + rw [← add_assoc, add_comm (wt B₀), ← succ_nsmul] + exact he) hγ + set S := insert (0, γ) (insert (γ, 0) + ((σ.lift B₀ : HahnSeries G K).closedSupportAddFiber + ((σ.lift B₀ ^ e * u : Nonpositive G K) : HahnSeries G K) γ)) with hS + set f : G × G → MvPolynomial ι K := fun q ↦ + σ.pol hx α (translatedTruncLE q.1 (σ.lift B₀)) * + σ.pol hx α (translatedTruncLE q.2 (σ.lift B₀ ^ e * u)) with hf + have h0S : (0, γ) ∈ S := Finset.mem_insert_self _ _ + have hγS : (γ, 0) ∈ S := Finset.mem_insert_of_mem (Finset.mem_insert_self _ _) + have hne : (γ, 0) ≠ (0, γ) := fun h ↦ hγ.ne (congrArg Prod.fst h) + have hsplit : ∑ q ∈ S, f q = f (0, γ) + f (γ, 0) + + ∑ q ∈ (S.erase (0, γ)).erase (γ, 0), f q := + sum_eq_add_add_sum_erase h0S hγS hne f + have hpowmul := hu.pol_lift_pow_mul hσ hinj e he' + have hf0 : f (0, γ) = X B₀ * σ.pol hx α + (translatedTruncLE γ (σ.lift B₀ ^ e * u)) := by + rw [hf] + change σ.pol hx α (translatedTruncLE 0 (σ.lift B₀)) * + σ.pol hx α (translatedTruncLE γ (σ.lift B₀ ^ e * u)) = _ + rw [translatedTruncLE_zero, σ.pol_lift hx hinj hB₀] + have hfγ : f (γ, 0) = σ.pol hx α (translatedTruncLE γ (σ.lift B₀)) * + (X B₀ ^ e * σ.pol hx α u) := by + rw [hf] + change σ.pol hx α (translatedTruncLE γ (σ.lift B₀)) * + σ.pol hx α (translatedTruncLE 0 (σ.lift B₀ ^ e * u)) = _ + rw [translatedTruncLE_zero, hpowmul] + have hinterior : ∀ q ∈ (S.erase (0, γ)).erase (γ, 0), + q.1 < 0 ∧ q.2 < 0 ∧ + σ.pol hx α (translatedTruncLE q.1 (σ.lift B₀)) ∈ supported K {B₀}ᶜ := by + intro q hq + have hqneγ : q ≠ (γ, 0) := (Finset.mem_erase.mp hq).1 + have hqne0 : q ≠ (0, γ) := (Finset.mem_erase.mp + (Finset.mem_erase.mp hq).2).1 + have hqmemS : q ∈ S := (Finset.mem_erase.mp + (Finset.mem_erase.mp hq).2).2 + have hqmem : q ∈ (σ.lift B₀ : HahnSeries G K).closedSupportAddFiber + ((σ.lift B₀ ^ e * u : Nonpositive G K) : HahnSeries G K) γ := by + rw [hS] at hqmemS + rcases Finset.mem_insert.mp hqmemS with hqeq | hqmemS + · exact (hqne0 hqeq).elim + rcases Finset.mem_insert.mp hqmemS with hqeq | hqmemS + · exact (hqneγ hqeq).elim + · exact hqmemS + obtain ⟨hq1mem, hq2mem, hsum⟩ := + ((σ.lift B₀ : HahnSeries G K).mem_closedSupportAddFiber + ((σ.lift B₀ ^ e * u : Nonpositive G K) : HahnSeries G K) γ q).mp hqmem + have hq1le : q.1 ≤ 0 := closure_minimal (σ.lift B₀).property isClosed_Iic + ((mem_closedSupport _ _).mp hq1mem) + have hq2le : q.2 ≤ 0 := closure_minimal (σ.lift B₀ ^ e * u).property isClosed_Iic + ((mem_closedSupport _ _).mp hq2mem) + have hq1ne : q.1 ≠ 0 := fun hq10 ↦ hqne0 (Prod.ext hq10 (by + simpa [hq10] using hsum)) + have hq2ne : q.2 ≠ 0 := fun hq20 ↦ hqneγ (Prod.ext (by + simpa [hq20] using hsum) hq20) + have hq1neg : q.1 < 0 := lt_of_le_of_ne hq1le hq1ne + have hq2neg : q.2 < 0 := lt_of_le_of_ne hq2le hq2ne + exact ⟨hq1neg, hq2neg, + σ.pol_translatedTruncLE_lift_mem_supported hx hσ hB₀ le_rfl hq1neg⟩ + have hfhigh : ∀ q ∈ (S.erase (0, γ)).erase (γ, 0), ∀ k, e < k → + xCoeff B₀ k (f q) = 0 := by + intro q hq k hk + have hiq := ih he'.le (hinterior q hq).2.1 + rw [hf, xCoeff_mul_of_mem_supported B₀ (hinterior q hq).2.2 k, + hiq.1 k hk, mul_zero] + have hexp : σ.lift B₀ ^ (e + 1) * u = + σ.lift B₀ * (σ.lift B₀ ^ e * u) := by ring + rw [hexp, hconv, hsplit, hf0, hfγ] + refine ⟨fun k hk ↦ ?_, ?_⟩ + · rw [map_add, map_add, map_sum, + Finset.sum_eq_zero fun q hq ↦ hfhigh q hq k (by omega)] + obtain ⟨k', rfl⟩ : ∃ k', k = k' + 1 := ⟨k - 1, by omega⟩ + rw [xCoeff_succ_X_mul, ih'.1 k' (by omega), ← mul_assoc, + show σ.pol hx α (translatedTruncLE γ (σ.lift B₀)) * X B₀ ^ e * + σ.pol hx α u = + (σ.pol hx α (translatedTruncLE γ (σ.lift B₀)) * σ.pol hx α u) * + X B₀ ^ e by ring, + xCoeff_mul_X_pow B₀ (Subalgebra.mul_mem _ + (σ.pol_translatedTruncLE_lift_mem_supported hx hσ hB₀ le_rfl hγ) + hu.pol_mem) (k' + 1) e, ite_eq_right (by omega), add_zero, add_zero] + · rw [map_add, map_add, map_sum, + Finset.sum_eq_zero fun q hq ↦ hfhigh q hq (e + 1) (Nat.lt_succ_self e), + xCoeff_succ_X_mul, ih'.2, ← mul_assoc, + show σ.pol hx α (translatedTruncLE γ (σ.lift B₀)) * X B₀ ^ e * + σ.pol hx α u = + (σ.pol hx α (translatedTruncLE γ (σ.lift B₀)) * σ.pol hx α u) * + X B₀ ^ e by ring, + xCoeff_mul_X_pow B₀ (Subalgebra.mul_mem _ + (σ.pol_translatedTruncLE_lift_mem_supported hx hσ hB₀ le_rfl hγ) + hu.pol_mem) (e + 1) e, ite_eq_right (Nat.succ_ne_self e), add_zero, add_zero] + +/-- A proper truncation of the evaluation of a top-degree homogeneous polynomial which omits +`B₀` and uses no heavier variable still has a representing polynomial which omits `B₀`. -/ +theorem pol_translatedTruncLE_aeval_mem_supported + (hσ : HasLowerTruncationDegrees σ) {α : NatOrdinal.{u}} + (hinj : ∀ β < α, OrdinalGraded.InjectiveAt K wt xg β) + {B₀ : ι} (hB₀ : wt B₀ < α) {F : MvPolynomial ι K} + (hF : IsWeightedHomogeneous wt F α) (hmem : F ∈ supported K {B₀}ᶜ) + (hle : ∀ i ∈ F.vars, wt i ≤ wt B₀) {γ : G} (hγ : γ < 0) : + σ.pol hx α (translatedTruncLE γ (MvPolynomial.aeval σ.lift F)) ∈ + supported K {B₀}ᶜ := by + classical + have hα0 : α ≠ 0 := ne_of_gt ((zero_le : (0 : NatOrdinal) ≤ wt B₀).trans_lt hB₀) + have hterm : ∀ d ∈ F.support, + σ.pol hx α (translatedTruncLE γ + (MvPolynomial.aeval σ.lift (monomial d (F.coeff d)))) ∈ + supported K {B₀}ᶜ := by + intro d hd + have hdw : Finsupp.weight wt d = α := hF (mem_support_iff.mp hd) + have hd0 : d B₀ = 0 := by + by_contra h0 + exact (mem_supported.mp hmem) ((mem_vars_iff_mem_support B₀).mpr + ⟨d, hd, Finsupp.mem_support_iff.mpr h0⟩) rfl + have hdne : d ≠ 0 := by + rintro rfl + rw [map_zero] at hdw + exact hα0 hdw.symm + obtain ⟨i, hi⟩ := Finsupp.support_nonempty_iff.mpr hdne + have hi0 : d i ≠ 0 := Finsupp.mem_support_iff.mp hi + have hiB₀ : i ≠ B₀ := fun h ↦ hi0 (h ▸ hd0) + have hiwt : wt i ≤ wt B₀ := + hle i ((mem_vars_iff_mem_support i).mpr ⟨d, hd, hi⟩) + set d' := d - Finsupp.single i 1 with hd' + have hdd' : d = Finsupp.single i 1 + d' := by + rw [hd', add_comm, tsub_add_cancel_of_le] + intro j + rw [Finsupp.single_apply] + split_ifs with hji + · subst j + exact Nat.pos_of_ne_zero hi0 + · exact Nat.zero_le _ + have hweight : wt i + Finsupp.weight wt d' = α := by + rw [← hdw, hdd', map_add, Finsupp.weight_single, one_smul] + have hiα : wt i < α := hiwt.trans_lt hB₀ + have hd'α : Finsupp.weight wt d' < α := by + rw [← hweight] + exact lt_add_of_pos_left _ (pos_iff_ne_zero.mpr (hx.ne_zero i)) + have hd'0 : d' B₀ = 0 := by + rw [hd', Finsupp.tsub_apply, hd0, zero_tsub] + have hd'wt : ∀ j ∈ d'.support, wt j ≤ wt B₀ := fun j hj ↦ + hle j ((mem_vars_iff_mem_support j).mpr ⟨d, hd, Finsupp.support_tsub hj⟩) + have hfreei := FreeOfVariable.lift (σ := σ) (hx := hx) hσ hinj hiB₀ hiwt hB₀ + have hfreed := FreeOfVariable.aeval_monomial (σ := σ) (hx := hx) hσ hinj hB₀ + d' hd'0 hd'wt hd'α + have hsplit : MvPolynomial.aeval σ.lift (monomial d (1 : K)) = + σ.lift i * MvPolynomial.aeval σ.lift (monomial d' (1 : K)) := by + rw [hdd', add_comm, monomial_add_single, pow_one, map_mul, aeval_X, mul_comm] + have hconv := σ.pol_translatedTruncLE_mul hx hinj hfreei.lowerTruncationDegree + hfreed.lowerTruncationDegree + hiα hd'α hweight.le hγ + have hone : σ.pol hx α (translatedTruncLE γ + (MvPolynomial.aeval σ.lift (monomial d (1 : K)))) ∈ supported K {B₀}ᶜ := by + rw [hsplit, hconv] + refine Subalgebra.sum_mem _ fun q hq ↦ Subalgebra.mul_mem _ ?_ ?_ + · exact hfreei.pol_trunc_mem_nonpos (closure_minimal (σ.lift i).property isClosed_Iic + ((mem_closedSupport _ _).mp (((σ.lift i : HahnSeries G K).mem_closedSupportAddFiber + ((MvPolynomial.aeval σ.lift (monomial d' (1 : K)) : Nonpositive G K) : + HahnSeries G K) γ q).mp + hq).1)) + · exact hfreed.pol_trunc_mem_nonpos + (closure_minimal (MvPolynomial.aeval σ.lift (monomial d' (1 : K))).property + isClosed_Iic + ((mem_closedSupport _ _).mp (((σ.lift i : HahnSeries G K).mem_closedSupportAddFiber + ((MvPolynomial.aeval σ.lift (monomial d' (1 : K)) : Nonpositive G K) : + HahnSeries G K) γ q).mp + hq).2.1)) + have hmono : (monomial d (F.coeff d) : MvPolynomial ι K) = + MvPolynomial.C (F.coeff d) * monomial d (1 : K) := by + rw [C_mul_monomial, mul_one] + rw [hmono, map_mul, aeval_C, Algebra.algebraMap_eq_smul_one, smul_mul_assoc, one_mul, + translatedTruncLE_smul, σ.pol_smul hx hinj] + · exact Subalgebra.smul_mem _ hone _ + · exact (σ.hasLowerTruncationDegree_aeval hσ + (isWeightedHomogeneous_monomial wt d (1 : K) hdw)).degree_translatedTruncLE_lt hγ + have hexp : MvPolynomial.aeval σ.lift F = ∑ d ∈ F.support, + MvPolynomial.aeval σ.lift (monomial d (F.coeff d)) := by + conv_lhs => rw [F.as_sum] + rw [map_sum] + rw [hexp, map_sum, σ.pol_sum hx hinj _ _ (fun d hd ↦ by + have hp := σ.hasLowerTruncationDegree_aeval hσ (isWeightedHomogeneous_monomial wt d + (F.coeff d) (hF (mem_support_iff.mp hd))) + exact hp.degree_translatedTruncLE_lt hγ)] + exact Subalgebra.sum_mem _ fun d hd ↦ hterm d hd + +open Classical in +/-- The coefficient one below the top in a proper truncation of `lift B₀ ^ (e + 1)` is +`(e + 1)` times the polynomial of the truncated lift. -/ +theorem xCoeff_pol_translatedTruncLE_lift_pow + (hσ : HasLowerTruncationDegrees σ) {α : NatOrdinal.{u}} + (hinj : ∀ β < α, OrdinalGraded.InjectiveAt K wt xg β) + {B₀ : ι} (hB₀ : wt B₀ < α) (e : ℕ) + (he : (e + 1) • wt B₀ ≤ α) {γ : G} (hγ : γ < 0) : + xCoeff B₀ e (σ.pol hx α (translatedTruncLE γ (σ.lift B₀ ^ (e + 1)))) = + (e + 1 : ℕ) • σ.pol hx α (translatedTruncLE γ (σ.lift B₀)) := by + classical + induction e generalizing γ with + | zero => + rw [zero_add, pow_one, xCoeff_of_mem_supported B₀ + (σ.pol_translatedTruncLE_lift_mem_supported hx hσ hB₀ le_rfl hγ) 0, + ite_eq_left rfl, one_smul] + | succ e ih => + have hg0 : wt B₀ ≠ 0 := hx.ne_zero B₀ + have hstep : (e + 1) • wt B₀ < (e + 1 + 1) • wt B₀ := by + rw [succ_nsmul] + exact lt_add_of_pos_right _ (pos_iff_ne_zero.mpr hg0) + have he' : (e + 1) • wt B₀ < α := hstep.trans_le he + have hα0 : 0 < α := (zero_le : (0 : NatOrdinal) ≤ wt B₀).trans_lt hB₀ + have hone := FreeOfVariable.one (σ := σ) (hx := hx) hα0 hinj (B₀ := B₀) + have hright : Nonpositive.HasLowerTruncationDegree + (σ.lift B₀ ^ (e + 1)) ((e + 1) • wt B₀) := + ((hasLowerTruncationDegrees_iff σ).mp hσ B₀).pow (e + 1) + have hconv := σ.pol_translatedTruncLE_mul_boundary hx hinj + ((hasLowerTruncationDegrees_iff σ).mp hσ B₀) hright hB₀ he' (by + rw [add_comm, ← succ_nsmul] + exact he) hγ + set S := insert (0, γ) (insert (γ, 0) + ((σ.lift B₀ : HahnSeries G K).closedSupportAddFiber + ((σ.lift B₀ ^ (e + 1) : Nonpositive G K) : HahnSeries G K) γ)) with hS + set f : G × G → MvPolynomial ι K := fun q ↦ + σ.pol hx α (translatedTruncLE q.1 (σ.lift B₀)) * + σ.pol hx α (translatedTruncLE q.2 (σ.lift B₀ ^ (e + 1))) with hf + have h0S : (0, γ) ∈ S := Finset.mem_insert_self _ _ + have hγS : (γ, 0) ∈ S := Finset.mem_insert_of_mem (Finset.mem_insert_self _ _) + have hne : (γ, 0) ≠ (0, γ) := fun h ↦ hγ.ne (congrArg Prod.fst h) + have hsplit : ∑ q ∈ S, f q = f (0, γ) + f (γ, 0) + + ∑ q ∈ (S.erase (0, γ)).erase (γ, 0), f q := + sum_eq_add_add_sum_erase h0S hγS hne f + have hf0 : f (0, γ) = X B₀ * + σ.pol hx α (translatedTruncLE γ (σ.lift B₀ ^ (e + 1))) := by + rw [hf] + change σ.pol hx α (translatedTruncLE 0 (σ.lift B₀)) * _ = _ + rw [translatedTruncLE_zero, σ.pol_lift hx hinj hB₀] + have hfγ : f (γ, 0) = σ.pol hx α (translatedTruncLE γ (σ.lift B₀)) * + X B₀ ^ (e + 1) := by + rw [hf] + change σ.pol hx α (translatedTruncLE γ (σ.lift B₀)) * + σ.pol hx α (translatedTruncLE 0 (σ.lift B₀ ^ (e + 1))) = _ + rw [translatedTruncLE_zero, σ.pol_lift_pow hx hinj (e + 1) he'] + have hinterior : ∀ q ∈ (S.erase (0, γ)).erase (γ, 0), + q.1 < 0 ∧ q.2 < 0 ∧ + σ.pol hx α (translatedTruncLE q.1 (σ.lift B₀)) ∈ supported K {B₀}ᶜ := by + intro q hq + have hqneγ : q ≠ (γ, 0) := (Finset.mem_erase.mp hq).1 + have hqne0 : q ≠ (0, γ) := (Finset.mem_erase.mp + (Finset.mem_erase.mp hq).2).1 + have hqmemS : q ∈ S := (Finset.mem_erase.mp + (Finset.mem_erase.mp hq).2).2 + have hqmem : q ∈ (σ.lift B₀ : HahnSeries G K).closedSupportAddFiber + ((σ.lift B₀ ^ (e + 1) : Nonpositive G K) : HahnSeries G K) γ := by + rw [hS] at hqmemS + rcases Finset.mem_insert.mp hqmemS with hqeq | hqmemS + · exact (hqne0 hqeq).elim + rcases Finset.mem_insert.mp hqmemS with hqeq | hqmemS + · exact (hqneγ hqeq).elim + · exact hqmemS + obtain ⟨hq1mem, hq2mem, hsum⟩ := + ((σ.lift B₀ : HahnSeries G K).mem_closedSupportAddFiber + ((σ.lift B₀ ^ (e + 1) : Nonpositive G K) : HahnSeries G K) γ q).mp hqmem + have hq1le : q.1 ≤ 0 := closure_minimal (σ.lift B₀).property isClosed_Iic + ((mem_closedSupport _ _).mp hq1mem) + have hq2le : q.2 ≤ 0 := closure_minimal (σ.lift B₀ ^ (e + 1)).property isClosed_Iic + ((mem_closedSupport _ _).mp hq2mem) + have hq1ne : q.1 ≠ 0 := fun hq10 ↦ hqne0 (Prod.ext hq10 (by + simpa [hq10] using hsum)) + have hq2ne : q.2 ≠ 0 := fun hq20 ↦ hqneγ (Prod.ext (by + simpa [hq20] using hsum) hq20) + have hq1neg : q.1 < 0 := lt_of_le_of_ne hq1le hq1ne + have hq2neg : q.2 < 0 := lt_of_le_of_ne hq2le hq2ne + exact ⟨hq1neg, hq2neg, + σ.pol_translatedTruncLE_lift_mem_supported hx hσ hB₀ le_rfl hq1neg⟩ + have hfzero : ∀ q ∈ (S.erase (0, γ)).erase (γ, 0), + xCoeff B₀ (e + 1) (f q) = 0 := by + intro q hq + have htopq := FreeOfVariable.xCoeff_pol_translatedTruncLE_lift_pow_mul + (σ := σ) (hx := hx) hσ hinj hB₀ hone (e + 1) (by simpa using he'.le) + (hinterior q hq).2.1 + rw [mul_one] at htopq + have hpone : σ.pol hx α (translatedTruncLE q.2 (1 : Nonpositive G K)) = 0 := by + rw [FreeOfVariable.translatedTruncLE_one (hinterior q hq).2.1, + σ.pol_eq_zero_of_degree_eq_bot hx (by rw [(ν).map_zero])] + rw [hf, xCoeff_mul_of_mem_supported B₀ (hinterior q hq).2.2 (e + 1), + htopq.2, hpone, mul_zero] + have hexp : σ.lift B₀ ^ (e + 1 + 1) = + σ.lift B₀ * σ.lift B₀ ^ (e + 1) := by ring + rw [hexp, hconv, hsplit, hf0, hfγ, map_add, map_add, map_sum, + Finset.sum_eq_zero hfzero, add_zero, xCoeff_succ_X_mul, ih he'.le hγ, + xCoeff_mul_X_pow B₀ + (σ.pol_translatedTruncLE_lift_mem_supported hx hσ hB₀ le_rfl hγ) + (e + 1) (e + 1), ite_eq_left rfl] + exact (succ_nsmul _ (e + 1)).symm + +end FreeOfVariable + +end LiftFamily + +end HahnSeries.Nonpositive + +end diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart.lean new file mode 100644 index 0000000000..037a48809d --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart.lean @@ -0,0 +1,33 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Assumptions +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.CardinalFiniteClassReduction +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.CardinalIntegerPartSplitting +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.CardinalPrimalityTransfer +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.CardinalProposition922 +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.CardinalSplitting +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.ClassTruncation +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.FiniteClassPrimality +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.FiniteClassReduction +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.IntegerPartSplitting +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.IrreducibilityTransfer +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.LimitTailPrimality +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.PrimalityTransfer +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Reduced +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.ReducedCharacterization +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.ReducedDivisibility +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.ReducedPrimality +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Reduction +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Refinement +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.SplitTruncation +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Tests +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.TruncationDivisibility +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.TruncationPrimality + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Assumptions.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Assumptions.lean new file mode 100644 index 0000000000..45b1958872 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Assumptions.lean @@ -0,0 +1,117 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.CardinalTruncation +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.ArchimedeanSplitting +public import Mathlib.Algebra.Order.Module.Archimedean +public import Mathlib.Basic.Real.Embedding + +/-! +# LM24 assumptions at an Archimedean class + +This module records assumptions `(A1)_σ` and `(A2)_σ` from LM24, Theorem 9.0.1. Assumption +`(A1)_σ` says that the chosen complement at a nonzero class is isomorphic, as an ordered +additive group, to `ℝ`. Assumption `(A2)_σ` is the paper's cofinality or degenerate-inner-group +disjunction. Both full predicates retain the paper's zero-class clause; their finite-class +specializations remove precisely that clause. + +The elimination theorem supplies the fraction-field conclusion of LM24, Proposition 2.4.5 for +the cardinal-bounded inner truncation integer part. It does not replace `(A2)_σ` by that +conclusion: both the printed assumption and its consequence remain visible in the public API. +-/ + +universe u v + +public noncomputable section + +open Cardinal + +namespace LM24 + +variable {K : Type*} {G : Type u} {R : Type v} +variable [DivisionRing K] [LinearOrder K] [IsOrderedRing K] [Archimedean K] +variable [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] +variable [Module K G] [IsOrderedModule K G] +variable [Field R] + +/-! ### Assumption `(A1)_σ` -/ + +/-- LM24 assumption `(A1)_σ`: the chosen stratum at `σ` is order-additively isomorphic to +`ℝ`, or `σ` is the class of zero. Mathlib orders Archimedean classes oppositely to LM24, so +the zero class is `⊤`. -/ +def AssumptionA1 (u : HahnEmbedding.ArchimedeanStrata K G) + (σ : ArchimedeanClass G) : Prop := + σ = ⊤ ∨ + ∃ c : FiniteArchimedeanClass G, + FiniteArchimedeanClass.withTopOrderIso G c = σ ∧ + Nonempty (u.stratum c ≃+o ℝ) + +/-- The defining zero-class/isomorphic-stratum disjunction for `(A1)_σ`. -/ +theorem assumptionA1_iff (u : HahnEmbedding.ArchimedeanStrata K G) + (σ : ArchimedeanClass G) : + AssumptionA1 u σ ↔ + σ = ⊤ ∨ + ∃ c : FiniteArchimedeanClass G, + FiniteArchimedeanClass.withTopOrderIso G c = σ ∧ + Nonempty (u.stratum c ≃+o ℝ) := + (Iff.rfl) + +/-- The nonzero-class specialization of LM24 assumption `(A1)_σ`. -/ +def AssumptionA1AtFiniteClass (u : HahnEmbedding.ArchimedeanStrata K G) + (c : FiniteArchimedeanClass G) : Prop := + Nonempty (u.stratum c ≃+o ℝ) + +/-- The defining ordered-additive isomorphism for `(A1)_σ` at a nonzero class. -/ +theorem assumptionA1AtFiniteClass_iff (u : HahnEmbedding.ArchimedeanStrata K G) + (c : FiniteArchimedeanClass G) : + AssumptionA1AtFiniteClass u c ↔ Nonempty (u.stratum c ≃+o ℝ) := + (Iff.rfl) + +/-! ### Assumption `(A2)_σ` -/ + +/-- LM24 assumption `(A2)_σ`: the inner exponent group has cofinality at least `κ`, or it +is zero and `Frac(Z) = R`, or `σ` is the class of zero. -/ +def AssumptionA2 (κ : Cardinal.{u}) (Z : Subring R) (σ : ArchimedeanClass G) : Prop := + κ ≤ Order.cof ↥(ArchimedeanClass.ballAddSubgroup σ) ∨ + (Subsingleton ↥(ArchimedeanClass.ballAddSubgroup σ) ∧ + Subring.fracSubring Z = ⊤) ∨ σ = ⊤ + +/-- The defining disjunction for `(A2)_σ`. -/ +theorem assumptionA2_iff (κ : Cardinal.{u}) (Z : Subring R) (σ : ArchimedeanClass G) : + AssumptionA2 κ Z σ ↔ + κ ≤ Order.cof ↥(ArchimedeanClass.ballAddSubgroup σ) ∨ + (Subsingleton ↥(ArchimedeanClass.ballAddSubgroup σ) ∧ + Subring.fracSubring Z = ⊤) ∨ σ = ⊤ := + (Iff.rfl) + +/-- The nonzero-class specialization of LM24 assumption `(A2)_σ`. -/ +def AssumptionA2AtFiniteClass (κ : Cardinal.{u}) (Z : Subring R) + (σ : FiniteArchimedeanClass G) : Prop := + κ ≤ Order.cof ↥(FiniteArchimedeanClass.ball K σ) ∨ + (Subsingleton ↥(FiniteArchimedeanClass.ball K σ) ∧ Subring.fracSubring Z = ⊤) + +/-- The defining disjunction for `(A2)_σ` at a nonzero Archimedean class. -/ +theorem assumptionA2AtFiniteClass_iff (κ : Cardinal.{u}) (Z : Subring R) + (σ : FiniteArchimedeanClass G) : + AssumptionA2AtFiniteClass (K := K) κ Z σ ↔ + κ ≤ Order.cof ↥(FiniteArchimedeanClass.ball K σ) ∨ + (Subsingleton ↥(FiniteArchimedeanClass.ball K σ) ∧ Subring.fracSubring Z = ⊤) := + (Iff.rfl) + +/-- The cofinality clause implies the bounded inner fraction-field equality. -/ +theorem fracSubring_cardSuppLTTruncationIntegerPart_eq_top_of_assumptionA2AtFiniteClass + {κ : Cardinal.{u}} [Fact (ℵ₀ < κ)] (Z : Subring R) (σ : FiniteArchimedeanClass G) + (hA2 : AssumptionA2AtFiniteClass (K := K) κ Z σ) : + Subring.fracSubring + (HahnSeries.cardSuppLTTruncationIntegerPart + (G := ↥(FiniteArchimedeanClass.ball K σ)) (R := R) (κ := κ) Z) = ⊤ := by + rcases (assumptionA2AtFiniteClass_iff (K := K) κ Z σ).mp hA2 with hcof | ⟨hzero, hfrac⟩ + · exact HahnSeries.fracSubring_cardSuppLTTruncationIntegerPart_eq_top_of_le_cof Z hcof + · let : Subsingleton ↥(FiniteArchimedeanClass.ball K σ) := hzero + exact HahnSeries.fracSubring_cardSuppLTTruncationIntegerPart_eq_top_of_subsingleton Z hfrac + +end LM24 diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/CardinalFiniteClassReduction.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/CardinalFiniteClassReduction.lean new file mode 100644 index 0000000000..8a34c5c2f1 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/CardinalFiniteClassReduction.lean @@ -0,0 +1,154 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Reduction +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.CardinalTruncation + +/-! +# Finite-class reduction in a bounded Hahn integer part + +LM24's open truncation and reduction at an Archimedean class preserve a cardinal-bounded Hahn +integer part. When the open truncation is nonzero, their product is the original series. +-/ + +public noncomputable section + +open Cardinal FiniteArchimedeanClass +open scoped HahnSeries + +namespace HahnSeries.Nonpositive + +variable {K G R : Type*} {κ : Cardinal} +variable [DivisionRing K] [LinearOrder K] [IsOrderedRing K] [Archimedean K] +variable [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] +variable [Module K G] [IsOrderedModule K G] +variable [Field R] [Fact (ℵ₀ < κ)] + +private theorem support_tau_subset (c : FiniteArchimedeanClass G) (x : Nonpositive G R) : + ((tau (K := K) c x : Nonpositive G R) : R⟦G⟧).support ⊆ (x : R⟦G⟧).support := by + intro g hg + by_cases hball : g ∈ ball K c + · rw [HahnSeries.mem_support, coeff_tau_of_mem c x hball] at hg + exact hg + · rw [HahnSeries.mem_support, coeff_tau_of_not_mem c x hball] at hg + exact (hg rfl).elim + +/-- The open truncation `τ_σ(x)`, regarded as an element of the bounded integer part. -/ +def tauIntegerPart (c : FiniteArchimedeanClass G) (Z : Subring R) + (x : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) : + cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z := + ⟨⟨((tau (K := K) c (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z x) : + Nonpositive G R) : R⟦G⟧), + (HahnSeries.cardSupp_mono (support_tau_subset c _)).trans_lt + (CardSuppLTTruncationIntegerPart.cardSupp_toNonpositiveRingHom_lt Z x)⟩, by + rw [mem_cardSuppLTTruncationIntegerPart] + refine ⟨support_subset _, ?_⟩ + rw [coeff_tau_of_mem c _ (zero_mem _), + CardSuppLTTruncationIntegerPart.coe_toNonpositiveRingHom] + exact ((mem_cardSuppLTTruncationIntegerPart (Z := Z)).mp x.2).2⟩ + +@[simp] +theorem toNonpositive_tauIntegerPart (c : FiniteArchimedeanClass G) (Z : Subring R) + (x : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) : + CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z (tauIntegerPart (K := K) c Z x) = + tau (K := K) c (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z x) := by + apply Subtype.ext + rw [CardSuppLTTruncationIntegerPart.coe_toNonpositiveRingHom] + rfl + +/-- The coefficient at zero of LM24's reduction is one when the open truncation is nonzero. -/ +theorem coeff_zero_rho_of_tau_ne_zero (u : HahnEmbedding.ArchimedeanStrata K G) + (c : FiniteArchimedeanClass G) (x : Nonpositive G R) (htau : tau (K := K) c x ≠ 0) : + ((rho u c x : Nonpositive G R) : R⟦G⟧).coeff 0 = 1 := by + rw [rho_of_tau_ne_zero u c x htau] + exact coeff_zero_reductionQuotient u c x _ + +/-- LM24's reduction `ρ_σ(x)`, regarded as an element of the bounded integer part. -/ +def rhoIntegerPart (u : HahnEmbedding.ArchimedeanStrata K G) + (c : FiniteArchimedeanClass G) (Z : Subring R) + (x : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) + (hT : T (K := K) c (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z x) = + CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z x) + (htau : tau (K := K) c (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z x) ≠ 0) : + cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z := by + refine ⟨(x : CardSuppLTField (G := G) (R := R) (κ := κ)) / + (tauIntegerPart (K := K) c Z x : CardSuppLTField (G := G) (R := R) (κ := κ)), ?_⟩ + have hτ : ((tauIntegerPart (K := K) c Z x : + CardSuppLTField (G := G) (R := R) (κ := κ)) : R⟦G⟧) ≠ 0 := by + intro h + apply htau + apply Subtype.ext + exact h + have hq : (((x : CardSuppLTField (G := G) (R := R) (κ := κ)) / + (tauIntegerPart (K := K) c Z x : CardSuppLTField (G := G) (R := R) (κ := κ)) : + CardSuppLTField (G := G) (R := R) (κ := κ)) : R⟦G⟧) = + ((rho u c (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z x) : + Nonpositive G R) : R⟦G⟧) := by + have hmul := reductionQuotient_mul_tau u c + (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z x) + (fun hzero ↦ htau ((tauBall_eq_zero_iff c _).mp hzero)) + rw [← rho_of_tau_ne_zero u c _ htau, hT] at hmul + have hmul' := congrArg (fun q : Nonpositive G R ↦ (q : R⟦G⟧)) hmul + simp only [Subring.coe_mul] at hmul' + rw [Subfield.coe_div, div_eq_iff hτ] + change ((x : CardSuppLTField (G := G) (R := R) (κ := κ)) : R⟦G⟧) = + ((rho u c (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z x) : + Nonpositive G R) : R⟦G⟧) * + ((tau (K := K) c (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z x) : + Nonpositive G R) : R⟦G⟧) + rw [hmul', CardSuppLTTruncationIntegerPart.coe_toNonpositiveRingHom] + rw [mem_cardSuppLTTruncationIntegerPart, hq] + refine ⟨support_subset _, ?_⟩ + rw [coeff_zero_rho_of_tau_ne_zero u c _ htau] + exact Z.one_mem + +theorem toNonpositive_rhoIntegerPart (u : HahnEmbedding.ArchimedeanStrata K G) + (c : FiniteArchimedeanClass G) (Z : Subring R) + (x : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) + (hT : T (K := K) c (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z x) = + CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z x) + (htau : tau (K := K) c (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z x) ≠ 0) : + CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z (rhoIntegerPart u c Z x hT htau) = + rho u c (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z x) := by + apply Subtype.ext + rw [CardSuppLTTruncationIntegerPart.coe_toNonpositiveRingHom] + have hτ : ((tauIntegerPart (K := K) c Z x : + CardSuppLTField (G := G) (R := R) (κ := κ)) : R⟦G⟧) ≠ 0 := by + intro h + apply htau + apply Subtype.ext + exact h + have hmul := reductionQuotient_mul_tau u c + (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z x) + (fun hzero ↦ htau ((tauBall_eq_zero_iff c _).mp hzero)) + rw [← rho_of_tau_ne_zero u c _ htau, hT] at hmul + have hmul' := congrArg (fun q : Nonpositive G R ↦ (q : R⟦G⟧)) hmul + simp only [Subring.coe_mul] at hmul' + change (((x : CardSuppLTField (G := G) (R := R) (κ := κ)) / + (tauIntegerPart (K := K) c Z x : CardSuppLTField (G := G) (R := R) (κ := κ)) : + CardSuppLTField (G := G) (R := R) (κ := κ)) : R⟦G⟧) = _ + rw [Subfield.coe_div, div_eq_iff hτ] + change ((x : CardSuppLTField (G := G) (R := R) (κ := κ)) : R⟦G⟧) = + ((rho u c (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z x) : + Nonpositive G R) : R⟦G⟧) * + ((tau (K := K) c (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z x) : + Nonpositive G R) : R⟦G⟧) + rw [hmul', CardSuppLTTruncationIntegerPart.coe_toNonpositiveRingHom] + +/-- The factorisation `x = ρ_σ(x) τ_σ(x)` inside the bounded integer part. -/ +theorem rhoIntegerPart_mul_tauIntegerPart (u : HahnEmbedding.ArchimedeanStrata K G) + (c : FiniteArchimedeanClass G) (Z : Subring R) + (x : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) + (hT : T (K := K) c (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z x) = + CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z x) + (htau : tau (K := K) c (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z x) ≠ 0) : + rhoIntegerPart u c Z x hT htau * tauIntegerPart (K := K) c Z x = x := by + apply CardSuppLTTruncationIntegerPart.toNonpositiveRingHom_injective Z + rw [map_mul, toNonpositive_rhoIntegerPart, toNonpositive_tauIntegerPart, + rho_of_tau_ne_zero u c _ htau, reductionQuotient_mul_tau, hT] + +end HahnSeries.Nonpositive diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/CardinalIntegerPartSplitting.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/CardinalIntegerPartSplitting.lean new file mode 100644 index 0000000000..a3574f7788 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/CardinalIntegerPartSplitting.lean @@ -0,0 +1,433 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.CardinalPrimalityTransfer +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.CoefficientMap +import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Ring.Hom.OfInjectiveComp + +/-! +# Cardinal-bounded leading-class integer-part splitting + +This module restricts LM24, Fact 2.4.2(5) to Hahn series with support cardinality less than +`κ`. The forward split always respects the bound on every inner coefficient. For the inverse, +regularity of `κ` ensures that flattening the countable outer support over the Archimedean +stratum, whose coefficients each have support smaller than `κ`, again has support smaller than +`κ`. + +The regularity hypothesis records the exact set-sized cardinal closure used here. It is not folded +into the printed statement of LM24, where the intended omnific Hahn field has a proper-class +exponent group and every individual support remains a set. +-/ + +public noncomputable section + +open Cardinal FiniteArchimedeanClass + +namespace HahnSeries.Nonpositive + +variable {K G R : Type*} {κ : Cardinal} +variable [DivisionRing K] [LinearOrder K] [IsOrderedRing K] [Archimedean K] +variable [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] +variable [Module K G] [IsOrderedModule K G] +variable [Field R] [Fact (ℵ₀ < κ)] + +/-- Embed the bounded inner Hahn field into the full inner Hahn field. -/ +def cardSuppLTInnerFieldSubtypeRingHom (c : FiniteArchimedeanClass G) : + CardSuppLTField (G := ↥(ball K c)) (R := R) (κ := κ) →+* R⟦ball K c⟧ := + (cardSuppLTSubfield (ball K c) R κ).subtype + +/-- Forget the cardinal bound on every coefficient of an outer nonpositive Hahn series. -/ +def forgetCardSuppLTInnerCoefficients + (c : FiniteArchimedeanClass G) (u : HahnEmbedding.ArchimedeanStrata K G) : + Nonpositive (u.stratum c) + (CardSuppLTField (G := ↥(ball K c)) (R := R) (κ := κ)) →+* + Nonpositive (u.stratum c) R⟦ball K c⟧ := + coefficientMapRingHom (cardSuppLTInnerFieldSubtypeRingHom c) + +/-- Forgetting bounded inner coefficients preserves their underlying Hahn series. -/ +@[simp] +theorem coeff_forgetCardSuppLTInnerCoefficients + (c : FiniteArchimedeanClass G) (u : HahnEmbedding.ArchimedeanStrata K G) + (y : Nonpositive (u.stratum c) + (CardSuppLTField (G := ↥(ball K c)) (R := R) (κ := κ))) (s : u.stratum c) : + (((forgetCardSuppLTInnerCoefficients c u y : Nonpositive + (u.stratum c) R⟦ball K c⟧) : (R⟦ball K c⟧)⟦u.stratum c⟧).coeff s) = + ((y : (CardSuppLTField (G := ↥(ball K c)) (R := R) + (κ := κ))⟦u.stratum c⟧).coeff s : R⟦ball K c⟧) := by + rw [forgetCardSuppLTInnerCoefficients, coe_coefficientMapRingHom, + HahnSeries.coefficientMapRingHom_coeff] + rfl + +/-- Forget the inner cardinal bounds on a split truncation integer part. -/ +def forgetSplitCardSuppLTIntegerPartRingHom + (u : HahnEmbedding.ArchimedeanStrata K G) (c : FiniteArchimedeanClass G) + (Z : Subring R) : + truncationIntegerPart (u.stratum c) + (cardSuppLTTruncationIntegerPart (G := ↥(ball K c)) (R := R) (κ := κ) Z) →+* + truncationIntegerPart (u.stratum c) + (innerIntegerPartSubring (K := K) (G := G) c Z) where + toFun y := ⟨forgetCardSuppLTInnerCoefficients (K := K) (R := R) (κ := κ) c u y, by + rw [mem_truncationIntegerPart] + rw [mem_innerIntegerPartSubring_iff] + have hy := (mem_truncationIntegerPart (Γ := u.stratum c) + (R := CardSuppLTField (G := ↥(ball K c)) (R := R) (κ := κ))).mp y.2 + rw [coeff_forgetCardSuppLTInnerCoefficients (K := K) (R := R) (κ := κ)] + exact (mem_cardSuppLTTruncationIntegerPart (Z := Z)).mp hy⟩ + map_one' := Subtype.ext (map_one + (forgetCardSuppLTInnerCoefficients (K := K) (R := R) (κ := κ) c u)) + map_mul' x y := Subtype.ext (map_mul + (forgetCardSuppLTInnerCoefficients (K := K) (R := R) (κ := κ) c u) + (x : Nonpositive (u.stratum c) + (CardSuppLTField (G := ↥(ball K c)) (R := R) (κ := κ))) y) + map_zero' := Subtype.ext (map_zero + (forgetCardSuppLTInnerCoefficients (K := K) (R := R) (κ := κ) c u)) + map_add' x y := Subtype.ext (map_add + (forgetCardSuppLTInnerCoefficients (K := K) (R := R) (κ := κ) c u) + (x : Nonpositive (u.stratum c) + (CardSuppLTField (G := ↥(ball K c)) (R := R) (κ := κ))) y) + +/-- Forgetting the target bound acts by forgetting every inner coefficient. -/ +@[simp] +theorem coe_forgetSplitCardSuppLTIntegerPartRingHom + (u : HahnEmbedding.ArchimedeanStrata K G) (c : FiniteArchimedeanClass G) + (Z : Subring R) + (y : truncationIntegerPart (u.stratum c) + (cardSuppLTTruncationIntegerPart (G := ↥(ball K c)) (R := R) (κ := κ) Z)) : + ((forgetSplitCardSuppLTIntegerPartRingHom u c Z y : + truncationIntegerPart (u.stratum c) (innerIntegerPartSubring c Z)) : + Nonpositive (u.stratum c) R⟦ball K c⟧) = + forgetCardSuppLTInnerCoefficients (K := K) (R := R) (κ := κ) c u + (y : Nonpositive (u.stratum c) + (CardSuppLTField (G := ↥(ball K c)) (R := R) (κ := κ))) := + (rfl) + +/-- Forgetting bounds after the bounded split recovers the full integer-part split. -/ +theorem forget_splitTruncationCardSuppLTIntegerPart + (u : HahnEmbedding.ArchimedeanStrata K G) (c : FiniteArchimedeanClass G) + (Z : Subring R) + (b : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) : + forgetSplitCardSuppLTIntegerPartRingHom u c Z + (splitTruncationCardSuppLTIntegerPart u c Z b) = + splitIntegerPartRingHom u c Z + (CardSuppLTTruncationIntegerPart.toTruncationIntegerPartRingHom Z b) := by + apply Subtype.ext + rw [coe_forgetSplitCardSuppLTIntegerPartRingHom, coe_splitIntegerPartRingHom] + rw [coe_splitTruncationCardSuppLTIntegerPart] + rw [CardSuppLTTruncationIntegerPart.coe_toTruncationIntegerPartRingHom] + apply Subtype.ext + apply HahnSeries.ext + funext s + rw [coeff_forgetCardSuppLTInnerCoefficients] + exact coe_coeff_splitTruncationCardSuppLT u c + (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b) + (CardSuppLTTruncationIntegerPart.cardSupp_toNonpositiveRingHom_lt Z b) s + +/-- Forgetting bounded inner coefficients is injective on the split integer part. -/ +theorem forgetSplitCardSuppLTIntegerPartRingHom_injective + (u : HahnEmbedding.ArchimedeanStrata K G) (c : FiniteArchimedeanClass G) + (Z : Subring R) : + Function.Injective + (forgetSplitCardSuppLTIntegerPartRingHom (K := K) (R := R) (κ := κ) u c Z) := by + intro x y hxy + apply Subtype.ext + apply Subtype.ext + apply HahnSeries.ext + funext s + apply Subtype.ext + have hcoeff := congrArg (fun q : truncationIntegerPart (u.stratum c) + (innerIntegerPartSubring (K := K) (G := G) c Z) ↦ + ((q : Nonpositive (u.stratum c) R⟦ball K c⟧) : + (R⟦ball K c⟧)⟦u.stratum c⟧).coeff s) hxy + simpa only [coe_forgetSplitCardSuppLTIntegerPartRingHom (K := K) (R := R) (κ := κ), + coeff_forgetCardSuppLTInnerCoefficients (K := K) (R := R) (κ := κ)] using hcoeff + +/-- The leading-class split as a ring homomorphism on cardinal-bounded integer parts. -/ +def splitCardSuppLTIntegerPartRingHom + (u : HahnEmbedding.ArchimedeanStrata K G) (c : FiniteArchimedeanClass G) + (Z : Subring R) : + cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z →+* + truncationIntegerPart (u.stratum c) + (cardSuppLTTruncationIntegerPart (G := ↥(ball K c)) (R := R) (κ := κ) Z) := + RingHom.ofInjectiveComp _ (forgetSplitCardSuppLTIntegerPartRingHom_injective u c Z) + ((splitIntegerPartRingHom u c Z).comp + (CardSuppLTTruncationIntegerPart.toTruncationIntegerPartRingHom Z)) + (splitTruncationCardSuppLTIntegerPart u c Z) + (forget_splitTruncationCardSuppLTIntegerPart u c Z) + +/-- The bounded split ring homomorphism applies by the bounded split construction. -/ +@[simp] +theorem splitCardSuppLTIntegerPartRingHom_apply + (u : HahnEmbedding.ArchimedeanStrata K G) (c : FiniteArchimedeanClass G) + (Z : Subring R) + (b : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) : + splitCardSuppLTIntegerPartRingHom u c Z b = + splitTruncationCardSuppLTIntegerPart u c Z b := + RingHom.ofInjectiveComp_apply _ _ _ _ _ b + +/-- The bounded fixed integer part is the preimage of the full fixed integer part under the +bound-forgetting homomorphism. -/ +def cardSuppLTFixedIntegerPartSubring + (c : FiniteArchimedeanClass G) (Z : Subring R) : + Subring (cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) := + (fixedIntegerPartSubring (K := K) (G := G) (R := R) c Z).comap + (CardSuppLTTruncationIntegerPart.toTruncationIntegerPartRingHom Z) + +/-- Forget the cardinal bound on a bounded fixed integer-part element. -/ +def forgetCardSuppLTFixedIntegerPartRingHom + (c : FiniteArchimedeanClass G) (Z : Subring R) : + cardSuppLTFixedIntegerPartSubring (K := K) (κ := κ) c Z →+* + fixedIntegerPartSubring (K := K) (G := G) (R := R) c Z where + toFun x := ⟨CardSuppLTTruncationIntegerPart.toTruncationIntegerPartRingHom Z + (x : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z), x.2⟩ + map_one' := by + apply Subtype.ext + change CardSuppLTTruncationIntegerPart.toTruncationIntegerPartRingHom + (G := G) (R := R) (κ := κ) Z (1 : + cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) = 1 + rw [map_one] + map_mul' x y := by + apply Subtype.ext + change CardSuppLTTruncationIntegerPart.toTruncationIntegerPartRingHom Z + ((x : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) * + (y : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z)) = _ + rw [map_mul] + rfl + map_zero' := by + apply Subtype.ext + change CardSuppLTTruncationIntegerPart.toTruncationIntegerPartRingHom + (G := G) (R := R) (κ := κ) Z (0 : + cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) = 0 + rw [map_zero] + map_add' x y := by + apply Subtype.ext + change CardSuppLTTruncationIntegerPart.toTruncationIntegerPartRingHom Z + ((x : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) + + (y : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z)) = _ + rw [map_add] + rfl + +/-- Forgetting a bounded fixed element uses the underlying bound-forgetting homomorphism. -/ +@[simp] +theorem coe_forgetCardSuppLTFixedIntegerPartRingHom + (c : FiniteArchimedeanClass G) (Z : Subring R) + (x : cardSuppLTFixedIntegerPartSubring (K := K) (κ := κ) c Z) : + (forgetCardSuppLTFixedIntegerPartRingHom c Z x : truncationIntegerPart G Z) = + CardSuppLTTruncationIntegerPart.toTruncationIntegerPartRingHom Z + (x : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) := + (rfl) + +/-- Forgetting the bound is injective on bounded fixed integer-part elements. -/ +theorem forgetCardSuppLTFixedIntegerPartRingHom_injective + (c : FiniteArchimedeanClass G) (Z : Subring R) : + Function.Injective + (forgetCardSuppLTFixedIntegerPartRingHom (K := K) (κ := κ) c Z) := by + intro x y hxy + apply Subtype.ext + apply Subtype.ext + apply Subtype.ext + have hraw := congrArg (fun q : fixedIntegerPartSubring + (K := K) (G := G) (R := R) c Z ↦ + (((q : truncationIntegerPart G Z) : Nonpositive G R) : R⟦G⟧)) hxy + simpa only [coe_forgetCardSuppLTFixedIntegerPartRingHom, + CardSuppLTTruncationIntegerPart.coe_toTruncationIntegerPartRingHom, + CardSuppLTTruncationIntegerPart.coe_toNonpositiveRingHom] using hraw + +/-- Restrict the bounded split homomorphism to the bounded fixed integer part. -/ +def splitCardSuppLTFixedIntegerPartRingHom + (u : HahnEmbedding.ArchimedeanStrata K G) (c : FiniteArchimedeanClass G) + (Z : Subring R) : + cardSuppLTFixedIntegerPartSubring (K := K) (κ := κ) c Z →+* + truncationIntegerPart (u.stratum c) + (cardSuppLTTruncationIntegerPart (G := ↥(ball K c)) (R := R) (κ := κ) Z) := + (splitCardSuppLTIntegerPartRingHom u c Z).comp + (cardSuppLTFixedIntegerPartSubring (K := K) (κ := κ) c Z).subtype + +/-- The fixed bounded split is the unrestricted bounded split of the underlying element. -/ +@[simp] +theorem splitCardSuppLTFixedIntegerPartRingHom_apply + (u : HahnEmbedding.ArchimedeanStrata K G) (c : FiniteArchimedeanClass G) + (Z : Subring R) + (x : cardSuppLTFixedIntegerPartSubring (K := K) (κ := κ) c Z) : + splitCardSuppLTFixedIntegerPartRingHom u c Z x = + splitCardSuppLTIntegerPartRingHom u c Z + (x : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) := + (rfl) + +/-- Forgetting bounds commutes with the fixed integer-part split. -/ +theorem forget_splitCardSuppLTFixedIntegerPartRingHom + (u : HahnEmbedding.ArchimedeanStrata K G) (c : FiniteArchimedeanClass G) + (Z : Subring R) + (x : cardSuppLTFixedIntegerPartSubring (K := K) (κ := κ) c Z) : + forgetSplitCardSuppLTIntegerPartRingHom u c Z + (splitCardSuppLTFixedIntegerPartRingHom u c Z x) = + splitFixedIntegerPartRingHom u c Z + (forgetCardSuppLTFixedIntegerPartRingHom c Z x) := by + rw [splitCardSuppLTFixedIntegerPartRingHom_apply, splitCardSuppLTIntegerPartRingHom_apply, + forget_splitTruncationCardSuppLTIntegerPart] + apply Subtype.ext + rw [coe_splitFixedIntegerPartRingHom, coe_splitIntegerPartRingHom] + rw [coe_forgetCardSuppLTFixedIntegerPartRingHom, + CardSuppLTTruncationIntegerPart.coe_toTruncationIntegerPartRingHom] + +/-- The full unsplit of a bounded outer integer-part element still has support smaller than a +regular `κ`. -/ +theorem cardSupp_unsplit_forgetSplitCardSuppLTIntegerPart_lt + [Fact κ.IsRegular] + (u : HahnEmbedding.ArchimedeanStrata K G) (c : FiniteArchimedeanClass G) + (Z : Subring R) + (y : truncationIntegerPart (u.stratum c) + (cardSuppLTTruncationIntegerPart (G := ↥(ball K c)) (R := R) (κ := κ) Z)) : + ((((unsplitIntegerPart u c Z + (forgetSplitCardSuppLTIntegerPartRingHom u c Z y) : + truncationIntegerPart G Z) : Nonpositive G R) : R⟦G⟧).cardSupp) < κ := by + let yBounded : Nonpositive (u.stratum c) + (CardSuppLTField (G := ↥(ball K c)) (R := R) (κ := κ)) := y + let yFull : Nonpositive (u.stratum c) R⟦ball K c⟧ := + forgetCardSuppLTInnerCoefficients c u yBounded + have houter : ((yFull : (R⟦ball K c⟧)⟦u.stratum c⟧).cardSupp) < κ := + (HahnSeries.cardSupp_le_aleph0_of_archimedean + (yFull : (R⟦ball K c⟧)⟦u.stratum c⟧)).trans_lt (Fact.out : ℵ₀ < κ) + have hcoeff : ∀ s, + (((yFull : (R⟦ball K c⟧)⟦u.stratum c⟧).coeff s).cardSupp) < κ := by + intro s + dsimp only [yFull] + rw [coeff_forgetCardSuppLTInnerCoefficients] + exact ((yBounded : + (CardSuppLTField (G := ↥(ball K c)) (R := R) (κ := κ))⟦u.stratum c⟧).coeff s).2 + have hflat : (HahnSeries.iterateRingEquiv + (yFull : (R⟦ball K c⟧)⟦u.stratum c⟧)).cardSupp < κ := + HahnSeries.cardSupp_iterateRingEquiv_lt_of_isRegular Fact.out + (yFull : (R⟦ball K c⟧)⟦u.stratum c⟧) houter hcoeff + let zClosed := (HahnSeries.archimedeanSplitRingEquiv u c).symm + (yFull : (R⟦ball K c⟧)⟦u.stratum c⟧) + have hsplit : HahnSeries.archimedeanSplitRingEquiv u c zClosed = + (yFull : (R⟦ball K c⟧)⟦u.stratum c⟧) := + (HahnSeries.archimedeanSplitRingEquiv u c).apply_symm_apply _ + have hiterate := iterateRingEquiv_archimedeanSplitRingEquiv u c zClosed + rw [hsplit] at hiterate + have hzClosed : zClosed.cardSupp < κ := by + rw [← HahnSeries.cardSupp_embDomainRingEquiv + (HahnEmbedding.ArchimedeanStrata.closedBallEquivStratumLexBall u c) zClosed] + rw [← hiterate] + exact hflat + rw [coe_unsplitIntegerPart] + rw [HahnSeries.cardSupp_embDomain] + exact hzClosed + +/-- Unsplit a bounded outer integer-part element and retain the support-cardinality witness. -/ +def unsplitCardSuppLTIntegerPart + [Fact κ.IsRegular] + (u : HahnEmbedding.ArchimedeanStrata K G) (c : FiniteArchimedeanClass G) + (Z : Subring R) + (y : truncationIntegerPart (u.stratum c) + (cardSuppLTTruncationIntegerPart (G := ↥(ball K c)) (R := R) (κ := κ) Z)) : + cardSuppLTFixedIntegerPartSubring (K := K) (κ := κ) c Z := by + let xFull := unsplitIntegerPart u c Z + (forgetSplitCardSuppLTIntegerPartRingHom u c Z y) + let xBounded : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z := + ⟨⟨((xFull : truncationIntegerPart G Z) : Nonpositive G R), + cardSupp_unsplit_forgetSplitCardSuppLTIntegerPart_lt u c Z y⟩, + by + rw [mem_cardSuppLTTruncationIntegerPart] + exact ⟨support_subset ((xFull : truncationIntegerPart G Z) : Nonpositive G R), + (mem_truncationIntegerPart (Γ := G) (R := R)).mp + (xFull : truncationIntegerPart G Z).2⟩⟩ + refine ⟨xBounded, ?_⟩ + change CardSuppLTTruncationIntegerPart.toTruncationIntegerPartRingHom Z xBounded ∈ + fixedIntegerPartSubring (K := K) (G := G) (R := R) c Z + have hx : CardSuppLTTruncationIntegerPart.toTruncationIntegerPartRingHom Z xBounded = + (xFull : truncationIntegerPart G Z) := by + apply Subtype.ext + rw [CardSuppLTTruncationIntegerPart.coe_toTruncationIntegerPartRingHom] + apply Subtype.ext + rw [CardSuppLTTruncationIntegerPart.coe_toNonpositiveRingHom] + rw [hx] + exact xFull.2 + +/-- Forgetting the source bound after bounded unsplitting recovers the full unsplit. -/ +theorem forget_unsplitCardSuppLTIntegerPart + [Fact κ.IsRegular] + (u : HahnEmbedding.ArchimedeanStrata K G) (c : FiniteArchimedeanClass G) + (Z : Subring R) + (y : truncationIntegerPart (u.stratum c) + (cardSuppLTTruncationIntegerPart (G := ↥(ball K c)) (R := R) (κ := κ) Z)) : + forgetCardSuppLTFixedIntegerPartRingHom c Z + (unsplitCardSuppLTIntegerPart u c Z y) = + unsplitIntegerPart u c Z + (forgetSplitCardSuppLTIntegerPartRingHom u c Z y) := by + apply Subtype.ext + rw [coe_forgetCardSuppLTFixedIntegerPartRingHom] + apply Subtype.ext + rw [CardSuppLTTruncationIntegerPart.coe_toTruncationIntegerPartRingHom] + apply Subtype.ext + rw [CardSuppLTTruncationIntegerPart.coe_toNonpositiveRingHom] + rfl + +/-- For regular `κ`, the bounded fixed integer part is equivalent to the outer integer part over +the bounded inner coefficient integer part. -/ +def splitCardSuppLTFixedIntegerPartRingEquiv + [Fact κ.IsRegular] + (u : HahnEmbedding.ArchimedeanStrata K G) (c : FiniteArchimedeanClass G) + (Z : Subring R) : + cardSuppLTFixedIntegerPartSubring (K := K) (κ := κ) c Z ≃+* + truncationIntegerPart (u.stratum c) + (cardSuppLTTruncationIntegerPart (G := ↥(ball K c)) (R := R) (κ := κ) Z) where + toFun := splitCardSuppLTFixedIntegerPartRingHom u c Z + invFun := unsplitCardSuppLTIntegerPart u c Z + left_inv x := by + apply forgetCardSuppLTFixedIntegerPartRingHom_injective c Z + rw [forget_unsplitCardSuppLTIntegerPart, + forget_splitCardSuppLTFixedIntegerPartRingHom] + rw [← splitFixedIntegerPartRingEquiv_apply, + ← splitFixedIntegerPartRingEquiv_symm_apply] + exact (splitFixedIntegerPartRingEquiv u c Z).left_inv _ + right_inv y := by + apply forgetSplitCardSuppLTIntegerPartRingHom_injective u c Z + rw [forget_splitCardSuppLTFixedIntegerPartRingHom, + forget_unsplitCardSuppLTIntegerPart] + rw [← splitFixedIntegerPartRingEquiv_apply, + ← splitFixedIntegerPartRingEquiv_symm_apply] + exact (splitFixedIntegerPartRingEquiv u c Z).right_inv _ + map_mul' := (splitCardSuppLTFixedIntegerPartRingHom u c Z).map_mul + map_add' := (splitCardSuppLTFixedIntegerPartRingHom u c Z).map_add + +/-- The bounded fixed equivalence applies by the bounded split ring homomorphism. -/ +@[simp] +theorem splitCardSuppLTFixedIntegerPartRingEquiv_apply + [Fact κ.IsRegular] + (u : HahnEmbedding.ArchimedeanStrata K G) (c : FiniteArchimedeanClass G) + (Z : Subring R) + (x : cardSuppLTFixedIntegerPartSubring (K := K) (κ := κ) c Z) : + splitCardSuppLTFixedIntegerPartRingEquiv u c Z x = + splitCardSuppLTFixedIntegerPartRingHom u c Z x := + (rfl) + +/-- The inverse bounded fixed equivalence is the bounded unsplit construction. -/ +@[simp] +theorem splitCardSuppLTFixedIntegerPartRingEquiv_symm_apply + [Fact κ.IsRegular] + (u : HahnEmbedding.ArchimedeanStrata K G) (c : FiniteArchimedeanClass G) + (Z : Subring R) + (y : truncationIntegerPart (u.stratum c) + (cardSuppLTTruncationIntegerPart (G := ↥(ball K c)) (R := R) (κ := κ) Z)) : + (splitCardSuppLTFixedIntegerPartRingEquiv u c Z).symm y = + unsplitCardSuppLTIntegerPart u c Z y := + (rfl) + +/-- Membership in the bounded fixed integer part is invariance under the closed-class cut. -/ +theorem mem_cardSuppLTFixedIntegerPartSubring_iff + (c : FiniteArchimedeanClass G) (Z : Subring R) + (x : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) : + x ∈ cardSuppLTFixedIntegerPartSubring (K := K) c Z ↔ + T (K := K) c (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z x) = + CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z x := by + change CardSuppLTTruncationIntegerPart.toTruncationIntegerPartRingHom Z x ∈ + fixedIntegerPartSubring (K := K) (G := G) (R := R) c Z ↔ _ + rw [mem_fixedIntegerPartSubring_iff] + rw [CardSuppLTTruncationIntegerPart.coe_toTruncationIntegerPartRingHom] + +end HahnSeries.Nonpositive diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/CardinalPrimalityTransfer.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/CardinalPrimalityTransfer.lean new file mode 100644 index 0000000000..3bf7ef6a49 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/CardinalPrimalityTransfer.lean @@ -0,0 +1,144 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.CardinalSplitting +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Assumptions +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.IntegerPartSplitting +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.TruncationIntegerPartPrimal + +/-! +# Local primality transfer for cardinal-bounded Hahn series + +This module applies LM24, Lemma 9.2.1 after the leading-class split has been bundled over the +bounded inner Hahn field. In the zero-residue branch, the exact nonzero-class specialization of +`(A2)_σ` supplies the fraction-field equality. In the residue-one branch no form of `(A2)_σ` is +used. + +The remaining step toward LM24, Proposition 9.2.2 is the bounded restriction of the source-side +fixed-ring equivalence. It is kept separate from this local residue calculation. +-/ + +public noncomputable section + +open Cardinal FiniteArchimedeanClass + +namespace HahnSeries.Nonpositive + +variable {K G R : Type*} {κ : Cardinal} +variable [DivisionRing K] [LinearOrder K] [IsOrderedRing K] [Archimedean K] +variable [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] +variable [Module K G] [IsOrderedModule K G] +variable [Field R] [Fact (ℵ₀ < κ)] + +/-- The bounded split truncation in the outer integer part whose coefficient subring is the +bounded inner truncation integer part. -/ +def splitTruncationCardSuppLTIntegerPart + (u : HahnEmbedding.ArchimedeanStrata K G) (c : FiniteArchimedeanClass G) + (Z : Subring R) + (b : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) : + truncationIntegerPart (u.stratum c) + (cardSuppLTTruncationIntegerPart (G := ↥(ball K c)) (R := R) (κ := κ) Z) := by + let bFull := CardSuppLTTruncationIntegerPart.toTruncationIntegerPartRingHom Z b + let bNP := CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b + let hb := CardSuppLTTruncationIntegerPart.cardSupp_toNonpositiveRingHom_lt Z b + let y := splitTruncationCardSuppLT u c bNP hb + refine ⟨y, ?_⟩ + rw [mem_truncationIntegerPart] + rw [← constantCoeff_apply] + rw [show constantCoeff y = constantCoeff (splitTruncationCardSuppLT u c bNP hb) from rfl] + rw [mem_cardSuppLTTruncationIntegerPart] + constructor + · rw [coe_constantCoeff_splitTruncationCardSuppLT] + have htau := tauBall_mem_innerIntegerPartSubring (K := K) (G := G) c Z bFull + rw [CardSuppLTTruncationIntegerPart.coe_toTruncationIntegerPartRingHom] at htau + exact (mem_innerIntegerPartSubring_iff (K := K) c Z _).mp htau |>.1 + · rw [coe_constantCoeff_splitTruncationCardSuppLT, + coeff_zero_tauBall (K := K)] + rw [show (bNP : R⟦G⟧) = + (b : CardSuppLTField (G := G) (R := R) (κ := κ)) by + exact CardSuppLTTruncationIntegerPart.coe_toNonpositiveRingHom Z b] + exact (mem_cardSuppLTTruncationIntegerPart (Z := Z)).mp b.2 |>.2 + +/-- The bounded split integer-part element has the underlying bounded split truncation. -/ +@[simp] +theorem coe_splitTruncationCardSuppLTIntegerPart + (u : HahnEmbedding.ArchimedeanStrata K G) (c : FiniteArchimedeanClass G) + (Z : Subring R) + (b : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) : + ((splitTruncationCardSuppLTIntegerPart u c Z b : + truncationIntegerPart (u.stratum c) + (cardSuppLTTruncationIntegerPart (G := ↥(ball K c)) (R := R) (κ := κ) Z)) : + Nonpositive (u.stratum c) + (CardSuppLTField (G := ↥(ball K c)) (R := R) (κ := κ))) = + splitTruncationCardSuppLT u c + (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b) + (CardSuppLTTruncationIntegerPart.cardSupp_toNonpositiveRingHom_lt Z b) := + (rfl) + +/-- In the residue-one branch, primality in the split bounded integer part is ambient primality. -/ +theorem isPrimal_splitTruncationCardSuppLTIntegerPart_iff_of_tau_eq_one + (u : HahnEmbedding.ArchimedeanStrata K G) (c : FiniteArchimedeanClass G) + (Z : Subring R) + (b : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) + (htau : tauBall (K := K) c + (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b) = 1) : + IsPrimal (splitTruncationCardSuppLTIntegerPart u c Z b) ↔ + IsPrimal (splitTruncationCardSuppLT u c + (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b) + (CardSuppLTTruncationIntegerPart.cardSupp_toNonpositiveRingHom_lt Z b)) := by + apply isPrimal_truncationIntegerPart_iff_of_constantCoeff_eq_one + (cardSuppLTTruncationIntegerPart (G := ↥(ball K c)) (R := R) (κ := κ) Z) + rw [constantCoeffAlgHom_apply] + apply Subtype.ext + rw [show ((splitTruncationCardSuppLTIntegerPart u c Z b : + Nonpositive (u.stratum c) + (CardSuppLTField (G := ↥(ball K c)) (R := R) (κ := κ))) : + (CardSuppLTField (G := ↥(ball K c)) (R := R) (κ := κ))⟦u.stratum c⟧).coeff 0 = + ((splitTruncationCardSuppLT u c + (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b) + (CardSuppLTTruncationIntegerPart.cardSupp_toNonpositiveRingHom_lt Z b) : + Nonpositive (u.stratum c) + (CardSuppLTField (G := ↥(ball K c)) (R := R) (κ := κ))) : + (CardSuppLTField (G := ↥(ball K c)) (R := R) (κ := κ))⟦u.stratum c⟧).coeff 0 from rfl] + rw [coe_coeff_splitTruncationCardSuppLT] + rw [← constantCoeff_apply, constantCoeff_splitTruncation, htau] + rfl + +/-- In the residue-zero branch, `(A2)_σ` identifies primality in the split bounded integer part +with ambient primality. -/ +theorem isPrimal_splitTruncationCardSuppLTIntegerPart_iff_of_tau_eq_zero + (u : HahnEmbedding.ArchimedeanStrata K G) (c : FiniteArchimedeanClass G) + (Z : Subring R) + (hA2 : LM24.AssumptionA2AtFiniteClass (K := K) κ Z c) + (b : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) + (htau : tauBall (K := K) c + (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b) = 0) : + IsPrimal (splitTruncationCardSuppLTIntegerPart u c Z b) ↔ + IsPrimal (splitTruncationCardSuppLT u c + (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b) + (CardSuppLTTruncationIntegerPart.cardSupp_toNonpositiveRingHom_lt Z b)) := by + apply isPrimal_truncationIntegerPart_iff_of_constantCoeff_eq_zero + (cardSuppLTTruncationIntegerPart (G := ↥(ball K c)) (R := R) (κ := κ) Z) + (LM24.fracSubring_cardSuppLTTruncationIntegerPart_eq_top_of_assumptionA2AtFiniteClass + Z c hA2) + rw [constantCoeffAlgHom_apply] + apply Subtype.ext + rw [show ((splitTruncationCardSuppLTIntegerPart u c Z b : + Nonpositive (u.stratum c) + (CardSuppLTField (G := ↥(ball K c)) (R := R) (κ := κ))) : + (CardSuppLTField (G := ↥(ball K c)) (R := R) (κ := κ))⟦u.stratum c⟧).coeff 0 = + ((splitTruncationCardSuppLT u c + (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b) + (CardSuppLTTruncationIntegerPart.cardSupp_toNonpositiveRingHom_lt Z b) : + Nonpositive (u.stratum c) + (CardSuppLTField (G := ↥(ball K c)) (R := R) (κ := κ))) : + (CardSuppLTField (G := ↥(ball K c)) (R := R) (κ := κ))⟦u.stratum c⟧).coeff 0 from rfl] + rw [coe_coeff_splitTruncationCardSuppLT] + rw [← constantCoeff_apply, constantCoeff_splitTruncation] + exact htau + +end HahnSeries.Nonpositive diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/CardinalProposition922.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/CardinalProposition922.lean new file mode 100644 index 0000000000..b3f46f276e --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/CardinalProposition922.lean @@ -0,0 +1,588 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.CardinalIntegerPartSplitting +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.PrimalityTransfer + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint + +/-! +# LM24 Proposition 9.2.2 for cardinal-bounded Hahn fields + +This module proves the set-sized, cardinal-bounded form of LM24, Proposition 9.2.2. Closed-class +truncation preserves the bound directly. Its divisibility-localization converse stays bounded +because a quotient of two `< κ`-supported Hahn series again has support smaller than the +uncountable cardinal `κ`. + +The bounded fixed-ring equivalence used later requires regularity of `κ`; that hypothesis records +the countable-union closure needed to flatten arbitrary bounded inner coefficients. The +hypothesis `(A2)_σ` is needed only in the zero-residue branch. +-/ + +public noncomputable section + +open Cardinal FiniteArchimedeanClass + +namespace HahnSeries.Nonpositive + +variable {K G R : Type*} {κ : Cardinal} +variable [DivisionRing K] [LinearOrder K] [IsOrderedRing K] [Archimedean K] +variable [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] +variable [Module K G] [IsOrderedModule K G] +variable [Field R] [Fact (ℵ₀ < κ)] + +/-- Closed-class truncation does not increase support cardinality. -/ +theorem cardSupp_T_le (c : FiniteArchimedeanClass G) (x : Nonpositive G R) : + ((T (K := K) c x : Nonpositive G R) : R⟦G⟧).cardSupp ≤ (x : R⟦G⟧).cardSupp := + HahnSeries.cardSupp_mono (support_T_subset c x) + +/-- Closed-class truncation restricted to a cardinal-bounded truncation integer part. -/ +def TCardSuppLTIntegerPartRingHom + (c : FiniteArchimedeanClass G) (Z : Subring R) : + cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z →+* + cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z where + toFun x := by + let xNP := CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z x + let tx := T (K := K) c xNP + refine ⟨⟨(tx : R⟦G⟧), (cardSupp_T_le c xNP).trans_lt + (CardSuppLTTruncationIntegerPart.cardSupp_toNonpositiveRingHom_lt Z x)⟩, ?_⟩ + rw [mem_cardSuppLTTruncationIntegerPart] + constructor + · exact support_subset tx + · rw [show (tx : R⟦G⟧).coeff 0 = (xNP : R⟦G⟧).coeff 0 by + exact coeff_T_of_mem c xNP (zero_mem _)] + rw [CardSuppLTTruncationIntegerPart.coe_toNonpositiveRingHom] + exact (mem_cardSuppLTTruncationIntegerPart (Z := Z)).mp x.2 |>.2 + map_one' := by + apply Subtype.ext + apply Subtype.ext + change (((T (K := K) c + (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z (1 : + cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z)) : + Nonpositive G R) : R⟦G⟧)) = 1 + rw [map_one, map_one] + rfl + map_mul' x y := by + apply Subtype.ext + apply Subtype.ext + change (((T (K := K) c + (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z (x * y)) : + Nonpositive G R) : R⟦G⟧)) = _ + rw [map_mul, map_mul] + rfl + map_zero' := by + apply Subtype.ext + apply Subtype.ext + change (((T (K := K) c + (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z (0 : + cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z)) : + Nonpositive G R) : R⟦G⟧)) = 0 + rw [map_zero, map_zero] + rfl + map_add' x y := by + apply Subtype.ext + apply Subtype.ext + change (((T (K := K) c + (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z (x + y)) : + Nonpositive G R) : R⟦G⟧)) = _ + rw [map_add, map_add] + rfl + +/-- The bounded truncation homomorphism has the expected underlying nonpositive series. -/ +@[simp] +theorem toNonpositive_TCardSuppLTIntegerPartRingHom + (c : FiniteArchimedeanClass G) (Z : Subring R) + (x : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) : + CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z + (TCardSuppLTIntegerPartRingHom (K := K) c Z x) = + T (K := K) c (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z x) := by + apply Subtype.ext + rw [CardSuppLTTruncationIntegerPart.coe_toNonpositiveRingHom] + rfl + +/-- Forgetting the cardinal bound commutes with closed-class truncation. -/ +theorem toTruncationIntegerPart_TCardSuppLTIntegerPartRingHom + (c : FiniteArchimedeanClass G) (Z : Subring R) + (x : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) : + CardSuppLTTruncationIntegerPart.toTruncationIntegerPartRingHom Z + (TCardSuppLTIntegerPartRingHom (K := K) c Z x) = + TIntegerPartRingHom (K := K) c Z + (CardSuppLTTruncationIntegerPart.toTruncationIntegerPartRingHom Z x) := by + apply Subtype.ext + rw [coe_TIntegerPartRingHom, + CardSuppLTTruncationIntegerPart.coe_toTruncationIntegerPartRingHom] + rw [toNonpositive_TCardSuppLTIntegerPartRingHom] + rw [CardSuppLTTruncationIntegerPart.coe_toTruncationIntegerPartRingHom] + +/-- A bounded integer-part element is fixed by bounded truncation exactly when its underlying +nonpositive series is fixed. -/ +theorem TCardSuppLTIntegerPartRingHom_eq_iff + (c : FiniteArchimedeanClass G) (Z : Subring R) + (x : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) : + TCardSuppLTIntegerPartRingHom (K := K) c Z x = x ↔ + T (K := K) c (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z x) = + CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z x := by + constructor + · intro h + have h' := congrArg + (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom + (G := G) (R := R) (κ := κ) Z) h + rwa [toNonpositive_TCardSuppLTIntegerPartRingHom] at h' + · intro h + apply CardSuppLTTruncationIntegerPart.toNonpositiveRingHom_injective Z + rwa [toNonpositive_TCardSuppLTIntegerPartRingHom] + +/-- Bounded closed-class truncation is idempotent. -/ +@[simp] +theorem TCardSuppLTIntegerPartRingHom_TCardSuppLTIntegerPartRingHom + (c : FiniteArchimedeanClass G) (Z : Subring R) + (x : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) : + TCardSuppLTIntegerPartRingHom (K := K) c Z + (TCardSuppLTIntegerPartRingHom (K := K) c Z x) = + TCardSuppLTIntegerPartRingHom (K := K) c Z x := by + apply (TCardSuppLTIntegerPartRingHom_eq_iff c Z _).mpr + rw [toNonpositive_TCardSuppLTIntegerPartRingHom] + exact T_T c (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z x) + +/-- Divisibility by a nonzero fixed bounded integer-part element can be tested after closed-class +truncation, with the quotient remaining cardinal-bounded. -/ +theorem dvd_iff_dvd_TCardSuppLTIntegerPart_of_fixed + (c : FiniteArchimedeanClass G) (Z : Subring R) + (b : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) + (hb0 : CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b ≠ 0) + (hbFixed : T (K := K) c + (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b) = + CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b) + (x : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) : + b ∣ x ↔ b ∣ TCardSuppLTIntegerPartRingHom (K := K) c Z x := by + let f := CardSuppLTTruncationIntegerPart.toTruncationIntegerPartRingHom + (G := G) (R := R) (κ := κ) Z + have hbFixedBounded : TCardSuppLTIntegerPartRingHom (K := K) c Z b = b := + (TCardSuppLTIntegerPartRingHom_eq_iff c Z b).mpr hbFixed + constructor + · rintro ⟨q, hq⟩ + refine ⟨TCardSuppLTIntegerPartRingHom (K := K) c Z q, ?_⟩ + calc + TCardSuppLTIntegerPartRingHom (K := K) c Z x = + TCardSuppLTIntegerPartRingHom (K := K) c Z (b * q) := congrArg _ hq + _ = TCardSuppLTIntegerPartRingHom (K := K) c Z b * + TCardSuppLTIntegerPartRingHom (K := K) c Z q := map_mul _ _ _ + _ = b * TCardSuppLTIntegerPartRingHom (K := K) c Z q := by rw [hbFixedBounded] + · intro h + have hFullT0 : f b ∣ f (TCardSuppLTIntegerPartRingHom (K := K) c Z x) := + map_dvd f h + have hFullT : f b ∣ TIntegerPartRingHom (K := K) c Z (f x) := by + rw [← toTruncationIntegerPart_TCardSuppLTIntegerPartRingHom] + exact hFullT0 + have hbFull0 : (f b : Nonpositive G R) ≠ 0 := by + rw [CardSuppLTTruncationIntegerPart.coe_toTruncationIntegerPartRingHom] + exact hb0 + have hbFullFixed : T (K := K) c (f b : Nonpositive G R) = f b := by + rw [CardSuppLTTruncationIntegerPart.coe_toTruncationIntegerPartRingHom] + exact hbFixed + have hFull : f b ∣ f x := + (dvd_iff_dvd_TIntegerPart_of_fixed c Z (f b) hbFull0 hbFullFixed (f x)).mpr hFullT + obtain ⟨q, hq⟩ := hFull + let bRaw : R⟦G⟧ := CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b + let xRaw : R⟦G⟧ := CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z x + let qRaw : R⟦G⟧ := (q : Nonpositive G R) + have hbRaw0 : bRaw ≠ 0 := by + intro hzero + apply hb0 + exact Subtype.ext hzero + have hprod : xRaw = bRaw * qRaw := by + have hraw := congrArg (fun z : truncationIntegerPart G Z ↦ + ((z : Nonpositive G R) : R⟦G⟧)) hq + have hfx : (((f x : truncationIntegerPart G Z) : Nonpositive G R) : R⟦G⟧) = + xRaw := by + calc + _ = (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z x : R⟦G⟧) := + congrArg Subtype.val + (CardSuppLTTruncationIntegerPart.coe_toTruncationIntegerPartRingHom Z x) + _ = xRaw := rfl + have hfb : (((f b : truncationIntegerPart G Z) : Nonpositive G R) : R⟦G⟧) = + bRaw := by + calc + _ = (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b : R⟦G⟧) := + congrArg Subtype.val + (CardSuppLTTruncationIntegerPart.coe_toTruncationIntegerPartRingHom Z b) + _ = bRaw := rfl + have hmul : ((((f b) * q : truncationIntegerPart G Z) : Nonpositive G R) : R⟦G⟧) = + (((f b : truncationIntegerPart G Z) : Nonpositive G R) : R⟦G⟧) * qRaw := + (rfl) + rw [hfx, hmul, hfb] at hraw + exact hraw + have hqDiv : qRaw = xRaw / bRaw := (eq_div_iff hbRaw0).mpr (by + calc + qRaw * bRaw = bRaw * qRaw := mul_comm _ _ + _ = xRaw := hprod.symm) + have hbCard : bRaw.cardSupp < κ := by + exact CardSuppLTTruncationIntegerPart.cardSupp_toNonpositiveRingHom_lt Z b + have hxCard : xRaw.cardSupp < κ := by + exact CardSuppLTTruncationIntegerPart.cardSupp_toNonpositiveRingHom_lt Z x + have hqCard : qRaw.cardSupp < κ := by + rw [hqDiv] + exact (HahnSeries.cardSupp_div_le xRaw bRaw).trans_lt + (Cardinal.mul_lt_of_lt (Fact.out : ℵ₀ < κ).le hxCard + (max_lt (Fact.out : ℵ₀ < κ) hbCard)) + let qBounded : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z := + ⟨⟨qRaw, hqCard⟩, by + rw [mem_cardSuppLTTruncationIntegerPart] + exact ⟨support_subset (q : Nonpositive G R), + (mem_truncationIntegerPart (Γ := G) (R := R)).mp q.2⟩⟩ + refine ⟨qBounded, ?_⟩ + apply Subtype.ext + apply Subtype.ext + have hxval : ((x : CardSuppLTField (G := G) (R := R) (κ := κ)) : R⟦G⟧) = + xRaw := + (CardSuppLTTruncationIntegerPart.coe_toNonpositiveRingHom Z x).symm + have hbval : ((b : CardSuppLTField (G := G) (R := R) (κ := κ)) : R⟦G⟧) = + bRaw := + (CardSuppLTTruncationIntegerPart.coe_toNonpositiveRingHom Z b).symm + have hqval : ((qBounded : CardSuppLTField (G := G) (R := R) (κ := κ)) : R⟦G⟧) = + qRaw := + (rfl) + have hmul : (((b * qBounded : + cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) : + CardSuppLTField (G := G) (R := R) (κ := κ)) : R⟦G⟧) = + ((b : CardSuppLTField (G := G) (R := R) (κ := κ)) : R⟦G⟧) * + ((qBounded : CardSuppLTField (G := G) (R := R) (κ := κ)) : R⟦G⟧) := + (rfl) + rw [hxval, hmul, hbval, hqval] + exact hprod + +/-- Membership in the bounded fixed subring can be stated using the bundled bounded truncation +homomorphism. -/ +theorem mem_cardSuppLTFixedIntegerPartSubring_iff_TCardSuppLT + (c : FiniteArchimedeanClass G) (Z : Subring R) + (x : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) : + x ∈ cardSuppLTFixedIntegerPartSubring (K := K) c Z ↔ + TCardSuppLTIntegerPartRingHom (K := K) c Z x = x := + (mem_cardSuppLTFixedIntegerPartSubring_iff c Z x).trans + (TCardSuppLTIntegerPartRingHom_eq_iff c Z x).symm + +/-- A nonconstant bounded integer-part element, regarded in the bounded subring fixed at its +leading Archimedean class. -/ +def leadingCardSuppLTFixedIntegerPartElement + (Z : Subring R) + (b : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) + (horder : ((CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b : + Nonpositive G R) : R⟦G⟧).order ≠ 0) : + cardSuppLTFixedIntegerPartSubring (K := K) (κ := κ) + (leadingClass (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b) horder) Z := + ⟨b, (mem_cardSuppLTFixedIntegerPartSubring_iff _ Z b).mpr + (T_leadingClass (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b) horder)⟩ + +/-- The leading bounded fixed element has the original bounded integer-part element as value. -/ +@[simp] +theorem coe_leadingCardSuppLTFixedIntegerPartElement + (Z : Subring R) + (b : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) + (horder : ((CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b : + Nonpositive G R) : R⟦G⟧).order ≠ 0) : + (leadingCardSuppLTFixedIntegerPartElement (K := K) Z b horder : + cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) = b := + (rfl) + +/-- Primality of a nonzero nonconstant bounded integer-part element is unchanged when restricted +to the bounded subring fixed by truncation at its leading class. -/ +theorem isPrimal_leadingCardSuppLTFixedIntegerPartElement_iff + (Z : Subring R) + (b : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) + (hb0 : CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b ≠ 0) + (horder : ((CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b : + Nonpositive G R) : R⟦G⟧).order ≠ 0) : + IsPrimal (leadingCardSuppLTFixedIntegerPartElement (K := K) Z b horder) ↔ + IsPrimal b := by + let sigma := leadingClass + (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b) horder + let t := TCardSuppLTIntegerPartRingHom (K := K) (R := R) (κ := κ) sigma Z + have hbFixed : t b = b := + (TCardSuppLTIntegerPartRingHom_eq_iff sigma Z b).mpr + (T_leadingClass (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b) horder) + constructor + · intro h x y hdvd + obtain ⟨q, hq⟩ := hdvd + have hdivLocal : leadingCardSuppLTFixedIntegerPartElement (K := K) Z b horder ∣ + ⟨t x, (mem_cardSuppLTFixedIntegerPartSubring_iff_TCardSuppLT sigma Z _).mpr + (TCardSuppLTIntegerPartRingHom_TCardSuppLTIntegerPartRingHom sigma Z x)⟩ * + ⟨t y, (mem_cardSuppLTFixedIntegerPartSubring_iff_TCardSuppLT sigma Z _).mpr + (TCardSuppLTIntegerPartRingHom_TCardSuppLTIntegerPartRingHom sigma Z y)⟩ := by + refine ⟨⟨t q, (mem_cardSuppLTFixedIntegerPartSubring_iff_TCardSuppLT sigma Z _).mpr + (TCardSuppLTIntegerPartRingHom_TCardSuppLTIntegerPartRingHom sigma Z q)⟩, ?_⟩ + apply Subtype.ext + change t x * t y = b * t q + rw [← map_mul] + rw [show x * y = b * q from hq] + rw [map_mul, hbFixed] + obtain ⟨b₁, b₂, h₁, h₂, hprod⟩ := h hdivLocal + have hprodSource : b = + (b₁ : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) * + (b₂ : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) := + congrArg Subtype.val hprod + have hb₁Ne : CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z + (b₁ : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) ≠ 0 := by + intro hz + apply hb0 + rw [show CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b = + CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z + ((b₁ : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) * + (b₂ : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z)) by + exact congrArg _ hprodSource] + rw [map_mul, hz, zero_mul] + have hb₂Ne : CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z + (b₂ : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) ≠ 0 := by + intro hz + apply hb0 + rw [show CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b = + CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z + ((b₁ : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) * + (b₂ : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z)) by + exact congrArg _ hprodSource] + rw [map_mul, hz, mul_zero] + have hfix₁ := (mem_cardSuppLTFixedIntegerPartSubring_iff sigma Z _).mp b₁.2 + have hfix₂ := (mem_cardSuppLTFixedIntegerPartSubring_iff sigma Z _).mp b₂.2 + have hiff₁ := dvd_iff_dvd_TCardSuppLTIntegerPart_of_fixed sigma Z b₁ hb₁Ne hfix₁ x + have hiff₂ := dvd_iff_dvd_TCardSuppLTIntegerPart_of_fixed sigma Z b₂ hb₂Ne hfix₂ y + have hmap₁ := map_dvd (cardSuppLTFixedIntegerPartSubring (K := K) (κ := κ) sigma Z).subtype h₁ + have hmap₂ := map_dvd (cardSuppLTFixedIntegerPartSubring (K := K) (κ := κ) sigma Z).subtype h₂ + exact ⟨_, _, hiff₁.mpr hmap₁, hiff₂.mpr hmap₂, hprodSource⟩ + · intro h x y hdvd + have hdvdSource : b ∣ + (x : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) * y := + map_dvd (cardSuppLTFixedIntegerPartSubring + (K := K) (κ := κ) sigma Z).subtype hdvd + obtain ⟨b₁, b₂, h₁, h₂, hprod⟩ := h hdvdSource + have hb₁Mem : t b₁ = b₁ := + (TCardSuppLTIntegerPartRingHom_eq_iff sigma Z b₁).mpr (by + apply T_leadingClass_of_dvd + (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b) hb0 horder + exact map_dvd (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom + (G := G) (R := R) (κ := κ) Z) + (hprod.symm ▸ dvd_mul_right b₁ b₂)) + have hb₂Mem : t b₂ = b₂ := + (TCardSuppLTIntegerPartRingHom_eq_iff sigma Z b₂).mpr (by + apply T_leadingClass_of_dvd + (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b) hb0 horder + exact map_dvd (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom + (G := G) (R := R) (κ := κ) Z) + (hprod.symm ▸ dvd_mul_left b₂ b₁)) + have hb₁Ne : b₁ ≠ 0 := by + intro hz + apply hb0 + rw [show b = b₁ * b₂ from hprod, hz, zero_mul, map_zero] + have hb₂Ne : b₂ ≠ 0 := by + intro hz + apply hb0 + rw [show b = b₁ * b₂ from hprod, hz, mul_zero, map_zero] + have hq₁Mem : t h₁.choose = h₁.choose := by + apply mul_left_cancel₀ hb₁Ne + calc + b₁ * t h₁.choose = t b₁ * t h₁.choose := by rw [hb₁Mem] + _ = t (b₁ * h₁.choose) := (map_mul t b₁ h₁.choose).symm + _ = t (x : cardSuppLTTruncationIntegerPart + (G := G) (R := R) (κ := κ) Z) := congrArg t h₁.choose_spec.symm + _ = (x : cardSuppLTTruncationIntegerPart + (G := G) (R := R) (κ := κ) Z) := + (mem_cardSuppLTFixedIntegerPartSubring_iff_TCardSuppLT sigma Z _).mp x.2 + _ = b₁ * h₁.choose := h₁.choose_spec + have hq₂Mem : t h₂.choose = h₂.choose := by + apply mul_left_cancel₀ hb₂Ne + calc + b₂ * t h₂.choose = t b₂ * t h₂.choose := by rw [hb₂Mem] + _ = t (b₂ * h₂.choose) := (map_mul t b₂ h₂.choose).symm + _ = t (y : cardSuppLTTruncationIntegerPart + (G := G) (R := R) (κ := κ) Z) := congrArg t h₂.choose_spec.symm + _ = (y : cardSuppLTTruncationIntegerPart + (G := G) (R := R) (κ := κ) Z) := + (mem_cardSuppLTFixedIntegerPartSubring_iff_TCardSuppLT sigma Z _).mp y.2 + _ = b₂ * h₂.choose := h₂.choose_spec + refine ⟨⟨b₁, (mem_cardSuppLTFixedIntegerPartSubring_iff_TCardSuppLT sigma Z _).mpr hb₁Mem⟩, + ⟨b₂, (mem_cardSuppLTFixedIntegerPartSubring_iff_TCardSuppLT sigma Z _).mpr hb₂Mem⟩, + ?_, ?_, ?_⟩ + · exact ⟨⟨h₁.choose, + (mem_cardSuppLTFixedIntegerPartSubring_iff_TCardSuppLT sigma Z _).mpr hq₁Mem⟩, + Subtype.ext h₁.choose_spec⟩ + · exact ⟨⟨h₂.choose, + (mem_cardSuppLTFixedIntegerPartSubring_iff_TCardSuppLT sigma Z _).mpr hq₂Mem⟩, + Subtype.ext h₂.choose_spec⟩ + · exact Subtype.ext hprod + +/-- Splitting the leading bounded fixed element gives the bounded split truncation integer-part +element. -/ +theorem splitCardSuppLTFixedIntegerPartRingEquiv_leadingElement + [Fact κ.IsRegular] + (u : HahnEmbedding.ArchimedeanStrata K G) (Z : Subring R) + (b : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) + (horder : ((CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b : + Nonpositive G R) : R⟦G⟧).order ≠ 0) : + splitCardSuppLTFixedIntegerPartRingEquiv u + (leadingClass (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b) horder) Z + (leadingCardSuppLTFixedIntegerPartElement (K := K) Z b horder) = + splitTruncationCardSuppLTIntegerPart u + (leadingClass (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b) horder) Z b := by + rw [splitCardSuppLTFixedIntegerPartRingEquiv_apply, + splitCardSuppLTFixedIntegerPartRingHom_apply, + splitCardSuppLTIntegerPartRingHom_apply, + coe_leadingCardSuppLTFixedIntegerPartElement] + +/-- In the residue-one branch of LM24, Proposition 9.2.2, bounded source primality is equivalent +to ambient primality of the bounded split truncation, without `(A2)_σ`. -/ +theorem isPrimal_iff_isPrimal_splitTruncationCardSuppLT_of_tau_eq_one + [Fact κ.IsRegular] + (u : HahnEmbedding.ArchimedeanStrata K G) (Z : Subring R) + (b : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) + (hb0 : CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b ≠ 0) + (horder : ((CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b : + Nonpositive G R) : R⟦G⟧).order ≠ 0) + (htau : tauBall (K := K) + (leadingClass (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b) horder) + (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b) = 1) : + IsPrimal b ↔ + IsPrimal (splitTruncationCardSuppLT u + (leadingClass (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b) horder) + (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b) + (CardSuppLTTruncationIntegerPart.cardSupp_toNonpositiveRingHom_lt Z b)) := by + let sigma := leadingClass + (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b) horder + let bFixed := leadingCardSuppLTFixedIntegerPartElement (K := K) Z b horder + let e := splitCardSuppLTFixedIntegerPartRingEquiv (R := R) (κ := κ) u sigma Z + calc + IsPrimal b ↔ IsPrimal bFixed := + (isPrimal_leadingCardSuppLTFixedIntegerPartElement_iff Z b hb0 horder).symm + _ ↔ IsPrimal (e bFixed) := (RingEquiv.isPrimal_iff e bFixed).symm + _ ↔ IsPrimal (splitTruncationCardSuppLTIntegerPart u sigma Z b) := by + rw [show e bFixed = splitTruncationCardSuppLTIntegerPart u sigma Z b by + exact splitCardSuppLTFixedIntegerPartRingEquiv_leadingElement u Z b horder] + _ ↔ IsPrimal (splitTruncationCardSuppLT u sigma + (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b) + (CardSuppLTTruncationIntegerPart.cardSupp_toNonpositiveRingHom_lt Z b)) := + isPrimal_splitTruncationCardSuppLTIntegerPart_iff_of_tau_eq_one + u sigma Z b htau + +/-- In the residue-zero branch of LM24, Proposition 9.2.2, exact assumption `(A2)_σ` supplies the +bounded inner fraction-field equality. -/ +theorem isPrimal_iff_isPrimal_splitTruncationCardSuppLT_of_tau_eq_zero + [Fact κ.IsRegular] + (u : HahnEmbedding.ArchimedeanStrata K G) (Z : Subring R) + (b : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) + (hb0 : CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b ≠ 0) + (horder : ((CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b : + Nonpositive G R) : R⟦G⟧).order ≠ 0) + (hA2 : LM24.AssumptionA2AtFiniteClass (K := K) κ Z + (leadingClass (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b) horder)) + (htau : tauBall (K := K) + (leadingClass (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b) horder) + (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b) = 0) : + IsPrimal b ↔ + IsPrimal (splitTruncationCardSuppLT u + (leadingClass (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b) horder) + (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b) + (CardSuppLTTruncationIntegerPart.cardSupp_toNonpositiveRingHom_lt Z b)) := by + let sigma := leadingClass + (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b) horder + let bFixed := leadingCardSuppLTFixedIntegerPartElement (K := K) Z b horder + let e := splitCardSuppLTFixedIntegerPartRingEquiv (R := R) (κ := κ) u sigma Z + calc + IsPrimal b ↔ IsPrimal bFixed := + (isPrimal_leadingCardSuppLTFixedIntegerPartElement_iff Z b hb0 horder).symm + _ ↔ IsPrimal (e bFixed) := (RingEquiv.isPrimal_iff e bFixed).symm + _ ↔ IsPrimal (splitTruncationCardSuppLTIntegerPart u sigma Z b) := by + rw [show e bFixed = splitTruncationCardSuppLTIntegerPart u sigma Z b by + exact splitCardSuppLTFixedIntegerPartRingEquiv_leadingElement u Z b horder] + _ ↔ IsPrimal (splitTruncationCardSuppLT u sigma + (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b) + (CardSuppLTTruncationIntegerPart.cardSupp_toNonpositiveRingHom_lt Z b)) := + isPrimal_splitTruncationCardSuppLTIntegerPart_iff_of_tau_eq_zero + u sigma Z hA2 b htau + +/-- The set-sized cardinal-bounded core of LM24, Proposition 9.2.2, with `(A2)_σ` required only +when reduction places the leading residue in the zero branch. -/ +@[blueprint "fact:leading-class-primality-transfer" + (phase := "Finitely many Archimedean classes") + (title := "Primality transfer at the leading Archimedean class") + (statement := /-- + Let $\kappa$ be an uncountable regular cardinal, $K$ an Archimedean ordered + division ring, $G$ a linearly ordered abelian group and ordered $K$-module, + $R$ a field, and $Z$ a subring of $R$; choose the Archimedean splitting of + $G$. Let $b\in Z+R((G^{<0}))_\kappa$ be nonzero and reduced, with nonzero + lowest exponent, and set $\sigma=[v(b)]$ and + $L_\sigma=R((G_{\prec\sigma}))_\kappa$. If $(A2)_\sigma$ holds whenever the + coefficient of exponent $0$ in $\iota_\sigma(b)$ is zero, then $b$ is primal + in $Z+R((G^{<0}))_\kappa$ if and only if $\iota_\sigma(b)$ is primal in + $L_\sigma((H_\sigma^{\le 0}))$. This is the set-sized $\kappa$-bounded form + of [LM24, Prop. 9.2.2]. + -/) + (proof := /-- + First restrict to the subring fixed by $T_\sigma$; this does not change the + primality of $b$. The splitting $\iota_\sigma$ identifies that subring with + $S_\sigma+L_\sigma((H_\sigma^{<0}))$. Reducedness says that the + coefficient of exponent $0$ is either $0$ or $1$. In the coefficient-one + branch it is a unit, so the transfer lemma applies directly. In the + coefficient-zero branch, the cofinal alternative in $(A2)_\sigma$ and + \ref{thm:bounded-hahn-integer-part-fraction-field} give + $\operatorname{Frac}(S_\sigma)=L_\sigma$; the degenerate alternative gives + the same equality directly. The transfer lemma therefore applies in both + cases. Transport primality back through the splitting. Regularity makes + the split and unsplit support bounds compatible, while uncountability keeps + quotient supports below $\kappa$. + -/)] +theorem isPrimal_iff_isPrimal_splitTruncationCardSuppLT_of_isReduced_if_A2 + [Fact κ.IsRegular] + (u : HahnEmbedding.ArchimedeanStrata K G) (Z : Subring R) + (b : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) + (hb0 : CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b ≠ 0) + (horder : ((CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b : + Nonpositive G R) : R⟦G⟧).order ≠ 0) + (hbReduced : IsReduced (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b)) + (hA2 : tauBall (K := K) + (leadingClass (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b) horder) + (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b) = 0 → + LM24.AssumptionA2AtFiniteClass (K := K) κ Z + (leadingClass (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b) horder)) : + IsPrimal b ↔ + IsPrimal (splitTruncationCardSuppLT u + (leadingClass (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b) horder) + (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b) + (CardSuppLTTruncationIntegerPart.cardSupp_toNonpositiveRingHom_lt Z b)) := by + rcases (isReduced_iff_tau_leadingClass_eq_zero_or_one (K := K) + (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b) hb0 horder).mp hbReduced with + htau | htau + · have htauBall : tauBall (K := K) + (leadingClass (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b) horder) + (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b) = 0 := + (tauBall_eq_zero_iff _ _).mpr htau + exact isPrimal_iff_isPrimal_splitTruncationCardSuppLT_of_tau_eq_zero + u Z b hb0 horder (hA2 htauBall) htauBall + · have htauBall : tauBall (K := K) + (leadingClass (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b) horder) + (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b) = 1 := + tauBall_eq_one_of_tau_eq_one _ _ htau + exact isPrimal_iff_isPrimal_splitTruncationCardSuppLT_of_tau_eq_one + u Z b hb0 horder htauBall + +/-- The unconditional-`(A2)_σ` specialization of the set-sized, `κ`-bounded form of LM24, +Proposition 9.2.2. -/ +theorem isPrimal_iff_isPrimal_splitTruncationCardSuppLT_of_isReduced + [Fact κ.IsRegular] + (u : HahnEmbedding.ArchimedeanStrata K G) (Z : Subring R) + (b : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) + (hb0 : CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b ≠ 0) + (horder : ((CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b : + Nonpositive G R) : R⟦G⟧).order ≠ 0) + (hbReduced : IsReduced (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b)) + (hA2 : LM24.AssumptionA2AtFiniteClass (K := K) κ Z + (leadingClass (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b) horder)) : + IsPrimal b ↔ + IsPrimal (splitTruncationCardSuppLT u + (leadingClass (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b) horder) + (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b) + (CardSuppLTTruncationIntegerPart.cardSupp_toNonpositiveRingHom_lt Z b)) := + isPrimal_iff_isPrimal_splitTruncationCardSuppLT_of_isReduced_if_A2 + u Z b hb0 horder hbReduced (fun _ ↦ hA2) + +end HahnSeries.Nonpositive diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/CardinalSplitting.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/CardinalSplitting.lean new file mode 100644 index 0000000000..d1ae765920 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/CardinalSplitting.lean @@ -0,0 +1,282 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.SplitTruncation +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.CardinalTruncation +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrderType + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.DomainOrderType +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IterateOrderType + +/-! +# Cardinal bounds under leading-class splitting + +This module proves the forward support bounds needed to restrict LM24's leading-class Hahn +splitting to `κ`-bounded series. Closed-class restriction cannot enlarge support. Flattening the +split series recovers a reindexing of that restriction, so both its outer support and every inner +coefficient support have cardinality no larger than the original support. +-/ + +public noncomputable section + +open Cardinal FiniteArchimedeanClass + +namespace HahnSeries.Nonpositive + +variable {K G R : Type*} +variable [DivisionRing K] [LinearOrder K] [IsOrderedRing K] [Archimedean K] +variable [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] +variable [Module K G] [IsOrderedModule K G] +variable [Field R] + +/-- Restricting the closed-class truncation cannot increase support order type. -/ +theorem supportOrderType_TClosed_le (c : FiniteArchimedeanClass G) + (x : Nonpositive G R) : + (TClosed (K := K) c x).supportOrderType ≤ (x : R⟦G⟧).supportOrderType := by + rw [TClosed_eq] + exact (HahnSeries.supportOrderType_restrictDomain_le (closedBallOrderEmbedding c) + ((T (K := K) c x : Nonpositive G R) : R⟦G⟧)).trans + (HahnSeries.supportOrderType_mono (support_T_subset c x)) + +/-- Closed-class restriction does not increase support cardinality. -/ +theorem cardSupp_TClosed_le (c : FiniteArchimedeanClass G) (x : Nonpositive G R) : + (TClosed (K := K) c x).cardSupp ≤ (x : R⟦G⟧).cardSupp := by + rw [cardSupp, cardSupp] + let f : ↥(TClosed (K := K) c x).support → ↥(x : R⟦G⟧).support := fun g ↦ + ⟨g.1.1, by + rw [mem_support] + have hg := (mem_support _ _).mp g.2 + rw [TClosed_coeff, coeff_T_of_mem c x g.1.2] at hg + exact hg⟩ + apply Cardinal.mk_le_of_injective (f := f) + intro a b h + dsimp only [f] at h + have hv : a.1.1 = b.1.1 := + congrArg (fun z : ↥(x : R⟦G⟧).support ↦ z.1) h + exact Subtype.ext (Subtype.ext hv) + +/-- Flattening the Archimedean split is its ordered reindexing of the closed-ball series. -/ +theorem iterateRingEquiv_archimedeanSplitRingEquiv + (u : HahnEmbedding.ArchimedeanStrata K G) (c : FiniteArchimedeanClass G) + (x : R⟦closedBall K c⟧) : + HahnSeries.iterateRingEquiv (HahnSeries.archimedeanSplitRingEquiv u c x) = + HahnSeries.embDomainRingEquiv + (HahnEmbedding.ArchimedeanStrata.closedBallEquivStratumLexBall u c) x := by + ext p + rw [show p = toLex ((ofLex p).1, (ofLex p).2) by simp] + rw [HahnSeries.iterateRingEquiv_coeff, + HahnSeries.archimedeanSplitRingEquiv_coeff] + let q := HahnEmbedding.ArchimedeanStrata.stratumLexBallEquivClosedBall u c + (toLex ((ofLex p).1, (ofLex p).2)) + let e := HahnEmbedding.ArchimedeanStrata.closedBallEquivStratumLexBall u c + have hp : toLex ((ofLex p).1, (ofLex p).2) = e q := by + simp [q, e] + rw [hp, HahnSeries.embDomainRingEquiv_coeff] + simp [q, e] + +/-- The outer support of an Archimedean split is no larger than the unsplit support. -/ +theorem cardSupp_archimedeanSplitRingEquiv_outer_le + (u : HahnEmbedding.ArchimedeanStrata K G) (c : FiniteArchimedeanClass G) + (x : R⟦closedBall K c⟧) : + (HahnSeries.archimedeanSplitRingEquiv u c x).cardSupp ≤ x.cardSupp := by + calc + _ ≤ (HahnSeries.iterateRingEquiv + (HahnSeries.archimedeanSplitRingEquiv u c x)).cardSupp := + HahnSeries.cardSupp_outer_le_cardSupp_iterateRingEquiv _ + _ = x.cardSupp := by + rw [iterateRingEquiv_archimedeanSplitRingEquiv] + exact HahnSeries.cardSupp_embDomainRingEquiv _ _ + +/-- The split truncation's outer support order type is no larger than the original support order +type. -/ +theorem supportOrderType_splitTruncation_le + (u : HahnEmbedding.ArchimedeanStrata K G) (c : FiniteArchimedeanClass G) + (x : Nonpositive G R) : + ((splitTruncation u c x : Nonpositive (u.stratum c) R⟦ball K c⟧) : + (R⟦ball K c⟧)⟦u.stratum c⟧).supportOrderType ≤ + (x : R⟦G⟧).supportOrderType := by + rw [coe_splitTruncation] + calc + (HahnSeries.archimedeanSplitRingEquiv u c (TClosed c x)).supportOrderType ≤ + (HahnSeries.iterateRingEquiv + (HahnSeries.archimedeanSplitRingEquiv u c (TClosed c x))).supportOrderType := + HahnSeries.supportOrderType_outer_le_iterateRingEquiv _ + _ = (HahnSeries.embDomainRingEquiv + (HahnEmbedding.ArchimedeanStrata.closedBallEquivStratumLexBall u c) + (TClosed c x)).supportOrderType := by + rw [iterateRingEquiv_archimedeanSplitRingEquiv] + _ = (TClosed (K := K) c x).supportOrderType := + HahnSeries.supportOrderType_embDomainRingEquiv _ _ + _ ≤ (x : R⟦G⟧).supportOrderType := supportOrderType_TClosed_le c x + +/-- Leading-class splitting cannot increase LM24 degree. -/ +theorem degree_splitTruncation_le + (u : HahnEmbedding.ArchimedeanStrata K G) (c : FiniteArchimedeanClass G) + (x : Nonpositive G R) : + HahnSeries.degree + ((splitTruncation u c x : Nonpositive (u.stratum c) R⟦ball K c⟧) : + (R⟦ball K c⟧)⟦u.stratum c⟧) ≤ + HahnSeries.degree (x : R⟦G⟧) := by + rw [HahnSeries.degree_eq_cantorDegree, HahnSeries.degree_eq_cantorDegree] + exact Ordinal.cantorDegree_mono (supportOrderType_splitTruncation_le u c x) + +/-- Every inner coefficient support of an Archimedean split is no larger than the unsplit +support. -/ +theorem cardSupp_archimedeanSplitRingEquiv_coeff_le + (u : HahnEmbedding.ArchimedeanStrata K G) (c : FiniteArchimedeanClass G) + (x : R⟦closedBall K c⟧) (s : u.stratum c) : + ((HahnSeries.archimedeanSplitRingEquiv u c x).coeff s).cardSupp ≤ x.cardSupp := by + calc + _ ≤ (HahnSeries.iterateRingEquiv + (HahnSeries.archimedeanSplitRingEquiv u c x)).cardSupp := + HahnSeries.cardSupp_coeff_le_cardSupp_iterateRingEquiv _ s + _ = x.cardSupp := by + rw [iterateRingEquiv_archimedeanSplitRingEquiv] + exact HahnSeries.cardSupp_embDomainRingEquiv _ _ + +/-- The split truncation's outer support is no larger than the original support. -/ +theorem cardSupp_splitTruncation_outer_le + (u : HahnEmbedding.ArchimedeanStrata K G) (c : FiniteArchimedeanClass G) + (x : Nonpositive G R) : + ((splitTruncation u c x : Nonpositive (u.stratum c) R⟦ball K c⟧) : + (R⟦ball K c⟧)⟦u.stratum c⟧).cardSupp ≤ (x : R⟦G⟧).cardSupp := by + rw [coe_splitTruncation] + exact (cardSupp_archimedeanSplitRingEquiv_outer_le u c (TClosed c x)).trans + (cardSupp_TClosed_le c x) + +/-- Every coefficient of the split truncation has support no larger than the original support. -/ +theorem cardSupp_splitTruncation_coeff_le + (u : HahnEmbedding.ArchimedeanStrata K G) (c : FiniteArchimedeanClass G) + (x : Nonpositive G R) (s : u.stratum c) : + ((((splitTruncation u c x : Nonpositive (u.stratum c) R⟦ball K c⟧) : + (R⟦ball K c⟧)⟦u.stratum c⟧).coeff s).cardSupp) ≤ (x : R⟦G⟧).cardSupp := by + rw [coe_splitTruncation] + exact (cardSupp_archimedeanSplitRingEquiv_coeff_le u c (TClosed c x) s).trans + (cardSupp_TClosed_le c x) + +/-- The split truncation with each inner coefficient bundled in the `κ`-bounded Hahn field. -/ +def splitTruncationCardSuppLT {κ : Cardinal} + [Fact (ℵ₀ < κ)] + (u : HahnEmbedding.ArchimedeanStrata K G) (c : FiniteArchimedeanClass G) + (x : Nonpositive G R) (hx : (x : R⟦G⟧).cardSupp < κ) : + Nonpositive (u.stratum c) + (CardSuppLTField (G := ↥(ball K c)) (R := R) (κ := κ)) := by + let y := splitTruncation u c x + let y' : (CardSuppLTField (G := ↥(ball K c)) (R := R) (κ := κ))⟦u.stratum c⟧ := + { coeff := fun s ↦ ⟨(y : (R⟦ball K c⟧)⟦u.stratum c⟧).coeff s, + (cardSupp_splitTruncation_coeff_le u c x s).trans_lt hx⟩ + isPWO_support' := by + have heq : Function.support (fun s ↦ + (⟨(y : (R⟦ball K c⟧)⟦u.stratum c⟧).coeff s, + (cardSupp_splitTruncation_coeff_le u c x s).trans_lt hx⟩ : + CardSuppLTField (G := ↥(ball K c)) (R := R) (κ := κ))) = + (y : (R⟦ball K c⟧)⟦u.stratum c⟧).support := by + ext s + rw [HahnSeries.mem_support] + constructor + · intro h hzero + apply h + apply Subtype.ext + exact hzero + · intro h hzero + apply h + exact congrArg Subtype.val hzero + rw [heq] + exact (y : (R⟦ball K c⟧)⟦u.stratum c⟧).isPWO_support } + exact ⟨y', by + intro s hs + have hs' : s ∈ (y : (R⟦ball K c⟧)⟦u.stratum c⟧).support := by + rw [HahnSeries.mem_support] at hs ⊢ + intro hzero + apply hs + apply Subtype.ext + exact hzero + exact support_subset y hs'⟩ + +/-- Coercing a coefficient of the bounded split truncation recovers the corresponding full +inner Hahn coefficient. -/ +@[simp] +theorem coe_coeff_splitTruncationCardSuppLT {κ : Cardinal} + [Fact (ℵ₀ < κ)] + (u : HahnEmbedding.ArchimedeanStrata K G) (c : FiniteArchimedeanClass G) + (x : Nonpositive G R) (hx : (x : R⟦G⟧).cardSupp < κ) (s : u.stratum c) : + ((((splitTruncationCardSuppLT u c x hx : Nonpositive (u.stratum c) + (CardSuppLTField (G := ↥(ball K c)) (R := R) (κ := κ))) : + (CardSuppLTField (G := ↥(ball K c)) (R := R) (κ := κ))⟦u.stratum c⟧).coeff s : + R⟦ball K c⟧)) = + ((splitTruncation u c x : Nonpositive (u.stratum c) R⟦ball K c⟧) : + (R⟦ball K c⟧)⟦u.stratum c⟧).coeff s := by + rfl + +/-- Bundling the inner coefficients with their cardinal bounds does not change the outer +support. -/ +theorem support_splitTruncationCardSuppLT {κ : Cardinal} + [Fact (ℵ₀ < κ)] + (u : HahnEmbedding.ArchimedeanStrata K G) (c : FiniteArchimedeanClass G) + (x : Nonpositive G R) (hx : (x : R⟦G⟧).cardSupp < κ) : + ((splitTruncationCardSuppLT u c x hx : Nonpositive (u.stratum c) + (CardSuppLTField (G := ↥(ball K c)) (R := R) (κ := κ))) : + (CardSuppLTField (G := ↥(ball K c)) (R := R) (κ := κ))⟦u.stratum c⟧).support = + ((splitTruncation u c x : Nonpositive (u.stratum c) R⟦ball K c⟧) : + (R⟦ball K c⟧)⟦u.stratum c⟧).support := by + ext s + rw [HahnSeries.mem_support, HahnSeries.mem_support] + constructor + · intro hs hs0 + apply hs + apply Subtype.ext + exact hs0 + · intro hs hs0 + apply hs + exact congrArg Subtype.val hs0 + +/-- The bounded split truncation has the same outer support order type as the unrestricted +split. -/ +theorem supportOrderType_splitTruncationCardSuppLT {κ : Cardinal} + [Fact (ℵ₀ < κ)] + (u : HahnEmbedding.ArchimedeanStrata K G) (c : FiniteArchimedeanClass G) + (x : Nonpositive G R) (hx : (x : R⟦G⟧).cardSupp < κ) : + ((splitTruncationCardSuppLT u c x hx : Nonpositive (u.stratum c) + (CardSuppLTField (G := ↥(ball K c)) (R := R) (κ := κ))) : + (CardSuppLTField (G := ↥(ball K c)) (R := R) (κ := κ))⟦u.stratum c⟧).supportOrderType = + ((splitTruncation u c x : Nonpositive (u.stratum c) R⟦ball K c⟧) : + (R⟦ball K c⟧)⟦u.stratum c⟧).supportOrderType := by + rw [HahnSeries.supportOrderType_eq_setOrderType, + HahnSeries.supportOrderType_eq_setOrderType] + exact Set.IsPWO.orderType_congr _ _ + (support_splitTruncationCardSuppLT u c x hx) + +/-- Cardinal-bounded leading-class splitting cannot increase LM24 degree. -/ +theorem degree_splitTruncationCardSuppLT_le {κ : Cardinal} + [Fact (ℵ₀ < κ)] + (u : HahnEmbedding.ArchimedeanStrata K G) (c : FiniteArchimedeanClass G) + (x : Nonpositive G R) (hx : (x : R⟦G⟧).cardSupp < κ) : + HahnSeries.degree + ((splitTruncationCardSuppLT u c x hx : Nonpositive (u.stratum c) + (CardSuppLTField (G := ↥(ball K c)) (R := R) (κ := κ))) : + (CardSuppLTField (G := ↥(ball K c)) (R := R) + (κ := κ))⟦u.stratum c⟧) ≤ + HahnSeries.degree (x : R⟦G⟧) := by + rw [HahnSeries.degree_eq_cantorDegree, HahnSeries.degree_eq_cantorDegree, + supportOrderType_splitTruncationCardSuppLT] + exact Ordinal.cantorDegree_mono (supportOrderType_splitTruncation_le u c x) + +/-- The bounded split truncation's constant coefficient is the bounded open-class +truncation. -/ +theorem coe_constantCoeff_splitTruncationCardSuppLT {κ : Cardinal} + [Fact (ℵ₀ < κ)] + (u : HahnEmbedding.ArchimedeanStrata K G) (c : FiniteArchimedeanClass G) + (x : Nonpositive G R) (hx : (x : R⟦G⟧).cardSupp < κ) : + ((constantCoeff (R := CardSuppLTField (G := ↥(ball K c)) (R := R) (κ := κ)) + (splitTruncationCardSuppLT u c x hx) : + CardSuppLTField (G := ↥(ball K c)) (R := R) (κ := κ)) : R⟦ball K c⟧) = + tauBall c x := by + rw [constantCoeff_apply, coe_coeff_splitTruncationCardSuppLT] + rw [← constantCoeff_apply] + exact constantCoeff_splitTruncation u c x + +end HahnSeries.Nonpositive diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/ClassTruncation.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/ClassTruncation.lean new file mode 100644 index 0000000000..9fe91eb47d --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/ClassTruncation.lean @@ -0,0 +1,269 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Truncation +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Nonpositive +public import Mathlib.Algebra.Order.Module.Archimedean + +/-! +# Truncation by an Archimedean class + +For a finite Archimedean class `c`, LM24, Definition 8.1.1 retains either the closed ball at `c` +or its open ball. On series supported at nonpositive exponents these coefficient restrictions are +ring homomorphisms: if `i, j ≤ 0`, then `i + j` lies in either ball exactly when both `i` and `j` +do. The reverse implication uses the convexity encoded by the Archimedean-class order and fails +for unrestricted Hahn series because opposite exponents can cancel. + +These are LM24's `T_σ` and `τ_σ`, with Mathlib's reversed ordering of Archimedean classes. +-/ + +public noncomputable section + +namespace HahnSeries.Nonpositive + +open FiniteArchimedeanClass + +variable {K G R : Type*} +variable [Ring K] [LinearOrder K] [IsOrderedRing K] [Archimedean K] +variable [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] +variable [Module K G] [IsOrderedModule K G] + +section Ring + +variable [Ring R] + +private theorem add_ne_zero_of_nonpos {i j : G} (hi : i ≤ 0) (hj : j ≤ 0) + (hij : i ≠ 0 ∨ j ≠ 0) : i + j ≠ 0 := by + intro hzero + have hi0 : i = 0 := le_antisymm hi (by + have heq : i = -j := eq_neg_of_add_eq_zero_left hzero + rw [heq] + exact neg_nonneg.mpr hj) + have hj0 : j = 0 := le_antisymm hj (by + have heq : j = -i := eq_neg_of_add_eq_zero_right hzero + rw [heq] + exact neg_nonneg.mpr hi) + exact hij.elim (fun h ↦ h hi0) (fun h ↦ h hj0) + +private theorem mk_add_le_left {i j : G} (hi : i ≤ 0) (hj : j ≤ 0) : + ArchimedeanClass.mk (i + j) ≤ ArchimedeanClass.mk i := by + have hsum : i + j ≤ i := by + have := add_le_add_left hj i + simpa using this + simpa using ArchimedeanClass.min_le_mk_of_le_of_le hsum hi + +private theorem mk_add_le_right {i j : G} (hi : i ≤ 0) (hj : j ≤ 0) : + ArchimedeanClass.mk (i + j) ≤ ArchimedeanClass.mk j := by + rw [add_comm] + exact mk_add_le_left hj hi + +private theorem mem_closedBall_add_iff (c : FiniteArchimedeanClass G) + {i j : G} (hi : i ≤ 0) (hj : j ≤ 0) : + i + j ∈ closedBall K c ↔ i ∈ closedBall K c ∧ j ∈ closedBall K c := by + constructor + · intro hij + constructor + · exact (FiniteArchimedeanClass.mem_closedBall_iff K).mpr fun hi0 ↦ + ((FiniteArchimedeanClass.mem_closedBall_iff K).mp hij + (add_ne_zero_of_nonpos hi hj (Or.inl hi0))).trans (mk_add_le_left hi hj) + · exact (FiniteArchimedeanClass.mem_closedBall_iff K).mpr fun hj0 ↦ + ((FiniteArchimedeanClass.mem_closedBall_iff K).mp hij + (add_ne_zero_of_nonpos hi hj (Or.inr hj0))).trans (mk_add_le_right hi hj) + · exact fun h ↦ add_mem h.1 h.2 + +private theorem mem_ball_add_iff (c : FiniteArchimedeanClass G) + {i j : G} (hi : i ≤ 0) (hj : j ≤ 0) : + i + j ∈ ball K c ↔ i ∈ ball K c ∧ j ∈ ball K c := by + constructor + · intro hij + constructor + · exact (FiniteArchimedeanClass.mem_ball_iff K).mpr fun hi0 ↦ + ((FiniteArchimedeanClass.mem_ball_iff K).mp hij + (add_ne_zero_of_nonpos hi hj (Or.inl hi0))).trans_le (mk_add_le_left hi hj) + · exact (FiniteArchimedeanClass.mem_ball_iff K).mpr fun hj0 ↦ + ((FiniteArchimedeanClass.mem_ball_iff K).mp hij + (add_ne_zero_of_nonpos hi hj (Or.inr hj0))).trans_le (mk_add_le_right hi hj) + · exact fun h ↦ add_mem h.1 h.2 + +private theorem filter_mul (p : G → Prop) [DecidablePred p] + (hpadd : ∀ {i j : G}, i ≤ 0 → j ≤ 0 → (p (i + j) ↔ p i ∧ p j)) + (x y : Nonpositive G R) : + HahnSeries.filter p ((x * y : Nonpositive G R) : R⟦G⟧) = + HahnSeries.filter p (x : R⟦G⟧) * HahnSeries.filter p (y : R⟦G⟧) := by + change HahnSeries.filter p ((x : R⟦G⟧) * (y : R⟦G⟧)) = _ + ext g + rw [HahnSeries.coeff_filter, HahnSeries.coeff_mul, HahnSeries.coeff_mul] + by_cases hg : p g + · rw [ite_eq_left hg] + apply Finset.sum_congr + · ext ij + simp only [Finset.mem_antidiagonal, HahnSeries.support_filter] + constructor + · rintro ⟨hi, hj, hij⟩ + have hp := (hpadd (support_subset x hi) (support_subset y hj)).mp (hij ▸ hg) + exact ⟨⟨hi, hp.1⟩, ⟨hj, hp.2⟩, hij⟩ + · rintro ⟨⟨hi, _⟩, ⟨hj, _⟩, hij⟩ + exact ⟨hi, hj, hij⟩ + · intro ij hij + rw [HahnSeries.coeff_filter, HahnSeries.coeff_filter] + rw [Finset.mem_antidiagonal] at hij + rw [HahnSeries.support_filter, HahnSeries.support_filter] at hij + simp [hij.1.2, hij.2.1.2] + · rw [ite_eq_right hg] + apply (Finset.sum_eq_zero fun ij hij ↦ ?_).symm + rw [Finset.mem_antidiagonal] at hij + rw [HahnSeries.support_filter] at hij + rw [HahnSeries.support_filter] at hij + have hpij := (hpadd (support_subset x hij.1.1) (support_subset y hij.2.1.1)).mpr + ⟨hij.1.2, hij.2.1.2⟩ + rw [hij.2.2] at hpij + exact (hg hpij).elim + +private def classTruncation (p : G → Prop) [DecidablePred p] + (hp0 : p 0) (hpadd : ∀ {i j : G}, i ≤ 0 → j ≤ 0 → (p (i + j) ↔ p i ∧ p j)) : + Nonpositive G R →+* Nonpositive G R where + toFun x := ⟨HahnSeries.filter p (x : R⟦G⟧), + (HahnSeries.support_filter_subset p (x : R⟦G⟧)).trans (support_subset x)⟩ + map_zero' := by ext; simp + map_one' := by ext g; by_cases hg : g = 0 <;> simp [hg, hp0] + map_add' x y := by + apply Subtype.ext + exact HahnSeries.filter_add p (x : R⟦G⟧) (y : R⟦G⟧) + map_mul' x y := by + apply Subtype.ext + exact filter_mul p hpadd x y + +/-- LM24's `T_σ`: retain coefficients whose exponents lie in the closed ball at `c`. -/ +def T (c : FiniteArchimedeanClass G) : Nonpositive G R →+* Nonpositive G R := + by + classical + exact classTruncation (fun g ↦ g ∈ closedBall K c) (zero_mem _) + (fun hi hj ↦ mem_closedBall_add_iff c hi hj) + +/-- LM24's `τ_σ`: retain coefficients whose exponents lie in the open ball at `c`. -/ +def tau (c : FiniteArchimedeanClass G) : Nonpositive G R →+* Nonpositive G R := + by + classical + exact classTruncation (fun g ↦ g ∈ ball K c) (zero_mem _) + (fun hi hj ↦ mem_ball_add_iff c hi hj) + +/-- The finite Archimedean class of the lowest exponent of a series whose lowest exponent is +nonzero. Constant series require the separate zero Archimedean class. -/ +def leadingClass (x : Nonpositive G R) (horder : (x : R⟦G⟧).order ≠ 0) : + FiniteArchimedeanClass G := + FiniteArchimedeanClass.mk (x : R⟦G⟧).order horder + +/-- The underlying Archimedean class of `leadingClass`. -/ +@[simp] +theorem leadingClass_val (x : Nonpositive G R) (horder : (x : R⟦G⟧).order ≠ 0) : + (leadingClass x horder).val = ArchimedeanClass.mk (x : R⟦G⟧).order := + (rfl) + +theorem coeff_T_of_mem (c : FiniteArchimedeanClass G) (x : Nonpositive G R) {g : G} + (hg : g ∈ closedBall K c) : + ((T (K := K) c x : Nonpositive G R) : R⟦G⟧).coeff g = (x : R⟦G⟧).coeff g := by + classical + change (HahnSeries.filter (fun g ↦ g ∈ closedBall K c) (x : R⟦G⟧)).coeff g = _ + rw [HahnSeries.coeff_filter, ite_eq_left hg] + +theorem coeff_T_of_not_mem (c : FiniteArchimedeanClass G) (x : Nonpositive G R) {g : G} + (hg : g ∉ closedBall K c) : + ((T (K := K) c x : Nonpositive G R) : R⟦G⟧).coeff g = 0 := by + classical + change (HahnSeries.filter (fun g ↦ g ∈ closedBall K c) (x : R⟦G⟧)).coeff g = 0 + rw [HahnSeries.coeff_filter, ite_eq_right hg] + +/-- Closed-class truncation cannot introduce a new support exponent. -/ +theorem support_T_subset (c : FiniteArchimedeanClass G) (x : Nonpositive G R) : + ((T (K := K) c x : Nonpositive G R) : R⟦G⟧).support ⊆ (x : R⟦G⟧).support := by + classical + change (HahnSeries.filter (fun g ↦ g ∈ closedBall K c) (x : R⟦G⟧)).support ⊆ _ + exact HahnSeries.support_filter_subset _ _ + +theorem coeff_tau_of_mem (c : FiniteArchimedeanClass G) (x : Nonpositive G R) {g : G} + (hg : g ∈ ball K c) : + ((tau (K := K) c x : Nonpositive G R) : R⟦G⟧).coeff g = (x : R⟦G⟧).coeff g := by + classical + change (HahnSeries.filter (fun g ↦ g ∈ ball K c) (x : R⟦G⟧)).coeff g = _ + rw [HahnSeries.coeff_filter, ite_eq_left hg] + +theorem coeff_tau_of_not_mem (c : FiniteArchimedeanClass G) (x : Nonpositive G R) {g : G} + (hg : g ∉ ball K c) : + ((tau (K := K) c x : Nonpositive G R) : R⟦G⟧).coeff g = 0 := by + classical + change (HahnSeries.filter (fun g ↦ g ∈ ball K c) (x : R⟦G⟧)).coeff g = 0 + rw [HahnSeries.coeff_filter, ite_eq_right hg] + +/-- Closed truncation at the class of the lowest nonzero exponent retains the whole series. -/ +theorem T_leadingClass (x : Nonpositive G R) (horder : (x : R⟦G⟧).order ≠ 0) : + T (K := K) (leadingClass x horder) x = x := by + apply Subtype.ext + ext g + by_cases hcoeff : (x : R⟦G⟧).coeff g = 0 + · by_cases hg : g ∈ closedBall K (leadingClass x horder) + · rw [coeff_T_of_mem _ x hg, hcoeff] + · rw [coeff_T_of_not_mem _ x hg, hcoeff] + · rw [coeff_T_of_mem] + apply (FiniteArchimedeanClass.mem_closedBall_iff K).mpr + intro hg + apply (FiniteArchimedeanClass.mk_le_mk horder hg).mpr + have horderLe : (x : R⟦G⟧).order ≤ g := + HahnSeries.order_le_of_coeff_ne_zero hcoeff + have hgNonpos : g ≤ 0 := support_subset x ((HahnSeries.mem_support _ _).mpr hcoeff) + simpa using ArchimedeanClass.min_le_mk_of_le_of_le horderLe hgNonpos + +/-- Closed-class truncation is idempotent. -/ +@[simp] +theorem T_T (c : FiniteArchimedeanClass G) (x : Nonpositive G R) : + T (K := K) c (T (K := K) c x) = T (K := K) c x := by + apply Subtype.ext + ext g + by_cases hg : g ∈ closedBall K c + · rw [coeff_T_of_mem c (T (K := K) c x) hg] + · rw [coeff_T_of_not_mem c (T (K := K) c x) hg, + coeff_T_of_not_mem c x hg] + +/-- Open-class truncation is idempotent. -/ +@[simp] +theorem tau_tau (c : FiniteArchimedeanClass G) (x : Nonpositive G R) : + tau (K := K) c (tau (K := K) c x) = tau (K := K) c x := by + apply Subtype.ext + ext g + by_cases hg : g ∈ ball K c + · rw [coeff_tau_of_mem c (tau (K := K) c x) hg] + · rw [coeff_tau_of_not_mem c (tau (K := K) c x) hg, + coeff_tau_of_not_mem c x hg] + +/-- Applying the closed cut after the open cut leaves the open cut. -/ +@[simp] +theorem T_tau (c : FiniteArchimedeanClass G) (x : Nonpositive G R) : + T (K := K) c (tau (K := K) c x) = tau (K := K) c x := by + apply Subtype.ext + ext g + by_cases hg : g ∈ closedBall K c + · rw [coeff_T_of_mem c (tau (K := K) c x) hg] + · have hball : g ∉ ball K c := fun h ↦ + hg ((FiniteArchimedeanClass.ball_lt_closedBall (K := K)).le h) + rw [coeff_T_of_not_mem c (tau (K := K) c x) hg, + coeff_tau_of_not_mem c x hball] + +/-- Applying the open cut after the closed cut leaves the open cut. -/ +@[simp] +theorem tau_T (c : FiniteArchimedeanClass G) (x : Nonpositive G R) : + tau (K := K) c (T (K := K) c x) = tau (K := K) c x := by + apply Subtype.ext + ext g + by_cases hg : g ∈ ball K c + · rw [coeff_tau_of_mem c (T (K := K) c x) hg, + coeff_T_of_mem c x ((FiniteArchimedeanClass.ball_lt_closedBall (K := K)).le hg), + coeff_tau_of_mem c x hg] + · rw [coeff_tau_of_not_mem c (T (K := K) c x) hg, + coeff_tau_of_not_mem c x hg] + +end Ring + +end HahnSeries.Nonpositive diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/FiniteClassPrimality.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/FiniteClassPrimality.lean new file mode 100644 index 0000000000..e8cdeeea95 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/FiniteClassPrimality.lean @@ -0,0 +1,283 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.ReducedPrimality +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.CardinalFiniteClassReduction +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.FiniteClassReduction +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.ConvexQuotientSplitting +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.CardinalTruncationDomainEmbedding +public import Mathlib.Data.Set.Card + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.CardinalTruncationResidue +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint + +/-! +# Primality for finite support-class sets + +Under LM24 conditions `(A1)`--`(A3)`, every cardinal-bounded Hahn integer-part series whose +support meets only finitely many Archimedean classes is primal. +-/ + +public noncomputable section + +open Cardinal FiniteArchimedeanClass +open scoped HahnSeries + +namespace HahnSeries.Nonpositive + +variable {K G R : Type*} {κ : Cardinal} +variable [DivisionRing K] [LinearOrder K] [IsOrderedRing K] [Archimedean K] +variable [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] +variable [Module K G] [IsOrderedModule K G] +variable [Field R] [Fact (ℵ₀ < κ)] +variable (Z : Subring R) + +/-- If order-zero elements and reduced elements with nonzero order are primal, every bounded +integer-part element meeting only finitely many Archimedean classes is primal. -/ +theorem isPrimal_of_supportArchimedeanClasses_finite_of_reduced + (u : HahnEmbedding.ArchimedeanStrata K G) + (hzero : ∀ y : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z, + ((CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z y : + Nonpositive G R) : R⟦G⟧).order = 0 → IsPrimal y) + (hreduced : ∀ y : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z, + ((CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z y : + Nonpositive G R) : R⟦G⟧).order ≠ 0 → + IsReduced (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z y) → IsPrimal y) + (x : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) + (hfinite : (supportArchimedeanClasses + (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z x)).Finite) : IsPrimal x := by + let classes := fun y : cardSuppLTTruncationIntegerPart + (G := G) (R := R) (κ := κ) Z ↦ + supportArchimedeanClasses (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z y) + have hind : ∀ n : ℕ, ∀ y : cardSuppLTTruncationIntegerPart + (G := G) (R := R) (κ := κ) Z, + (classes y).ncard = n → (classes y).Finite → IsPrimal y := by + intro n + induction n using Nat.strong_induction_on with + | h n ih => + intro y hn hyFinite + let yN := CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z y + by_cases horder : (yN : R⟦G⟧).order = 0 + · exact hzero y horder + have hyN0 : yN ≠ 0 := by + intro hyzero + apply horder + rw [hyzero, Subring.coe_zero, HahnSeries.order_zero] + let c := leadingClass yN horder + have hT : T (K := K) c yN = yN := T_leadingClass yN horder + by_cases htau : tau (K := K) c yN = 0 + · exact hreduced y horder + ((isReduced_iff_tau_leadingClass_eq_zero_or_one yN hyN0 horder).mpr + (Or.inl htau)) + let r := rhoIntegerPart u c Z y hT htau + let t := tauIntegerPart (K := K) c Z y + have hfac : r * t = y := rhoIntegerPart_mul_tauIntegerPart u c Z y hT htau + have hrReduced : IsReduced + (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z r) := by + rw [toNonpositive_rhoIntegerPart u c Z y hT htau] + exact isReduced_rho_leadingClass_of_tau_ne_zero u yN hyN0 horder htau + have hrPrimal : IsPrimal r := by + by_cases hrOrder : ((CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z r : + Nonpositive G R) : R⟦G⟧).order = 0 + · exact hzero r hrOrder + · exact hreduced r hrOrder hrReduced + have htClasses : classes t = + supportArchimedeanClasses (tau (K := K) c yN) := by + apply congrArg supportArchimedeanClasses + exact toNonpositive_tauIntegerPart c Z y + have htFinite : (classes t).Finite := by + rw [htClasses] + exact hyFinite.subset (supportArchimedeanClasses_tau_subset c yN) + have htCount : (classes t).ncard < n := by + rw [htClasses, ← hn] + exact Set.ncard_lt_ncard + (supportArchimedeanClasses_tau_ssubset yN hyN0 horder) hyFinite + have htPrimal : IsPrimal t := ih (classes t).ncard htCount t rfl htFinite + rw [← hfac] + exact hrPrimal.mul htPrimal + exact hind (classes x).ncard x rfl hfinite + + +/-- The finite-class part of the Hahn integer ring is pre-Schreier under the corresponding +Archimedean hypotheses and the pre-Schreier condition on the coefficient subring. -/ +@[blueprint "thm:finite-support-classes-primality" + (phase := "Finitely many Archimedean classes") + (title := "Primality for finitely many Archimedean support classes") + (statement := /-- + Let $K$ be an Archimedean ordered division ring, $G$ an ordered $K$-vector + space, $R$ a field of characteristic zero, $\kappa>\aleph_0$ a regular + cardinal, and $Z\subseteq R$ a pre-Schreier subring. At every nonzero + Archimedean class $\sigma$, choose an additive complement $H_\sigma$ to + $G_{\prec\sigma}$ in $G_{\preceq\sigma}$ that is order additively + isomorphic to $\mathbb R$. Assume that $G_{\prec\sigma}$ either has + cofinality at least $\kappa$, or is zero and every element of $R$ is a + fraction of elements of $Z$. Every element of + $Z+R((G^{<0}))_\kappa$ whose support meets only finitely many Archimedean + classes is primal. + -/) + (proof := /-- + Induct on the number of Archimedean classes met by the support. At the + leading class, split the series into its reduced factor and its strict + lower-class factor. The reduced factor is primal by + \ref{cor:reduced-hahn-integer-part-primal}; the other factor meets strictly + fewer classes and is primal by induction. A product of primal elements is + primal. + -/)] +theorem isPrimal_of_supportArchimedeanClasses_finite [CharZero R] + [Fact κ.IsRegular] [DecompositionMonoid Z] + (u : HahnEmbedding.ArchimedeanStrata K G) + (hA1 : ∀ c : FiniteArchimedeanClass G, Nonempty (u.stratum c ≃+o ℝ)) + (hA2 : ∀ c : FiniteArchimedeanClass G, + LM24.AssumptionA2AtFiniteClass (K := K) κ Z c) + (x : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) + (hfinite : (supportArchimedeanClasses + (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z x)).Finite) : IsPrimal x := by + apply isPrimal_of_supportArchimedeanClasses_finite_of_reduced Z u + · exact CardSuppLTTruncationIntegerPart.isPrimal_of_order_eq_zero Z + · intro y hyOrder hyReduced + have hy0 : CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z y ≠ 0 := by + intro hyzero + apply hyOrder + rw [hyzero, Subring.coe_zero, HahnSeries.order_zero] + let c := leadingClass (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z y) hyOrder + exact isPrimal_of_isReduced_of_leadingClass_orderIso_real + u Z y hy0 hyOrder hyReduced (hA2 c) + (Classical.choice (hA1 c)) + · exact hfinite + +end HahnSeries.Nonpositive + +namespace HahnSeries.CardSuppLTTruncationIntegerPart + +open Cardinal + +variable {G R : Type*} {κ : Cardinal} +variable [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] +variable [Field R] [Fact (ℵ₀ < κ)] + +/-- Viewing a bounded Hahn integer-part series as nonpositive does not change the +Archimedean classes met by its support. -/ +theorem supportArchimedeanClasses_toNonpositiveRingHom + (Z : Subring R) + (x : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) : + HahnSeries.Nonpositive.supportArchimedeanClasses (toNonpositiveRingHom Z x) = + ArchimedeanClass.mk '' (x : HahnSeries G R).support := by + ext c + rw [HahnSeries.Nonpositive.mem_supportArchimedeanClasses] + constructor + · rintro ⟨g, hg, rfl⟩ + exact ⟨g, by simpa only [coe_toNonpositiveRingHom] using hg, rfl⟩ + · rintro ⟨g, hg, rfl⟩ + exact ⟨g, by simpa only [coe_toNonpositiveRingHom] using hg, rfl⟩ + +/-- Finite-class primality in an ambient exponent group descends to every convex exponent +subgroup. -/ +private theorem isPrimal_addSubgroup_of_ambient_finiteClasses + (Z : Subring R) + (hfinite : ∀ x : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z, + (ArchimedeanClass.mk '' (x : HahnSeries G R).support).Finite → IsPrimal x) + (P : AddSubgroup G) (hP : (P : Set G).OrdConnected) + (a : cardSuppLTTruncationIntegerPart (G := P) (R := R) (κ := κ) Z) + (ha : (ArchimedeanClass.mk '' (a : HahnSeries P R).support).Finite) : IsPrimal a := by + let inc : P →+ G := P.subtype + have hinci : Function.Injective inc := Subtype.val_injective + have hinco : ∀ x y : P, inc x ≤ inc y ↔ x ≤ y := fun _ _ ↦ Iff.rfl + let A := mapDomain inc hinci hinco Z a + have hAfinite : (ArchimedeanClass.mk '' (A : HahnSeries G R).support).Finite := by + have hsupport : (A : HahnSeries G R).support = inc '' (a : HahnSeries P R).support := by + rw [coe_mapDomain] + exact HahnSeries.support_embDomain _ _ + rw [hsupport] + let e : P →+o G := + { toFun := inc + map_zero' := map_zero inc + map_add' := map_add inc + monotone' := fun _ _ h ↦ h } + let ac : ArchimedeanClass P → ArchimedeanClass G := ArchimedeanClass.orderHom e + have heq : ArchimedeanClass.mk '' (inc '' (a : HahnSeries P R).support) = + ac '' (ArchimedeanClass.mk '' (a : HahnSeries P R).support) := by + ext c + constructor + · rintro ⟨_, ⟨p, hp, rfl⟩, rfl⟩ + exact ⟨ArchimedeanClass.mk p, ⟨p, hp, rfl⟩, + ArchimedeanClass.orderHom_mk e p⟩ + · rintro ⟨_, ⟨p, hp, rfl⟩, rfl⟩ + exact ⟨inc p, ⟨p, hp, rfl⟩, (ArchimedeanClass.orderHom_mk e p).symm⟩ + rw [heq] + exact ha.image ac + apply isPrimal_of_isPrimal_mapDomain inc hinci hinco Z + · have hrange : Set.range inc = (P : Set G) := by + ext x + constructor + · rintro ⟨p, rfl⟩ + exact p.2 + · exact fun hx ↦ ⟨⟨x, hx⟩, rfl⟩ + rw [hrange] + exact hP + exact hfinite A hAfinite + +/-- The common-tail coefficient of a series is primal when its remaining support classes form +a finite block and finite-class primality is known in the ambient exponent group. -/ +theorem isPrimal_restrictDomain_tailSubmodule_of_ambient_finiteClasses + [Module ℚ G] [PosSMulMono ℚ G] + (Z : Subring R) + (hfinite : ∀ y : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z, + (ArchimedeanClass.mk '' (y : HahnSeries G R).support).Finite → IsPrimal y) + (T₀ T₁ : Set (ArchimedeanClass G)) + (hT₀gt : ∀ a ∈ T₀, ∃ b ∈ T₀, a < b) (hT₁ : T₁.Finite) + (x : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) + (hxclasses : ArchimedeanClass.mk '' (x : HahnSeries G R).support ⊆ T₀ ∪ T₁) : + let P := FiniteArchimedeanClass.tailSubmodule ℚ + {c : FiniteArchimedeanClass G | c.1 ∈ T₀} + IsPrimal (restrictDomain P.toAddSubgroup.subtype P.toAddSubgroup.subtype_injective + (fun _ _ ↦ ⟨fun h ↦ h, fun h ↦ h⟩) Z x) := by + let P := FiniteArchimedeanClass.tailSubmodule ℚ + {c : FiniteArchimedeanClass G | c.1 ∈ T₀} + apply isPrimal_addSubgroup_of_ambient_finiteClasses Z hfinite P.toAddSubgroup + (inferInstance : P.toAddSubgroup.IsConvex).ordConnected + have hfinite' := + HahnSeries.supportArchimedeanClasses_coeff_zero_convexQuotientSplitRingEquiv_finite + (K := ℚ) T₀ T₁ hT₀gt hT₁ (x : HahnSeries G R) hxclasses + rw [HahnSeries.coeff_zero_convexQuotientSplitRingEquiv] at hfinite' + have hre : ((restrictDomain P.toAddSubgroup.subtype P.toAddSubgroup.subtype_injective + (fun _ _ ↦ ⟨fun h ↦ h, fun h ↦ h⟩) Z x : + cardSuppLTTruncationIntegerPart (G := P) (R := R) (κ := κ) Z) : HahnSeries P R) = + HahnSeries.restrictDomain (HahnSeries.submoduleOrderEmbedding P) + (x : HahnSeries G R) := by + ext p + rw [coe_restrictDomain, HahnSeries.restrictDomain_coeff, + HahnSeries.restrictDomain_coeff] + congr 1 + exact HahnSeries.submoduleOrderEmbedding_apply P p |>.symm + rw [hre] + exact hfinite' + +/-- The constant coefficient after regrouping along the common tail is primal when finite-class +primality holds in the ambient exponent group. -/ +theorem isPrimal_coeff_zero_convexQuotientSplitRingEquiv_of_ambient_finiteClasses + [Module ℚ G] [PosSMulMono ℚ G] [Fact κ.IsRegular] + (Z : Subring R) + (hfinite : ∀ y : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z, + (ArchimedeanClass.mk '' (y : HahnSeries G R).support).Finite → IsPrimal y) + (T₀ T₁ : Set (ArchimedeanClass G)) + (hT₀gt : ∀ a ∈ T₀, ∃ b ∈ T₀, a < b) (hT₁ : T₁.Finite) + (x : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) + (hxclasses : ArchimedeanClass.mk '' (x : HahnSeries G R).support ⊆ T₀ ∪ T₁) : + let T : Set (FiniteArchimedeanClass G) := {c | c.1 ∈ T₀} + let P := FiniteArchimedeanClass.tailSubmodule ℚ T + let S := cardSuppLTTruncationIntegerPart (G := P) (R := R) (κ := κ) Z + let E := cardSuppLTTruncationIntegerPartConvexQuotientSplitRingEquiv + (R := R) (κ := κ) P Z + IsPrimal (⟨(E x : (CardSuppLTField (G := P) (R := R) (κ := κ))⟦ + G ⧸ P⟧).coeff 0, + ((mem_cardSuppLTTruncationIntegerPart (Z := S)).mp (E x).2).2⟩ : S) := by + dsimp only + rw [CardSuppLTTruncationIntegerPart.coeff_zero_convexQuotientSplitRingEquiv] + exact isPrimal_restrictDomain_tailSubmodule_of_ambient_finiteClasses + Z hfinite T₀ T₁ hT₀gt hT₁ x hxclasses + +end HahnSeries.CardSuppLTTruncationIntegerPart diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/FiniteClassReduction.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/FiniteClassReduction.lean new file mode 100644 index 0000000000..8d91792e73 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/FiniteClassReduction.lean @@ -0,0 +1,218 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.ReducedCharacterization +public import Mathlib.Data.Set.Finite.Basic + +/-! +# Removing the leading support class + +The finite-product calculation preceding LM24, Definition 8.4.2 repeatedly separates the leading +reduction from the open truncation. The open truncation has a strictly smaller set of support +classes. In the nonzero-truncation case the reduction has closed truncation equal to itself and +open truncation equal to one, so it is reduced in the sense of LM24, Definition 8.2.6. + +Support classes include the zero class `⊤`. Mathlib orders Archimedean classes oppositely to LM24; +the open truncation at the leading class therefore retains the strictly greater Mathlib classes. +-/ + +public noncomputable section + +open FiniteArchimedeanClass +open scoped HahnSeries + +namespace HahnSeries.Nonpositive + +variable {K G R : Type*} +variable [DivisionRing K] [LinearOrder K] [IsOrderedRing K] [Archimedean K] +variable [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] +variable [Module K G] [IsOrderedModule K G] + +section Ring + +variable [Ring R] + +/-- The Archimedean classes met by the support, including the zero class when zero is in the +support. This is a set of classes, not a set of exponents. -/ +def supportArchimedeanClasses (x : Nonpositive G R) : Set (ArchimedeanClass G) := + ArchimedeanClass.mk '' (x : R⟦G⟧).support + +/-- A class meets the support exactly when it contains an exponent with nonzero coefficient. -/ +theorem mem_supportArchimedeanClasses (x : Nonpositive G R) (c : ArchimedeanClass G) : + c ∈ supportArchimedeanClasses x ↔ + ∃ g ∈ (x : R⟦G⟧).support, ArchimedeanClass.mk g = c := + (Iff.rfl) + +/-- The zero series meets no Archimedean class. -/ +@[simp] +theorem supportArchimedeanClasses_zero : + supportArchimedeanClasses (0 : Nonpositive G R) = ∅ := by + ext c + simp [mem_supportArchimedeanClasses] + +/-- Open-class truncation cannot introduce a support class. -/ +theorem supportArchimedeanClasses_tau_subset (c : FiniteArchimedeanClass G) + (x : Nonpositive G R) : + supportArchimedeanClasses (tau (K := K) c x) ⊆ supportArchimedeanClasses x := by + rintro _ ⟨g, hg, rfl⟩ + refine ⟨g, ?_, rfl⟩ + by_cases hball : g ∈ ball K c + · rw [HahnSeries.mem_support, coeff_tau_of_mem c x hball] at hg + exact hg + · rw [HahnSeries.mem_support, coeff_tau_of_not_mem c x hball] at hg + exact (hg rfl).elim + +/-- A nonzero series meets its leading Archimedean class. -/ +theorem leadingClass_mem_supportArchimedeanClasses (x : Nonpositive G R) (hx : x ≠ 0) + (horder : (x : R⟦G⟧).order ≠ 0) : + (leadingClass x horder).val ∈ supportArchimedeanClasses x := by + refine ⟨(x : R⟦G⟧).order, ?_, (leadingClass_val x horder).symm⟩ + exact (HahnSeries.mem_support _ _).mpr + (HahnSeries.coeff_order_eq_zero.not.mpr fun h ↦ hx (Subtype.ext h)) + +/-- Open truncation at the leading class removes that class from the support. -/ +theorem leadingClass_not_mem_supportArchimedeanClasses_tau (x : Nonpositive G R) + (horder : (x : R⟦G⟧).order ≠ 0) : + (leadingClass x horder).val ∉ + supportArchimedeanClasses (tau (K := K) (leadingClass x horder) x) := by + rintro ⟨g, hg, hclass⟩ + have hgCoeff : + ((tau (K := K) (leadingClass x horder) x : Nonpositive G R) : R⟦G⟧).coeff g ≠ 0 := + (HahnSeries.mem_support _ _).mp hg + have hgBall : g ∈ ball K (leadingClass x horder) := by + by_contra hnot + exact hgCoeff (coeff_tau_of_not_mem (K := K) (leadingClass x horder) x hnot) + have hg0 : g ≠ 0 := by + intro hgzero + subst g + exact (leadingClass x horder).prop hclass.symm + have hlt := (FiniteArchimedeanClass.mem_ball_iff K).mp hgBall hg0 + exact (ne_of_lt hlt) (Subtype.ext hclass.symm) + +/-- The open truncation at a nonconstant series' leading class has strictly fewer support +classes, in the sense of strict set inclusion. -/ +theorem supportArchimedeanClasses_tau_ssubset (x : Nonpositive G R) (hx : x ≠ 0) + (horder : (x : R⟦G⟧).order ≠ 0) : + supportArchimedeanClasses (tau (K := K) (leadingClass x horder) x) ⊂ + supportArchimedeanClasses x := by + refine Set.ssubset_iff_subset_ne.mpr + ⟨supportArchimedeanClasses_tau_subset (leadingClass x horder) x, ?_⟩ + intro heq + exact leadingClass_not_mem_supportArchimedeanClasses_tau x horder + (heq ▸ leadingClass_mem_supportArchimedeanClasses x hx horder) + +/-- A nonzero series contained in a closed class ball with open truncation one is reduced. -/ +theorem isReduced_of_T_eq_self_of_tau_eq_one (c : FiniteArchimedeanClass G) + (x : Nonpositive G R) (hx : x ≠ 0) (hT : T (K := K) c x = x) + (htau : tau (K := K) c x = 1) : IsReduced x := by + refine isReduced_of_support_inter_support_sub_one_subset hx c.val ?_ + rintro g ⟨hg, hgSub⟩ + have hg0 : g ≠ 0 := by + intro hzero + subst g + have hcoeff := congrArg (fun y : Nonpositive G R ↦ (y : R⟦G⟧).coeff 0) htau + rw [coeff_tau_of_mem (K := K) c x (zero_mem _)] at hcoeff + have hsubCoeff := (HahnSeries.mem_support _ _).mp hgSub + change (((x : R⟦G⟧) - 1).coeff 0) ≠ 0 at hsubCoeff + rw [HahnSeries.coeff_sub, HahnSeries.coeff_one, hcoeff] at hsubCoeff + simp at hsubCoeff + have hgClosed : g ∈ closedBall K c := by + by_contra hnot + have hcoeff := (HahnSeries.mem_support _ _).mp hg + rw [← hT, coeff_T_of_not_mem (K := K) c x hnot] at hcoeff + exact hcoeff rfl + have hgNotBall : g ∉ ball K c := by + intro hball + have hcoeff := congrArg (fun y : Nonpositive G R ↦ (y : R⟦G⟧).coeff g) htau + rw [coeff_tau_of_mem (K := K) c x hball] at hcoeff + change (x : R⟦G⟧).coeff g = (1 : R⟦G⟧).coeff g at hcoeff + rw [HahnSeries.coeff_one, ite_eq_right hg0] at hcoeff + exact (HahnSeries.mem_support _ _).mp hg hcoeff + have hle := (FiniteArchimedeanClass.mem_closedBall_iff K).mp hgClosed hg0 + have hnlt : ¬ c < FiniteArchimedeanClass.mk g hg0 := fun hlt ↦ + hgNotBall ((FiniteArchimedeanClass.mem_ball_iff K).mpr fun _ ↦ hlt) + exact congrArg Subtype.val (le_antisymm (not_lt.mp hnlt) hle) + +/-- A reduced series meets at most its reduced class and the zero class, hence finitely many +Archimedean classes even when its support is infinite. -/ +theorem IsReduced.supportArchimedeanClasses_finite {x : Nonpositive G R} (hx : IsReduced x) : + (supportArchimedeanClasses x).Finite := by + obtain ⟨_, c, hc⟩ := hx.elim + apply ((Set.finite_singleton c).insert ⊤).subset + rintro _ ⟨g, hg, rfl⟩ + simp only [Set.mem_insert_iff, Set.mem_singleton_iff] + by_cases hg0 : g = 0 + · left + rw [hg0, ArchimedeanClass.mk_zero] + · right + apply hc + refine ⟨hg, ?_⟩ + rw [HahnSeries.mem_support] + change ((x : R⟦G⟧) - 1).coeff g ≠ 0 + rw [HahnSeries.coeff_sub, HahnSeries.coeff_one, ite_eq_right hg0, sub_zero] + exact (HahnSeries.mem_support _ _).mp hg + +end Ring + +section Field + +variable [Field R] + +/-- A reduction with nonzero open truncation is fixed by the closed truncation. -/ +theorem T_rho_of_tau_ne_zero (u : HahnEmbedding.ArchimedeanStrata K G) + (c : FiniteArchimedeanClass G) (x : Nonpositive G R) + (htau : tau (K := K) c x ≠ 0) : + T (K := K) c (rho u c x) = rho u c x := by + apply mul_right_cancel₀ htau + calc + T (K := K) c (rho u c x) * tau (K := K) c x = + T (K := K) c (rho u c x) * T (K := K) c (tau (K := K) c x) := by rw [T_tau] + _ = T (K := K) c (rho u c x * tau (K := K) c x) := (map_mul _ _ _).symm + _ = T (K := K) c (T (K := K) c x) := by + rw [rho_of_tau_ne_zero u c x htau, reductionQuotient_mul_tau] + _ = T (K := K) c x := T_T c x + _ = rho u c x * tau (K := K) c x := by + rw [rho_of_tau_ne_zero u c x htau, reductionQuotient_mul_tau] + +/-- A reduction with nonzero open truncation has open truncation one. -/ +theorem tau_rho_of_tau_ne_zero (u : HahnEmbedding.ArchimedeanStrata K G) + (c : FiniteArchimedeanClass G) (x : Nonpositive G R) + (htau : tau (K := K) c x ≠ 0) : + tau (K := K) c (rho u c x) = 1 := by + apply mul_right_cancel₀ htau + calc + tau (K := K) c (rho u c x) * tau (K := K) c x = + tau (K := K) c (rho u c x * tau (K := K) c x) := by + simpa only [tau_tau] using + ((tau (K := K) c).map_mul (rho u c x) (tau (K := K) c x)).symm + _ = tau (K := K) c (T (K := K) c x) := by + rw [rho_of_tau_ne_zero u c x htau, reductionQuotient_mul_tau] + _ = tau (K := K) c x := tau_T c x + _ = 1 * tau (K := K) c x := (one_mul _).symm + +/-- The leading reduction of a nonzero, nonconstant series is reduced when the open truncation +is nonzero, as in LM24, Proposition 8.2.5. -/ +theorem isReduced_rho_leadingClass_of_tau_ne_zero + (u : HahnEmbedding.ArchimedeanStrata K G) (x : Nonpositive G R) (hx : x ≠ 0) + (horder : (x : R⟦G⟧).order ≠ 0) + (htau : tau (K := K) (leadingClass x horder) x ≠ 0) : + IsReduced (rho u (leadingClass x horder) x) := by + have hrho0 : rho u (leadingClass x horder) x ≠ 0 := by + intro hrho + have hfac := reductionQuotient_mul_tau u (leadingClass x horder) x + (fun hzero ↦ htau ((tauBall_eq_zero_iff (leadingClass x horder) x).mp hzero)) + rw [← rho_of_tau_ne_zero u (leadingClass x horder) x htau, + hrho, zero_mul, T_leadingClass] at hfac + exact hx hfac.symm + exact isReduced_of_T_eq_self_of_tau_eq_one (leadingClass x horder) + (rho u (leadingClass x horder) x) hrho0 + (T_rho_of_tau_ne_zero u (leadingClass x horder) x htau) + (tau_rho_of_tau_ne_zero u (leadingClass x horder) x htau) + +end Field + +end HahnSeries.Nonpositive diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/IntegerPartSplitting.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/IntegerPartSplitting.lean new file mode 100644 index 0000000000..5afc1c472a --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/IntegerPartSplitting.lean @@ -0,0 +1,340 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.SplitTruncation +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.TruncationPrimality + +/-! +# Splitting a leading-class Hahn-series integer part + +This module formalizes LM24, Fact 2.4.2(5). The elements of the truncation integer part fixed by +the closed-class cut are identified with an outer truncation integer part whose coefficient +subring is the embedded inner truncation integer part. Keeping that exact coefficient subring is +essential: replacing it by the whole inner Hahn field loses the source integer-part condition. +-/ + +open FiniteArchimedeanClass + +public noncomputable section + +namespace HahnSeries.Nonpositive + +variable {K G R : Type*} +variable [DivisionRing K] [LinearOrder K] [IsOrderedRing K] [Archimedean K] +variable [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] +variable [Module K G] [IsOrderedModule K G] +variable [Field R] + +/-- The subring of the truncation integer part fixed by truncation at the chosen closed class. -/ +def fixedIntegerPartSubring (c : FiniteArchimedeanClass G) (Z : Subring R) : + Subring (truncationIntegerPart G Z) := + (truncationSubring (K := K) (R := R) c).comap + (truncationIntegerPart G Z).subtype + +/-- Membership in the fixed integer-part subring is exactly invariance under closed-class +truncation of the underlying nonpositive Hahn series. -/ +theorem mem_fixedIntegerPartSubring_iff (c : FiniteArchimedeanClass G) (Z : Subring R) + (x : truncationIntegerPart G Z) : + x ∈ fixedIntegerPartSubring (K := K) (G := G) (R := R) c Z ↔ + T (K := K) c (x : Nonpositive G R) = x := by + change (x : Nonpositive G R) ∈ truncationSubring (K := K) (R := R) c ↔ _ + exact mem_truncationSubring_iff c (x : Nonpositive G R) + +theorem coeff_zero_tauBall (c : FiniteArchimedeanClass G) (x : Nonpositive G R) : + (tauBall (K := K) c x).coeff 0 = (x : R⟦G⟧).coeff 0 := by + rw [tauBall_coeff] + exact coeff_tau_of_mem c x (Submodule.zero_mem _) + +/-- The inner truncation integer part embedded in the Hahn-series ring on the class ball. -/ +def innerIntegerPartSubring (c : FiniteArchimedeanClass G) (Z : Subring R) : + Subring R⟦ball K c⟧ := + (truncationIntegerPart (ball K c) Z).map + (nonpositiveSubring (ball K c) R).subtype + +/-- Membership in the embedded inner integer part means nonpositive support and constant +coefficient in `Z`. -/ +theorem mem_innerIntegerPartSubring_iff (c : FiniteArchimedeanClass G) (Z : Subring R) + (x : R⟦ball K c⟧) : + x ∈ innerIntegerPartSubring (K := K) (G := G) c Z ↔ + x.support ⊆ Set.Iic 0 ∧ x.coeff 0 ∈ Z := by + constructor + · intro hx + obtain ⟨y, hy, hxy⟩ := Subring.mem_map.mp hx + rw [← hxy] + exact ⟨support_subset y, (mem_truncationIntegerPart (R := R) (Γ := ball K c)).mp hy⟩ + · rintro ⟨hsupport, hcoeff⟩ + let y : Nonpositive (ball K c) R := ⟨x, hsupport⟩ + apply Subring.mem_map.mpr + exact ⟨y, (mem_truncationIntegerPart (R := R) (Γ := ball K c)).mpr hcoeff, rfl⟩ + +theorem tauBall_mem_innerIntegerPartSubring + (c : FiniteArchimedeanClass G) (Z : Subring R) + (x : truncationIntegerPart G Z) : + tauBall (K := K) c (x : Nonpositive G R) ∈ innerIntegerPartSubring c Z := by + apply Subring.mem_map.mpr + let y : Nonpositive (ball K c) R := ⟨tauBall c x, ?_⟩ + · refine ⟨y, ?_, rfl⟩ + rw [mem_truncationIntegerPart] + rw [show (y : R⟦ball K c⟧).coeff 0 = (tauBall c x).coeff 0 by rfl] + rw [coeff_zero_tauBall] + exact (mem_truncationIntegerPart (Γ := G) (R := R)).mp x.2 + · intro b hb + rw [HahnSeries.mem_support] at hb + rw [tauBall_coeff] at hb + change (HahnSeries.coeff + (((tau (K := K) c (x : Nonpositive G R) : Nonpositive G R) : R⟦G⟧)) + (b : G) ≠ 0) at hb + rw [coeff_tau_of_mem c (x : Nonpositive G R) b.2] at hb + exact Subtype.coe_le_coe.mp (support_subset (x : Nonpositive G R) hb) + +/-- Truncate at a closed Archimedean class and split its exponents into stratum and ball +coordinates. -/ +def splitRawRingHom + (u : HahnEmbedding.ArchimedeanStrata K G) (c : FiniteArchimedeanClass G) + : Nonpositive G R →+* (R⟦ball K c⟧)⟦u.stratum c⟧ := + (HahnSeries.archimedeanSplitRingEquiv u c).toRingHom.comp (TClosedRingHom c) + +@[simp] +theorem splitRawRingHom_apply + (u : HahnEmbedding.ArchimedeanStrata K G) (c : FiniteArchimedeanClass G) + (x : Nonpositive G R) : + splitRawRingHom u c x = HahnSeries.archimedeanSplitRingEquiv u c (TClosed c x) := by + rw [splitRawRingHom, RingHom.comp_apply, RingEquiv.toRingHom_eq_coe, + TClosedRingHom_apply] + rfl + +/-- Split the truncation integer part into outer stratum series whose constant term lies in the +inner integer part. -/ +def splitIntegerPartRingHom + (u : HahnEmbedding.ArchimedeanStrata K G) (c : FiniteArchimedeanClass G) + (Z : Subring R) : truncationIntegerPart G Z →+* + truncationIntegerPart (u.stratum c) + (innerIntegerPartSubring (K := K) (G := G) c Z) where + toFun x := ⟨⟨splitRawRingHom u c (x : Nonpositive G R), by + rw [splitRawRingHom_apply] + exact support_archimedeanSplitRingEquiv_TClosed_subset u c + (x : Nonpositive G R)⟩, by + rw [mem_truncationIntegerPart] + change (splitRawRingHom u c (x : Nonpositive G R)).coeff 0 ∈ + innerIntegerPartSubring (K := K) (G := G) c Z + rw [splitRawRingHom_apply, coeff_zero_archimedeanSplitRingEquiv_TClosed] + exact tauBall_mem_innerIntegerPartSubring c Z x⟩ + map_one' := by + apply Subtype.ext + apply Subtype.ext + exact map_one (splitRawRingHom u c) + map_mul' x y := by + apply Subtype.ext + apply Subtype.ext + exact map_mul (splitRawRingHom u c) (x : Nonpositive G R) y + map_zero' := by + apply Subtype.ext + apply Subtype.ext + exact map_zero (splitRawRingHom u c) + map_add' x y := by + apply Subtype.ext + apply Subtype.ext + exact map_add (splitRawRingHom u c) (x : Nonpositive G R) y + +/-- The integer-part split has the underlying nonpositive split truncation. -/ +@[simp] +theorem coe_splitIntegerPartRingHom + (u : HahnEmbedding.ArchimedeanStrata K G) (c : FiniteArchimedeanClass G) + (Z : Subring R) (x : truncationIntegerPart G Z) : + ((splitIntegerPartRingHom u c Z x : + truncationIntegerPart (u.stratum c) (innerIntegerPartSubring c Z)) : + Nonpositive (u.stratum c) R⟦ball K c⟧) = + splitTruncation u c (x : Nonpositive G R) := by + apply Subtype.ext + rw [coe_splitTruncation] + change splitRawRingHom u c (x : Nonpositive G R) = _ + rw [splitRawRingHom_apply] + +/-- The splitting homomorphism restricted to the integer-part subring fixed by closed-class +truncation. -/ +def splitFixedIntegerPartRingHom + (u : HahnEmbedding.ArchimedeanStrata K G) (c : FiniteArchimedeanClass G) + (Z : Subring R) : + fixedIntegerPartSubring (K := K) (G := G) (R := R) c Z →+* + truncationIntegerPart (u.stratum c) + (innerIntegerPartSubring (K := K) (G := G) c Z) := + (splitIntegerPartRingHom u c Z).comp + (fixedIntegerPartSubring (K := K) (G := G) (R := R) c Z).subtype + +@[simp] +theorem coe_splitFixedIntegerPartRingHom + (u : HahnEmbedding.ArchimedeanStrata K G) (c : FiniteArchimedeanClass G) + (Z : Subring R) (x : fixedIntegerPartSubring (K := K) (G := G) (R := R) c Z) : + ((splitFixedIntegerPartRingHom u c Z x : + truncationIntegerPart (u.stratum c) (innerIntegerPartSubring c Z)) : + Nonpositive (u.stratum c) R⟦ball K c⟧) = + splitTruncation u c (x : Nonpositive G R) := + by + apply Subtype.ext + rw [coe_splitTruncation] + change (splitRawRingHom u c (x : Nonpositive G R)) = _ + rw [splitRawRingHom_apply] + +/-- Reassemble an outer stratum series with an inner integer-part constant term into a fixed +integer-part element. -/ +def unsplitIntegerPart + (u : HahnEmbedding.ArchimedeanStrata K G) (c : FiniteArchimedeanClass G) + (Z : Subring R) + (y : truncationIntegerPart (u.stratum c) + (innerIntegerPartSubring (K := K) (G := G) c Z)) : + fixedIntegerPartSubring (K := K) (G := G) (R := R) c Z := by + let yOuter : Nonpositive (u.stratum c) R⟦ball K c⟧ := y + have hyZeroInner : (((yOuter : (R⟦ball K c⟧)⟦u.stratum c⟧).coeff 0).support ⊆ + Set.Iic 0) := by + have hyMem : (yOuter : (R⟦ball K c⟧)⟦u.stratum c⟧).coeff 0 ∈ + innerIntegerPartSubring (K := K) (G := G) c Z := + (mem_truncationIntegerPart (Γ := u.stratum c) (R := R⟦ball K c⟧)).mp y.2 + obtain ⟨z, hz, hzy⟩ := Subring.mem_map.mp hyMem + rw [← hzy] + exact support_subset z + let zClosed := (HahnSeries.archimedeanSplitRingEquiv u c).symm + (yOuter : (R⟦ball K c⟧)⟦u.stratum c⟧) + let z : Nonpositive G R := + ⟨HahnSeries.embDomain (closedBallOrderEmbedding (K := K) c) zClosed, by + rw [mem_nonpositiveSubring] + rw [HahnSeries.support_embDomain] + rintro _ ⟨g, hg, rfl⟩ + rw [closedBallOrderEmbedding_apply] + exact Subtype.coe_le_coe.mpr + (support_archimedeanSplitRingEquiv_symm_subset_Iic u c + (yOuter : (R⟦ball K c⟧)⟦u.stratum c⟧) + (support_subset yOuter) hyZeroInner hg)⟩ + have hzeroEmbedding : closedBallOrderEmbedding (K := K) c (0 : closedBall K c) = 0 := by + rw [closedBallOrderEmbedding_apply] + rfl + have hzCoeff : (z : R⟦G⟧).coeff 0 ∈ Z := by + have hyMem : (yOuter : (R⟦ball K c⟧)⟦u.stratum c⟧).coeff 0 ∈ + innerIntegerPartSubring (K := K) (G := G) c Z := + (mem_truncationIntegerPart (Γ := u.stratum c) (R := R⟦ball K c⟧)).mp y.2 + obtain ⟨w, hw, hwy⟩ := Subring.mem_map.mp hyMem + rw [mem_truncationIntegerPart] at hw + change (HahnSeries.embDomain (closedBallOrderEmbedding (K := K) c) zClosed).coeff 0 ∈ Z + rw [← hzeroEmbedding] + rw [HahnSeries.embDomain_coeff] + have hcoeff := congrArg (fun q : (R⟦ball K c⟧)⟦u.stratum c⟧ ↦ + (q.coeff 0).coeff 0) + ((HahnSeries.archimedeanSplitRingEquiv u c).apply_symm_apply (yOuter : _)) + rw [HahnSeries.archimedeanSplitRingEquiv_coeff] at hcoeff + rw [show HahnEmbedding.ArchimedeanStrata.stratumLexBallEquivClosedBall u c + (toLex (0, 0)) = 0 by simp] at hcoeff + change ((HahnSeries.archimedeanSplitRingEquiv u c).symm + (yOuter : (R⟦ball K c⟧)⟦u.stratum c⟧)).coeff 0 ∈ Z + rw [hcoeff, ← hwy] + exact hw + refine ⟨⟨z, (mem_truncationIntegerPart (Γ := G) (R := R)).mpr hzCoeff⟩, ?_⟩ + apply (mem_truncationSubring_iff c z).mpr + apply Subtype.ext + ext g + by_cases hg : g ∈ closedBall K c + · rw [coeff_T_of_mem c z hg] + · rw [coeff_T_of_not_mem c z hg] + symm + apply HahnSeries.embDomain_of_notMem_range + exact fun ⟨h, hh⟩ ↦ hg (by + rw [closedBallOrderEmbedding_apply] at hh + exact hh ▸ h.2) + +@[simp] +theorem coe_unsplitIntegerPart + (u : HahnEmbedding.ArchimedeanStrata K G) (c : FiniteArchimedeanClass G) + (Z : Subring R) + (y : truncationIntegerPart (u.stratum c) + (innerIntegerPartSubring (K := K) (G := G) c Z)) : + (((unsplitIntegerPart u c Z y : truncationIntegerPart G Z) : Nonpositive G R) : + R⟦G⟧) = + HahnSeries.embDomain (closedBallOrderEmbedding (K := K) c) + ((HahnSeries.archimedeanSplitRingEquiv u c).symm + (y : (R⟦ball K c⟧)⟦u.stratum c⟧)) := + by + rfl + +theorem TClosed_of_fixed (c : FiniteArchimedeanClass G) (x : Nonpositive G R) + (hx : T (K := K) c x = x) : + TClosed (K := K) c x = + HahnSeries.restrictDomain (closedBallOrderEmbedding (K := K) c) (x : R⟦G⟧) := by + ext g + rw [TClosed_coeff, hx, HahnSeries.restrictDomain_coeff, + closedBallOrderEmbedding_apply] + +-- Checking both inverses traverses the full nested subtype and Hahn-series equivalence stack. +/-- The ring equivalence between the fixed integer part and its stratum series over the inner +integer part. -/ +def splitFixedIntegerPartRingEquiv + (u : HahnEmbedding.ArchimedeanStrata K G) (c : FiniteArchimedeanClass G) + (Z : Subring R) : + fixedIntegerPartSubring (K := K) (G := G) (R := R) c Z ≃+* + truncationIntegerPart (u.stratum c) + (innerIntegerPartSubring (K := K) (G := G) c Z) where + toFun := splitFixedIntegerPartRingHom u c Z + invFun := unsplitIntegerPart u c Z + left_inv x := by + apply Subtype.ext + apply Subtype.ext + apply Subtype.ext + dsimp only [unsplitIntegerPart] + change HahnSeries.embDomain (closedBallOrderEmbedding (K := K) c) + ((HahnSeries.archimedeanSplitRingEquiv u c).symm + (((splitFixedIntegerPartRingHom u c Z x : _) : + Nonpositive (u.stratum c) R⟦ball K c⟧) : + (R⟦ball K c⟧)⟦u.stratum c⟧)) = (x : R⟦G⟧) + rw [coe_splitFixedIntegerPartRingHom] + rw [coe_splitTruncation] + rw [RingEquiv.symm_apply_apply, embDomain_TClosed] + exact congrArg Subtype.val ((mem_truncationSubring_iff c (x : Nonpositive G R)).mp x.2) + right_inv y := by + apply Subtype.ext + rw [coe_splitFixedIntegerPartRingHom] + apply Subtype.ext + rw [coe_splitTruncation] + rw [TClosed_of_fixed c (unsplitIntegerPart u c Z y : Nonpositive G R) + ((mem_truncationSubring_iff c _).mp (unsplitIntegerPart u c Z y).2)] + rw [coe_unsplitIntegerPart] + change HahnSeries.archimedeanSplitRingEquiv u c + (HahnSeries.restrictDomain (closedBallOrderEmbedding (K := K) c) + (HahnSeries.embDomain (closedBallOrderEmbedding (K := K) c) + ((HahnSeries.archimedeanSplitRingEquiv u c).symm + (y : (R⟦ball K c⟧)⟦u.stratum c⟧)))) = + (y : (R⟦ball K c⟧)⟦u.stratum c⟧) + rw [HahnSeries.restrictDomain_embDomain, RingEquiv.apply_symm_apply] + map_mul' := (splitFixedIntegerPartRingHom u c Z).map_mul + map_add' := (splitFixedIntegerPartRingHom u c Z).map_add + +/-- The fixed integer-part equivalence applies by the split ring homomorphism. -/ +@[simp] +theorem splitFixedIntegerPartRingEquiv_apply + (u : HahnEmbedding.ArchimedeanStrata K G) (c : FiniteArchimedeanClass G) + (Z : Subring R) (x : fixedIntegerPartSubring (K := K) (G := G) (R := R) c Z) : + splitFixedIntegerPartRingEquiv u c Z x = splitFixedIntegerPartRingHom u c Z x := + (rfl) + +/-- The inverse fixed integer-part equivalence is the explicit unsplit construction. -/ +@[simp] +theorem splitFixedIntegerPartRingEquiv_symm_apply + (u : HahnEmbedding.ArchimedeanStrata K G) (c : FiniteArchimedeanClass G) + (Z : Subring R) + (y : truncationIntegerPart (u.stratum c) + (innerIntegerPartSubring (K := K) (G := G) c Z)) : + (splitFixedIntegerPartRingEquiv u c Z).symm y = unsplitIntegerPart u c Z y := + (rfl) + +theorem coe_splitFixedIntegerPartRingEquiv + (u : HahnEmbedding.ArchimedeanStrata K G) (c : FiniteArchimedeanClass G) + (Z : Subring R) (x : fixedIntegerPartSubring (K := K) (G := G) (R := R) c Z) : + ((splitFixedIntegerPartRingEquiv u c Z x : + truncationIntegerPart (u.stratum c) (innerIntegerPartSubring c Z)) : + Nonpositive (u.stratum c) R⟦ball K c⟧) = + splitTruncation u c (x : Nonpositive G R) := by + change ((splitFixedIntegerPartRingHom u c Z x : _) : + Nonpositive (u.stratum c) R⟦ball K c⟧) = _ + exact coe_splitFixedIntegerPartRingHom u c Z x + +end HahnSeries.Nonpositive diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/IrreducibilityTransfer.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/IrreducibilityTransfer.lean new file mode 100644 index 0000000000..47768842bd --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/IrreducibilityTransfer.lean @@ -0,0 +1,196 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.PrimalityTransfer +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Monomial + +/-! +# Irreducibility transfer from a leading Archimedean class + +This module formalizes the residue-one irreducibility transfer used in LM24, +Proposition 8.3.6(5). If a nonconstant integer-part element has open truncation one and its +leading split is irreducible, then the original element is irreducible. + +Every factor of the element is fixed by truncation at its leading class. The fixed integer-part +subring is ring-equivalent to the split integer part. Finally, an ambient unit occurring in a +factorisation with constant coefficient one is already a unit of that integer part. +-/ + +public noncomputable section + +namespace HahnSeries.Nonpositive + +open FiniteArchimedeanClass + +variable {K G R : Type*} +variable [DivisionRing K] [LinearOrder K] [IsOrderedRing K] [Archimedean K] +variable [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] +variable [Module K G] [IsOrderedModule K G] +variable [Field R] + +private theorem irreducible_truncationIntegerPart_of_irreducible_of_constantCoeff_eq_one + {S : Subring R} {b : truncationIntegerPart G S} + (hirr : Irreducible (b : Nonpositive G R)) + (hconstant : constantCoeff (b : Nonpositive G R) = 1) : + Irreducible b := by + rw [irreducible_iff] + refine ⟨fun hunit ↦ hirr.not_isUnit + ((truncationIntegerPart G S).subtype.isUnit_map hunit), ?_⟩ + intro c d hfactor + have hfactorAmbient : (b : Nonpositive G R) = c * d := + congrArg Subtype.val hfactor + rcases hirr.isUnit_or_isUnit hfactorAmbient with hcUnit | hdUnit + · left + have hcoeffProduct : + constantCoeff (c : Nonpositive G R) * + constantCoeff (d : Nonpositive G R) = 1 := by + calc + _ = constantCoeff ((c : Nonpositive G R) * (d : Nonpositive G R)) := + (map_mul (constantCoeff (Γ := G) (R := R)) + (c : Nonpositive G R) (d : Nonpositive G R)).symm + _ = constantCoeff (b : Nonpositive G R) := by rw [hfactorAmbient] + _ = 1 := hconstant + let dConstant : truncationIntegerPart G S := + ⟨C (constantCoeff (d : Nonpositive G R)), by + rw [mem_truncationIntegerPart] + simpa [constantCoeff_apply] using + (mem_truncationIntegerPart (R := R) (Γ := G)).mp d.2⟩ + apply isUnit_iff_exists.mpr + refine ⟨dConstant, ?_⟩ + have hprod : c * dConstant = 1 := by + apply Subtype.ext + change (c : Nonpositive G R) * C (constantCoeff (d : Nonpositive G R)) = 1 + rw [eq_C_constantCoeff_of_isUnit hcUnit, ← map_mul, hcoeffProduct, map_one] + exact ⟨hprod, by simpa [mul_comm] using hprod⟩ + · right + have hcoeffProduct : + constantCoeff (c : Nonpositive G R) * + constantCoeff (d : Nonpositive G R) = 1 := by + calc + _ = constantCoeff ((c : Nonpositive G R) * (d : Nonpositive G R)) := + (map_mul (constantCoeff (Γ := G) (R := R)) + (c : Nonpositive G R) (d : Nonpositive G R)).symm + _ = constantCoeff (b : Nonpositive G R) := by rw [hfactorAmbient] + _ = 1 := hconstant + let cConstant : truncationIntegerPart G S := + ⟨C (constantCoeff (c : Nonpositive G R)), by + rw [mem_truncationIntegerPart] + simpa [constantCoeff_apply] using + (mem_truncationIntegerPart (R := R) (Γ := G)).mp c.2⟩ + apply isUnit_iff_exists.mpr + refine ⟨cConstant, ?_⟩ + have hprod : d * cConstant = 1 := by + apply Subtype.ext + change (d : Nonpositive G R) * C (constantCoeff (c : Nonpositive G R)) = 1 + rw [eq_C_constantCoeff_of_isUnit hdUnit, ← map_mul, mul_comm, + hcoeffProduct, map_one] + exact ⟨hprod, by simpa [mul_comm] using hprod⟩ + +/-- In the residue-one branch, irreducibility of the ambient split series implies +irreducibility in its split integer part. -/ +theorem irreducible_splitTruncationIntegerPart_of_tau_eq_one + (u : HahnEmbedding.ArchimedeanStrata K G) (c : FiniteArchimedeanClass G) + (S : Subring R⟦ball K c⟧) (x : Nonpositive G R) + (htau : tauBall c x = 1) + (hirr : Irreducible (splitTruncation u c x)) : + Irreducible + (splitTruncationIntegerPart u c S x (htau.symm ▸ S.one_mem)) := by + have hirr' : Irreducible + (splitTruncationIntegerPart u c S x (htau.symm ▸ S.one_mem) : + Nonpositive (u.stratum c) R⟦ball K c⟧) := by + rw [coe_splitTruncationIntegerPart] + exact hirr + apply irreducible_truncationIntegerPart_of_irreducible_of_constantCoeff_eq_one hirr' + rw [coe_splitTruncationIntegerPart, constantCoeff_splitTruncation, htau] + +/-- Irreducibility in the leading fixed integer-part subring implies irreducibility in the full +integer part. -/ +theorem irreducible_of_irreducible_leadingFixedIntegerPartElement + (Z : Subring R) (b : truncationIntegerPart G Z) + (hb0 : (b : Nonpositive G R) ≠ 0) + (horder : ((b : Nonpositive G R) : R⟦G⟧).order ≠ 0) + (hirr : Irreducible + (leadingFixedIntegerPartElement (K := K) Z b horder)) : + Irreducible b := by + rw [irreducible_iff] + refine ⟨?_, ?_⟩ + · intro hunit + have hunitAmbient : IsUnit (b : Nonpositive G R) := + (truncationIntegerPart G Z).subtype.isUnit_map hunit + have hsupport := support_eq_singleton_zero_of_isUnit hunitAmbient + have hbOrderMem : ((b : Nonpositive G R) : R⟦G⟧).order ∈ + ((b : Nonpositive G R) : R⟦G⟧).support := by + rw [HahnSeries.mem_support] + exact HahnSeries.coeff_order_eq_zero.not.mpr + (fun h ↦ hb0 (Subtype.ext h)) + rw [hsupport, Set.mem_singleton_iff] at hbOrderMem + exact horder hbOrderMem + · intro c d hfactor + have hcDvd : (c : Nonpositive G R) ∣ (b : Nonpositive G R) := + ⟨d, congrArg Subtype.val hfactor⟩ + have hdDvd : (d : Nonpositive G R) ∣ (b : Nonpositive G R) := + ⟨c, by simpa [mul_comm] using congrArg Subtype.val hfactor⟩ + have hcFixed := T_leadingClass_of_dvd (K := K) + (b : Nonpositive G R) hb0 horder hcDvd + have hdFixed := T_leadingClass_of_dvd (K := K) + (b : Nonpositive G R) hb0 horder hdDvd + let cFixed : fixedIntegerPartSubring (K := K) (G := G) (R := R) + (leadingClass (b : Nonpositive G R) horder) Z := + ⟨c, (mem_fixedIntegerPartSubring_iff _ Z c).mpr hcFixed⟩ + let dFixed : fixedIntegerPartSubring (K := K) (G := G) (R := R) + (leadingClass (b : Nonpositive G R) horder) Z := + ⟨d, (mem_fixedIntegerPartSubring_iff _ Z d).mpr hdFixed⟩ + have hfactorFixed : + leadingFixedIntegerPartElement (K := K) Z b horder = + cFixed * dFixed := by + apply Subtype.ext + rw [coe_leadingFixedIntegerPartElement] + simpa [cFixed, dFixed] using hfactor + rcases hirr.isUnit_or_isUnit hfactorFixed with hcUnit | hdUnit + · exact Or.inl + ((fixedIntegerPartSubring (K := K) (G := G) (R := R) + (leadingClass (b : Nonpositive G R) horder) Z).subtype.isUnit_map hcUnit) + · exact Or.inr + ((fixedIntegerPartSubring (K := K) (G := G) (R := R) + (leadingClass (b : Nonpositive G R) horder) Z).subtype.isUnit_map hdUnit) + +/-- LM24, Proposition 8.3.6(5), residue-one case: if the leading split of a nonzero, +nonconstant integer-part element is irreducible, then the original element is irreducible. -/ +theorem irreducible_of_irreducible_splitTruncation_of_tau_eq_one + (u : HahnEmbedding.ArchimedeanStrata K G) (Z : Subring R) + (b : truncationIntegerPart G Z) (hb0 : (b : Nonpositive G R) ≠ 0) + (horder : ((b : Nonpositive G R) : R⟦G⟧).order ≠ 0) + (htau : tauBall (K := K) (leadingClass (b : Nonpositive G R) horder) + (b : Nonpositive G R) = 1) + (hirr : Irreducible + (splitTruncation u (leadingClass (b : Nonpositive G R) horder) + (b : Nonpositive G R))) : + Irreducible b := by + let sigma := leadingClass (b : Nonpositive G R) horder + let bFixed := leadingFixedIntegerPartElement (K := K) Z b horder + let e := splitFixedIntegerPartRingEquiv u sigma Z + let S := innerIntegerPartSubring (K := K) (G := G) sigma Z + have hsplitIrr : Irreducible + (splitTruncationIntegerPart u sigma S (b : Nonpositive G R) + (htau.symm ▸ S.one_mem)) := + irreducible_splitTruncationIntegerPart_of_tau_eq_one u sigma S b htau hirr + have heq : e bFixed = + splitTruncationIntegerPart u sigma S (b : Nonpositive G R) + (htau.symm ▸ S.one_mem) := by + rw [show e bFixed = splitTruncationIntegerPart u sigma S + (b : Nonpositive G R) + (tauBall_mem_innerIntegerPartSubring sigma Z b) by + exact splitFixedIntegerPartRingEquiv_leadingFixedIntegerPartElement + u Z b horder] + have hfixedIrr : Irreducible bFixed := by + have hmapped := hsplitIrr.map e.symm + rw [← heq] at hmapped + simpa using hmapped + exact irreducible_of_irreducible_leadingFixedIntegerPartElement + Z b hb0 horder hfixedIrr + +end HahnSeries.Nonpositive diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/LimitTailPrimality.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/LimitTailPrimality.lean new file mode 100644 index 0000000000..0670a23e90 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/LimitTailPrimality.lean @@ -0,0 +1,255 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.SupportArchimedeanClasses +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Refinement.SupportClassFactorization +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Refinement.SupportClassRefinement +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Refinement.ClosedClassRefinementTransport + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint + +/-! +# Primality from common-tail quotients + +The induction rank is the order type of the Archimedean classes met by the non-zero support. A +supplied theorem handles the case in which this set is finite. At every infinite rank, the classes +split into a non-zero limit initial segment and a finite final segment. Cauchy completeness of the +quotient by the common tail below the limit segment, together with primality for every series whose +support meets only finitely many Archimedean classes and the hypothesis that the κ-bounded integer +part on the common tail has the required fraction field, gives an exact refinement at a class met by +the support. Factoring off the resulting divisor strictly lowers the rank, so ordinal induction +proves that every element is primal. +-/ + +public noncomputable section + +open Cardinal FiniteArchimedeanClass +open HahnSeries.CardSuppLTTruncationIntegerPart +open scoped HahnSeries + +universe u v + +namespace HahnSeries.CardSuppLTTruncationIntegerPart + +/-- The common-tail hypotheses extend finite-class primality to every cardinal-bounded Hahn +integer-part series. -/ +@[blueprint "thm:limit-tail-primality" + (phase := "Refinement over Archimedean classes") + (title := "Transfinite extension of finite-class primality") + (statement := /-- + Let $G$ be an ordered rational vector space, $R$ a field of characteristic + zero, $\kappa>\aleph_0$ a regular cardinal, and $Z\subseteq R$ a subring. + Assume that every element of $Z+R((G^{<0}))_\kappa$ meeting only finitely + many Archimedean classes is primal. For every nonempty set $T$ of nonzero + Archimedean classes with no least member in the magnitude order and + cardinality less than $\kappa$, assume that the quotient by the common tail + below $T$ is Cauchy complete for its additive uniformity and that the + bounded Hahn field on the common tail is the fraction field of its bounded + Hahn integer part. Then every element of + $Z+R((G^{<0}))_\kappa$ is primal. + -/) + (proof := /-- + Induct on the order type of the nonzero Archimedean support classes. The + finite case is the hypothesis. Otherwise split the class set into a limit + initial segment and a finite final segment. By + \ref{thm:support-class-refinement}, an equation $ad=bc$ has an exact + refinement at a quotient class met by the support of $a$. + By \ref{lem:support-class-factorisation}, factoring off the corresponding + retained block leaves a cofactor with strictly smaller support-class order + type. The induction hypothesis makes that cofactor primal, while + \ref{lem:closed-class-refinement-transport} transports the quotient + refinement to the ambient integer part. These two refinements prove that + $a$ is primal. + -/)] +theorem isPrimal_of_finite_classes_and_limit_tail_conditions + {G : Type u} {R : Type v} + [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [Module ℚ G] [PosSMulMono ℚ G] + [Field R] [CharZero R] + {κ : Cardinal} [Fact (ℵ₀ < κ)] [Fact κ.IsRegular] + (Z : Subring R) + (hfinite : ∀ y : HahnSeries.cardSuppLTTruncationIntegerPart + (G := G) (R := R) (κ := κ) Z, + (ArchimedeanClass.mk '' (y : HahnSeries G R).support).Finite → IsPrimal y) + (hcomplete : ∀ (T : Set (FiniteArchimedeanClass G)), T.Nonempty → + (∀ c ∈ T, ∃ d ∈ T, c < d) → + (#T < κ) → + Nonempty (CompleteSpace (FiniteArchimedeanClass.TailQuotient T))) + (htailfrac : ∀ (T : Set (FiniteArchimedeanClass G)), T.Nonempty → + (∀ c ∈ T, ∃ d ∈ T, c < d) → + (#T < κ) → + Subring.fracSubring (HahnSeries.cardSuppLTTruncationIntegerPart + (G := FiniteArchimedeanClass.tailSubmodule ℚ T) + (R := R) (κ := κ) Z) = ⊤) + (a : HahnSeries.cardSuppLTTruncationIntegerPart + (G := G) (R := R) (κ := κ) Z) : IsPrimal a := by + classical + let S := HahnSeries.cardSuppLTTruncationIntegerPart + (G := G) (R := R) (κ := κ) Z + let toN := toNonpositiveRingHom (G := G) (R := R) (κ := κ) Z + let rank : S → Ordinal := fun x ↦ + (HahnSeries.Nonpositive.isPWO_nonzeroSupportArchimedeanClasses (toN x)).orderType + have hind : ∀ o : Ordinal, ∀ x : S, rank x = o → IsPrimal x := by + intro o + induction o using WellFoundedLT.induction with + | ind o ih => + intro x hxrank + by_cases hx0 : x = 0 + · rw [hx0] + exact isPrimal_zero + let xN := toN x + rcases xN.isPWO_supportArchimedeanClasses.finite_or_exists_limit_initial_finite_final + with hfiniteClasses | ⟨T₀, T₁, hT₀pwo, _hT₁pwo, hT₀sub, _hT₁sub, _hbefore, + hT₀limit, hT₁finite, hclasses⟩ + · apply hfinite x + simpa only [xN, toN, coe_toNonpositiveRingHom] using hfiniteClasses + · have hT₀gt : ∀ c ∈ T₀, ∃ d ∈ T₀, c < d := fun c hc ↦ + hT₀pwo.exists_gt_of_isSuccLimit_orderType hT₀limit hc + have hxclasses : ArchimedeanClass.mk '' (x : HahnSeries G R).support = T₀ ∪ T₁ := by + simpa only [xN, toN, coe_toNonpositiveRingHom] using hclasses + let T : Set (FiniteArchimedeanClass G) := {c | c.1 ∈ T₀} + have hTne : T.Nonempty := by + have hT₀ne : T₀.Nonempty := by + by_contra hne + rw [Set.not_nonempty_iff_eq_empty] at hne + exact hT₀limit.ne_bot (hT₀pwo.orderType_eq_zero.mpr hne) + obtain ⟨c, hc⟩ := hT₀ne + obtain ⟨d, _hd, hcd⟩ := hT₀gt c hc + exact ⟨⟨c, ne_top_of_lt hcd⟩, hc⟩ + let : Nonempty T := + ⟨⟨Classical.choose hTne, Classical.choose_spec hTne⟩⟩ + have hTgt : ∀ c ∈ T, ∃ d ∈ T, c < d := by + intro c hc + obtain ⟨d, hd, hcd⟩ := hT₀gt c.1 hc + obtain ⟨e, _he, hde⟩ := hT₀gt d hd + exact ⟨⟨d, ne_top_of_lt hde⟩, hd, hcd⟩ + have hTcard : #T < κ := by + calc + #T = #(Subtype.val '' T) := (Cardinal.mk_image_eq Subtype.val_injective).symm + _ ≤ #T₀ := Cardinal.mk_le_mk_of_subset fun _ h ↦ by + obtain ⟨c, hc, rfl⟩ := h + exact hc + _ ≤ #(ArchimedeanClass.mk '' (x : HahnSeries G R).support) := + Cardinal.mk_le_mk_of_subset fun c hc ↦ by + rw [hxclasses] + exact Or.inl hc + _ ≤ #(x : HahnSeries G R).support := Cardinal.mk_image_le + _ < κ := x.1.2 + let : CompleteSpace (FiniteArchimedeanClass.TailQuotient T) := + Classical.choice (hcomplete T hTne hTgt hTcard) + let P := FiniteArchimedeanClass.tailSubmodule ℚ T + intro b c hdiv + obtain ⟨d, hprod⟩ := hdiv + have heq : x * d = b * c := hprod.symm + obtain ⟨q, hqocc, e, f, g, h, hxe, _hde, hbe, hce⟩ := + exists_closed_class_refinement_at_support_class Z hfinite + T₀ T₁ hT₀gt hT₁finite x d b c heq hxclasses + (htailfrac T hTne hTgt hTcard) + have hqocc' : q.1 ∈ ArchimedeanClass.mk '' + (Submodule.Quotient.mk (p := P) '' (x : HahnSeries G R).support) := by + obtain ⟨z, hz, hzq⟩ := hqocc + have hsupp := HahnSeries.support_convexQuotientSplitRingEquiv P + (x : HahnSeries G R) + rw [hsupp] at hz + obtain ⟨r, hr, hzr⟩ := hz + exact ⟨z, ⟨r, hr, hzr⟩, hzq⟩ + let C : AddSubgroup G := + (FiniteArchimedeanClass.closedBallAddSubgroup q).comap P.mkQ.toAddMonoidHom + have hfilter0 : HahnSeries.filter (· ∈ C) (x : HahnSeries G R) ≠ 0 := by + obtain ⟨z, ⟨r, hr, hqr⟩, hzq⟩ := hqocc' + intro hzero + have hcoeff := congrArg (fun y : HahnSeries G R ↦ y.coeff r) hzero + rw [HahnSeries.coeff_filter, ite_eq_left] at hcoeff + · exact (HahnSeries.mem_support _ _).mp hr hcoeff + · change P.mkQ r ∈ FiniteArchimedeanClass.closedBallAddSubgroup q + apply FiniteArchimedeanClass.mem_closedBallAddSubgroup_iff.mpr + intro _hr0 + change q.1 ≤ ArchimedeanClass.mk (P.mkQ r) + change P.mkQ r = z at hqr + rw [hqr, hzq] + obtain ⟨t, w, ht, hfac, hrank⟩ := + exists_factor_with_smaller_support_class_orderType + Z T q x hqocc' hfilter0 + have ht' : t = restrictToAddSubgroup Z C x := by + apply Subtype.ext + apply Subtype.ext + exact ht.trans (coe_restrictToAddSubgroup Z C x).symm + have ht0 : t ≠ 0 := fun htzero ↦ hx0 (by rw [hfac, htzero, zero_mul]) + obtain ⟨eA, fA, htef, heb, hfc⟩ := + exists_factor_refinement_of_closed_class_refinement + P Z q x b c t ht' ht0 e f g h hxe hbe hce + have hw : IsPrimal w := by + apply ih (rank w) + · rw [← hxrank] + exact hrank + · rfl + exact exists_primalRefinement_of_factor_refinement + hx0 heq hfac htef heb hfc hw + exact hind (rank a) a rfl + +/-- Conditions `(A1)`--`(A3)` at finite Archimedean classes, together with the two +common-tail hypotheses at limit families, make every element of the bounded Hahn integer part +primal. -/ +@[blueprint "thm:hahn-integer-part-primality" + (phase := "Refinement over Archimedean classes") + (title := "Primality under finite-class and common-tail hypotheses") + (statement := /-- + Let $G$ be an ordered rational vector space, $R$ a field of characteristic + zero, $\kappa>\aleph_0$ a regular cardinal, and $Z\subseteq R$ a + pre-Schreier subring. At every nonzero Archimedean class, choose an + additive complement to the strict inner ball that is order additively + isomorphic to $\mathbb R$. Assume that each strict inner ball either has + cofinality at least $\kappa$, or is zero and every element of $R$ is a + fraction of elements of $Z$. + + For every nonempty set $T$ of fewer than $\kappa$ nonzero Archimedean + classes having no least member in the magnitude order, let $H_T$ be the + rational subspace of exponents lying beyond every class in $T$. Assume + that $G/H_T$ is Cauchy complete for its additive uniformity and that the + bounded Hahn field on $H_T$ is the fraction field of its bounded Hahn + integer part. Then every element of + $Z+R((G^{<0}))_\kappa$ is primal. + -/) + (proof := /-- + By \ref{thm:finite-support-classes-primality}, assumptions + $(A1)_\sigma$--$(A3)$ make every series meeting finitely many Archimedean + classes primal. Apply \ref{thm:limit-tail-primality} to extend this result + to arbitrary support-class order type. + -/)] +theorem isPrimal_of_finite_class_assumptions_and_limit_tail_conditions + {G : Type u} {R : Type v} + [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [Module ℚ G] [IsOrderedModule ℚ G] + [Field R] [CharZero R] + {κ : Cardinal} [Fact (ℵ₀ < κ)] [Fact κ.IsRegular] + (Z : Subring R) [DecompositionMonoid Z] + (s : HahnEmbedding.ArchimedeanStrata ℚ G) + (hA1 : ∀ c : FiniteArchimedeanClass G, LM24.AssumptionA1AtFiniteClass s c) + (hA2 : ∀ c : FiniteArchimedeanClass G, + LM24.AssumptionA2AtFiniteClass (K := ℚ) κ Z c) + (hcomplete : ∀ (T : Set (FiniteArchimedeanClass G)), T.Nonempty → + (∀ c ∈ T, ∃ d ∈ T, c < d) → + (#T < κ) → + Nonempty (CompleteSpace (FiniteArchimedeanClass.TailQuotient T))) + (htailfrac : ∀ (T : Set (FiniteArchimedeanClass G)), T.Nonempty → + (∀ c ∈ T, ∃ d ∈ T, c < d) → + (#T < κ) → + Subring.fracSubring (HahnSeries.cardSuppLTTruncationIntegerPart + (G := FiniteArchimedeanClass.tailSubmodule ℚ T) + (R := R) (κ := κ) Z) = ⊤) + (a : HahnSeries.cardSuppLTTruncationIntegerPart + (G := G) (R := R) (κ := κ) Z) : IsPrimal a := by + apply isPrimal_of_finite_classes_and_limit_tail_conditions Z + · intro y hy + apply HahnSeries.Nonpositive.isPrimal_of_supportArchimedeanClasses_finite + Z s (fun c ↦ (LM24.assumptionA1AtFiniteClass_iff s c).mp (hA1 c)) hA2 y + rw [supportArchimedeanClasses_toNonpositiveRingHom] + exact hy + · exact hcomplete + · exact htailfrac + +end HahnSeries.CardSuppLTTruncationIntegerPart diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/PrimalityTransfer.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/PrimalityTransfer.lean new file mode 100644 index 0000000000..d907b3a8b2 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/PrimalityTransfer.lean @@ -0,0 +1,339 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.IntegerPartSplitting + +/-! +# Primality transfer at the leading Archimedean class + +This module assembles the generic set-level core of LM24, Proposition 9.2.2. A nonzero +nonconstant element of a Hahn-series truncation integer part is primal exactly when its split +leading truncation is primal in the ambient outer nonpositive Hahn ring, provided the element is +reduced and the embedded inner integer part generates the coefficient Hahn field. The latter is +the exact fraction-field input used in the zero-residue branch of the paper. + +The source localization is carried out inside the truncation integer part, not merely inside the +ambient nonpositive Hahn ring. In particular, the quotient constructed when divisibility is +tested after closed-class truncation is proved to retain its coefficient at exponent zero in the +source coefficient subring. +-/ + +open FiniteArchimedeanClass + +public noncomputable section + +namespace HahnSeries.Nonpositive + +variable {K G R : Type*} +variable [DivisionRing K] [LinearOrder K] [IsOrderedRing K] [Archimedean K] +variable [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] +variable [Module K G] [IsOrderedModule K G] +variable [Field R] + +/-- Closed-class truncation restricted to a truncation integer part. It preserves the +coefficient at exponent zero and hence the coefficient-subring condition. -/ +def TIntegerPartRingHom (c : FiniteArchimedeanClass G) (Z : Subring R) : + truncationIntegerPart G Z →+* truncationIntegerPart G Z where + toFun x := ⟨T (K := K) c (x : Nonpositive G R), by + rw [mem_truncationIntegerPart] + rw [coeff_T_of_mem c (x : Nonpositive G R) (zero_mem _)] + exact (mem_truncationIntegerPart (R := R) (Γ := G)).mp x.2⟩ + map_one' := Subtype.ext (map_one (T (K := K) c)) + map_mul' x y := Subtype.ext ((T (K := K) c).map_mul + (x : Nonpositive G R) (y : Nonpositive G R)) + map_zero' := Subtype.ext (map_zero (T (K := K) c)) + map_add' x y := Subtype.ext ((T (K := K) c).map_add + (x : Nonpositive G R) (y : Nonpositive G R)) + +/-- The integer-part truncation ring homomorphism agrees with closed-class truncation on the +underlying nonpositive Hahn series. -/ +@[simp] +theorem coe_TIntegerPartRingHom (c : FiniteArchimedeanClass G) (Z : Subring R) + (x : truncationIntegerPart G Z) : + (TIntegerPartRingHom (K := K) c Z x : Nonpositive G R) = + T (K := K) c (x : Nonpositive G R) := + (rfl) + +/-- Divisibility by a nonzero fixed integer-part element can be tested after closed-class +truncation, with the quotient witness remaining in the same integer part. -/ +theorem dvd_iff_dvd_TIntegerPart_of_fixed (c : FiniteArchimedeanClass G) + (Z : Subring R) (b : truncationIntegerPart G Z) (hb0 : (b : Nonpositive G R) ≠ 0) + (hbFixed : T (K := K) c (b : Nonpositive G R) = b) + (x : truncationIntegerPart G Z) : + b ∣ x ↔ b ∣ TIntegerPartRingHom (K := K) c Z x := by + constructor + · rintro ⟨q, hq⟩ + refine ⟨TIntegerPartRingHom (K := K) c Z q, ?_⟩ + apply Subtype.ext + change T (K := K) c (x : Nonpositive G R) = + (b : Nonpositive G R) * T (K := K) c (q : Nonpositive G R) + rw [show (x : Nonpositive G R) = b * q by exact congrArg Subtype.val hq] + rw [map_mul, hbFixed] + · intro h + have hAmbientT : (b : Nonpositive G R) ∣ T (K := K) c (x : Nonpositive G R) := by + simpa using map_dvd (truncationIntegerPart G Z).subtype h + have hAmbient : (b : Nonpositive G R) ∣ (x : Nonpositive G R) := + (dvd_iff_dvd_T_of_fixed c (b : Nonpositive G R) hb0 hbFixed x).mpr hAmbientT + obtain ⟨q, hq⟩ := hAmbient + obtain ⟨qT, hqT⟩ := h + have hqTFixed : T (K := K) c q = (qT : Nonpositive G R) := by + apply mul_left_cancel₀ hb0 + calc + (b : Nonpositive G R) * T (K := K) c q = + T (K := K) c b * T (K := K) c q := by rw [hbFixed] + _ = T (K := K) c ((b : Nonpositive G R) * q) := + ((T (K := K) c).map_mul (b : Nonpositive G R) q).symm + _ = T (K := K) c (x : Nonpositive G R) := by rw [hq] + _ = (b : Nonpositive G R) * (qT : Nonpositive G R) := + congrArg Subtype.val hqT + let q' : truncationIntegerPart G Z := ⟨q, by + rw [mem_truncationIntegerPart] + rw [← coeff_T_of_mem (K := K) c q (zero_mem _), hqTFixed] + exact (mem_truncationIntegerPart (R := R) (Γ := G)).mp qT.2⟩ + refine ⟨q', ?_⟩ + apply Subtype.ext + exact hq + +/-- A nonconstant integer-part element, regarded in the subring fixed by truncation at its +leading Archimedean class. -/ +def leadingFixedIntegerPartElement (Z : Subring R) (b : truncationIntegerPart G Z) + (horder : ((b : Nonpositive G R) : R⟦G⟧).order ≠ 0) : + fixedIntegerPartSubring (K := K) (G := G) (R := R) + (leadingClass (b : Nonpositive G R) horder) Z := + ⟨b, (mem_fixedIntegerPartSubring_iff _ Z b).mpr + (T_leadingClass (b : Nonpositive G R) horder)⟩ + +/-- The leading fixed integer-part element has the original integer-part element as its value. -/ +@[simp] +theorem coe_leadingFixedIntegerPartElement (Z : Subring R) + (b : truncationIntegerPart G Z) + (horder : ((b : Nonpositive G R) : R⟦G⟧).order ≠ 0) : + (leadingFixedIntegerPartElement (K := K) Z b horder : truncationIntegerPart G Z) = b := + (rfl) + +/-- Primality of a nonzero nonconstant integer-part element is unchanged when it is restricted +to the integer-part subring fixed by truncation at its leading class. -/ +theorem isPrimal_leadingFixedIntegerPartElement_iff (Z : Subring R) + (b : truncationIntegerPart G Z) (hb0 : (b : Nonpositive G R) ≠ 0) + (horder : ((b : Nonpositive G R) : R⟦G⟧).order ≠ 0) : + IsPrimal (leadingFixedIntegerPartElement (K := K) Z b horder) ↔ IsPrimal b := by + let sigma := leadingClass (b : Nonpositive G R) horder + constructor + · intro h x y hdvd + obtain ⟨q, hq⟩ := hdvd + have hdivLocal : leadingFixedIntegerPartElement (K := K) Z b horder ∣ + ⟨TIntegerPartRingHom (K := K) sigma Z x, + (mem_fixedIntegerPartSubring_iff sigma Z _).mpr (by + exact T_T sigma (x : Nonpositive G R))⟩ * + ⟨TIntegerPartRingHom (K := K) sigma Z y, + (mem_fixedIntegerPartSubring_iff sigma Z _).mpr (by + exact T_T sigma (y : Nonpositive G R))⟩ := by + refine ⟨⟨TIntegerPartRingHom (K := K) sigma Z q, + (mem_fixedIntegerPartSubring_iff sigma Z _).mpr (by + exact T_T sigma (q : Nonpositive G R))⟩, ?_⟩ + apply Subtype.ext + apply Subtype.ext + change T (K := K) sigma (x : Nonpositive G R) * T (K := K) sigma y = + (b : Nonpositive G R) * T (K := K) sigma q + rw [← map_mul] + rw [show (x : Nonpositive G R) * y = b * q by exact congrArg Subtype.val hq] + rw [map_mul, T_leadingClass (b : Nonpositive G R) horder] + obtain ⟨b₁, b₂, h₁, h₂, hprod⟩ := h hdivLocal + have hprodSource : b = (b₁ : truncationIntegerPart G Z) * b₂ := by + simpa using congrArg Subtype.val hprod + have hb₁Ne : (b₁ : Nonpositive G R) ≠ 0 := by + intro hz + apply hb0 + rw [show (b : Nonpositive G R) = b₁ * b₂ by + exact congrArg Subtype.val hprodSource] + rw [hz, zero_mul] + have hb₂Ne : (b₂ : Nonpositive G R) ≠ 0 := by + intro hz + apply hb0 + rw [show (b : Nonpositive G R) = b₁ * b₂ by + exact congrArg Subtype.val hprodSource] + rw [hz, mul_zero] + refine ⟨(b₁ : truncationIntegerPart G Z), (b₂ : truncationIntegerPart G Z), ?_, ?_, ?_⟩ + · refine (dvd_iff_dvd_TIntegerPart_of_fixed (K := K) (R := R) sigma Z b₁ hb₁Ne + ((mem_fixedIntegerPartSubring_iff sigma Z _).mp b₁.2) x).mpr ?_ + exact map_dvd + (fixedIntegerPartSubring (K := K) (G := G) (R := R) sigma Z).subtype h₁ + · refine (dvd_iff_dvd_TIntegerPart_of_fixed (K := K) (R := R) sigma Z b₂ hb₂Ne + ((mem_fixedIntegerPartSubring_iff sigma Z _).mp b₂.2) y).mpr ?_ + exact map_dvd + (fixedIntegerPartSubring (K := K) (G := G) (R := R) sigma Z).subtype h₂ + · exact hprodSource + · intro h x y hdvd + have hdvdSource : b ∣ (x : truncationIntegerPart G Z) * + (y : truncationIntegerPart G Z) := + map_dvd (fixedIntegerPartSubring (K := K) (G := G) (R := R) sigma Z).subtype hdvd + obtain ⟨b₁, b₂, h₁, h₂, hprod⟩ := h hdvdSource + have hb₁Mem : T (K := K) sigma (b₁ : Nonpositive G R) = b₁ := by + apply T_leadingClass_of_dvd (b : Nonpositive G R) hb0 horder + exact map_dvd (truncationIntegerPart G Z).subtype + (hprod.symm ▸ dvd_mul_right b₁ b₂) + have hb₂Mem : T (K := K) sigma (b₂ : Nonpositive G R) = b₂ := by + apply T_leadingClass_of_dvd (b : Nonpositive G R) hb0 horder + exact map_dvd (truncationIntegerPart G Z).subtype + (hprod.symm ▸ dvd_mul_left b₂ b₁) + have hb₁Ne : (b₁ : Nonpositive G R) ≠ 0 := by + intro hz + apply hb0 + rw [show (b : Nonpositive G R) = b₁ * b₂ by exact congrArg Subtype.val hprod] + rw [hz, zero_mul] + have hb₂Ne : (b₂ : Nonpositive G R) ≠ 0 := by + intro hz + apply hb0 + rw [show (b : Nonpositive G R) = b₁ * b₂ by exact congrArg Subtype.val hprod] + rw [hz, mul_zero] + have hq₁Mem : T (K := K) sigma (h₁.choose : Nonpositive G R) = h₁.choose := by + apply mul_left_cancel₀ hb₁Ne + calc + (b₁ : Nonpositive G R) * T (K := K) sigma h₁.choose = + T (K := K) sigma b₁ * T (K := K) sigma h₁.choose := by rw [hb₁Mem] + _ = T (K := K) sigma + ((b₁ : Nonpositive G R) * (h₁.choose : Nonpositive G R)) := + ((T (K := K) sigma).map_mul (b₁ : Nonpositive G R) + (h₁.choose : Nonpositive G R)).symm + _ = T (K := K) sigma (x : Nonpositive G R) := by + rw [← show (x : Nonpositive G R) = + (b₁ : Nonpositive G R) * (h₁.choose : Nonpositive G R) by + exact congrArg Subtype.val h₁.choose_spec] + _ = (x : Nonpositive G R) := (mem_fixedIntegerPartSubring_iff sigma Z _).mp x.2 + _ = (b₁ : Nonpositive G R) * (h₁.choose : Nonpositive G R) := + congrArg Subtype.val h₁.choose_spec + have hq₂Mem : T (K := K) sigma (h₂.choose : Nonpositive G R) = h₂.choose := by + apply mul_left_cancel₀ hb₂Ne + calc + (b₂ : Nonpositive G R) * T (K := K) sigma h₂.choose = + T (K := K) sigma b₂ * T (K := K) sigma h₂.choose := by rw [hb₂Mem] + _ = T (K := K) sigma + ((b₂ : Nonpositive G R) * (h₂.choose : Nonpositive G R)) := + ((T (K := K) sigma).map_mul (b₂ : Nonpositive G R) + (h₂.choose : Nonpositive G R)).symm + _ = T (K := K) sigma (y : Nonpositive G R) := by + rw [← show (y : Nonpositive G R) = + (b₂ : Nonpositive G R) * (h₂.choose : Nonpositive G R) by + exact congrArg Subtype.val h₂.choose_spec] + _ = (y : Nonpositive G R) := (mem_fixedIntegerPartSubring_iff sigma Z _).mp y.2 + _ = (b₂ : Nonpositive G R) * (h₂.choose : Nonpositive G R) := + congrArg Subtype.val h₂.choose_spec + refine ⟨⟨b₁, (mem_fixedIntegerPartSubring_iff sigma Z _).mpr hb₁Mem⟩, + ⟨b₂, (mem_fixedIntegerPartSubring_iff sigma Z _).mpr hb₂Mem⟩, ?_, ?_, ?_⟩ + · exact ⟨⟨h₁.choose, (mem_fixedIntegerPartSubring_iff sigma Z _).mpr hq₁Mem⟩, + Subtype.ext h₁.choose_spec⟩ + · exact ⟨⟨h₂.choose, (mem_fixedIntegerPartSubring_iff sigma Z _).mpr hq₂Mem⟩, + Subtype.ext h₂.choose_spec⟩ + · exact Subtype.ext hprod + +/-- Splitting the leading fixed integer-part element gives its split truncation in the exact +embedded inner integer part. -/ +theorem splitFixedIntegerPartRingEquiv_leadingFixedIntegerPartElement + (u : HahnEmbedding.ArchimedeanStrata K G) (Z : Subring R) + (b : truncationIntegerPart G Z) + (horder : ((b : Nonpositive G R) : R⟦G⟧).order ≠ 0) : + splitFixedIntegerPartRingEquiv u (leadingClass (b : Nonpositive G R) horder) Z + (leadingFixedIntegerPartElement (K := K) Z b horder) = + splitTruncationIntegerPart u (leadingClass (b : Nonpositive G R) horder) + (innerIntegerPartSubring (K := K) (G := G) + (leadingClass (b : Nonpositive G R) horder) Z) + (b : Nonpositive G R) + (tauBall_mem_innerIntegerPartSubring + (leadingClass (b : Nonpositive G R) horder) Z b) := by + apply Subtype.ext + rw [coe_splitFixedIntegerPartRingEquiv, coe_splitTruncationIntegerPart] + rw [show (leadingFixedIntegerPartElement (K := K) Z b horder : + truncationIntegerPart G Z) = b from coe_leadingFixedIntegerPartElement Z b horder] + +/-- In the residue-one branch, source primality is equivalent to ambient primality of the split +truncation without any fraction-field hypothesis. -/ +theorem isPrimal_iff_isPrimal_splitTruncation_of_tau_eq_one + (u : HahnEmbedding.ArchimedeanStrata K G) (Z : Subring R) + (b : truncationIntegerPart G Z) (hb0 : (b : Nonpositive G R) ≠ 0) + (horder : ((b : Nonpositive G R) : R⟦G⟧).order ≠ 0) + (htau : tauBall (K := K) (leadingClass (b : Nonpositive G R) horder) + (b : Nonpositive G R) = 1) : + IsPrimal b ↔ + IsPrimal (splitTruncation u (leadingClass (b : Nonpositive G R) horder) + (b : Nonpositive G R)) := by + let sigma := leadingClass (b : Nonpositive G R) horder + let bFixed := leadingFixedIntegerPartElement (K := K) Z b horder + let e := splitFixedIntegerPartRingEquiv u sigma Z + let S := innerIntegerPartSubring (K := K) (G := G) sigma Z + calc + IsPrimal b ↔ IsPrimal bFixed := + (isPrimal_leadingFixedIntegerPartElement_iff (K := K) Z b hb0 horder).symm + _ ↔ IsPrimal (e bFixed) := (RingEquiv.isPrimal_iff e bFixed).symm + _ ↔ IsPrimal (splitTruncationIntegerPart u sigma S (b : Nonpositive G R) + (htau.symm ▸ S.one_mem)) := by + rw [show e bFixed = splitTruncationIntegerPart u sigma S (b : Nonpositive G R) + (tauBall_mem_innerIntegerPartSubring sigma Z b) by + exact splitFixedIntegerPartRingEquiv_leadingFixedIntegerPartElement u Z b horder] + _ ↔ IsPrimal (splitTruncation u sigma (b : Nonpositive G R)) := + isPrimal_splitTruncationIntegerPart_iff_of_tau_eq_one u sigma S + (b : Nonpositive G R) htau + +/-- In the residue-zero branch, source primality is equivalent to ambient primality of the split +truncation when the embedded inner integer part generates the coefficient Hahn field. -/ +theorem isPrimal_iff_isPrimal_splitTruncation_of_tau_eq_zero + (u : HahnEmbedding.ArchimedeanStrata K G) (Z : Subring R) + (b : truncationIntegerPart G Z) (hb0 : (b : Nonpositive G R) ≠ 0) + (horder : ((b : Nonpositive G R) : R⟦G⟧).order ≠ 0) + (hfrac : Subring.fracSubring + (innerIntegerPartSubring (K := K) (G := G) + (leadingClass (b : Nonpositive G R) horder) Z) = ⊤) + (htau : tauBall (K := K) (leadingClass (b : Nonpositive G R) horder) + (b : Nonpositive G R) = 0) : + IsPrimal b ↔ + IsPrimal (splitTruncation u (leadingClass (b : Nonpositive G R) horder) + (b : Nonpositive G R)) := by + let sigma := leadingClass (b : Nonpositive G R) horder + let bFixed := leadingFixedIntegerPartElement (K := K) Z b horder + let e := splitFixedIntegerPartRingEquiv u sigma Z + let S := innerIntegerPartSubring (K := K) (G := G) sigma Z + calc + IsPrimal b ↔ IsPrimal bFixed := + (isPrimal_leadingFixedIntegerPartElement_iff (K := K) Z b hb0 horder).symm + _ ↔ IsPrimal (e bFixed) := (RingEquiv.isPrimal_iff e bFixed).symm + _ ↔ IsPrimal (splitTruncationIntegerPart u sigma S (b : Nonpositive G R) + (htau.symm ▸ S.zero_mem)) := by + rw [show e bFixed = splitTruncationIntegerPart u sigma S (b : Nonpositive G R) + (tauBall_mem_innerIntegerPartSubring sigma Z b) by + exact splitFixedIntegerPartRingEquiv_leadingFixedIntegerPartElement u Z b horder] + _ ↔ IsPrimal (splitTruncation u sigma (b : Nonpositive G R)) := + isPrimal_splitTruncationIntegerPart_iff_of_tau_eq_zero u sigma S hfrac + (b : Nonpositive G R) htau + +/-- Set-level primality transfer from LM24, Proposition 9.2.2. Generation of the coefficient Hahn +field by the embedded inner integer part is required only when the leading residue is zero. -/ +theorem isPrimal_iff_isPrimal_splitTruncation_of_isReduced + (u : HahnEmbedding.ArchimedeanStrata K G) (Z : Subring R) + (b : truncationIntegerPart G Z) (hb0 : (b : Nonpositive G R) ≠ 0) + (horder : ((b : Nonpositive G R) : R⟦G⟧).order ≠ 0) + (hbReduced : IsReduced (b : Nonpositive G R)) + (hfrac : tauBall (K := K) (leadingClass (b : Nonpositive G R) horder) + (b : Nonpositive G R) = 0 → + Subring.fracSubring (innerIntegerPartSubring (K := K) (G := G) + (leadingClass (b : Nonpositive G R) horder) Z) = ⊤) : + IsPrimal b ↔ + IsPrimal (splitTruncation u (leadingClass (b : Nonpositive G R) horder) + (b : Nonpositive G R)) := by + rcases (isReduced_iff_tau_leadingClass_eq_zero_or_one (K := K) + (b : Nonpositive G R) hb0 horder).mp hbReduced with htau | htau + · have htauBall : tauBall (K := K) (leadingClass (b : Nonpositive G R) horder) + (b : Nonpositive G R) = 0 := + (tauBall_eq_zero_iff (leadingClass (b : Nonpositive G R) horder) + (b : Nonpositive G R)).mpr htau + exact isPrimal_iff_isPrimal_splitTruncation_of_tau_eq_zero u Z b hb0 horder + (hfrac htauBall) htauBall + · have htauBall : tauBall (K := K) (leadingClass (b : Nonpositive G R) horder) + (b : Nonpositive G R) = 1 := by + exact tauBall_eq_one_of_tau_eq_one (leadingClass (b : Nonpositive G R) horder) + (b : Nonpositive G R) htau + exact isPrimal_iff_isPrimal_splitTruncation_of_tau_eq_one u Z b hb0 horder htauBall + +end HahnSeries.Nonpositive diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Reduced.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Reduced.lean new file mode 100644 index 0000000000..fb59231c19 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Reduced.lean @@ -0,0 +1,51 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Nonpositive +public import Mathlib.Algebra.Order.Archimedean.Class + +/-! +# Reduced Hahn series + +LM24, Definition 8.2.6 calls a nonzero series reduced when the intersection of its support with +the support after subtracting one lies in a single Archimedean class. We retain the zero class: +`ArchimedeanClass.mk 0 = ⊤`. This matters when the constant coefficient is neither zero nor one, +and distinguishes the printed definition from the incorrect variant that inspects only nonzero +exponents. +-/ + +public section + +namespace HahnSeries.Nonpositive + +variable {G R : Type*} +variable [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] [Ring R] + +/-- LM24, Definition 8.2.6: a nonzero nonpositive Hahn series whose support and shifted support +intersect in one Archimedean class. The class may be the zero class `⊤`. -/ +def IsReduced (b : Nonpositive G R) : Prop := + b ≠ 0 ∧ ∃ c : ArchimedeanClass G, + (b : R⟦G⟧).support ∩ ((b - 1 : Nonpositive G R) : R⟦G⟧).support ⊆ + {x | ArchimedeanClass.mk x = c} + +/-- Elimination rule for reducedness. -/ +theorem IsReduced.elim {b : Nonpositive G R} (hb : IsReduced b) : + b ≠ 0 ∧ ∃ c : ArchimedeanClass G, + (b : R⟦G⟧).support ∩ ((b - 1 : Nonpositive G R) : R⟦G⟧).support ⊆ + {x | ArchimedeanClass.mk x = c} := + hb + +/-- Introduction rule for reducedness. -/ +theorem isReduced_of_support_inter_support_sub_one_subset {b : Nonpositive G R} + (hb : b ≠ 0) (c : ArchimedeanClass G) + (hsupport : + (b : R⟦G⟧).support ∩ ((b - 1 : Nonpositive G R) : R⟦G⟧).support ⊆ + {x | ArchimedeanClass.mk x = c}) : + IsReduced b := + ⟨hb, c, hsupport⟩ + +end HahnSeries.Nonpositive diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/ReducedCharacterization.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/ReducedCharacterization.lean new file mode 100644 index 0000000000..a14108aa7f --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/ReducedCharacterization.lean @@ -0,0 +1,192 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Reduction +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Reduced + +/-! +# Reducedness and leading-class reduction + +This module proves the nonconstant case of LM24, Proposition 8.2.5 `(4) ↔ (5)`. For a +nonpositive Hahn series whose lowest exponent is nonzero, reducedness is equivalent to its +open truncation at the lowest exponent's Archimedean class being zero or one. The proof treats +the exponent zero explicitly: it belongs to both supports exactly when the constant coefficient +is neither zero nor one. +-/ + +public noncomputable section + +namespace HahnSeries.Nonpositive + +open FiniteArchimedeanClass + +variable {K G R : Type*} +variable [DivisionRing K] [LinearOrder K] [IsOrderedRing K] [Archimedean K] +variable [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] +variable [Module K G] [IsOrderedModule K G] +variable [Field R] + +private theorem coeff_sub_one_of_ne_zero (x : Nonpositive G R) {g : G} (hg : g ≠ 0) : + ((x - 1 : Nonpositive G R) : R⟦G⟧).coeff g = (x : R⟦G⟧).coeff g := by + change ((x : R⟦G⟧) - 1).coeff g = _ + rw [HahnSeries.coeff_sub, HahnSeries.coeff_one, ite_eq_right hg, sub_zero] + +private theorem leadingClass_le_mk_of_mem_support (x : Nonpositive G R) + (horder : (x : R⟦G⟧).order ≠ 0) {g : G} (hg : g ∈ (x : R⟦G⟧).support) + (hg0 : g ≠ 0) : + leadingClass x horder ≤ FiniteArchimedeanClass.mk g hg0 := by + rw [show leadingClass x horder = FiniteArchimedeanClass.mk + (x : R⟦G⟧).order horder by apply Subtype.ext; simp] + apply (FiniteArchimedeanClass.mk_le_mk horder hg0).mpr + have horderLe : (x : R⟦G⟧).order ≤ g := + HahnSeries.order_le_of_coeff_ne_zero ((HahnSeries.mem_support _ _).mp hg) + have hgNonpos : g ≤ 0 := support_subset x hg + simpa using ArchimedeanClass.min_le_mk_of_le_of_le horderLe hgNonpos + +private theorem tau_eq_zero_of_support_nonzero_class + (x : Nonpositive G R) (horder : (x : R⟦G⟧).order ≠ 0) + (hcoeffZero : (x : R⟦G⟧).coeff 0 = 0) + (hclass : ∀ g ∈ (x : R⟦G⟧).support, ∀ hg0 : g ≠ 0, + FiniteArchimedeanClass.mk g hg0 = leadingClass x horder) : + tau (K := K) (leadingClass x horder) x = 0 := by + apply Subtype.ext + ext g + by_cases hg0 : g = 0 + · subst g + rw [coeff_tau_of_mem] + · exact hcoeffZero + · exact zero_mem _ + by_cases hg : g ∈ (x : R⟦G⟧).support + · rw [coeff_tau_of_not_mem] + · simp + · intro hball + have hlt := (FiniteArchimedeanClass.mem_ball_iff K).mp hball hg0 + rw [hclass g hg hg0] at hlt + exact lt_irrefl _ hlt + · have hcoeff : (x : R⟦G⟧).coeff g = 0 := + not_ne_iff.mp ((HahnSeries.mem_support _ _).not.mp hg) + by_cases hball : g ∈ ball K (leadingClass x horder) + · rw [coeff_tau_of_mem _ _ hball, hcoeff]; simp + · rw [coeff_tau_of_not_mem _ _ hball]; simp + +private theorem tau_eq_C_constantCoeff_of_support_nonzero_class + (x : Nonpositive G R) (horder : (x : R⟦G⟧).order ≠ 0) + (hclass : ∀ g ∈ (x : R⟦G⟧).support, ∀ hg0 : g ≠ 0, + FiniteArchimedeanClass.mk g hg0 = leadingClass x horder) : + tau (K := K) (leadingClass x horder) x = C ((x : R⟦G⟧).coeff 0) := by + apply Subtype.ext + ext g + by_cases hg0 : g = 0 + · subst g + rw [coeff_tau_of_mem] + · simp + · exact zero_mem _ + · rw [coe_C] + change ((tau (K := K) (leadingClass x horder) x : Nonpositive G R) : + R⟦G⟧).coeff g = (HahnSeries.single 0 ((x : R⟦G⟧).coeff 0)).coeff g + rw [HahnSeries.coeff_single, ite_eq_right hg0] + by_cases hg : g ∈ (x : R⟦G⟧).support + · rw [coeff_tau_of_not_mem] + intro hball + have hlt := (FiniteArchimedeanClass.mem_ball_iff K).mp hball hg0 + rw [hclass g hg hg0] at hlt + exact lt_irrefl _ hlt + · have hcoeff : (x : R⟦G⟧).coeff g = 0 := + not_ne_iff.mp ((HahnSeries.mem_support _ _).not.mp hg) + by_cases hball : g ∈ ball K (leadingClass x horder) + · rw [coeff_tau_of_mem _ _ hball, hcoeff] + · rw [coeff_tau_of_not_mem _ _ hball] + +/-- LM24, Proposition 8.2.5 `(4) ↔ (5)` for a series with nonzero lowest exponent. -/ +theorem isReduced_iff_tau_leadingClass_eq_zero_or_one + (x : Nonpositive G R) (hx : x ≠ 0) (horder : (x : R⟦G⟧).order ≠ 0) : + IsReduced x ↔ + tau (K := K) (leadingClass x horder) x = 0 ∨ + tau (K := K) (leadingClass x horder) x = 1 := by + constructor + · intro hReduced + obtain ⟨_, d, hd⟩ := hReduced.elim + have horderSupport : (x : R⟦G⟧).order ∈ (x : R⟦G⟧).support := by + exact (HahnSeries.mem_support _ _).mpr + (HahnSeries.coeff_order_eq_zero.not.mpr (fun h ↦ hx (Subtype.ext h))) + have horderSubSupport : + (x : R⟦G⟧).order ∈ ((x - 1 : Nonpositive G R) : R⟦G⟧).support := by + rw [HahnSeries.mem_support, coeff_sub_one_of_ne_zero x horder] + exact HahnSeries.coeff_order_eq_zero.not.mpr (fun h ↦ hx (Subtype.ext h)) + have hdLeading : ArchimedeanClass.mk (x : R⟦G⟧).order = d := + hd ⟨horderSupport, horderSubSupport⟩ + have hclass : ∀ g ∈ (x : R⟦G⟧).support, ∀ hg0 : g ≠ 0, + FiniteArchimedeanClass.mk g hg0 = leadingClass x horder := by + intro g hg hg0 + apply Subtype.ext + rw [FiniteArchimedeanClass.val_mk, leadingClass_val] + exact (hd ⟨hg, by + rw [HahnSeries.mem_support, coeff_sub_one_of_ne_zero x hg0] + exact (HahnSeries.mem_support _ _).mp hg⟩).trans hdLeading.symm + have hconstant : (x : R⟦G⟧).coeff 0 = 0 ∨ (x : R⟦G⟧).coeff 0 = 1 := by + by_contra hnot + push Not at hnot + have hzeroSupport : 0 ∈ (x : R⟦G⟧).support := + (HahnSeries.mem_support _ _).mpr hnot.1 + have hzeroSubSupport : + 0 ∈ ((x - 1 : Nonpositive G R) : R⟦G⟧).support := by + rw [HahnSeries.mem_support] + change (((x : R⟦G⟧) - 1).coeff 0) ≠ 0 + rw [HahnSeries.coeff_sub, HahnSeries.coeff_one, ite_eq_left rfl] + exact sub_ne_zero.mpr hnot.2 + have htop : (⊤ : ArchimedeanClass G) = d := hd ⟨hzeroSupport, hzeroSubSupport⟩ + exact (FiniteArchimedeanClass.mk (x : R⟦G⟧).order horder).prop + (hdLeading.trans htop.symm) + rcases hconstant with hzero | hone + · exact Or.inl (tau_eq_zero_of_support_nonzero_class x horder hzero hclass) + · right + rw [tau_eq_C_constantCoeff_of_support_nonzero_class x horder hclass, hone] + exact map_one C + · intro htau + refine isReduced_of_support_inter_support_sub_one_subset hx + (ArchimedeanClass.mk (x : R⟦G⟧).order) ?_ + intro g hg + have hgSupport := hg.1 + have hg0 : g ≠ 0 := by + intro hzero + subst g + rcases htau with htau | htau + · have hcoeff := congrArg + (fun y : Nonpositive G R ↦ (y : R⟦G⟧).coeff 0) htau + rw [coeff_tau_of_mem _ _ (zero_mem _)] at hcoeff + exact ((HahnSeries.mem_support _ _).mp hgSupport) hcoeff + · have hcoeff := congrArg + (fun y : Nonpositive G R ↦ (y : R⟦G⟧).coeff 0) htau + rw [coeff_tau_of_mem _ _ (zero_mem _)] at hcoeff + change (x : R⟦G⟧).coeff 0 = (1 : R⟦G⟧).coeff 0 at hcoeff + simp only [HahnSeries.coeff_one] at hcoeff + have hsubCoeff := (HahnSeries.mem_support _ _).mp hg.2 + change (((x : R⟦G⟧) - 1).coeff 0) ≠ 0 at hsubCoeff + rw [HahnSeries.coeff_sub, HahnSeries.coeff_one, hcoeff] at hsubCoeff + simp at hsubCoeff + have hle := leadingClass_le_mk_of_mem_support x horder hgSupport hg0 + have hnlt : ¬ leadingClass x horder < FiniteArchimedeanClass.mk g hg0 := by + intro hlt + have hball : g ∈ ball K (leadingClass x horder) := + (FiniteArchimedeanClass.mem_ball_iff K).mpr fun _ ↦ hlt + rcases htau with htau | htau + · have hcoeff := congrArg + (fun y : Nonpositive G R ↦ (y : R⟦G⟧).coeff g) htau + rw [coeff_tau_of_mem _ _ hball] at hcoeff + exact ((HahnSeries.mem_support _ _).mp hgSupport) hcoeff + · have hcoeff := congrArg + (fun y : Nonpositive G R ↦ (y : R⟦G⟧).coeff g) htau + rw [coeff_tau_of_mem _ _ hball] at hcoeff + change (x : R⟦G⟧).coeff g = (1 : R⟦G⟧).coeff g at hcoeff + simp only [HahnSeries.coeff_one, ite_eq_right hg0] at hcoeff + exact ((HahnSeries.mem_support _ _).mp hgSupport) hcoeff + have heq : leadingClass x horder = FiniteArchimedeanClass.mk g hg0 := + le_antisymm hle (not_lt.mp hnlt) + have hval := congrArg Subtype.val heq + simpa using hval.symm + +end HahnSeries.Nonpositive diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/ReducedDivisibility.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/ReducedDivisibility.lean new file mode 100644 index 0000000000..7a0a9d3623 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/ReducedDivisibility.lean @@ -0,0 +1,115 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.ReducedCharacterization + +/-! +# Divisibility after LM24 reduction + +This module proves the reduction-algebra core of LM24, Proposition 8.2.8. At the leading class +of a reduced nonconstant series `b`, divisibility of the closed truncation `T(c)` by `b` is +equivalent to divisibility of `rho(c)` by `b`. Proposition 8.2.1, which identifies divisibility +of `c` with divisibility of `T(c)`, is the remaining ambient-series bridge. +-/ + +public noncomputable section + +namespace HahnSeries.Nonpositive + +open FiniteArchimedeanClass HahnEmbedding + +variable {K G R : Type*} +variable [DivisionRing K] [LinearOrder K] [IsOrderedRing K] [Archimedean K] +variable [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] +variable [Module K G] [IsOrderedModule K G] +variable [Field R] + +private theorem reductionQuotient_dvd_T + (u : HahnEmbedding.ArchimedeanStrata K G) (c : FiniteArchimedeanClass G) + (x : Nonpositive G R) (htau : tau (K := K) c x ≠ 0) : + reductionQuotient u c x + (fun hzero ↦ htau ((tauBall_eq_zero_iff c x).mp hzero)) ∣ + T (K := K) c x := by + refine ⟨tau (K := K) c x, ?_⟩ + exact (reductionQuotient_mul_tau u c x + (fun hzero ↦ htau ((tauBall_eq_zero_iff c x).mp hzero))).symm + +/-- LM24's reduction always divides the corresponding closed-class truncation. -/ +theorem rho_dvd_T (u : HahnEmbedding.ArchimedeanStrata K G) + (c : FiniteArchimedeanClass G) (x : Nonpositive G R) : + rho u c x ∣ T (K := K) c x := by + by_cases htau : tau (K := K) c x = 0 + · rw [rho_of_tau_eq_zero u c x htau] + · rw [rho_of_tau_ne_zero u c x htau] + exact reductionQuotient_dvd_T u c x htau + +/-- The reduction-algebra core of LM24, Proposition 8.2.8. For a reduced nonconstant `b`, +divisibility of `T(c)` by `b` is equivalent to divisibility of `rho(c)` by `b`. -/ +theorem dvd_T_iff_dvd_rho_leadingClass + (u : HahnEmbedding.ArchimedeanStrata K G) (b : Nonpositive G R) (hb0 : b ≠ 0) + (horder : (b : R⟦G⟧).order ≠ 0) (hbReduced : IsReduced b) + (c : Nonpositive G R) : + b ∣ T (K := K) (leadingClass b horder) c ↔ + b ∣ rho u (leadingClass b horder) c := by + let sigma := leadingClass b horder + have hTb : T (K := K) sigma b = b := T_leadingClass b horder + have htaub : tau (K := K) sigma b = 0 ∨ tau (K := K) sigma b = 1 := + (isReduced_iff_tau_leadingClass_eq_zero_or_one b hb0 horder).mp hbReduced + constructor + · rintro ⟨e, hce⟩ + have hTe : T (K := K) sigma e = e := by + apply mul_left_cancel₀ hb0 + calc + b * T (K := K) sigma e = + T (K := K) sigma b * T (K := K) sigma e := by rw [hTb] + _ = T (K := K) sigma (b * e) := + ((T (K := K) sigma).map_mul b e).symm + _ = T (K := K) sigma (T (K := K) sigma c) := by rw [hce] + _ = T (K := K) sigma c := T_T sigma c + _ = b * e := hce + have htauMul : tau (K := K) sigma c = + tau (K := K) sigma b * tau (K := K) sigma e := by + calc + tau (K := K) sigma c = + tau (K := K) sigma (T (K := K) sigma c) := (tau_T sigma c).symm + _ = tau (K := K) sigma (b * e) := by rw [hce] + _ = tau (K := K) sigma b * tau (K := K) sigma e := + (tau (K := K) sigma).map_mul b e + by_cases htauc : tau (K := K) sigma c = 0 + · rw [rho_of_tau_eq_zero u sigma c htauc] + exact ⟨e, hce⟩ + · have htaue : tau (K := K) sigma e ≠ 0 := by + intro he + apply htauc + rw [htauMul, he, mul_zero] + have htaubOne : tau (K := K) sigma b = 1 := htaub.resolve_left (by + intro hb + apply htauc + rw [htauMul, hb, zero_mul]) + have htaucEq : tau (K := K) sigma c = tau (K := K) sigma e := by + rw [htauMul, htaubOne, one_mul] + rw [rho_of_tau_ne_zero u sigma c htauc] + let qC := reductionQuotient u sigma c + (fun hzero ↦ htauc ((tauBall_eq_zero_iff sigma c).mp hzero)) + let qE := reductionQuotient u sigma e + (fun hzero ↦ htaue ((tauBall_eq_zero_iff sigma e).mp hzero)) + refine ⟨qE, ?_⟩ + apply mul_right_cancel₀ htauc + have hqC : qC * tau (K := K) sigma c = T (K := K) sigma c := + reductionQuotient_mul_tau u sigma c _ + have hqE : qE * tau (K := K) sigma e = T (K := K) sigma e := + reductionQuotient_mul_tau u sigma e _ + calc + qC * tau (K := K) sigma c = T (K := K) sigma c := hqC + _ = b * e := hce + _ = b * T (K := K) sigma e := by rw [hTe] + _ = b * (qE * tau (K := K) sigma e) := by rw [hqE] + _ = (b * qE) * tau (K := K) sigma c := by rw [mul_assoc, htaucEq] + · intro hdiv + exact dvd_trans hdiv (rho_dvd_T u sigma c) + +end HahnSeries.Nonpositive diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/ReducedPrimality.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/ReducedPrimality.lean new file mode 100644 index 0000000000..1088bf9822 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/ReducedPrimality.lean @@ -0,0 +1,93 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Primality.Primality +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.CardinalProposition922 +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.NonpositiveDomainEquiv +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Divisibility.PrimalPreimage + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.CharZero + +/-! +# Primality of reduced Hahn integer-part series + +LM24's reduction at the leading Archimedean class transfers primality from a real-exponent Hahn +series to a reduced element of a cardinal-bounded Hahn integer part. Polynomiality of the +real-exponent series ring supplies this primality without a finite-degree hypothesis. +-/ + +public noncomputable section + +open Cardinal FiniteArchimedeanClass +open scoped HahnSeries + +namespace HahnSeries.Nonpositive + +variable {G K : Type*} +variable [LinearOrder G] [AddCommGroup G] [IsOrderedAddMonoid G] [Field K] [CharZero K] + +/-- A nonpositive Hahn series whose exponent group is order-isomorphic to `ℝ` is primal. -/ +theorem isPrimal_of_orderIso_real (e : G ≃+o ℝ) (a : Nonpositive G K) : IsPrimal a := + (RingEquiv.isPrimal_iff (embDomainRingEquiv e) a).mp + (Berarducci.isPrimal (embDomainRingEquiv e a)) + +end HahnSeries.Nonpositive + +namespace HahnSeries.Nonpositive + +variable {K G R : Type*} {κ : Cardinal} +variable [DivisionRing K] [LinearOrder K] [IsOrderedRing K] [Archimedean K] +variable [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] +variable [Module K G] [IsOrderedModule K G] +variable [Field R] [CharZero R] [Fact (ℵ₀ < κ)] + +/-- A nonzero reduced bounded Hahn integer-part series is primal under the leading-class +Archimedean hypotheses. -/ +@[blueprint "cor:reduced-hahn-integer-part-primal" + (phase := "Finitely many Archimedean classes") + (title := "Primality of reduced bounded Hahn integer-part series") + (statement := /-- + Let $K$ be an Archimedean ordered division ring, $G$ an ordered + $K$-vector space, $R$ a field of characteristic $0$, $\kappa>\aleph_0$ a + regular cardinal, and $Z\subseteq R$ a subring. For every nonzero + Archimedean class $\tau$ of $G$, fix a complement $H_\tau$ of + $G_{\prec\tau}$ in $G_{\preceq\tau}$, and write + $L_\tau:=R((G_{\prec\tau}))_\kappa$. Let + $b\in Z+R((G^{<0}))_\kappa$ be reduced, with nonzero underlying series and + nonzero order, and let $\sigma$ be its leading Archimedean class. If + $H_\sigma\simeq\mathbb R$ as ordered additive groups, and either + $G_{\prec\sigma}$ has cofinality at least $\kappa$ or + $G_{\prec\sigma}=\{0\}$ and every element of $R$ is a fraction of elements + of $Z$, then $b$ is primal in $Z+R((G^{<0}))_\kappa$. + -/) + (proof := /-- + By \ref{fact:leading-class-primality-transfer}, primality of $b$ is equivalent + to primality of $\iota_\sigma(T_\sigma b)$ in + $L_\sigma((H_\sigma^{\le 0}))$. Transport the exponent group through + $H_\sigma\simeq\mathbb R$. By \ref{thm:hahn-series-primality}, the + transported series is primal in + $L_\sigma((\mathbb R^{\le 0}))$, so the equivalence transfers primality back + to $b$. + -/)] +theorem isPrimal_of_isReduced_of_leadingClass_orderIso_real + [Fact κ.IsRegular] + (u : HahnEmbedding.ArchimedeanStrata K G) (Z : Subring R) + (b : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) + (hb0 : CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b ≠ 0) + (horder : ((CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b : + Nonpositive G R) : R⟦G⟧).order ≠ 0) + (hbReduced : IsReduced (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b)) + (hA2 : LM24.AssumptionA2AtFiniteClass (K := K) κ Z + (leadingClass (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b) horder)) + (e : u.stratum + (leadingClass (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b) horder) ≃+o ℝ) : + IsPrimal b := + (isPrimal_iff_isPrimal_splitTruncationCardSuppLT_of_isReduced + u Z b hb0 horder hbReduced hA2).mpr (isPrimal_of_orderIso_real e _) + +end HahnSeries.Nonpositive diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Reduction.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Reduction.lean new file mode 100644 index 0000000000..ac059e954d --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Reduction.lean @@ -0,0 +1,564 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.ArchimedeanSplitting +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.ClassTruncation +public import Mathlib.RingTheory.HahnSeries.Summable + +/-! +# Reduction at an Archimedean class + +LM24, Definition 8.2.4 divides the closed-class truncation `T_σ(x)` by the open-class +truncation `τ_σ(x)` when the latter is nonzero. This module establishes the structural facts +needed for that division. Under the iterated Hahn-series presentation `ι_σ`, `τ_σ(x)` is a +coefficient-series scalar, while `T_σ(x)` has only nonpositive outer exponents. + +The scalar statement is essential: the inverse of a negative monomial has positive exponent, so +the quotient cannot be justified by claiming that the full nonpositive Hahn-series ring is closed +under inversion. +-/ + +public noncomputable section + +namespace HahnSeries.Nonpositive + +open FiniteArchimedeanClass HahnEmbedding + +variable {K G R : Type*} +variable [DivisionRing K] [LinearOrder K] [IsOrderedRing K] [Archimedean K] +variable [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] +variable [Module K G] [IsOrderedModule K G] +variable [Field R] + +/-- The ordered inclusion of a closed Archimedean ball into the ambient exponent group. -/ +def closedBallOrderEmbedding (c : FiniteArchimedeanClass G) : closedBall K c ↪o G where + toFun := (↑) + inj' := Subtype.val_injective + map_rel_iff' := Iff.rfl + +@[simp] +theorem closedBallOrderEmbedding_apply (c : FiniteArchimedeanClass G) + (g : closedBall K c) : closedBallOrderEmbedding c g = (g : G) := + (rfl) + +/-- The ordered inclusion of an open Archimedean ball into the ambient exponent group. -/ +def ballOrderEmbedding (c : FiniteArchimedeanClass G) : ball K c ↪o G where + toFun := (↑) + inj' := Subtype.val_injective + map_rel_iff' := Iff.rfl + +@[simp] +theorem ballOrderEmbedding_apply (c : FiniteArchimedeanClass G) (g : ball K c) : + ballOrderEmbedding c g = (g : G) := + (rfl) + +/-- The closed-class truncation, with its exponent domain restricted to the closed ball. -/ +def TClosed (c : FiniteArchimedeanClass G) (x : Nonpositive G R) : R⟦closedBall K c⟧ := + HahnSeries.restrictDomain (closedBallOrderEmbedding c) + ((T (K := K) c x : Nonpositive G R) : R⟦G⟧) + +/-- The closed-class truncation is exponent-domain restriction of the ambient truncation. -/ +theorem TClosed_eq (c : FiniteArchimedeanClass G) (x : Nonpositive G R) : + TClosed (K := K) c x = + HahnSeries.restrictDomain (closedBallOrderEmbedding c) + ((T (K := K) c x : Nonpositive G R) : R⟦G⟧) := + (rfl) + +@[simp] +theorem TClosed_coeff (c : FiniteArchimedeanClass G) (x : Nonpositive G R) + (g : closedBall K c) : + (TClosed (K := K) c x).coeff g = + ((T (K := K) c x : Nonpositive G R) : R⟦G⟧).coeff g := by + rw [TClosed, HahnSeries.restrictDomain_coeff] + rfl + +/-- The open-class truncation, with its exponent domain restricted to the open ball. -/ +def tauBall (c : FiniteArchimedeanClass G) (x : Nonpositive G R) : R⟦ball K c⟧ := + HahnSeries.restrictDomain (ballOrderEmbedding c) + ((tau (K := K) c x : Nonpositive G R) : R⟦G⟧) + +@[simp] +theorem tauBall_coeff (c : FiniteArchimedeanClass G) (x : Nonpositive G R) + (g : ball K c) : + (tauBall (K := K) c x).coeff g = + ((tau (K := K) c x : Nonpositive G R) : R⟦G⟧).coeff g := by + rw [tauBall, HahnSeries.restrictDomain_coeff] + rfl + +/-- The open-class truncation, regarded as a series on the containing closed ball. -/ +def tauClosed (c : FiniteArchimedeanClass G) (x : Nonpositive G R) : + R⟦closedBall K c⟧ := + HahnSeries.restrictDomain (closedBallOrderEmbedding c) + ((tau (K := K) c x : Nonpositive G R) : R⟦G⟧) + +/-- Under the Archimedean splitting, the open-class truncation is a scalar coefficient series. -/ +theorem archimedeanSplitRingEquiv_tauClosed + (u : HahnEmbedding.ArchimedeanStrata K G) (c : FiniteArchimedeanClass G) + (x : Nonpositive G R) : + HahnSeries.archimedeanSplitRingEquiv u c (tauClosed c x) = + HahnSeries.C (tauBall c x) := by + ext s b + rw [HahnSeries.archimedeanSplitRingEquiv_coeff] + rw [tauClosed, HahnSeries.restrictDomain_coeff] + by_cases hs : s = 0 + · subst s + change ((tau (K := K) c x : Nonpositive G R) : R⟦G⟧).coeff + (HahnEmbedding.ArchimedeanStrata.stratumLexBallEquivClosedBall u c + (toLex (0, b)) : G) = _ + rw [HahnEmbedding.ArchimedeanStrata.stratumLexBallEquivClosedBall_apply] + have hcoe0 : ((0 : u.stratum c) : G) = 0 := rfl + rw [show (ofLex (toLex ((0 : u.stratum c), b))).1 = 0 by rfl, + show (ofLex (toLex ((0 : u.stratum c), b))).2 = b by rfl, hcoe0, zero_add] + exact + (show ((tau (K := K) c x : Nonpositive G R) : R⟦G⟧).coeff (b : G) = + ((HahnSeries.C (tauBall c x)).coeff 0).coeff b by + rw [coeff_tau_of_mem (K := K) c x b.2] + rw [HahnSeries.C_apply, HahnSeries.coeff_single_same] + rw [tauBall, HahnSeries.restrictDomain_coeff] + change (x : R⟦G⟧).coeff (b : G) = + ((tau (K := K) c x : Nonpositive G R) : R⟦G⟧).coeff (b : G) + exact (coeff_tau_of_mem (K := K) c x b.2).symm) + · have hnotmem : + (HahnEmbedding.ArchimedeanStrata.stratumLexBallEquivClosedBall u c + (toLex (s, b)) : G) ∉ ball K c := by + intro hmem + have hsball : (s : G) ∈ ball K c := by + rw [HahnEmbedding.ArchimedeanStrata.stratumLexBallEquivClosedBall_apply] at hmem + simpa using sub_mem hmem b.2 + have hzero : (s : G) = 0 := + Submodule.disjoint_def.mp (u.disjoint_ball_stratum c) (s : G) hsball s.2 + exact hs (Subtype.ext hzero) + change ((tau (K := K) c x : Nonpositive G R) : R⟦G⟧).coeff + (HahnEmbedding.ArchimedeanStrata.stratumLexBallEquivClosedBall u c + (toLex (s, b)) : G) = _ + rw [coeff_tau_of_not_mem (K := K) c x hnotmem] + simp [hs] + +/-- The outer constant coefficient of the split closed-class truncation is the open-class +truncation. This is LM24's identity `π(ισ(Tσ(x))) = τσ(x)`. -/ +theorem coeff_zero_archimedeanSplitRingEquiv_TClosed + (u : HahnEmbedding.ArchimedeanStrata K G) (c : FiniteArchimedeanClass G) + (x : Nonpositive G R) : + (HahnSeries.archimedeanSplitRingEquiv u c (TClosed c x)).coeff 0 = + tauBall c x := by + ext b + rw [HahnSeries.archimedeanSplitRingEquiv_coeff] + rw [TClosed, HahnSeries.restrictDomain_coeff] + change ((T (K := K) c x : Nonpositive G R) : R⟦G⟧).coeff + (HahnEmbedding.ArchimedeanStrata.stratumLexBallEquivClosedBall u c + (toLex (0, b)) : G) = _ + rw [HahnEmbedding.ArchimedeanStrata.stratumLexBallEquivClosedBall_apply] + have hcoe0 : ((0 : u.stratum c) : G) = 0 := rfl + simp only [ofLex_toLex, hcoe0, zero_add] + rw [coeff_T_of_mem (K := K) c x + ((FiniteArchimedeanClass.ball_lt_closedBall (K := K)).le b.2)] + rw [tauBall, HahnSeries.restrictDomain_coeff] + exact (coeff_tau_of_mem (K := K) c x b.2).symm + +/-- The split closed-class truncation has no positive outer exponent. -/ +theorem support_archimedeanSplitRingEquiv_TClosed_subset + (u : HahnEmbedding.ArchimedeanStrata K G) (c : FiniteArchimedeanClass G) + (x : Nonpositive G R) : + (HahnSeries.archimedeanSplitRingEquiv u c (TClosed c x)).support ⊆ Set.Iic 0 := by + intro s hs + rw [HahnSeries.mem_support] at hs + obtain ⟨b, hb⟩ : ∃ b : ball K c, + ((HahnSeries.archimedeanSplitRingEquiv u c (TClosed c x)).coeff s).coeff b ≠ 0 := by + by_contra hall + push Not at hall + apply hs + ext b + exact hall b + rw [HahnSeries.archimedeanSplitRingEquiv_coeff] at hb + rw [TClosed, HahnSeries.restrictDomain_coeff] at hb + change ((T (K := K) c x : Nonpositive G R) : R⟦G⟧).coeff + (HahnEmbedding.ArchimedeanStrata.stratumLexBallEquivClosedBall u c + (toLex (s, b))) ≠ 0 at hb + rw [coeff_T_of_mem (K := K) c x + (HahnEmbedding.ArchimedeanStrata.stratumLexBallEquivClosedBall u c + (toLex (s, b))).2] at hb + have hnonpos := support_subset x hb + rw [HahnEmbedding.ArchimedeanStrata.stratumLexBallEquivClosedBall_apply] at hnonpos + simp only [ofLex_toLex] at hnonpos + change ((s : G) + (b : G)) ≤ 0 at hnonpos + have hlex : toLex (s, b) ≤ 0 := by + apply (HahnEmbedding.ArchimedeanStrata.stratumLexBallEquivClosedBall u c).map_le_map_iff'.mp + apply Subtype.coe_le_coe.mp + convert hnonpos using 1 <;> + simp [HahnEmbedding.ArchimedeanStrata.stratumLexBallEquivClosedBall_apply] + rcases Prod.Lex.le_iff.mp hlex with hsle | ⟨hszero, _⟩ + · exact hsle.le + · simpa using hszero.le + +private theorem support_div_C_subset {A H : Type*} [Field A] + [AddCommGroup H] [LinearOrder H] [IsOrderedAddMonoid H] + (x : A⟦H⟧) (a : A) : + (x / (HahnSeries.C a : A⟦H⟧)).support ⊆ x.support := by + intro h hh + rw [div_eq_mul_inv, ← map_inv₀ HahnSeries.C] at hh + obtain ⟨i, hi, j, hj, hij⟩ := HahnSeries.support_mul_subset hh + have hj0 : j = 0 := HahnSeries.support_single_subset hj + have hih : i = h := by simpa [hj0] using hij + simpa [hih] using hi + +/-- Dividing the split closed-class truncation by the open-class scalar does not introduce +positive outer exponents. -/ +theorem support_archimedeanSplitRingEquiv_TClosed_div_C_subset + (u : HahnEmbedding.ArchimedeanStrata K G) (c : FiniteArchimedeanClass G) + (x : Nonpositive G R) : + ((HahnSeries.archimedeanSplitRingEquiv u c (TClosed c x)) / + (HahnSeries.C (tauBall c x) : + (R⟦ball K c⟧)⟦u.stratum c⟧)).support ⊆ Set.Iic 0 := + (support_div_C_subset _ _).trans (support_archimedeanSplitRingEquiv_TClosed_subset u c x) + +/-- In the nonzero branch of LM24's reduction, the outer-zero coefficient of the quotient is +one. This rules out positive infinitesimal exponents at the only outer boundary where the outer +support condition alone would be insufficient. -/ +theorem coeff_zero_archimedeanSplitRingEquiv_TClosed_div_C + (u : HahnEmbedding.ArchimedeanStrata K G) (c : FiniteArchimedeanClass G) + (x : Nonpositive G R) (htau : tauBall (K := K) c x ≠ 0) : + (((HahnSeries.archimedeanSplitRingEquiv u c (TClosed c x)) / + (HahnSeries.C (tauBall c x) : + (R⟦ball K c⟧)⟦u.stratum c⟧)).coeff 0) = 1 := by + rw [div_eq_mul_inv] + rw [HahnSeries.C_apply, HahnSeries.inv_single] + simp only [neg_zero] + rw [HahnSeries.coeff_mul_single_zero] + rw [coeff_zero_archimedeanSplitRingEquiv_TClosed] + exact mul_inv_cancel₀ htau + +private def splitQuotient (u : HahnEmbedding.ArchimedeanStrata K G) + (c : FiniteArchimedeanClass G) (x : Nonpositive G R) : + (R⟦ball K c⟧)⟦u.stratum c⟧ := + HahnSeries.archimedeanSplitRingEquiv u c (TClosed c x) / + HahnSeries.C (tauBall c x) + +/-- If an iterated Hahn series has no positive outer exponents and its coefficient at outer +exponent zero has no positive inner exponents, then its image back on the closed Archimedean ball +has no positive exponents. -/ +theorem support_archimedeanSplitRingEquiv_symm_subset_Iic + (u : HahnEmbedding.ArchimedeanStrata K G) (c : FiniteArchimedeanClass G) + (y : (R⟦ball K c⟧)⟦u.stratum c⟧) + (hyOuter : y.support ⊆ Set.Iic 0) + (hyZero : (y.coeff 0).support ⊆ Set.Iic 0) : + ((HahnSeries.archimedeanSplitRingEquiv u c).symm y).support ⊆ Set.Iic 0 := by + intro g hg + let p := HahnEmbedding.ArchimedeanStrata.closedBallEquivStratumLexBall u c g + let s : u.stratum c := (ofLex p).1 + let b : ball K c := (ofLex p).2 + have hsplitBack : + HahnEmbedding.ArchimedeanStrata.stratumLexBallEquivClosedBall u c p = g := + ArchimedeanStrata.stratumLexBallEquivClosedBall_closedBallEquivStratumLexBall + u c g + have hcoeff : (y.coeff s).coeff b ≠ 0 := by + have h := congrArg (fun z : (R⟦ball K c⟧)⟦u.stratum c⟧ ↦ + (z.coeff s).coeff b) + ((HahnSeries.archimedeanSplitRingEquiv u c).apply_symm_apply y) + rw [HahnSeries.archimedeanSplitRingEquiv_coeff] at h + rw [show HahnEmbedding.ArchimedeanStrata.stratumLexBallEquivClosedBall u c + (toLex (s, b)) = g by + change HahnEmbedding.ArchimedeanStrata.stratumLexBallEquivClosedBall u c p = g + exact hsplitBack] at h + exact fun hzero ↦ hg (h.trans hzero) + have hsupp : s ∈ y.support := by + rw [HahnSeries.mem_support] + intro hzero + exact hcoeff (congrArg (fun z : R⟦ball K c⟧ ↦ z.coeff b) hzero) + have hsnonpos : s ≤ 0 := hyOuter hsupp + rcases hsnonpos.eq_or_lt with hs0 | hsneg + · have hbzero : b ≤ 0 := by + apply hyZero + rw [HahnSeries.mem_support] + simpa [hs0] using hcoeff + have hpnonpos : p ≤ 0 := by + apply Prod.Lex.le_iff.mpr + exact Or.inr ⟨hs0, hbzero⟩ + rw [← hsplitBack, ← + (HahnEmbedding.ArchimedeanStrata.stratumLexBallEquivClosedBall u c).map_zero] + apply + (HahnEmbedding.ArchimedeanStrata.stratumLexBallEquivClosedBall u c).map_le_map_iff'.mpr + exact hpnonpos + · have hpneg : p < 0 := Prod.Lex.lt_iff.mpr (Or.inl hsneg) + have hgneg : g < 0 := by + rw [← hsplitBack] + apply lt_of_not_ge + intro hge + rw [← + (HahnEmbedding.ArchimedeanStrata.stratumLexBallEquivClosedBall u c).map_zero] at hge + let e := HahnEmbedding.ArchimedeanStrata.stratumLexBallEquivClosedBall u c + have hpge : 0 ≤ p := by + exact e.map_le_map_iff'.mp hge + exact (not_le_of_gt hpneg) hpge + exact hgneg.le + +private theorem support_splitQuotient_symm_subset + (u : HahnEmbedding.ArchimedeanStrata K G) (c : FiniteArchimedeanClass G) + (x : Nonpositive G R) (htau : tauBall (K := K) c x ≠ 0) : + ((HahnSeries.archimedeanSplitRingEquiv u c).symm + (splitQuotient u c x)).support ⊆ Set.Iic 0 := by + apply support_archimedeanSplitRingEquiv_symm_subset_Iic u c + · exact support_archimedeanSplitRingEquiv_TClosed_div_C_subset u c x + · change + ((((HahnSeries.archimedeanSplitRingEquiv u c (TClosed c x)) / + HahnSeries.C (tauBall c x)).coeff 0).support ⊆ Set.Iic 0) + rw [coeff_zero_archimedeanSplitRingEquiv_TClosed_div_C u c x htau] + intro b hb + exact (HahnSeries.support_single_subset hb).le + +/-- The nonzero quotient branch in LM24, Definition 8.2.4, as a nonpositive Hahn series. -/ +def reductionQuotient (u : HahnEmbedding.ArchimedeanStrata K G) + (c : FiniteArchimedeanClass G) (x : Nonpositive G R) + (htau : tauBall (K := K) c x ≠ 0) : Nonpositive G R := + ⟨HahnSeries.embDomain (closedBallOrderEmbedding c) + ((HahnSeries.archimedeanSplitRingEquiv u c).symm (splitQuotient u c x)), by + change (HahnSeries.embDomain (closedBallOrderEmbedding c) + ((HahnSeries.archimedeanSplitRingEquiv u c).symm + (splitQuotient u c x))).support ⊆ Set.Iic 0 + rw [HahnSeries.support_embDomain] + rintro _ ⟨g, hg, rfl⟩ + exact support_splitQuotient_symm_subset u c x htau hg⟩ + +/-- In the nonzero branch of LM24's reduction, the coefficient at the exponent zero is one: the +outer-zero coefficient of the split quotient is the constant one. -/ +theorem coeff_zero_reductionQuotient (u : HahnEmbedding.ArchimedeanStrata K G) + (c : FiniteArchimedeanClass G) (x : Nonpositive G R) + (htau : tauBall (K := K) c x ≠ 0) : + ((reductionQuotient u c x htau : Nonpositive G R) : R⟦G⟧).coeff 0 = 1 := by + change (HahnSeries.embDomain (closedBallOrderEmbedding c) + ((HahnSeries.archimedeanSplitRingEquiv u c).symm (splitQuotient u c x))).coeff 0 = 1 + have h0 : (0 : G) = closedBallOrderEmbedding (K := K) c 0 := by + rw [closedBallOrderEmbedding_apply]; rfl + rw [h0, HahnSeries.embDomain_coeff] + have hsplit := HahnSeries.archimedeanSplitRingEquiv_coeff u c + ((HahnSeries.archimedeanSplitRingEquiv u c).symm (splitQuotient u c x)) 0 0 + rw [RingEquiv.apply_symm_apply] at hsplit + have hzero : HahnEmbedding.ArchimedeanStrata.stratumLexBallEquivClosedBall u c + (toLex ((0 : u.stratum c), (0 : ball K c))) = 0 := by + apply Subtype.ext + rw [HahnEmbedding.ArchimedeanStrata.stratumLexBallEquivClosedBall_apply] + simp + rw [hzero] at hsplit + rw [← hsplit] + change ((HahnSeries.archimedeanSplitRingEquiv u c (TClosed c x) / + HahnSeries.C (tauBall c x)).coeff 0).coeff 0 = 1 + rw [coeff_zero_archimedeanSplitRingEquiv_TClosed_div_C u c x htau] + rw [HahnSeries.coeff_one, ite_eq_left rfl] + +/-- LM24's `ρ_σ`: divide the closed-class truncation by the open-class truncation when the +latter is nonzero, and otherwise retain the closed-class truncation. -/ +def rho (u : HahnEmbedding.ArchimedeanStrata K G) + (c : FiniteArchimedeanClass G) (x : Nonpositive G R) : Nonpositive G R := + by + classical + exact if htau : tauBall (K := K) c x = 0 then T (K := K) c x + else reductionQuotient u c x htau + +/-- The open-ball restriction vanishes exactly when the original open-class truncation does. -/ +theorem tauBall_eq_zero_iff (c : FiniteArchimedeanClass G) (x : Nonpositive G R) : + tauBall (K := K) c x = 0 ↔ tau (K := K) c x = 0 := by + constructor + · intro hzero + apply Subtype.ext + ext g + by_cases hg : g ∈ ball K c + · have hcoeff := congrArg (fun y : R⟦ball K c⟧ ↦ + y.coeff ⟨g, hg⟩) hzero + rw [tauBall, HahnSeries.restrictDomain_coeff] at hcoeff + change ((tau (K := K) c x : Nonpositive G R) : R⟦G⟧).coeff g = 0 at hcoeff + exact hcoeff + · rw [coeff_tau_of_not_mem (K := K) c x hg] + simp + · intro hzero + ext b + rw [tauBall, HahnSeries.restrictDomain_coeff] + change ((tau (K := K) c x : Nonpositive G R) : R⟦G⟧).coeff (b : G) = 0 + rw [hzero] + simp + +/-- Restricting an open-class truncation equal to one to its open ball yields one. -/ +theorem tauBall_eq_one_of_tau_eq_one (c : FiniteArchimedeanClass G) + (x : Nonpositive G R) (htau : tau (K := K) c x = 1) : + tauBall (K := K) c x = 1 := by + ext b + rw [tauBall, HahnSeries.restrictDomain_coeff] + change ((tau (K := K) c x : Nonpositive G R) : R⟦G⟧).coeff (b : G) = _ + rw [htau] + simp + +/-- In the zero branch, LM24's reduction is the closed-class truncation. -/ +theorem rho_of_tau_eq_zero (u : HahnEmbedding.ArchimedeanStrata K G) + (c : FiniteArchimedeanClass G) (x : Nonpositive G R) + (htau : tau (K := K) c x = 0) : + rho u c x = T (K := K) c x := by + rw [rho] + split + · rfl + · rename_i hne + exact (hne ((tauBall_eq_zero_iff c x).mpr htau)).elim + +/-- In the nonzero branch, LM24's reduction uses the quotient constructed through the +Archimedean splitting. -/ +theorem rho_of_tau_ne_zero (u : HahnEmbedding.ArchimedeanStrata K G) + (c : FiniteArchimedeanClass G) (x : Nonpositive G R) + (htau : tau (K := K) c x ≠ 0) : + rho u c x = reductionQuotient u c x + (fun hzero ↦ htau ((tauBall_eq_zero_iff c x).mp hzero)) := by + rw [rho] + split + · rename_i hzero + exact (htau ((tauBall_eq_zero_iff c x).mp hzero)).elim + · rfl + +theorem support_T_subset_range (c : FiniteArchimedeanClass G) + (x : Nonpositive G R) : + ((T (K := K) c x : Nonpositive G R) : R⟦G⟧).support ⊆ + Set.range (closedBallOrderEmbedding (K := K) c) := by + intro g hg + have hmem : g ∈ closedBall K c := by + by_contra hnot + exact hg (coeff_T_of_not_mem (K := K) c x hnot) + exact ⟨⟨g, hmem⟩, rfl⟩ + +private theorem support_tau_subset_range (c : FiniteArchimedeanClass G) + (x : Nonpositive G R) : + ((tau (K := K) c x : Nonpositive G R) : R⟦G⟧).support ⊆ + Set.range (closedBallOrderEmbedding (K := K) c) := by + intro g hg + have hmem : g ∈ closedBall K c := by + by_contra hnot + have hnotBall : g ∉ ball K c := fun hball ↦ + hnot ((FiniteArchimedeanClass.ball_lt_closedBall (K := K)).le hball) + exact hg (coeff_tau_of_not_mem (K := K) c x hnotBall) + exact ⟨⟨g, hmem⟩, rfl⟩ + +theorem embDomain_TClosed (c : FiniteArchimedeanClass G) + (x : Nonpositive G R) : + HahnSeries.embDomain (closedBallOrderEmbedding (K := K) c) (TClosed (K := K) c x) = + ((T (K := K) c x : Nonpositive G R) : R⟦G⟧) := + HahnSeries.embDomain_restrictDomain _ _ (support_T_subset_range c x) + +/-- The closed-class truncation with its exponent domain restricted, as a ring homomorphism. -/ +def TClosedRingHom (c : FiniteArchimedeanClass G) : + Nonpositive G R →+* R⟦closedBall K c⟧ where + toFun := TClosed c + map_zero' := by + ext g + rw [TClosed, HahnSeries.restrictDomain_coeff, map_zero] + rfl + map_one' := by + ext g + rw [TClosed, HahnSeries.restrictDomain_coeff, map_one] + change (1 : R⟦G⟧).coeff (g : G) = (1 : R⟦closedBall K c⟧).coeff g + simp + map_add' x y := by + ext g + rw [TClosed, HahnSeries.restrictDomain_coeff, map_add] + change (((T (K := K) c x : Nonpositive G R) : R⟦G⟧) + + ((T (K := K) c y : Nonpositive G R) : R⟦G⟧)).coeff (g : G) = _ + rw [HahnSeries.coeff_add, HahnSeries.coeff_add] + rw [TClosed, TClosed, HahnSeries.restrictDomain_coeff, + HahnSeries.restrictDomain_coeff] + rfl + map_mul' x y := by + apply (HahnSeries.embDomain_injective + (R := R) (f := closedBallOrderEmbedding (K := K) c)) + rw [HahnSeries.embDomain_mul (f := closedBallOrderEmbedding (K := K) c) + (fun _ _ ↦ rfl)] + change HahnSeries.embDomain (closedBallOrderEmbedding (K := K) c) + (TClosed (K := K) c (x * y)) = _ + rw [embDomain_TClosed] + rw [map_mul] + change ((T (K := K) c x : Nonpositive G R) : R⟦G⟧) * + ((T (K := K) c y : Nonpositive G R) : R⟦G⟧) = _ + rw [← embDomain_TClosed, ← embDomain_TClosed] + +@[simp] +theorem TClosedRingHom_apply (c : FiniteArchimedeanClass G) (x : Nonpositive G R) : + TClosedRingHom (K := K) c x = TClosed c x := + (rfl) + +private theorem embDomain_tauClosed (c : FiniteArchimedeanClass G) + (x : Nonpositive G R) : + HahnSeries.embDomain (closedBallOrderEmbedding (K := K) c) (tauClosed (K := K) c x) = + ((tau (K := K) c x : Nonpositive G R) : R⟦G⟧) := + HahnSeries.embDomain_restrictDomain _ _ (support_tau_subset_range c x) + +/-- The nonzero reduction quotient multiplied by the open-class truncation recovers the +closed-class truncation. This is the defining quotient identity from LM24, Definition 8.2.4. -/ +theorem reductionQuotient_mul_tau (u : HahnEmbedding.ArchimedeanStrata K G) + (c : FiniteArchimedeanClass G) (x : Nonpositive G R) + (htau : tauBall (K := K) c x ≠ 0) : + reductionQuotient u c x htau * tau (K := K) c x = T (K := K) c x := by + apply Subtype.ext + change HahnSeries.embDomain (closedBallOrderEmbedding c) + ((HahnSeries.archimedeanSplitRingEquiv u c).symm (splitQuotient u c x)) * + ((tau (K := K) c x : Nonpositive G R) : R⟦G⟧) = + ((T (K := K) c x : Nonpositive G R) : R⟦G⟧) + rw [← embDomain_tauClosed (K := K) c x, ← embDomain_TClosed (K := K) c x] + rw [← HahnSeries.embDomain_mul (f := closedBallOrderEmbedding (K := K) c) + (fun _ _ ↦ rfl)] + apply congrArg (HahnSeries.embDomain (closedBallOrderEmbedding (K := K) c)) + apply (HahnSeries.archimedeanSplitRingEquiv u c).injective + rw [map_mul, RingEquiv.apply_symm_apply] + rw [archimedeanSplitRingEquiv_tauClosed] + change splitQuotient u c x * HahnSeries.C (tauBall c x) = + HahnSeries.archimedeanSplitRingEquiv u c (TClosed c x) + rw [splitQuotient, div_eq_mul_inv, mul_assoc] + let a : (R⟦ball K c⟧)⟦u.stratum c⟧ := HahnSeries.C (tauBall c x) + have hC : a ≠ 0 := HahnSeries.C_ne_zero htau + have hinv : a⁻¹ * a = 1 := by + rw [mul_comm] + exact Field.mul_inv_cancel a hC + change HahnSeries.archimedeanSplitRingEquiv u c (TClosed c x) * (a⁻¹ * a) = _ + rw [hinv, mul_one] + +/-- At a class containing the whole series, a nonzero fixed point of `rho` has open truncation +zero or one. This is the fixed-class core of LM24, Proposition 8.2.5 (3) iff (4). -/ +theorem rho_eq_self_iff_tau_eq_zero_or_one + (u : HahnEmbedding.ArchimedeanStrata K G) (c : FiniteArchimedeanClass G) + (x : Nonpositive G R) (hx : x ≠ 0) (hT : T (K := K) c x = x) : + rho u c x = x ↔ tau (K := K) c x = 0 ∨ tau (K := K) c x = 1 := by + constructor + · intro hrho + by_cases htau : tau (K := K) c x = 0 + · exact Or.inl htau + · right + have hmul := reductionQuotient_mul_tau u c x + (fun hzero ↦ htau ((tauBall_eq_zero_iff c x).mp hzero)) + rw [← rho_of_tau_ne_zero u c x htau, hrho, hT] at hmul + exact mul_left_cancel₀ hx (hmul.trans (mul_one x).symm) + · rintro (htau | htau) + · rw [rho_of_tau_eq_zero u c x htau, hT] + · have htauNe : tau (K := K) c x ≠ 0 := by rw [htau]; exact one_ne_zero + have hmul := reductionQuotient_mul_tau u c x + (fun hzero ↦ htauNe ((tauBall_eq_zero_iff c x).mp hzero)) + have hmul' : reductionQuotient u c x + (fun hzero ↦ htauNe ((tauBall_eq_zero_iff c x).mp hzero)) = x := by + have hone : reductionQuotient u c x + (fun hzero ↦ htauNe ((tauBall_eq_zero_iff c x).mp hzero)) * 1 = + reductionQuotient u c x + (fun hzero ↦ htauNe ((tauBall_eq_zero_iff c x).mp hzero)) := + mul_one _ + exact hone.symm.trans ((congrArg + (fun t : Nonpositive G R ↦ reductionQuotient u c x + (fun hzero ↦ htauNe ((tauBall_eq_zero_iff c x).mp hzero)) * t) + htau.symm).trans (hmul.trans hT)) + exact (rho_of_tau_ne_zero u c x htauNe).trans hmul' + +/-- At the class of a nonzero, nonconstant series' lowest exponent, LM24's reduction fixes the +series exactly when its open-class truncation is zero or one. This is Proposition 8.2.5 +`(3) ↔ (4)` away from the separate constant-series case. -/ +theorem rho_leadingClass_eq_self_iff_tau_eq_zero_or_one + (u : HahnEmbedding.ArchimedeanStrata K G) (x : Nonpositive G R) (hx : x ≠ 0) + (horder : (x : R⟦G⟧).order ≠ 0) : + rho u (leadingClass x horder) x = x ↔ + tau (K := K) (leadingClass x horder) x = 0 ∨ + tau (K := K) (leadingClass x horder) x = 1 := + rho_eq_self_iff_tau_eq_zero_or_one u (leadingClass x horder) x hx + (T_leadingClass x horder) + +end HahnSeries.Nonpositive diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Refinement.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Refinement.lean new file mode 100644 index 0000000000..c213598ddb --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Refinement.lean @@ -0,0 +1,20 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Refinement.CardinalGermRefinement +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Refinement.CardinalTruncationClosedClass +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Refinement.ClosedClassRefinementTransport +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Refinement.CompleteGermRefinement +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Refinement.ConvexRestrictionFactorization +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Refinement.FiniteGermError +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Refinement.LimitTailRefinement +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Refinement.SupportClassFactorization +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Refinement.SupportClassRefinement +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Refinement.TruncationIntegerPartFractionField + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Refinement/CardinalGermRefinement.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Refinement/CardinalGermRefinement.lean new file mode 100644 index 0000000000..67aee2c3a7 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Refinement/CardinalGermRefinement.lean @@ -0,0 +1,330 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Order.ArchimedeanQuotient +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Refinement.CompleteGermRefinement +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.DomainEmbedding +public import LeanPool.ConwayRefinement.ConwayRefinement.Topology.Order.SmallClosedSubspace +public import Mathlib.RingTheory.HahnSeries.Cardinal +public import Mathlib.SetTheory.Cardinal.Regular + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint + +/-! +# Cardinal-bounded germ refinement + +Four cardinal-bounded generalised power series and a cardinal-bounded positive coinitial family +lie in one Cauchy-complete closed rational subspace. Germ refinement inside that subspace produces +factors with well-ordered support. Although the subspace itself may be large, density of the +original rational span bounds each such support by the prescribed cardinal. +-/ + +open Cardinal Set +open scoped HahnSeries + +universe u v + +public noncomputable section + +namespace HahnSeries.Nonpositive + +variable {C : Type u} {K : Type v} +variable [AddCommGroup C] [LinearOrder C] [IsOrderedAddMonoid C] + [UniformSpace C] [IsUniformAddGroup C] [OrderTopology C] [Nontrivial C] [CompleteSpace C] + [Field K] [CharZero K] + +private theorem exists_mapDomain_germ_eq + {D : Type u} + [AddCommGroup D] [LinearOrder D] [IsOrderedAddMonoid D] + [UniformSpace D] [IsUniformAddGroup D] [OrderTopology D] [Nontrivial D] [CompleteSpace D] + (inc : D →+ C) (hinc : Function.Injective inc) + (hincOrder : ∀ x y : D, inc x ≤ inc y ↔ x ≤ y) + (x y : Nonpositive D K) + (hxy : ∃ r < (0 : D), ∀ q > r, + (x : HahnSeries D K).coeff q = (y : HahnSeries D K).coeff q) : + ∃ r < (0 : C), ∀ q > r, + (mapDomain inc hinc hincOrder x : HahnSeries C K).coeff q = + (mapDomain inc hinc hincOrder y : HahnSeries C K).coeff q := by + let JD := (cantorBendixsonValuation (G := D) (R := K)).supp + let JC := (cantorBendixsonValuation (G := C) (R := K)).supp + have mapMemSupp (z : Nonpositive D K) (hz : z ∈ JD) : + mapDomain inc hinc hincOrder z ∈ JC := by + rw [mem_cantorBendixsonValuation_supp] at hz ⊢ + obtain ⟨r, hr, hzr⟩ := hz + refine ⟨inc r, ?_, ?_⟩ + · have hle : inc r ≤ inc 0 := (hincOrder r 0).mpr hr.le + rw [map_zero] at hle + exact lt_of_le_of_ne hle (fun h ↦ hr.ne (hinc (by simpa using h))) + rw [support_mapDomain] + rintro _ ⟨q, hq, rfl⟩ + exact (hincOrder q r).mpr (hzr hq) + apply cantorBendixson_germ_eq_iff _ _ |>.mp + apply Ideal.Quotient.eq.mpr + change mapDomain inc hinc hincOrder x - mapDomain inc hinc hincOrder y ∈ JC + rw [← map_sub] + exact mapMemSupp _ + (Ideal.Quotient.eq.mp (cantorBendixson_germ_eq_iff x y |>.mpr hxy)) + +private theorem mapDomain_refinement + {D : Type u} + [AddCommGroup D] [LinearOrder D] [IsOrderedAddMonoid D] + [UniformSpace D] [IsUniformAddGroup D] [OrderTopology D] [Nontrivial D] [CompleteSpace D] + (inc : D →+ C) (hinc : Function.Injective inc) + (hincOrder : ∀ x y : D, inc x ≤ inc y ↔ x ≤ y) + (a b c d e f g h : Nonpositive D K) + (hea : ∃ r < (0 : D), ∀ q > r, + (a : HahnSeries D K).coeff q = (e * f : Nonpositive D K).1.coeff q) + (heb : ∃ r < (0 : D), ∀ q > r, + (b : HahnSeries D K).coeff q = (g * h : Nonpositive D K).1.coeff q) + (hec : ∃ r < (0 : D), ∀ q > r, + (c : HahnSeries D K).coeff q = (e * g : Nonpositive D K).1.coeff q) + (hed : ∃ r < (0 : D), ∀ q > r, + (d : HahnSeries D K).coeff q = (f * h : Nonpositive D K).1.coeff q) : + (∃ r < (0 : C), ∀ q > r, + (mapDomain inc hinc hincOrder a : HahnSeries C K).coeff q = + (mapDomain inc hinc hincOrder (e * f) : HahnSeries C K).coeff q) ∧ + (∃ r < (0 : C), ∀ q > r, + (mapDomain inc hinc hincOrder b : HahnSeries C K).coeff q = + (mapDomain inc hinc hincOrder (g * h) : HahnSeries C K).coeff q) ∧ + (∃ r < (0 : C), ∀ q > r, + (mapDomain inc hinc hincOrder c : HahnSeries C K).coeff q = + (mapDomain inc hinc hincOrder (e * g) : HahnSeries C K).coeff q) ∧ + ∃ r < (0 : C), ∀ q > r, + (mapDomain inc hinc hincOrder d : HahnSeries C K).coeff q = + (mapDomain inc hinc hincOrder (f * h) : HahnSeries C K).coeff q := + ⟨exists_mapDomain_germ_eq inc hinc hincOrder a (e * f) hea, + exists_mapDomain_germ_eq inc hinc hincOrder b (g * h) heb, + exists_mapDomain_germ_eq inc hinc hincOrder c (e * g) hec, + exists_mapDomain_germ_eq inc hinc hincOrder d (f * h) hed⟩ + +private theorem exists_cardinal_refinement_mapDomain + {D : Type u} {κ : Cardinal.{u}} + [AddCommGroup D] [LinearOrder D] [IsOrderedAddMonoid D] + [UniformSpace D] [IsUniformAddGroup D] [OrderTopology D] [Nontrivial D] [CompleteSpace D] + (inc : D →+ C) (hinc : Function.Injective inc) + (hincOrder : ∀ x y : D, inc x ≤ inc y ↔ x ≤ y) + (hDsupport : ∀ z : Nonpositive D K, + (z : HahnSeries D K).cardSupp < κ) + (a b c d : Nonpositive C K) (a₀ b₀ c₀ d₀ e₀ f₀ g₀ h₀ : Nonpositive D K) + (ha₀ : mapDomain inc hinc hincOrder a₀ = a) + (hb₀ : mapDomain inc hinc hincOrder b₀ = b) + (hc₀ : mapDomain inc hinc hincOrder c₀ = c) + (hd₀ : mapDomain inc hinc hincOrder d₀ = d) + (hea : ∃ r < (0 : D), ∀ q > r, + (a₀ : HahnSeries D K).coeff q = (e₀ * f₀ : Nonpositive D K).1.coeff q) + (heb : ∃ r < (0 : D), ∀ q > r, + (b₀ : HahnSeries D K).coeff q = (g₀ * h₀ : Nonpositive D K).1.coeff q) + (hec : ∃ r < (0 : D), ∀ q > r, + (c₀ : HahnSeries D K).coeff q = (e₀ * g₀ : Nonpositive D K).1.coeff q) + (hed : ∃ r < (0 : D), ∀ q > r, + (d₀ : HahnSeries D K).coeff q = (f₀ * h₀ : Nonpositive D K).1.coeff q) : + ∃ e f g h : Nonpositive C K, + (∃ r < (0 : C), ∀ q > r, + (a : HahnSeries C K).coeff q = (e * f : Nonpositive C K).1.coeff q) ∧ + (∃ r < (0 : C), ∀ q > r, + (b : HahnSeries C K).coeff q = (g * h : Nonpositive C K).1.coeff q) ∧ + (∃ r < (0 : C), ∀ q > r, + (c : HahnSeries C K).coeff q = (e * g : Nonpositive C K).1.coeff q) ∧ + (∃ r < (0 : C), ∀ q > r, + (d : HahnSeries C K).coeff q = (f * h : Nonpositive C K).1.coeff q) ∧ + (e : HahnSeries C K).cardSupp < κ ∧ + (f : HahnSeries C K).cardSupp < κ ∧ + (g : HahnSeries C K).cardSupp < κ ∧ + (h : HahnSeries C K).cardSupp < κ := by + let e := mapDomain inc hinc hincOrder e₀ + let f := mapDomain inc hinc hincOrder f₀ + let g := mapDomain inc hinc hincOrder g₀ + let h := mapDomain inc hinc hincOrder h₀ + have cardMap (z : Nonpositive D K) : + (mapDomain inc hinc hincOrder z : HahnSeries C K).cardSupp < κ := by + rw [HahnSeries.cardSupp, support_mapDomain] + exact Cardinal.mk_image_le.trans_lt (by + simpa only [HahnSeries.cardSupp] using hDsupport z) + obtain ⟨hea', heb', hec', hed'⟩ := + mapDomain_refinement inc hinc hincOrder a₀ b₀ c₀ d₀ e₀ f₀ g₀ h₀ hea heb hec hed + refine ⟨e, f, g, h, ?_, ?_, ?_, ?_, cardMap e₀, cardMap f₀, cardMap g₀, cardMap h₀⟩ + · simpa only [ha₀, map_mul] using hea' + · simpa only [hb₀, map_mul] using heb' + · simpa only [hc₀, map_mul] using hec' + · simpa only [hd₀, map_mul] using hed' + +variable [Module ℚ C] [PosSMulMono ℚ C] [DenselyOrdered C] + [NoMaxOrder (FiniteArchimedeanClass C)] + +/-- Cauchy-complete germ refinement preserves a cardinal support bound. -/ +@[blueprint "thm:cardinal-bounded-germ-refinement" + (phase := "Refinement over Archimedean classes") + (title := "Cardinal-bounded refinement modulo series bounded away from zero") + (statement := /-- + Let $C$ be an ordered rational vector space that is Cauchy complete for its + additive uniformity and whose nonzero Archimedean classes have no least + element in the magnitude order. Let $K$ be a field of characteristic zero + and let $\kappa>\aleph_0$. If $C$ has a positive coinitial subset of + cardinality less than $\kappa$, then every equation $ab=cd$ among four + $\kappa$-bounded series in $K((C^{\le 0}))$ admits a four-factor refinement + modulo series bounded strictly below zero whose four factors are also + $\kappa$-bounded. + -/) + (proof := /-- + Put the supports of $a,b,c,d$ and the chosen positive coinitial set into + one closed rational subspace $C_0$. + The coinitial set remains positive and coinitial in $C_0$; hence $C_0$ is + nontrivial, has no endpoints, and its nonzero Archimedean classes have no + least element in the magnitude order. As a closed subspace of $C$, it is + Cauchy complete for its additive uniformity, and its induced order topology + and rational vector-space structure satisfy the remaining hypotheses of + \ref{thm:complete-hahn-germ-refinement}. Apply that theorem over $C_0$, + and then map the four factors back to $C$. Each factor has well-ordered + support in $C_0$. By + \ref{lem:well-ordered-subset-closed-rational-span-cardinality}, such a + support has cardinality less than $\kappa$. + -/)] +theorem exists_cardinal_germ_refinement + {κ : Cardinal.{u}} [Fact (ℵ₀ < κ)] + (E : Set C) (hEcard : #E < κ) + (hEcoinitial : ∀ y : C, 0 < y → ∃ x ∈ E, 0 < x ∧ x ≤ y) + (a b c d : Nonpositive C K) + (ha : (a : HahnSeries C K).cardSupp < κ) + (hb : (b : HahnSeries C K).cardSupp < κ) + (hc : (c : HahnSeries C K).cardSupp < κ) + (hd : (d : HahnSeries C K).cardSupp < κ) + (habcd : a * b = c * d) : + ∃ e f g h : Nonpositive C K, + (∃ r < (0 : C), ∀ q > r, + (a : HahnSeries C K).coeff q = (e * f : Nonpositive C K).1.coeff q) ∧ + (∃ r < (0 : C), ∀ q > r, + (b : HahnSeries C K).coeff q = (g * h : Nonpositive C K).1.coeff q) ∧ + (∃ r < (0 : C), ∀ q > r, + (c : HahnSeries C K).coeff q = (e * g : Nonpositive C K).1.coeff q) ∧ + (∃ r < (0 : C), ∀ q > r, + (d : HahnSeries C K).coeff q = (f * h : Nonpositive C K).1.coeff q) ∧ + (e : HahnSeries C K).cardSupp < κ ∧ + (f : HahnSeries C K).cardSupp < κ ∧ + (g : HahnSeries C K).cardSupp < κ ∧ + (h : HahnSeries C K).cardSupp < κ := by + let S : Set C := + (a : HahnSeries C K).support ∪ (b : HahnSeries C K).support ∪ + (c : HahnSeries C K).support ∪ (d : HahnSeries C K).support ∪ E + have hκ : ℵ₀ ≤ κ := (Fact.out : ℵ₀ < κ).le + have hS : #S < κ := by + have ha' : #(a : HahnSeries C K).support < κ := by + simpa only [HahnSeries.cardSupp] using ha + have hb' : #(b : HahnSeries C K).support < κ := by + simpa only [HahnSeries.cardSupp] using hb + have hc' : #(c : HahnSeries C K).support < κ := by + simpa only [HahnSeries.cardSupp] using hc + have hd' : #(d : HahnSeries C K).support < κ := by + simpa only [HahnSeries.cardSupp] using hd + exact (Cardinal.mk_union_le _ _).trans_lt (Cardinal.add_lt_of_lt hκ + ((Cardinal.mk_union_le _ _).trans_lt (Cardinal.add_lt_of_lt hκ + ((Cardinal.mk_union_le _ _).trans_lt (Cardinal.add_lt_of_lt hκ + ((Cardinal.mk_union_le _ _).trans_lt (Cardinal.add_lt_of_lt hκ ha' hb')) hc')) hd')) + hEcard) + let C₀ := (Submodule.span ℚ S).topologicalClosure + let inc : C₀ →+ C := C₀.subtype + have hinc : Function.Injective inc := Subtype.val_injective + have hincOrder : ∀ x y : C₀, inc x ≤ inc y ↔ x ≤ y := fun _ _ ↦ Iff.rfl + have hcoinitial : ∀ y : C, 0 < y → ∃ x : C₀, 0 < (x : C) ∧ (x : C) ≤ y := by + intro y hy + obtain ⟨x, hxE, hx, hxy⟩ := hEcoinitial y hy + have hxS : x ∈ S := by + exact Or.inr hxE + exact ⟨⟨x, (Submodule.span ℚ S).le_topologicalClosure + (Submodule.subset_span hxS)⟩, hx, hxy⟩ + let y : C := Classical.choose (exists_ne (0 : C)) + have hy : y ≠ 0 := Classical.choose_spec (exists_ne (0 : C)) + have habsy : 0 < |y| := abs_pos.mpr hy + have hSne : S.Nonempty := by + obtain ⟨x, hxE, -⟩ := hEcoinitial |y| habsy + exact ⟨x, Or.inr hxE⟩ + let : NoMaxOrder (FiniteArchimedeanClass C₀) := + AddSubgroup.finiteArchimedeanClass_noMax_of_pos_coinitial C₀.toAddSubgroup hcoinitial + let : NoMinOrder C₀ := ⟨fun x ↦ by + obtain ⟨z, hz, -⟩ := hcoinitial |y| habsy + exact ⟨x - z, sub_lt_self x hz⟩⟩ + let : NoMaxOrder C₀ := ⟨fun x ↦ by + obtain ⟨z, hz, -⟩ := hcoinitial |y| habsy + exact ⟨x + z, lt_add_of_pos_right x hz⟩⟩ + let : OrderTopology C₀ := by + apply induced_orderTopology' (fun z : C₀ ↦ (z : C)) (fun {_ _} ↦ Iff.rfl) + · intro x y hyx + obtain ⟨z, hzpos, hzle⟩ := hcoinitial ((x : C) - y) (sub_pos.mpr hyx) + refine ⟨x - z, sub_lt_self x hzpos, ?_⟩ + simpa [sub_le_iff_le_add] using sub_le_sub_left hzle (x : C) + · intro x y hxy + obtain ⟨z, hzpos, hzle⟩ := hcoinitial (y - (x : C)) (sub_pos.mpr hxy) + refine ⟨x + z, lt_add_of_pos_right x hzpos, ?_⟩ + change (x : C) + (z : C) ≤ y + rw [add_comm] + exact le_sub_iff_add_le.mp hzle + let : PosSMulMono ℚ C₀ := { + smul_le_smul_of_nonneg_left := fun {q} hq {_ _} hxy ↦ + smul_le_smul_of_nonneg_left (α := ℚ) (β := C) hxy hq } + let : PosSMulStrictMono ℚ C₀ := + PosSMulMono.toPosSMulStrictMono (α := ℚ) (β := C₀) + let : DenselyOrdered C₀ := by + constructor + intro x y hxy + refine ⟨(2 : ℚ)⁻¹ • (x + y), ?_, ?_⟩ + · calc + x = (2 : ℚ)⁻¹ • (x + x) := by rw [smul_add, ← add_smul]; norm_num + _ < (2 : ℚ)⁻¹ • (x + y) := smul_lt_smul_of_pos_left + (add_lt_add_left hxy x |>.trans_eq (add_comm _ _)) (by norm_num) + · calc + (2 : ℚ)⁻¹ • (x + y) < (2 : ℚ)⁻¹ • (y + y) := + smul_lt_smul_of_pos_left + (by simpa [add_comm] using add_lt_add_left hxy y) (by norm_num) + _ = y := by rw [smul_add, ← add_smul]; norm_num + let : IsUniformAddGroup C₀ := C₀.toAddSubgroup.isUniformAddGroup + let : Nontrivial C₀ := by + obtain ⟨z, hz, -⟩ := hcoinitial |y| habsy + exact ⟨⟨0, z, ne_of_lt hz⟩⟩ + have haRange : (a : HahnSeries C K).support ⊆ Set.range inc := by + intro q hq + exact ⟨⟨q, (Submodule.span ℚ S).le_topologicalClosure + (Submodule.subset_span (Or.inl (Or.inl (Or.inl (Or.inl hq)))))⟩, rfl⟩ + have hbRange : (b : HahnSeries C K).support ⊆ Set.range inc := by + intro q hq + exact ⟨⟨q, (Submodule.span ℚ S).le_topologicalClosure + (Submodule.subset_span (Or.inl (Or.inl (Or.inl (Or.inr hq)))))⟩, rfl⟩ + have hcRange : (c : HahnSeries C K).support ⊆ Set.range inc := by + intro q hq + exact ⟨⟨q, (Submodule.span ℚ S).le_topologicalClosure + (Submodule.subset_span (Or.inl (Or.inl (Or.inr hq))))⟩, rfl⟩ + have hdRange : (d : HahnSeries C K).support ⊆ Set.range inc := by + intro q hq + exact ⟨⟨q, (Submodule.span ℚ S).le_topologicalClosure + (Submodule.subset_span (Or.inl (Or.inr hq)))⟩, rfl⟩ + let a₀ := restrictDomain inc hinc hincOrder a + let b₀ := restrictDomain inc hinc hincOrder b + let c₀ := restrictDomain inc hinc hincOrder c + let d₀ := restrictDomain inc hinc hincOrder d + have habcd₀ : a₀ * b₀ = c₀ * d₀ := by + apply mapDomain_injective inc hinc hincOrder + rw [map_mul, map_mul, mapDomain_restrictDomain inc hinc hincOrder a haRange, + mapDomain_restrictDomain inc hinc hincOrder b hbRange, + mapDomain_restrictDomain inc hinc hincOrder c hcRange, + mapDomain_restrictDomain inc hinc hincOrder d hdRange, habcd] + obtain ⟨e₀, f₀, g₀, h₀, hea, heb, hec, hed⟩ := + exists_germ_refinement_of_complete_exponent_group a₀ b₀ c₀ d₀ habcd₀ + have ha₀ : mapDomain inc hinc hincOrder a₀ = a := + mapDomain_restrictDomain inc hinc hincOrder a haRange + have hb₀ : mapDomain inc hinc hincOrder b₀ = b := + mapDomain_restrictDomain inc hinc hincOrder b hbRange + have hc₀ : mapDomain inc hinc hincOrder c₀ = c := + mapDomain_restrictDomain inc hinc hincOrder c hcRange + have hd₀ : mapDomain inc hinc hincOrder d₀ = d := + mapDomain_restrictDomain inc hinc hincOrder d hdRange + have hC₀support (z : Nonpositive C₀ K) : + (z : HahnSeries C₀ K).cardSupp < κ := by + rw [HahnSeries.cardSupp] + exact Submodule.mk_lt_of_isPWO_topologicalClosure_span S hS hSne + (z : HahnSeries C₀ K).support (z : HahnSeries C₀ K).isPWO_support + exact exists_cardinal_refinement_mapDomain inc hinc hincOrder hC₀support + a b c d a₀ b₀ c₀ d₀ e₀ f₀ g₀ h₀ ha₀ hb₀ hc₀ hd₀ hea heb hec hed + +end HahnSeries.Nonpositive diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Refinement/CardinalTruncationClosedClass.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Refinement/CardinalTruncationClosedClass.lean new file mode 100644 index 0000000000..4a70f2fd21 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Refinement/CardinalTruncationClosedClass.lean @@ -0,0 +1,353 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.CardinalTruncationResidue +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Refinement.FiniteGermError + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint + +/-! +# Closed-class restrictions of cardinal-bounded Hahn series + +Restriction to a closed Archimedean ball preserves a support-cardinality bound. Since the ball +contains zero, it also preserves the constant coefficient and hence every truncation integer part +defined by a coefficient subring. +-/ + +public noncomputable section + +open scoped HahnSeries + +universe u v + +namespace HahnSeries + +variable {G : Type u} {L : Type v} {κ : Cardinal.{u}} +variable [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] +variable [Field L] [Fact (Cardinal.aleph0 < κ)] + +namespace CardSuppLTNonpositive + +/-- Package a nonpositive Hahn series with an explicit support-cardinality bound. -/ +def ofNonpositive (x : Nonpositive G L) (hx : (x : L⟦G⟧).cardSupp < κ) : + CardSuppLTNonpositive (G := G) (L := L) (κ := κ) := + ⟨⟨x, (mem_cardSuppLTSubfield (Γ := G) (R := L) (κ := κ)).mpr hx⟩, by + rw [mem_cardSuppLTTruncationIntegerPart] + exact ⟨x.2, Subring.mem_top _⟩⟩ + +/-- Forgetting the cardinal-bound package recovers the original nonpositive series. -/ +@[simp] +theorem coe_ofNonpositive (x : Nonpositive G L) (hx : (x : L⟦G⟧).cardSupp < κ) : + ((ofNonpositive x hx : CardSuppLTNonpositive (G := G) (L := L) (κ := κ)) : + L⟦G⟧) = (x : L⟦G⟧) := + (rfl) + +/-- Forgetting the support bound from a packaged nonpositive series recovers that series. -/ +@[simp] +theorem toNonpositiveRingHom_ofNonpositive + (x : Nonpositive G L) (hx : (x : L⟦G⟧).cardSupp < κ) : + CardSuppLTTruncationIntegerPart.toNonpositiveRingHom (⊤ : Subring L) + (ofNonpositive x hx) = x := by + apply Subtype.ext + rw [CardSuppLTTruncationIntegerPart.coe_toNonpositiveRingHom] + exact coe_ofNonpositive x hx + +/-- Forgetting a residue-subring presentation gives the same nonpositive series as forgetting +the original truncation integer part. -/ +@[simp] +theorem toNonpositiveRingHom_truncationIntegerPartEquivResidueSubring + (S : Subring L) + (x : cardSuppLTTruncationIntegerPart (G := G) (R := L) (κ := κ) S) : + CardSuppLTTruncationIntegerPart.toNonpositiveRingHom (⊤ : Subring L) + ((truncationIntegerPartEquivResidueSubring S x : + Subring.residueSubring constantCoeffAlgHom S) : + CardSuppLTNonpositive (G := G) (L := L) (κ := κ)) = + CardSuppLTTruncationIntegerPart.toNonpositiveRingHom S x := by + apply Subtype.ext + rw [CardSuppLTTruncationIntegerPart.coe_toNonpositiveRingHom, + coe_truncationIntegerPartEquivResidueSubring, + CardSuppLTTruncationIntegerPart.coe_toNonpositiveRingHom] + +/-- Restrict a cardinal-bounded nonpositive series to a closed Archimedean ball. -/ +def closedClassRestrict (q : FiniteArchimedeanClass G) + (x : CardSuppLTNonpositive (G := G) (L := L) (κ := κ)) : + CardSuppLTNonpositive (G := G) (L := L) (κ := κ) := by + let xN := CardSuppLTTruncationIntegerPart.toNonpositiveRingHom (⊤ : Subring L) x + let xr := Nonpositive.closedClassRestrict q xN + have hxcard : (x : L⟦G⟧).cardSupp < κ := + (mem_cardSuppLTSubfield (Γ := G) (R := L) (κ := κ)).mp x.1.2 + have hxNcard : (xN : L⟦G⟧).cardSupp < κ := by + simpa only [xN, CardSuppLTTruncationIntegerPart.coe_toNonpositiveRingHom] using hxcard + exact ⟨⟨xr, (mem_cardSuppLTSubfield (Γ := G) (R := L) (κ := κ)).mpr + ((cardSupp_mono (Nonpositive.support_closedClassRestrict_subset q xN)).trans_lt + hxNcard)⟩, by + rw [mem_cardSuppLTTruncationIntegerPart] + exact ⟨xr.2, Subring.mem_top _⟩⟩ + +/-- Forgetting the cardinal bound exposes the ordinary closed-class restriction. -/ +@[simp] +theorem coe_closedClassRestrict (q : FiniteArchimedeanClass G) + (x : CardSuppLTNonpositive (G := G) (L := L) (κ := κ)) : + ((closedClassRestrict q x : CardSuppLTNonpositive (G := G) (L := L) (κ := κ)) : + L⟦G⟧) = + (Nonpositive.closedClassRestrict q + (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom (⊤ : Subring L) x) : + Nonpositive G L) := + (rfl) + +/-- Forgetting only the cardinal bound commutes with closed-class restriction. -/ +theorem toNonpositiveRingHom_closedClassRestrict (q : FiniteArchimedeanClass G) + (x : CardSuppLTNonpositive (G := G) (L := L) (κ := κ)) : + CardSuppLTTruncationIntegerPart.toNonpositiveRingHom (⊤ : Subring L) + (closedClassRestrict q x) = + Nonpositive.closedClassRestrict q + (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom (⊤ : Subring L) x) := by + apply Subtype.ext + rw [CardSuppLTTruncationIntegerPart.coe_toNonpositiveRingHom] + exact coe_closedClassRestrict q x + +/-- Closed-class restriction is multiplicative on cardinal-bounded nonpositive series. -/ +theorem closedClassRestrict_mul (q : FiniteArchimedeanClass G) + (x y : CardSuppLTNonpositive (G := G) (L := L) (κ := κ)) : + closedClassRestrict q (x * y) = + closedClassRestrict q x * closedClassRestrict q y := by + apply CardSuppLTTruncationIntegerPart.toNonpositiveRingHom_injective + (⊤ : Subring L) + rw [map_mul, toNonpositiveRingHom_closedClassRestrict, + toNonpositiveRingHom_closedClassRestrict, toNonpositiveRingHom_closedClassRestrict, + map_mul, Nonpositive.closedClassRestrict_mul] + +/-- Restriction at a class met by the support of a bounded nonpositive series is nonzero. -/ +theorem closedClassRestrict_ne_zero_of_mem_image_mk_support + (q : FiniteArchimedeanClass G) + (x : CardSuppLTNonpositive (G := G) (L := L) (κ := κ)) + (hq : q.1 ∈ ArchimedeanClass.mk '' (x : L⟦G⟧).support) : + closedClassRestrict q x ≠ 0 := by + intro hzero + have hzero' : Nonpositive.closedClassRestrict q + (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom (⊤ : Subring L) x) = 0 := by + apply Subtype.ext + exact congrArg (fun z : CardSuppLTNonpositive (G := G) (L := L) (κ := κ) ↦ + (z : L⟦G⟧)) hzero + apply Nonpositive.closedClassRestrict_ne_zero_of_mem_image_mk_support + (c := q) + (b := CardSuppLTTruncationIntegerPart.toNonpositiveRingHom (⊤ : Subring L) x) + · simpa only [CardSuppLTTruncationIntegerPart.coe_toNonpositiveRingHom] using hq + · exact hzero' + +end CardSuppLTNonpositive + +namespace CardSuppLTTruncationIntegerPart + +/-- Restriction to a closed Archimedean ball preserves a cardinal-bounded truncation integer +part. -/ +def closedClassRestrict (S : Subring L) (q : FiniteArchimedeanClass G) + (x : cardSuppLTTruncationIntegerPart (G := G) (R := L) (κ := κ) S) : + cardSuppLTTruncationIntegerPart (G := G) (R := L) (κ := κ) S := by + let xN := toNonpositiveRingHom S x + let xr := Nonpositive.closedClassRestrict q xN + have hxcard : (x : L⟦G⟧).cardSupp < κ := + (mem_cardSuppLTSubfield (Γ := G) (R := L) (κ := κ)).mp x.1.2 + have hxNcard : (xN : L⟦G⟧).cardSupp < κ := by + simpa only [xN, coe_toNonpositiveRingHom] using hxcard + have hxmem := (mem_cardSuppLTTruncationIntegerPart (Z := S)).mp x.2 + exact ⟨⟨xr, (mem_cardSuppLTSubfield (Γ := G) (R := L) (κ := κ)).mpr + ((cardSupp_mono (Nonpositive.support_closedClassRestrict_subset q xN)).trans_lt + hxNcard)⟩, by + rw [mem_cardSuppLTTruncationIntegerPart] + refine ⟨xr.2, ?_⟩ + rw [Nonpositive.closedClassRestrict_coeff, ite_eq_left] + · simpa only [xN, coe_toNonpositiveRingHom] using hxmem.2 + · exact (FiniteArchimedeanClass.closedBallAddSubgroup q).zero_mem⟩ + +/-- Forgetting the bound and residue condition exposes the ordinary closed-class restriction. -/ +@[simp] +theorem coe_closedClassRestrict (S : Subring L) (q : FiniteArchimedeanClass G) + (x : cardSuppLTTruncationIntegerPart (G := G) (R := L) (κ := κ) S) : + ((closedClassRestrict S q x : + cardSuppLTTruncationIntegerPart (G := G) (R := L) (κ := κ) S) : L⟦G⟧) = + (Nonpositive.closedClassRestrict q (toNonpositiveRingHom S x) : Nonpositive G L) := + (rfl) + +/-- Forgetting only the cardinal bound and residue condition commutes with closed-class +restriction. -/ +theorem toNonpositiveRingHom_closedClassRestrict (S : Subring L) + (q : FiniteArchimedeanClass G) + (x : cardSuppLTTruncationIntegerPart (G := G) (R := L) (κ := κ) S) : + toNonpositiveRingHom S (closedClassRestrict S q x) = + Nonpositive.closedClassRestrict q (toNonpositiveRingHom S x) := by + apply Subtype.ext + rw [coe_toNonpositiveRingHom] + exact coe_closedClassRestrict S q x + +/-- Restriction at a class met by the support of a cardinal-bounded integer part is nonzero. -/ +theorem closedClassRestrict_ne_zero_of_mem_image_mk_support + (S : Subring L) (q : FiniteArchimedeanClass G) + (x : cardSuppLTTruncationIntegerPart (G := G) (R := L) (κ := κ) S) + (hq : q.1 ∈ ArchimedeanClass.mk '' (x : L⟦G⟧).support) : + closedClassRestrict S q x ≠ 0 := by + intro hzero + have hzero' : Nonpositive.closedClassRestrict q (toNonpositiveRingHom S x) = 0 := by + rw [← toNonpositiveRingHom_closedClassRestrict] + simpa only [map_zero] using congrArg (toNonpositiveRingHom S) hzero + apply Nonpositive.closedClassRestrict_ne_zero_of_mem_image_mk_support + (c := q) (b := toNonpositiveRingHom S x) + · simpa only [coe_toNonpositiveRingHom] using hq + · exact hzero' + +/-- Closed-class restriction is multiplicative in every cardinal-bounded truncation integer +part. -/ +theorem closedClassRestrict_mul (S : Subring L) (q : FiniteArchimedeanClass G) + (x y : cardSuppLTTruncationIntegerPart (G := G) (R := L) (κ := κ) S) : + closedClassRestrict S q (x * y) = + closedClassRestrict S q x * closedClassRestrict S q y := by + apply toNonpositiveRingHom_injective S + rw [map_mul, toNonpositiveRingHom_closedClassRestrict, + toNonpositiveRingHom_closedClassRestrict, toNonpositiveRingHom_closedClassRestrict, + map_mul, Nonpositive.closedClassRestrict_mul] + +/-- An exact closed-class refinement by bounded nonpositive factors can be normalized inside a +cardinal-bounded truncation integer part. -/ +@[blueprint "lem:closed-class-refinement-normalization" + (phase := "Refinement over Archimedean classes") + (title := "Normalization of a closed-class refinement in a Hahn integer part") + (statement := /-- + Let $S\subseteq L$ be a subring of a field, let $q$ be a nonzero + Archimedean class of an ordered exponent group, and let + $a,b,c,d\in S+L((G^{<0}))_\kappa$ satisfy $ab=cd$. Assume the constant + coefficient of $a$ is primal in $S$, every element of $L$ is a fraction of + elements of $S$, and the closed-class restriction $a_q$ is nonzero. + + If the restrictions of $a,b,c,d$ admit a four-factor refinement by + $\kappa$-bounded nonpositive Hahn series, then they admit such a refinement + by elements of $S+L((G^{<0}))_\kappa$. + -/) + (proof := /-- + Regard the bounded Hahn integer part as the inverse image of $S$ under the + constant-coefficient homomorphism on bounded nonpositive series. The + primality of the constant coefficient of $a$ and the fraction-field + hypothesis allow a common scalar adjustment of the four ambient factors + so that all four constant coefficients lie in $S$. Transport the adjusted + refinement back through this residue-subring presentation. + -/)] +theorem exists_refinement_closedClassRestrict_of_ambient + (S : Subring L) (q : FiniteArchimedeanClass G) + (a b c d : cardSuppLTTruncationIntegerPart + (G := G) (R := L) (κ := κ) S) + (haS : IsPrimal (⟨(a : L⟦G⟧).coeff 0, + ((mem_cardSuppLTTruncationIntegerPart (Z := S)).mp a.2).2⟩ : S)) + (hfrac : Subring.fracSubring S = ⊤) + (ha0 : closedClassRestrict S q a ≠ 0) (habcd : a * b = c * d) + (e f g h : Nonpositive G L) + (hecard : (e : L⟦G⟧).cardSupp < κ) + (hfcard : (f : L⟦G⟧).cardSupp < κ) + (hgcard : (g : L⟦G⟧).cardSupp < κ) + (hhcard : (h : L⟦G⟧).cardSupp < κ) + (ha : Nonpositive.closedClassRestrict q (toNonpositiveRingHom S a) = + Nonpositive.closedClassRestrict q e * Nonpositive.closedClassRestrict q f) + (hb : Nonpositive.closedClassRestrict q (toNonpositiveRingHom S b) = + Nonpositive.closedClassRestrict q g * Nonpositive.closedClassRestrict q h) + (hc : Nonpositive.closedClassRestrict q (toNonpositiveRingHom S c) = + Nonpositive.closedClassRestrict q e * Nonpositive.closedClassRestrict q g) + (hd : Nonpositive.closedClassRestrict q (toNonpositiveRingHom S d) = + Nonpositive.closedClassRestrict q f * Nonpositive.closedClassRestrict q h) : + ∃ E F H₁ H₂ : cardSuppLTTruncationIntegerPart + (G := G) (R := L) (κ := κ) S, + closedClassRestrict S q a = E * F ∧ + closedClassRestrict S q b = H₁ * H₂ ∧ + closedClassRestrict S q c = E * H₁ ∧ + closedClassRestrict S q d = F * H₂ := by + let eb := CardSuppLTNonpositive.closedClassRestrict q + (CardSuppLTNonpositive.ofNonpositive e hecard) + let fb := CardSuppLTNonpositive.closedClassRestrict q + (CardSuppLTNonpositive.ofNonpositive f hfcard) + let gb := CardSuppLTNonpositive.closedClassRestrict q + (CardSuppLTNonpositive.ofNonpositive g hgcard) + let hbnd := CardSuppLTNonpositive.closedClassRestrict q + (CardSuppLTNonpositive.ofNonpositive h hhcard) + have hea : ((CardSuppLTNonpositive.truncationIntegerPartEquivResidueSubring S + (closedClassRestrict S q a) : + Subring.residueSubring CardSuppLTNonpositive.constantCoeffAlgHom S) : + CardSuppLTNonpositive (G := G) (L := L) (κ := κ)) = eb * fb := by + apply CardSuppLTTruncationIntegerPart.toNonpositiveRingHom_injective + (⊤ : Subring L) + rw [map_mul, + CardSuppLTNonpositive.toNonpositiveRingHom_truncationIntegerPartEquivResidueSubring, + CardSuppLTTruncationIntegerPart.toNonpositiveRingHom_closedClassRestrict, + CardSuppLTNonpositive.toNonpositiveRingHom_closedClassRestrict, + CardSuppLTNonpositive.toNonpositiveRingHom_closedClassRestrict, + CardSuppLTNonpositive.toNonpositiveRingHom_ofNonpositive, + CardSuppLTNonpositive.toNonpositiveRingHom_ofNonpositive] + exact ha + have heb : ((CardSuppLTNonpositive.truncationIntegerPartEquivResidueSubring S + (closedClassRestrict S q b) : + Subring.residueSubring CardSuppLTNonpositive.constantCoeffAlgHom S) : + CardSuppLTNonpositive (G := G) (L := L) (κ := κ)) = gb * hbnd := by + apply CardSuppLTTruncationIntegerPart.toNonpositiveRingHom_injective + (⊤ : Subring L) + rw [map_mul, + CardSuppLTNonpositive.toNonpositiveRingHom_truncationIntegerPartEquivResidueSubring, + CardSuppLTTruncationIntegerPart.toNonpositiveRingHom_closedClassRestrict, + CardSuppLTNonpositive.toNonpositiveRingHom_closedClassRestrict, + CardSuppLTNonpositive.toNonpositiveRingHom_closedClassRestrict, + CardSuppLTNonpositive.toNonpositiveRingHom_ofNonpositive, + CardSuppLTNonpositive.toNonpositiveRingHom_ofNonpositive] + exact hb + have hec : ((CardSuppLTNonpositive.truncationIntegerPartEquivResidueSubring S + (closedClassRestrict S q c) : + Subring.residueSubring CardSuppLTNonpositive.constantCoeffAlgHom S) : + CardSuppLTNonpositive (G := G) (L := L) (κ := κ)) = eb * gb := by + apply CardSuppLTTruncationIntegerPart.toNonpositiveRingHom_injective + (⊤ : Subring L) + rw [map_mul, + CardSuppLTNonpositive.toNonpositiveRingHom_truncationIntegerPartEquivResidueSubring, + CardSuppLTTruncationIntegerPart.toNonpositiveRingHom_closedClassRestrict, + CardSuppLTNonpositive.toNonpositiveRingHom_closedClassRestrict, + CardSuppLTNonpositive.toNonpositiveRingHom_closedClassRestrict, + CardSuppLTNonpositive.toNonpositiveRingHom_ofNonpositive, + CardSuppLTNonpositive.toNonpositiveRingHom_ofNonpositive] + exact hc + have hed : ((CardSuppLTNonpositive.truncationIntegerPartEquivResidueSubring S + (closedClassRestrict S q d) : + Subring.residueSubring CardSuppLTNonpositive.constantCoeffAlgHom S) : + CardSuppLTNonpositive (G := G) (L := L) (κ := κ)) = fb * hbnd := by + apply CardSuppLTTruncationIntegerPart.toNonpositiveRingHom_injective + (⊤ : Subring L) + rw [map_mul, + CardSuppLTNonpositive.toNonpositiveRingHom_truncationIntegerPartEquivResidueSubring, + CardSuppLTTruncationIntegerPart.toNonpositiveRingHom_closedClassRestrict, + CardSuppLTNonpositive.toNonpositiveRingHom_closedClassRestrict, + CardSuppLTNonpositive.toNonpositiveRingHom_closedClassRestrict, + CardSuppLTNonpositive.toNonpositiveRingHom_ofNonpositive, + CardSuppLTNonpositive.toNonpositiveRingHom_ofNonpositive] + exact hd + have haS' : IsPrimal + (⟨((closedClassRestrict S q a : + cardSuppLTTruncationIntegerPart (G := G) (R := L) (κ := κ) S) : + L⟦G⟧).coeff 0, + ((mem_cardSuppLTTruncationIntegerPart (Z := S)).mp + (closedClassRestrict S q a).2).2⟩ : S) := by + have hcoeff : + ((closedClassRestrict S q a : + cardSuppLTTruncationIntegerPart (G := G) (R := L) (κ := κ) S) : + L⟦G⟧).coeff 0 = (a : L⟦G⟧).coeff 0 := by + rw [coe_closedClassRestrict, Nonpositive.closedClassRestrict_coeff, ite_eq_left] + · exact congrArg (fun z : L⟦G⟧ ↦ z.coeff 0) (coe_toNonpositiveRingHom S a) + · exact (FiniteArchimedeanClass.closedBallAddSubgroup q).zero_mem + convert haS using 1 + apply Subtype.ext + exact hcoeff + have heq : closedClassRestrict S q a * closedClassRestrict S q b = + closedClassRestrict S q c * closedClassRestrict S q d := by + rw [← closedClassRestrict_mul, ← closedClassRestrict_mul, + habcd] + exact CardSuppLTNonpositive.exists_refinement_truncationIntegerPart_of_ambient + S haS' hfrac ha0 heq hea heb hec hed + +end CardSuppLTTruncationIntegerPart + +end HahnSeries diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Refinement/ClosedClassRefinementTransport.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Refinement/ClosedClassRefinementTransport.lean new file mode 100644 index 0000000000..9d21d7aaf5 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Refinement/ClosedClassRefinementTransport.lean @@ -0,0 +1,398 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Refinement.CardinalTruncationClosedClass +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.CardinalTruncationDomainEmbedding +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.ConvexQuotientSplitting +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Order.ArchimedeanBall +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Refinement.ConvexRestrictionFactorization + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint + +/-! +# Transporting refinement from a closed quotient class + +Closed-class restriction after convex quotient regrouping is ambient restriction to the preimage +of that class ball. This identifies exact quotient refinements with retained ambient factors and +allows truncation-divisibility to lift the two required divisibilities. +-/ + +public noncomputable section + +open scoped HahnSeries + +universe u v w + +namespace HahnSeries.CardSuppLTTruncationIntegerPart + +private theorem eq_symm_mul_symm_of_map_eq_mul + {A B : Type*} [Semiring A] [Semiring B] (E : A ≃+* B) + {t : A} {e f : B} (h : E t = e * f) : t = E.symm e * E.symm f := by + apply E.injective + have he : E (E.symm e) = e := E.apply_symm_apply e + have hf : E (E.symm f) = f := E.apply_symm_apply f + exact h.trans ((congrArg₂ (· * ·) he.symm hf.symm).trans (E.map_mul _ _).symm) + +variable {G : Type u} {R : Type v} {K : Type w} {κ : Cardinal.{u}} +variable [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] +variable [Field K] [Module K G] [Field R] +variable [Fact (Cardinal.aleph0 < κ)] [Fact κ.IsRegular] + +/-- Restriction to a closed quotient class is ambient restriction to the preimage of its closed +ball. -/ +@[blueprint "lem:quotient-regrouping-closed-ball-restriction" + (phase := "Refinement over Archimedean classes") + (title := "Closed-ball restriction under quotient regrouping") + (statement := /-- + Let $P$ be a convex subspace of an ordered vector space $G$, and regroup a + bounded Hahn series first by exponents in $G/P$ and then by exponents in + $P$. For an Archimedean class $q$ of $G/P$, restriction of the regrouped + series to the closed ball of $q$ is the regrouping of the original series + restricted to the inverse image of that ball in $G$. + -/) + (proof := /-- + Compare the coefficient at an outer exponent $\bar g\in G/P$ and an inner + exponent $p\in P$. If $\bar g$ lies in the closed ball of $q$, both sides + have the coefficient of the unique exponent of $G$ represented by + $(\bar g,p)$; otherwise both coefficients are zero. + -/)] +theorem convexQuotientSplit_filter_eq_closed_class_restrict + (P : Submodule K G) [P.toAddSubgroup.IsConvex] (Z : Subring R) + (q : FiniteArchimedeanClass (G ⧸ P)) + (x t : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) + (ht : (t : R⟦G⟧) = @HahnSeries.filter R G _ _ + (· ∈ (FiniteArchimedeanClass.closedBallAddSubgroup q).comap + P.mkQ.toAddMonoidHom) (Classical.decPred _) (x : R⟦G⟧)) : + cardSuppLTTruncationIntegerPartConvexQuotientSplitRingEquiv P Z t = + closedClassRestrict + (cardSuppLTTruncationIntegerPart (G := P) (R := R) (κ := κ) Z) q + (cardSuppLTTruncationIntegerPartConvexQuotientSplitRingEquiv P Z x) := by + classical + let D := FiniteArchimedeanClass.closedBallAddSubgroup q + apply Subtype.ext + apply Subtype.ext + ext z p + have hsplit : convexQuotientSplitRingEquiv P (t : R⟦G⟧) = + HahnSeries.filter (· ∈ D) (convexQuotientSplitRingEquiv P (x : R⟦G⟧)) := by + rw [ht] + exact convexQuotientSplitRingEquiv_filter_comap P D (x : R⟦G⟧) + have hz := congrArg (fun y : (R⟦P⟧)⟦G ⧸ P⟧ ↦ (y.coeff z).coeff p) hsplit + rw [HahnSeries.coeff_filter] at hz + have htcoeff := congrArg + (fun y : (R⟦P⟧)⟦G ⧸ P⟧ ↦ (y.coeff z).coeff p) + (boundedOuterCoefficientInclusion_split P t.1) + rw [boundedOuterCoefficientInclusion_coeff] at htcoeff + rw [coe_cardSuppLTTruncationIntegerPartConvexQuotientSplitRingEquiv] + rw [htcoeff] + rw [CardSuppLTTruncationIntegerPart.coe_closedClassRestrict, + Nonpositive.closedClassRestrict_coeff] + by_cases hzD : z ∈ D + · rw [ite_eq_left hzD] + change ((convexQuotientSplitRingEquiv P (t : R⟦G⟧)).coeff z).coeff p = _ + have hxcoeff := congrArg + (fun y : (R⟦P⟧)⟦G ⧸ P⟧ ↦ (y.coeff z).coeff p) + (boundedOuterCoefficientInclusion_split P x.1) + rw [boundedOuterCoefficientInclusion_coeff] at hxcoeff + rw [CardSuppLTTruncationIntegerPart.coe_toNonpositiveRingHom] + rw [coe_cardSuppLTTruncationIntegerPartConvexQuotientSplitRingEquiv] + rw [hxcoeff] + simpa only [D, ite_eq_left hzD] using hz + · rw [ite_eq_right hzD] + change ((convexQuotientSplitRingEquiv P (t : R⟦G⟧)).coeff z).coeff p = 0 + simpa only [D, ite_eq_right hzD, HahnSeries.coeff_zero] using hz + +private theorem ambient_factorization_of_closed_class_factorization + (P : Submodule K G) [P.toAddSubgroup.IsConvex] (Z : Subring R) + (q : FiniteArchimedeanClass (G ⧸ P)) + (a t : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) + (ht : t = restrictToAddSubgroup Z + ((FiniteArchimedeanClass.closedBallAddSubgroup q).comap P.mkQ.toAddMonoidHom) a) + (ht0 : t ≠ 0) + (e f : cardSuppLTTruncationIntegerPart (G := G ⧸ P) + (R := CardSuppLTField (G := P) (R := R) (κ := κ)) (κ := κ) + (cardSuppLTTruncationIntegerPart (G := P) (R := R) (κ := κ) Z)) + (ha : closedClassRestrict + (cardSuppLTTruncationIntegerPart (G := P) (R := R) (κ := κ) Z) q + (cardSuppLTTruncationIntegerPartConvexQuotientSplitRingEquiv P Z a) = e * f) : + let E := cardSuppLTTruncationIntegerPartConvexQuotientSplitRingEquiv + (R := R) (κ := κ) P Z + E t = e * f ∧ t = E.symm e * E.symm f ∧ e ≠ 0 ∧ f ≠ 0 := by + let E := cardSuppLTTruncationIntegerPartConvexQuotientSplitRingEquiv + (R := R) (κ := κ) P Z + have hEt : E t = e * f := by + rw [convexQuotientSplit_filter_eq_closed_class_restrict P Z q a t] + · exact ha + · simp only [ht, coe_restrictToAddSubgroup] + have htef : t = E.symm e * E.symm f := eq_symm_mul_symm_of_map_eq_mul E hEt + have he0 : e ≠ 0 := fun he ↦ ht0 (by simp only [htef, he, map_zero, zero_mul]) + have hf0 : f ≠ 0 := fun hf ↦ ht0 (by simp only [htef, hf, map_zero, mul_zero]) + exact ⟨hEt, htef, he0, hf0⟩ + +private theorem nonpositive_factor_supports_subset_closed_ball + (P : Submodule K G) [P.toAddSubgroup.IsConvex] (Z : Subring R) + (q : FiniteArchimedeanClass (G ⧸ P)) + (a t : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) + (ht : t = restrictToAddSubgroup Z + ((FiniteArchimedeanClass.closedBallAddSubgroup q).comap P.mkQ.toAddMonoidHom) a) + (e f : cardSuppLTTruncationIntegerPart (G := G ⧸ P) + (R := CardSuppLTField (G := P) (R := R) (κ := κ)) (κ := κ) + (cardSuppLTTruncationIntegerPart (G := P) (R := R) (κ := κ) Z)) + (hEt : cardSuppLTTruncationIntegerPartConvexQuotientSplitRingEquiv P Z t = e * f) + (he0 : e ≠ 0) (hf0 : f ≠ 0) : + let InnerPart := cardSuppLTTruncationIntegerPart + (G := P) (R := R) (κ := κ) Z + let eN := toNonpositiveRingHom InnerPart e + let fN := toNonpositiveRingHom InnerPart f + let D := FiniteArchimedeanClass.closedBallAddSubgroup q + (eN : (CardSuppLTField (G := P) (R := R) (κ := κ))⟦G ⧸ P⟧).support ⊆ + (D : Set (G ⧸ P)) ∧ + (fN : (CardSuppLTField (G := P) (R := R) (κ := κ))⟦G ⧸ P⟧).support ⊆ + (D : Set (G ⧸ P)) := by + let E := cardSuppLTTruncationIntegerPartConvexQuotientSplitRingEquiv + (R := R) (κ := κ) P Z + let InnerPart := cardSuppLTTruncationIntegerPart (G := P) (R := R) (κ := κ) Z + let eN := toNonpositiveRingHom InnerPart e + let fN := toNonpositiveRingHom InnerPart f + let D := FiniteArchimedeanClass.closedBallAddSubgroup q + have heN0 : eN ≠ 0 := by + intro heN + apply he0 + exact toNonpositiveRingHom_injective InnerPart (heN.trans (map_zero _).symm) + have hfN0 : fN ≠ 0 := by + intro hfN + apply hf0 + exact toNonpositiveRingHom_injective InnerPart (hfN.trans (map_zero _).symm) + have hprodD : ((eN * fN : Nonpositive (G ⧸ P) + (CardSuppLTField (G := P) (R := R) (κ := κ))) : + (CardSuppLTField (G := P) (R := R) (κ := κ))⟦G ⧸ P⟧).support ⊆ + (D : Set (G ⧸ P)) := by + have hraw : eN * fN = toNonpositiveRingHom InnerPart (E t) := by + let F := toNonpositiveRingHom + (G := G ⧸ P) (R := CardSuppLTField (G := P) (R := R) (κ := κ)) + (κ := κ) InnerPart + change F e * F f = F (E t) + exact (F.map_mul e f).symm.trans (congrArg F hEt.symm) + rw [hraw, coe_toNonpositiveRingHom, + support_cardSuppLTTruncationIntegerPartConvexQuotientSplitRingEquiv] + apply support_convexQuotientSplitRingEquiv_subset_iff P D (t : R⟦G⟧) |>.mpr + intro z hz + rw [ht, coe_restrictToAddSubgroup, HahnSeries.support_filter] at hz + exact hz.2 + exact Nonpositive.support_subset_convex_of_mul_support_subset + (FiniteArchimedeanClass.closedBall_ordConnected q) heN0 hfN0 hprodD + +private theorem support_symm_subset_comap_of_nonpositive_support_subset + (P : Submodule K G) [P.toAddSubgroup.IsConvex] (Z : Subring R) + (D : AddSubgroup (G ⧸ P)) + (x : cardSuppLTTruncationIntegerPart (G := G ⧸ P) + (R := CardSuppLTField (G := P) (R := R) (κ := κ)) (κ := κ) + (cardSuppLTTruncationIntegerPart (G := P) (R := R) (κ := κ) Z)) + (hx : ((toNonpositiveRingHom + (cardSuppLTTruncationIntegerPart (G := P) (R := R) (κ := κ) Z) x : + Nonpositive (G ⧸ P) (CardSuppLTField (G := P) (R := R) (κ := κ))) : + (CardSuppLTField (G := P) (R := R) (κ := κ))⟦G ⧸ P⟧).support ⊆ D) : + ((cardSuppLTTruncationIntegerPartConvexQuotientSplitRingEquiv + (R := R) (κ := κ) P Z).symm x : R⟦G⟧).support ⊆ + (D.comap P.mkQ.toAddMonoidHom : Set G) := by + let E := cardSuppLTTruncationIntegerPartConvexQuotientSplitRingEquiv + (R := R) (κ := κ) P Z + let xA := E.symm x + let InnerPart := cardSuppLTTruncationIntegerPart (G := P) (R := R) (κ := κ) Z + let xN := toNonpositiveRingHom InnerPart x + apply support_convexQuotientSplitRingEquiv_subset_iff P D (xA : R⟦G⟧) |>.mp + have hxEq : E xA = x := E.apply_symm_apply x + have hsupp : (convexQuotientSplitRingEquiv P (xA : R⟦G⟧)).support = + (xN : (CardSuppLTField (G := P) (R := R) (κ := κ))⟦G ⧸ P⟧).support := by + rw [← support_cardSuppLTTruncationIntegerPartConvexQuotientSplitRingEquiv P Z xA, + hxEq, coe_toNonpositiveRingHom] + rw [hsupp] + exact hx + +private theorem ambient_factor_dvd_of_closed_class_factorization + (P : Submodule K G) [P.toAddSubgroup.IsConvex] (Z : Subring R) + (q : FiniteArchimedeanClass (G ⧸ P)) + (x : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) + (y z : cardSuppLTTruncationIntegerPart (G := G ⧸ P) + (R := CardSuppLTField (G := P) (R := R) (κ := κ)) (κ := κ) + (cardSuppLTTruncationIntegerPart (G := P) (R := R) (κ := κ) Z)) + (hxy : closedClassRestrict + (cardSuppLTTruncationIntegerPart (G := P) (R := R) (κ := κ) Z) q + (cardSuppLTTruncationIntegerPartConvexQuotientSplitRingEquiv P Z x) = y * z) + (hy0 : y ≠ 0) + (hySupp : ((cardSuppLTTruncationIntegerPartConvexQuotientSplitRingEquiv + (R := R) (κ := κ) P Z).symm y : R⟦G⟧).support ⊆ + ((FiniteArchimedeanClass.closedBallAddSubgroup q).comap + P.mkQ.toAddMonoidHom : Set G)) : + (cardSuppLTTruncationIntegerPartConvexQuotientSplitRingEquiv + (R := R) (κ := κ) P Z).symm y ∣ x := by + classical + let E := cardSuppLTTruncationIntegerPartConvexQuotientSplitRingEquiv + (R := R) (κ := κ) P Z + let D := FiniteArchimedeanClass.closedBallAddSubgroup q + let C : AddSubgroup G := D.comap P.mkQ.toAddMonoidHom + let yA := E.symm y + let zA := E.symm z + let xC := restrictToAddSubgroup Z C x + have hEx : E xC = y * z := by + rw [convexQuotientSplit_filter_eq_closed_class_restrict P Z q x xC] + · exact hxy + · simp only [xC, C, D, coe_restrictToAddSubgroup] + have hxC : xC = yA * zA := eq_symm_mul_symm_of_map_eq_mul E hEx + have hC : (C : Set G).OrdConnected := + (FiniteArchimedeanClass.closedBall_ordConnected q).preimage_mono + (fun _ _ huv ↦ ConvexQuotient.mk_le_mk huv) + have hyA0 : yA ≠ 0 := by + intro hyA0 + apply hy0 + rw [← E.apply_symm_apply y, show E.symm y = 0 from hyA0, map_zero] + apply dvd_of_restriction_factorization Z hC yA zA x hySupp hyA0 + have hraw := congrArg (fun w : cardSuppLTTruncationIntegerPart + (G := G) (R := R) (κ := κ) Z ↦ (w : R⟦G⟧)) hxC + calc + HahnSeries.filter (· ∈ C) (x : R⟦G⟧) = (xC : R⟦G⟧) := by + exact (coe_restrictToAddSubgroup Z C x).symm + _ = ((yA * zA : cardSuppLTTruncationIntegerPart + (G := G) (R := R) (κ := κ) Z) : R⟦G⟧) := hraw + _ = (yA : R⟦G⟧) * (zA : R⟦G⟧) := rfl + +private theorem ambient_factors_supported_of_closed_class_factorization + (P : Submodule K G) [P.toAddSubgroup.IsConvex] (Z : Subring R) + (q : FiniteArchimedeanClass (G ⧸ P)) + (a t : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) + (ht : t = restrictToAddSubgroup Z + ((FiniteArchimedeanClass.closedBallAddSubgroup q).comap P.mkQ.toAddMonoidHom) a) + (ht0 : t ≠ 0) + (e f : cardSuppLTTruncationIntegerPart (G := G ⧸ P) + (R := CardSuppLTField (G := P) (R := R) (κ := κ)) (κ := κ) + (cardSuppLTTruncationIntegerPart (G := P) (R := R) (κ := κ) Z)) + (ha : closedClassRestrict + (cardSuppLTTruncationIntegerPart (G := P) (R := R) (κ := κ) Z) q + (cardSuppLTTruncationIntegerPartConvexQuotientSplitRingEquiv P Z a) = e * f) : + let E := cardSuppLTTruncationIntegerPartConvexQuotientSplitRingEquiv + (R := R) (κ := κ) P Z + let D := FiniteArchimedeanClass.closedBallAddSubgroup q + let C : AddSubgroup G := D.comap P.mkQ.toAddMonoidHom + let eA := E.symm e + let fA := E.symm f + t = eA * fA ∧ e ≠ 0 ∧ f ≠ 0 ∧ + (eA : R⟦G⟧).support ⊆ (C : Set G) ∧ + (fA : R⟦G⟧).support ⊆ (C : Set G) := by + classical + let E := + cardSuppLTTruncationIntegerPartConvexQuotientSplitRingEquiv (R := R) (κ := κ) P Z + let D := FiniteArchimedeanClass.closedBallAddSubgroup q + let C : AddSubgroup G := D.comap P.mkQ.toAddMonoidHom + let eA := E.symm e + let fA := E.symm f + have hfactor := ambient_factorization_of_closed_class_factorization + P Z q a t ht ht0 e f ha + dsimp only at hfactor + obtain ⟨hEt, htef, he0, hf0⟩ := hfactor + have hsupp := nonpositive_factor_supports_subset_closed_ball + P Z q a t ht e f hEt he0 hf0 + dsimp only at hsupp + have heSupp : (eA : R⟦G⟧).support ⊆ (C : Set G) := + support_symm_subset_comap_of_nonpositive_support_subset P Z D e hsupp.1 + have hfSupp : (fA : R⟦G⟧).support ⊆ (C : Set G) := + support_symm_subset_comap_of_nonpositive_support_subset P Z D f hsupp.2 + exact ⟨htef, he0, hf0, heSupp, hfSupp⟩ + +private theorem ambient_factors_dvd_of_closed_class_factorizations + (P : Submodule K G) [P.toAddSubgroup.IsConvex] (Z : Subring R) + (q : FiniteArchimedeanClass (G ⧸ P)) + (c d : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) + (e f g h : cardSuppLTTruncationIntegerPart (G := G ⧸ P) + (R := CardSuppLTField (G := P) (R := R) (κ := κ)) (κ := κ) + (cardSuppLTTruncationIntegerPart (G := P) (R := R) (κ := κ) Z)) + (hc : closedClassRestrict + (cardSuppLTTruncationIntegerPart (G := P) (R := R) (κ := κ) Z) q + (cardSuppLTTruncationIntegerPartConvexQuotientSplitRingEquiv P Z c) = e * g) + (hd : closedClassRestrict + (cardSuppLTTruncationIntegerPart (G := P) (R := R) (κ := κ) Z) q + (cardSuppLTTruncationIntegerPartConvexQuotientSplitRingEquiv P Z d) = f * h) + (he0 : e ≠ 0) (hf0 : f ≠ 0) + (heSupp : ((cardSuppLTTruncationIntegerPartConvexQuotientSplitRingEquiv + (R := R) (κ := κ) P Z).symm e : R⟦G⟧).support ⊆ + ((FiniteArchimedeanClass.closedBallAddSubgroup q).comap + P.mkQ.toAddMonoidHom : Set G)) + (hfSupp : ((cardSuppLTTruncationIntegerPartConvexQuotientSplitRingEquiv + (R := R) (κ := κ) P Z).symm f : R⟦G⟧).support ⊆ + ((FiniteArchimedeanClass.closedBallAddSubgroup q).comap + P.mkQ.toAddMonoidHom : Set G)) : + (cardSuppLTTruncationIntegerPartConvexQuotientSplitRingEquiv + (R := R) (κ := κ) P Z).symm e ∣ c ∧ + (cardSuppLTTruncationIntegerPartConvexQuotientSplitRingEquiv + (R := R) (κ := κ) P Z).symm f ∣ d := by + constructor + · exact ambient_factor_dvd_of_closed_class_factorization + P Z q c e g hc he0 heSupp + · exact ambient_factor_dvd_of_closed_class_factorization + P Z q d f h hd hf0 hfSupp + +/-- An exact quotient-class refinement transports to a factorisation of the retained ambient +block, with the two factors dividing the corresponding ambient right-hand factors. -/ +@[blueprint "lem:closed-class-refinement-transport" + (phase := "Refinement over Archimedean classes") + (title := "Transport of refinement from a quotient Archimedean class") + (statement := /-- + Let $P$ be a convex subspace of an ordered vector space $G$, let $q$ be a + nonzero Archimedean class of $G/P$, and let $t\ne0$ be the restriction of + $a$ to the inverse image of the closed ball of $q$. If the closed-ball + restrictions of $a,c,d$ in the iterated Hahn field factor as + \[ + a_q=ef,\qquad c_q=eg,\qquad d_q=fh, + \] + then there are $e_A,f_A\in Z+R((G^{<0}))_\kappa$ such that + $t=e_Af_A$, $e_A\mid c$, and $f_A\mid d$. + -/) + (proof := /-- + By \ref{lem:quotient-regrouping-closed-ball-restriction}, the Hahn-field + isomorphism obtained by regrouping exponents along $P$ identifies + closed-ball restriction in $G/P$ with restriction to its inverse image in + $G$. Transport $e$ and $f$ back through this isomorphism. + Since their product is supported in the retained convex subgroup, + \ref{lem:convex-support-of-factors} confines both supports there. Apply + \ref{lem:divisibility-from-convex-restriction} to the restricted + factorisations of $c$ and $d$ to obtain $e_A\mid c$ and $f_A\mid d$ in the + ambient integer part. + -/)] +theorem exists_factor_refinement_of_closed_class_refinement + (P : Submodule K G) [P.toAddSubgroup.IsConvex] (Z : Subring R) + (q : FiniteArchimedeanClass (G ⧸ P)) + (a c d t : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) + (ht : t = restrictToAddSubgroup Z + ((FiniteArchimedeanClass.closedBallAddSubgroup q).comap P.mkQ.toAddMonoidHom) a) + (ht0 : t ≠ 0) + (e f g h : cardSuppLTTruncationIntegerPart (G := G ⧸ P) + (R := CardSuppLTField (G := P) (R := R) (κ := κ)) (κ := κ) + (cardSuppLTTruncationIntegerPart (G := P) (R := R) (κ := κ) Z)) + (ha : closedClassRestrict + (cardSuppLTTruncationIntegerPart (G := P) (R := R) (κ := κ) Z) q + (cardSuppLTTruncationIntegerPartConvexQuotientSplitRingEquiv P Z a) = e * f) + (hc : closedClassRestrict + (cardSuppLTTruncationIntegerPart (G := P) (R := R) (κ := κ) Z) q + (cardSuppLTTruncationIntegerPartConvexQuotientSplitRingEquiv P Z c) = e * g) + (hd : closedClassRestrict + (cardSuppLTTruncationIntegerPart (G := P) (R := R) (κ := κ) Z) q + (cardSuppLTTruncationIntegerPartConvexQuotientSplitRingEquiv P Z d) = f * h) : + ∃ eA fA : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z, + t = eA * fA ∧ eA ∣ c ∧ fA ∣ d := by + classical + let E := + cardSuppLTTruncationIntegerPartConvexQuotientSplitRingEquiv (R := R) (κ := κ) P Z + let eA := E.symm e + let fA := E.symm f + have hfactor := + ambient_factors_supported_of_closed_class_factorization P Z q a t ht ht0 e f ha + dsimp only at hfactor + obtain ⟨htef, he0, hf0, heSupp, hfSupp⟩ := hfactor + have hdvd := + ambient_factors_dvd_of_closed_class_factorizations + P Z q c d e f g h hc hd he0 hf0 heSupp hfSupp + exact ⟨eA, fA, htef, hdvd.1, hdvd.2⟩ + +end HahnSeries.CardSuppLTTruncationIntegerPart diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Refinement/CompleteGermRefinement.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Refinement/CompleteGermRefinement.lean new file mode 100644 index 0000000000..d937d4e695 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Refinement/CompleteGermRefinement.lean @@ -0,0 +1,86 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.PolynomialAlgebra.CompleteGermOfCauchyComplete + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint + +/-! +# Refinement of a complete generalised-power-series germ ring + +The polynomial presentation of the quotient by series bounded strictly below zero gives +four-factor refinement in that quotient. +-/ + +open Set +open scoped HahnSeries + +universe u v + +public noncomputable section + +namespace HahnSeries.Nonpositive + +variable {G : Type u} {K : Type v} +variable [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [UniformSpace G] [IsUniformAddGroup G] [OrderTopology G] [Nontrivial G] [CompleteSpace G] + [DenselyOrdered G] [NoMinOrder G] [NoMaxOrder G] + [NoMaxOrder (FiniteArchimedeanClass G)] + [Field K] [CharZero K] + +/-- An ordered exponent group that is Cauchy complete and has no smallest nonzero magnitude has +four-factor refinement modulo series bounded away from zero. -/ +@[blueprint "thm:complete-hahn-germ-refinement" + (phase := "Refinement over Archimedean classes") + (title := "Four-factor refinement in the germ ring over a Cauchy-complete exponent group") + (statement := /-- + Under the hypotheses of + \ref{thm:complete-hahn-germ-polynomial-algebra}, if + $a,b,c,d\in K((G^{\le 0}))$ and $ab=cd$, then there are + $e,f,g,h\in K((G^{\le 0}))$ such that, modulo series whose support is + bounded strictly below zero, + \[ + a=ef,\qquad b=gh,\qquad c=eg,\qquad d=fh. + \] + -/) + (proof := /-- + By \ref{thm:complete-hahn-germ-polynomial-algebra}, the germ ring is a + polynomial ring over $K$, hence is a unique factorisation domain and has + the refinement property. Refine the four images in the quotient and + choose series representing the four factors. + -/)] +theorem exists_germ_refinement_of_complete_exponent_group + (a b c d : Nonpositive G K) (habcd : a * b = c * d) : + ∃ e f g h : Nonpositive G K, + (∃ r < (0 : G), ∀ q > r, + (a : HahnSeries G K).coeff q = (e * f : Nonpositive G K).1.coeff q) ∧ + (∃ r < (0 : G), ∀ q > r, + (b : HahnSeries G K).coeff q = (g * h : Nonpositive G K).1.coeff q) ∧ + (∃ r < (0 : G), ∀ q > r, + (c : HahnSeries G K).coeff q = (e * g : Nonpositive G K).1.coeff q) ∧ + (∃ r < (0 : G), ∀ q > r, + (d : HahnSeries G K).coeff q = (f * h : Nonpositive G K).1.coeff q) := by + let J := (cantorBendixsonValuation (G := G) (R := K)).supp + obtain ⟨ι, ⟨equiv⟩⟩ := exists_mvPolynomial_algEquiv_germ (G := G) (K := K) + let : DecompositionMonoid (Nonpositive G K ⧸ J) := + MulEquiv.decompositionMonoid equiv.symm.toMulEquiv + have hrefinement : HasFourFactorRefinement (Nonpositive G K ⧸ J) := + hasFourFactorRefinement_of_decompositionMonoid + obtain ⟨qe, qf, qg, qh, heq, hfq, hgq, hhq⟩ := hrefinement.refine + (show Ideal.Quotient.mk J a * Ideal.Quotient.mk J b = + Ideal.Quotient.mk J c * Ideal.Quotient.mk J d by + simpa only [map_mul] using congrArg (Ideal.Quotient.mk J) habcd) + obtain ⟨e, rfl⟩ := Ideal.Quotient.mk_surjective qe + obtain ⟨f, rfl⟩ := Ideal.Quotient.mk_surjective qf + obtain ⟨g, rfl⟩ := Ideal.Quotient.mk_surjective qg + obtain ⟨h, rfl⟩ := Ideal.Quotient.mk_surjective qh + refine ⟨e, f, g, h, ?_, ?_, ?_, ?_⟩ + · exact cantorBendixson_germ_eq_iff a (e * f) |>.mp heq + · exact cantorBendixson_germ_eq_iff b (g * h) |>.mp hfq + · exact cantorBendixson_germ_eq_iff c (e * g) |>.mp hgq + · exact cantorBendixson_germ_eq_iff d (f * h) |>.mp hhq +end HahnSeries.Nonpositive diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Refinement/ConvexRestrictionFactorization.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Refinement/ConvexRestrictionFactorization.lean new file mode 100644 index 0000000000..34fb70cee0 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Refinement/ConvexRestrictionFactorization.lean @@ -0,0 +1,349 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.CardinalTruncation +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.SubgroupSupport +public import Mathlib.Algebra.Group.Subgroup.Order +public import Mathlib.Algebra.Order.Archimedean.Class +public import Mathlib.Order.Interval.Set.OrdConnected + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint + +/-! +# Divisibility descends from a convex restriction + +A divisor supported in a convex subgroup of the exponents divides a series as soon as it divides +the convex restriction: the discarded part has all its exponents nonpositive and outside the +subgroup, so multiplying it by the inverse of the divisor keeps every exponent nonpositive and +outside the subgroup, hence away from zero. The cofactor therefore stays in the integral part. + +This is the step by which a refinement obtained after restricting at a support class is +transported back to the original divisibility. +-/ + +public noncomputable section + +open scoped HahnSeries + +namespace HahnSeries.ConvexRestriction + +variable {G K : Type*} [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [Field K] + +private theorem add_nonpos_of_mem_of_nonpos_of_not_mem {C : AddSubgroup G} + (hC : (C : Set G).OrdConnected) {a b : G} + (ha : a ∈ C) (hb : b ≤ 0) (hbC : b ∉ C) : a + b ≤ 0 := by + by_contra h + have hab : 0 < a + b := lt_of_not_ge h + apply hbC + have hba : 0 < b + a := by simpa only [add_comm] using hab + exact hC.out (C.neg_mem ha) C.zero_mem ⟨(neg_lt_iff_pos_add.mpr hba).le, hb⟩ + +/-- Adding an exponent in a convex subgroup to one outside it preserves the outside exponent's +Archimedean class. -/ +private theorem archimedeanClass_add_eq_right_of_mem_of_not_mem {C : AddSubgroup G} + (hC : (C : Set G).OrdConnected) {i j : G} (hi : i ∈ C) (hj : j ∉ C) : + ArchimedeanClass.mk (i + j) = ArchimedeanClass.mk j := by + apply ArchimedeanClass.mk_add_eq_mk_right + rw [ArchimedeanClass.mk_lt_mk] + intro n + apply lt_of_not_ge + intro hji + have habsi : |i| ∈ C := abs_mem_iff.mpr hi + have hni : n • |i| ∈ C := C.nsmul_mem habsi n + have habsj : |j| ∈ C := hC.out C.zero_mem hni ⟨abs_nonneg j, hji⟩ + exact hj (abs_mem_iff.mp habsj) + +open Classical in +/-- **Truncation-divisibility.** A nonzero divisor supported in a convex subgroup divides a +series with nonpositive support as soon as it divides the convex restriction, and the cofactor +stays in the integral part: nonpositive support with constant coefficient in the coefficient +subring. The discarded part has all exponents outside the subgroup, so dividing it by the +subgroup-supported divisor keeps every exponent nonpositive and nonzero. -/ +private theorem exists_integral_cofactor {C : AddSubgroup G} + (hC : (C : Set G).OrdConnected) (Z : Subring K) + {q c w : K⟦G⟧} (hq : q.support ⊆ (C : Set G)) (hq0 : q ≠ 0) + (hc : c.support ⊆ Set.Iic 0) + (hw : w.support ⊆ Set.Iic 0) (hw0 : w.coeff 0 ∈ Z) + (heq : HahnSeries.filter (· ∈ C) c = q * w) : + ∃ w' : K⟦G⟧, w'.support ⊆ Set.Iic 0 ∧ w'.coeff 0 ∈ Z ∧ c = q * w' := by + classical + set r : K⟦G⟧ := HahnSeries.filter (fun g ↦ g ∉ C) c with hr + have hsplit : HahnSeries.filter (· ∈ C) c + r = c := HahnSeries.filter_add_filter_not _ c + have hrsupp : ∀ g ∈ r.support, g ≤ 0 ∧ g ∉ C := by + intro g hg + rw [hr, HahnSeries.support_filter] at hg + exact ⟨hc hg.1, hg.2⟩ + -- The inverse of the divisor stays supported in the subgroup. + have hone : (1 : K⟦G⟧).support ⊆ (C : Set G) := by + intro g hg + have hg0 : g = 0 := by + simpa only [HahnSeries.support_one, Set.mem_singleton_iff] using hg + exact hg0 ▸ C.zero_mem + have hinv : (q⁻¹ : K⟦G⟧).support ⊆ (C : Set G) := + HahnSeries.support_subset_of_mul_eq (f := (1 : K⟦G⟧)) hq hq0 hone + (mul_inv_cancel₀ hq0).symm + -- The discarded part divided by the divisor keeps nonpositive, nonzero exponents. + have hprod : ∀ g ∈ ((q⁻¹ : K⟦G⟧) * r).support, g ≤ 0 ∧ g ∉ C := by + intro g hg + obtain ⟨a, ha, b, hb, rfl⟩ := HahnSeries.support_mul_subset hg + obtain ⟨hb0, hbC⟩ := hrsupp b hb + refine ⟨add_nonpos_of_mem_of_nonpos_of_not_mem hC (hinv ha) hb0 hbC, ?_⟩ + intro hab + exact hbC (by simpa using C.sub_mem hab (hinv ha)) + refine ⟨w + q⁻¹ * r, ?_, ?_, ?_⟩ + · intro g hg + rcases HahnSeries.support_add_subset _ _ hg with h | h + · exact hw h + · exact (hprod g h).1 + · have hzero : ((q⁻¹ : K⟦G⟧) * r).coeff 0 = 0 := by + by_contra hne + exact (hprod 0 ((HahnSeries.mem_support _ _).mpr hne)).2 C.zero_mem + rw [HahnSeries.coeff_add, hzero, add_zero] + exact hw0 + · rw [mul_add, ← heq, ← mul_assoc, mul_inv_cancel₀ hq0, one_mul, hsplit] + +open Classical in +/-- **The class-block factorisation.** An integral series with a nonzero convex restriction is +that restriction times an integral series whose constant coefficient is one and whose remaining +exponents all lie outside the subgroup. An induction over support classes can therefore split an +integral series into blocks and, with primality of each block, conclude primality of the whole by +`IsPrimal.mul`. -/ +private theorem exists_complementary_factor {C : AddSubgroup G} + (hC : (C : Set G).OrdConnected) {b : K⟦G⟧} (hb : b.support ⊆ Set.Iic 0) + (hne : HahnSeries.filter (· ∈ C) b ≠ 0) : + ∃ w : K⟦G⟧, w.support ⊆ Set.Iic 0 ∧ w.coeff 0 = 1 ∧ + (∀ g ∈ w.support, g ≠ 0 → g ∉ C) ∧ + (∀ g ∈ w.support, g ≠ 0 → + ArchimedeanClass.mk g ∈ ArchimedeanClass.mk '' b.support) ∧ + b = HahnSeries.filter (· ∈ C) b * w := by + classical + set q : K⟦G⟧ := HahnSeries.filter (· ∈ C) b with hq_def + set r : K⟦G⟧ := HahnSeries.filter (fun g ↦ g ∉ C) b with hr_def + have hsplit : q + r = b := HahnSeries.filter_add_filter_not _ b + have hqC : q.support ⊆ (C : Set G) := by + intro g hg + rw [hq_def, HahnSeries.support_filter] at hg + exact hg.2 + have hrsupp : ∀ g ∈ r.support, g ≤ 0 ∧ g ∉ C := by + intro g hg + rw [hr_def, HahnSeries.support_filter] at hg + exact ⟨hb hg.1, hg.2⟩ + have hone : (1 : K⟦G⟧).support ⊆ (C : Set G) := by + intro g hg + have hg0 : g = 0 := by + simpa only [HahnSeries.support_one, Set.mem_singleton_iff] using hg + exact hg0 ▸ C.zero_mem + have hinv : (q⁻¹ : K⟦G⟧).support ⊆ (C : Set G) := + HahnSeries.support_subset_of_mul_eq (f := (1 : K⟦G⟧)) hqC hne hone + (mul_inv_cancel₀ hne).symm + have hprod : ∀ g ∈ ((q⁻¹ : K⟦G⟧) * r).support, g ≤ 0 ∧ g ∉ C := by + intro g hg + obtain ⟨a, ha, c', hc', rfl⟩ := HahnSeries.support_mul_subset hg + obtain ⟨hc0, hcC⟩ := hrsupp c' hc' + refine ⟨add_nonpos_of_mem_of_nonpos_of_not_mem hC (hinv ha) hc0 hcC, ?_⟩ + intro hab + exact hcC (by simpa using C.sub_mem hab (hinv ha)) + have hzero : ((q⁻¹ : K⟦G⟧) * r).coeff 0 = 0 := by + by_contra hnz + exact (hprod 0 ((HahnSeries.mem_support _ _).mpr hnz)).2 C.zero_mem + refine ⟨1 + q⁻¹ * r, ?_, ?_, ?_, ?_, ?_⟩ + · intro g hg + rcases HahnSeries.support_add_subset _ _ hg with h | h + · have hg0 : g = 0 := by + simpa only [HahnSeries.support_one, Set.mem_singleton_iff] using h + exact hg0 ▸ Set.mem_Iic.mpr le_rfl + · exact Set.mem_Iic.mpr (hprod g h).1 + · rw [HahnSeries.coeff_add, HahnSeries.coeff_one, ite_eq_left rfl, hzero, add_zero] + · intro g hg hg0 + rcases HahnSeries.support_add_subset _ _ hg with h | h + · exact absurd (by + simpa only [HahnSeries.support_one, Set.mem_singleton_iff] using h) hg0 + · exact (hprod g h).2 + · intro g hg hg0 + rcases HahnSeries.support_add_subset _ _ hg with h | h + · exact absurd (by + simpa only [HahnSeries.support_one, Set.mem_singleton_iff] using h) hg0 + · obtain ⟨i, hi, j, hj, hij⟩ := HahnSeries.support_mul_subset h + have hiC : i ∈ C := hinv hi + have hjr : j ∈ r.support := hj + have hjb : j ∈ b.support := by + rw [hr_def, HahnSeries.support_filter] at hjr + exact hjr.1 + have hjC : j ∉ C := (hrsupp j hj).2 + refine ⟨j, hjb, ?_⟩ + rw [← hij] + exact (archimedeanClass_add_eq_right_of_mem_of_not_mem hC hiC hjC).symm + · rw [mul_add, mul_one, ← mul_assoc, mul_inv_cancel₀ hne, one_mul, hsplit] + +end HahnSeries.ConvexRestriction + +namespace HahnSeries.CardSuppLTTruncationIntegerPart + +open Cardinal + +variable {G K : Type*} {κ : Cardinal} +variable [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] +variable [Field K] [Fact (aleph0 < κ)] + +/-- Restrict a bounded truncation-integer-part series to an exponent subgroup. -/ +def restrictToAddSubgroup (Z : Subring K) (C : AddSubgroup G) + (x : HahnSeries.cardSuppLTTruncationIntegerPart (G := G) (R := K) (κ := κ) Z) : + HahnSeries.cardSuppLTTruncationIntegerPart (G := G) (R := K) (κ := κ) Z := by + classical + let xf : HahnSeries.CardSuppLTField (G := G) (R := K) (κ := κ) := + ⟨HahnSeries.filter (· ∈ C) (x : K⟦G⟧), + (HahnSeries.mem_cardSuppLTSubfield (Γ := G) (R := K) (κ := κ)).mpr + ((HahnSeries.cardSupp_mono (HahnSeries.support_filter_subset _ _)).trans_lt x.1.2)⟩ + have hxmem := (HahnSeries.mem_cardSuppLTTruncationIntegerPart (Z := Z)).mp x.2 + exact ⟨xf, by + rw [HahnSeries.mem_cardSuppLTTruncationIntegerPart] + refine ⟨(HahnSeries.support_filter_subset _ _).trans hxmem.1, ?_⟩ + change (HahnSeries.filter (· ∈ C) (x : K⟦G⟧)).coeff 0 ∈ Z + rw [HahnSeries.coeff_filter, ite_eq_left C.zero_mem] + exact hxmem.2⟩ + +open Classical in +/-- The subgroup restriction package has the expected underlying Hahn series. -/ +@[simp] +theorem coe_restrictToAddSubgroup (Z : Subring K) (C : AddSubgroup G) + (x : HahnSeries.cardSuppLTTruncationIntegerPart (G := G) (R := K) (κ := κ) Z) : + (restrictToAddSubgroup Z C x : K⟦G⟧) = HahnSeries.filter (· ∈ C) (x : K⟦G⟧) := + (rfl) + +open Classical in +/-- A nonzero bounded integer-part factor supported in a convex subgroup divides an ambient +bounded integer-part series as soon as it factors the convex restriction. -/ +@[blueprint "lem:divisibility-from-convex-restriction" + (phase := "Refinement over Archimedean classes") + (title := "Divisibility from a convex restriction") + (statement := /-- + Let $C$ be a convex subgroup of an ordered abelian group $G$, and let + $q,w,x\in Z+K((G^{<0}))_\kappa$. Suppose $q\ne0$, + $\operatorname{supp}(q)\subseteq C$, and + \[ + x_{\vert C}=qw. + \] + Then $q\mid x$ in $Z+K((G^{<0}))_\kappa$. + -/) + (proof := /-- + Divide $x$ by $q$ in the bounded Hahn field. On $C$ the quotient is $w$. + Outside $C$, convexity and nonpositivity keep every exponent of the + quotient strictly negative; the constant coefficient is therefore the + constant coefficient of $w$ and lies in $Z$. Hence the quotient belongs + to the bounded Hahn integer part. + -/)] +theorem dvd_of_restriction_factorization + (Z : Subring K) {C : AddSubgroup G} (hC : (C : Set G).OrdConnected) + (q w x : HahnSeries.cardSuppLTTruncationIntegerPart + (G := G) (R := K) (κ := κ) Z) + (hqsupp : (q : K⟦G⟧).support ⊆ (C : Set G)) (hq0 : q ≠ 0) + (heq : HahnSeries.filter (· ∈ C) (x : K⟦G⟧) = (q * w : K⟦G⟧)) : + q ∣ x := by + have hqraw : (q : K⟦G⟧) ≠ 0 := fun h ↦ hq0 (Subtype.ext (Subtype.ext h)) + have hxmem := (HahnSeries.mem_cardSuppLTTruncationIntegerPart (Z := Z)).mp x.2 + have hwmem := (HahnSeries.mem_cardSuppLTTruncationIntegerPart (Z := Z)).mp w.2 + obtain ⟨v, hv, hv0, hxv⟩ := + HahnSeries.ConvexRestriction.exists_integral_cofactor hC Z hqsupp hqraw + hxmem.1 hwmem.1 hwmem.2 heq + let vf : HahnSeries.CardSuppLTField (G := G) (R := K) (κ := κ) := + (x : HahnSeries.CardSuppLTField (G := G) (R := K) (κ := κ)) / + (q : HahnSeries.CardSuppLTField (G := G) (R := K) (κ := κ)) + have hvraw : (vf : K⟦G⟧) = v := by + change (x : K⟦G⟧) / (q : K⟦G⟧) = v + rw [hxv, mul_comm, mul_div_assoc, div_self hqraw, mul_one] + let vI : HahnSeries.cardSuppLTTruncationIntegerPart + (G := G) (R := K) (κ := κ) Z := ⟨vf, by + rw [HahnSeries.mem_cardSuppLTTruncationIntegerPart, hvraw] + exact ⟨hv, hv0⟩⟩ + refine ⟨vI, ?_⟩ + apply Subtype.ext + change (x : HahnSeries.CardSuppLTField (G := G) (R := K) (κ := κ)) = + (q : HahnSeries.CardSuppLTField (G := G) (R := K) (κ := κ)) * vf + have hqfield : (q : HahnSeries.CardSuppLTField (G := G) (R := K) (κ := κ)) ≠ 0 := + fun h ↦ hq0 (Subtype.ext h) + rw [mul_comm, div_mul_cancel₀ _ hqfield] + +open Classical in +/-- Factor a bounded truncation-integer-part series by its nonzero restriction to a convex +exponent subgroup. The complementary factor remains bounded, has constant coefficient one, and +all its nonzero support exponents lie outside the subgroup in classes met by the original +support. -/ +@[blueprint "lem:factorisation-by-convex-restriction" + (phase := "Refinement over Archimedean classes") + (title := "Factorisation by a convex restriction") + (statement := /-- + Let $C$ be a convex subgroup of an ordered abelian group $G$, and let + $b\in Z+K((G^{<0}))_\kappa$ have nonzero restriction $t=b_{\vert C}$. + Then + \[ + b=tw + \] + for some $w\in Z+K((G^{<0}))_\kappa$ with constant coefficient $1$. + Every nonzero exponent in $\operatorname{supp}(w)$ lies outside $C$, and + its Archimedean class is met by $\operatorname{supp}(b)$. + -/) + (proof := /-- + Divide $b$ by its nonzero restriction $t$ in the bounded Hahn field. The + quotient has constant coefficient $1$. Convexity separates the discarded + support from $C$; the Hahn inverse expansion shows that each class appearing + in the quotient already appears in the support of $b$. Thus the quotient + remains in the bounded Hahn integer part and has the stated support. + -/)] +theorem exists_factorization_by_restriction + (Z : Subring K) {C : AddSubgroup G} (hC : (C : Set G).OrdConnected) + (b : HahnSeries.cardSuppLTTruncationIntegerPart (G := G) (R := K) (κ := κ) Z) + (hne : HahnSeries.filter (· ∈ C) (b : K⟦G⟧) ≠ 0) : + ∃ t w : HahnSeries.cardSuppLTTruncationIntegerPart (G := G) (R := K) (κ := κ) Z, + (t : K⟦G⟧) = HahnSeries.filter (· ∈ C) (b : K⟦G⟧) ∧ + b = t * w ∧ + (w : K⟦G⟧).coeff 0 = 1 ∧ + (∀ g ∈ (w : K⟦G⟧).support, g ≠ 0 → g ∉ C) ∧ + (∀ g ∈ (w : K⟦G⟧).support, g ≠ 0 → + ArchimedeanClass.mk g ∈ ArchimedeanClass.mk '' (b : K⟦G⟧).support) := by + have hbmem := (HahnSeries.mem_cardSuppLTTruncationIntegerPart (Z := Z)).mp b.2 + obtain ⟨wraw, hws, hw0, hwC, hwocc, hfac⟩ := + HahnSeries.ConvexRestriction.exists_complementary_factor hC hbmem.1 hne + let tf : HahnSeries.CardSuppLTField (G := G) (R := K) (κ := κ) := + ⟨HahnSeries.filter (· ∈ C) (b : K⟦G⟧), + (HahnSeries.mem_cardSuppLTSubfield (Γ := G) (R := K) (κ := κ)).mpr + ((HahnSeries.cardSupp_mono (HahnSeries.support_filter_subset _ _)).trans_lt b.1.2)⟩ + have ht0 : (tf : K⟦G⟧).coeff 0 = (b : K⟦G⟧).coeff 0 := by + rw [HahnSeries.coeff_filter, ite_eq_left C.zero_mem] + let t : HahnSeries.cardSuppLTTruncationIntegerPart (G := G) (R := K) (κ := κ) Z := + ⟨tf, by + rw [HahnSeries.mem_cardSuppLTTruncationIntegerPart] + exact ⟨(HahnSeries.support_filter_subset _ _).trans hbmem.1, ht0 ▸ hbmem.2⟩⟩ + have htfield0 : (t : HahnSeries.CardSuppLTField (G := G) (R := K) (κ := κ)) ≠ 0 := by + intro ht + apply hne + exact congrArg (fun z : HahnSeries.CardSuppLTField + (G := G) (R := K) (κ := κ) ↦ (z : K⟦G⟧)) ht + let wf : HahnSeries.CardSuppLTField (G := G) (R := K) (κ := κ) := + (b : HahnSeries.CardSuppLTField (G := G) (R := K) (κ := κ)) / + (t : HahnSeries.CardSuppLTField (G := G) (R := K) (κ := κ)) + have hwraw : (wf : K⟦G⟧) = wraw := by + change (b : K⟦G⟧) / (t : K⟦G⟧) = wraw + rw [hfac, mul_comm, mul_div_assoc, div_self] + · exact mul_one _ + · intro ht + apply htfield0 + exact Subtype.ext ht + let w : HahnSeries.cardSuppLTTruncationIntegerPart (G := G) (R := K) (κ := κ) Z := + ⟨wf, by + rw [HahnSeries.mem_cardSuppLTTruncationIntegerPart, hwraw] + exact ⟨hws, hw0 ▸ Z.one_mem⟩⟩ + refine ⟨t, w, rfl, ?_, ?_, ?_, ?_⟩ + · apply Subtype.ext + change (b : HahnSeries.CardSuppLTField (G := G) (R := K) (κ := κ)) = + (t : HahnSeries.CardSuppLTField (G := G) (R := K) (κ := κ)) * wf + rw [mul_comm, div_mul_cancel₀ _ htfield0] + · simpa only [w, hwraw] using hw0 + · simpa only [w, hwraw] using hwC + · simpa only [w, hwraw] using hwocc + +end HahnSeries.CardSuppLTTruncationIntegerPart diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Refinement/FiniteGermError.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Refinement/FiniteGermError.lean new file mode 100644 index 0000000000..b0d2704628 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Refinement/FiniteGermError.lean @@ -0,0 +1,337 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.Germ +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.SupportArchimedeanClasses +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Divisibility.Refinement + +/-! +# Killing finitely many Hahn-series germ errors at one Archimedean class + +An error that vanishes as a germ at zero is supported below some strictly negative exponent. +Its Archimedean classes are therefore bounded above by the class of that exponent. Restriction +to the closed ball at any strictly later finite Archimedean class kills the error exactly. + +For finitely many germ errors, one class works simultaneously. If `T` is a cofinal set of finite +classes, first take a common upper bound for the finitely many error bounds, then move strictly +above it and into `T`. This is the finite-error restriction used in the Conway limit step; it +does not choose a compatible infinite family of restrictions. +-/ + +open Set + +universe u v + +namespace HahnSeries.Nonpositive + +variable {G : Type u} {R : Type v} + [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] [CommRing R] + +public noncomputable section + +open Classical in +/-- The four errors measuring whether chosen representatives satisfy the four refinement +equations before passing to the quotient by series bounded strictly below zero. -/ +def fourFactorErrors (a b c d e f g h : Nonpositive G R) : Finset (Nonpositive G R) := + {a - e * f, b - g * h, c - e * g, d - f * h} + +/-- Equality of the four refinement equations in the germ quotient puts every representative +error in the valuation support ideal. -/ +theorem fourFactorErrors_mem_supp + [UniformSpace G] [IsUniformAddGroup G] [OrderTopology G] [Nontrivial G] + [CompleteSpace G] [NoZeroDivisors R] [CharZero R] + {a b c d e f g h : Nonpositive G R} + (ha : Ideal.Quotient.mk (cantorBendixsonValuation (G := G) (R := R)).supp a = + Ideal.Quotient.mk (cantorBendixsonValuation (G := G) (R := R)).supp (e * f)) + (hb : Ideal.Quotient.mk (cantorBendixsonValuation (G := G) (R := R)).supp b = + Ideal.Quotient.mk (cantorBendixsonValuation (G := G) (R := R)).supp (g * h)) + (hc : Ideal.Quotient.mk (cantorBendixsonValuation (G := G) (R := R)).supp c = + Ideal.Quotient.mk (cantorBendixsonValuation (G := G) (R := R)).supp (e * g)) + (hd : Ideal.Quotient.mk (cantorBendixsonValuation (G := G) (R := R)).supp d = + Ideal.Quotient.mk (cantorBendixsonValuation (G := G) (R := R)).supp (f * h)) : + ∀ z ∈ fourFactorErrors a b c d e f g h, + z ∈ (cantorBendixsonValuation (G := G) (R := R)).supp := by + intro z hz + simp only [fourFactorErrors, Finset.mem_insert, Finset.mem_singleton] at hz + rcases hz with rfl | rfl | rfl | rfl + · exact Ideal.Quotient.eq.mp ha + · exact Ideal.Quotient.eq.mp hb + · exact Ideal.Quotient.eq.mp hc + · exact Ideal.Quotient.eq.mp hd + +open Classical in +/-- Restriction of a nonpositive Hahn series to the closed ball at a finite Archimedean class. -/ +def closedClassRestrict (c : FiniteArchimedeanClass G) + (b : Nonpositive G R) : Nonpositive G R := + ⟨HahnSeries.filter (· ∈ FiniteArchimedeanClass.closedBallAddSubgroup c) + (b : HahnSeries G R), (HahnSeries.support_filter_subset _ _).trans b.property⟩ + +open Classical in +/-- The coefficient formula for restriction to a closed Archimedean ball. -/ +@[simp] +theorem closedClassRestrict_coeff (c : FiniteArchimedeanClass G) (b : Nonpositive G R) (g : G) : + ((closedClassRestrict c b : Nonpositive G R) : HahnSeries G R).coeff g = + if g ∈ FiniteArchimedeanClass.closedBallAddSubgroup c then + (b : HahnSeries G R).coeff g else 0 := by + rw [closedClassRestrict, HahnSeries.coeff_filter] + +/-- Closed-class restriction cannot introduce a new support exponent. -/ +theorem support_closedClassRestrict_subset (c : FiniteArchimedeanClass G) + (b : Nonpositive G R) : + ((closedClassRestrict c b : Nonpositive G R) : HahnSeries G R).support ⊆ + (b : HahnSeries G R).support := by + intro g hg + rw [HahnSeries.mem_support] at hg ⊢ + rw [closedClassRestrict_coeff] at hg + split at hg + · exact hg + · exact (hg rfl).elim + +/-- Restriction at an Archimedean class met by the support is nonzero. -/ +theorem closedClassRestrict_ne_zero_of_mem_image_mk_support + (c : FiniteArchimedeanClass G) (b : Nonpositive G R) + (hc : c.1 ∈ ArchimedeanClass.mk '' (b : HahnSeries G R).support) : + closedClassRestrict c b ≠ 0 := by + classical + obtain ⟨g, hg, hgc⟩ := hc + intro hzero + have hcoeff := congrArg (fun x : Nonpositive G R ↦ (x : HahnSeries G R).coeff g) hzero + rw [closedClassRestrict_coeff, ite_eq_left] at hcoeff + · exact (HahnSeries.mem_support _ _).mp hg hcoeff + · apply (FiniteArchimedeanClass.mem_closedBallAddSubgroup_iff).mpr + intro hg0 + change c.1 ≤ ArchimedeanClass.mk g + rw [hgc] + +/-- Restriction to a closed Archimedean ball preserves subtraction. -/ +theorem closedClassRestrict_sub (c : FiniteArchimedeanClass G) (a b : Nonpositive G R) : + closedClassRestrict c (a - b) = closedClassRestrict c a - closedClassRestrict c b := by + classical + apply Subtype.ext + ext g + change (HahnSeries.filter (· ∈ FiniteArchimedeanClass.closedBallAddSubgroup c) + ((a - b : Nonpositive G R) : HahnSeries G R)).coeff g = + ((closedClassRestrict c a : Nonpositive G R) : HahnSeries G R).coeff g - + ((closedClassRestrict c b : Nonpositive G R) : HahnSeries G R).coeff g + rw [HahnSeries.coeff_filter] + change (if g ∈ FiniteArchimedeanClass.closedBallAddSubgroup c then + ((a : HahnSeries G R) - (b : HahnSeries G R)).coeff g else 0) = _ + rw [HahnSeries.coeff_sub] + change _ = + (HahnSeries.filter (· ∈ FiniteArchimedeanClass.closedBallAddSubgroup c) + (a : HahnSeries G R)).coeff g - + (HahnSeries.filter (· ∈ FiniteArchimedeanClass.closedBallAddSubgroup c) + (b : HahnSeries G R)).coeff g + rw [HahnSeries.coeff_filter, HahnSeries.coeff_filter] + split_ifs <;> simp_all + +/-- Restriction to a closed Archimedean ball preserves multiplication of nonpositive series. -/ +theorem closedClassRestrict_mul (c : FiniteArchimedeanClass G) (a b : Nonpositive G R) : + closedClassRestrict c (a * b) = closedClassRestrict c a * closedClassRestrict c b := by + classical + apply Subtype.ext + ext g + rw [closedClassRestrict, HahnSeries.coeff_filter] + change (if g ∈ FiniteArchimedeanClass.closedBallAddSubgroup c then + ((a : HahnSeries G R) * (b : HahnSeries G R)).coeff g else 0) = _ + rw [HahnSeries.coeff_mul] + change _ = ((HahnSeries.filter + (· ∈ FiniteArchimedeanClass.closedBallAddSubgroup c) (a : HahnSeries G R)) * + HahnSeries.filter (· ∈ FiniteArchimedeanClass.closedBallAddSubgroup c) + (b : HahnSeries G R)).coeff g + rw [HahnSeries.coeff_mul] + let C := FiniteArchimedeanClass.closedBallAddSubgroup c + have hC : (C : Set G).OrdConnected := by + constructor + intro x hx y hy z hz + change x ∈ FiniteArchimedeanClass.closedBallAddSubgroup c at hx + change y ∈ FiniteArchimedeanClass.closedBallAddSubgroup c at hy + change z ∈ FiniteArchimedeanClass.closedBallAddSubgroup c + rw [FiniteArchimedeanClass.mem_closedBallAddSubgroup_iff] at hx hy ⊢ + intro hz0 + have hx' : c.1 ≤ ArchimedeanClass.mk x := by + by_cases hx0 : x = 0 + · simp [hx0] + · exact hx hx0 + have hy' : c.1 ≤ ArchimedeanClass.mk y := by + by_cases hy0 : y = 0 + · simp [hy0] + · exact hy hy0 + exact (le_min hx' hy').trans + (ArchimedeanClass.min_le_mk_of_le_of_le hz.1 hz.2) + have hsub : Finset.antidiagonal + (HahnSeries.filter (· ∈ C) (a : HahnSeries G R)).isPWO_support + (HahnSeries.filter (· ∈ C) (b : HahnSeries G R)).isPWO_support g ⊆ + Finset.antidiagonal (a : HahnSeries G R).isPWO_support + (b : HahnSeries G R).isPWO_support g := by + intro p hp + rw [Finset.mem_antidiagonal] at hp ⊢ + exact ⟨HahnSeries.support_filter_subset _ _ hp.1, + HahnSeries.support_filter_subset _ _ hp.2.1, hp.2.2⟩ + by_cases hg : g ∈ C + · rw [ite_eq_left hg] + refine Finset.sum_congr ?_ ?_ + · apply Finset.Subset.antisymm _ hsub + intro p hp + rw [Finset.mem_antidiagonal] at hp ⊢ + have hp1le : p.1 ≤ 0 := a.property hp.1 + have hp2le : p.2 ≤ 0 := b.property hp.2.1 + have hgp1 : g ≤ p.1 := by + rw [← hp.2.2] + simpa using add_le_add_left hp2le p.1 + have hp1C : p.1 ∈ C := hC.out hg C.zero_mem ⟨hgp1, hp1le⟩ + have hp2C : p.2 ∈ C := by simpa [← hp.2.2] using C.sub_mem hg hp1C + exact ⟨by simpa only [HahnSeries.support_filter, Set.mem_ofPred_eq] using + And.intro hp.1 hp1C, + by simpa only [HahnSeries.support_filter, Set.mem_ofPred_eq] using + And.intro hp.2.1 hp2C, hp.2.2⟩ + · intro p hp + rw [Finset.mem_antidiagonal, HahnSeries.support_filter, + HahnSeries.support_filter] at hp + simp only [HahnSeries.coeff_filter, ite_eq_left hp.1.2, ite_eq_left hp.2.1.2] + · rw [ite_eq_right hg] + refine (Finset.sum_eq_zero fun p hp ↦ ?_).symm + rw [Finset.mem_antidiagonal, HahnSeries.support_filter, + HahnSeries.support_filter] at hp + exact (hg (hp.2.2 ▸ C.add_mem hp.1.2 hp.2.1.2)).elim + +/-- Restriction at a class strictly above the class of a negative support bound is zero. -/ +theorem closedClassRestrict_eq_zero_of_support_subset_Iic + {e : G} (he : e < 0) {c : FiniteArchimedeanClass G} + (hec : FiniteArchimedeanClass.mk e he.ne < c) {b : Nonpositive G R} + (hb : (b : HahnSeries G R).support ⊆ Iic e) : + closedClassRestrict c b = 0 := by + classical + apply Subtype.ext + ext g + rw [closedClassRestrict, HahnSeries.coeff_filter] + split_ifs with hg + · by_contra hcoeff + have hgs : g ∈ (b : HahnSeries G R).support := HahnSeries.mem_support _ _ |>.mpr hcoeff + have hg0 : g ≠ 0 := fun h ↦ (not_le_of_gt he) (h ▸ hb hgs) + have hcg := (FiniteArchimedeanClass.mem_closedBallAddSubgroup_iff).mp hg hg0 + have hge := ArchimedeanClass.mk_le_mk_of_le_of_nonpos (hb hgs) he.le + exact (not_le_of_gt hec) (hcg.trans hge) + · rfl + +/-- One class in a cofinal set kills any finite family of explicitly bounded germ errors. -/ +theorem exists_closedClassRestrict_eq_zero_of_finset + [Nontrivial G] [NoMaxOrder (FiniteArchimedeanClass G)] + {s : Finset (Nonpositive G R)} + (e : Nonpositive G R → G) (he : ∀ b ∈ s, e b < 0) + (hbe : ∀ b ∈ s, (b : HahnSeries G R).support ⊆ Iic (e b)) + {T : Set (FiniteArchimedeanClass G)} (hT : IsCofinal T) : + ∃ c ∈ T, ∀ b ∈ s, closedClassRestrict c b = 0 := by + classical + let f : s → FiniteArchimedeanClass G := fun b ↦ + FiniteArchimedeanClass.mk (e b) (he b b.2).ne + obtain ⟨a, ha⟩ := Finset.exists_le (Finset.univ.image f) + obtain ⟨a', haa'⟩ := exists_gt a + obtain ⟨d, hdT, ha'd⟩ := hT a' + refine ⟨d, hdT, fun b hb ↦ ?_⟩ + have hba : FiniteArchimedeanClass.mk (e b) (he b hb).ne ≤ a := + ha _ (Finset.mem_image.mpr ⟨⟨b, hb⟩, Finset.mem_univ _, rfl⟩) + exact closedClassRestrict_eq_zero_of_support_subset_Iic (he b hb) + (hba.trans_lt (haa'.trans_le ha'd)) (hbe b hb) + +/-- One class in a cofinal set kills any finite family of errors that vanish in the +quotient by series bounded strictly below zero. -/ +theorem exists_closedClassRestrict_eq_zero_of_finset_mem_supp + [UniformSpace G] [IsUniformAddGroup G] [OrderTopology G] [Nontrivial G] + [CompleteSpace G] [NoMaxOrder (FiniteArchimedeanClass G)] + [NoZeroDivisors R] [CharZero R] + {s : Finset (Nonpositive G R)} + (hs : ∀ b ∈ s, b ∈ (cantorBendixsonValuation (G := G) (R := R)).supp) + {T : Set (FiniteArchimedeanClass G)} (hT : IsCofinal T) : + ∃ c ∈ T, ∀ b ∈ s, closedClassRestrict c b = 0 := by + classical + choose e he hbe using fun b : s ↦ + (mem_cantorBendixsonValuation_supp (b : Nonpositive G R)).mp (hs b.1 b.2) + let f : s → FiniteArchimedeanClass G := fun b ↦ + FiniteArchimedeanClass.mk (e b) (he b).ne + obtain ⟨a, ha⟩ := Finset.exists_le (Finset.univ.image f) + obtain ⟨a', haa'⟩ := exists_gt a + obtain ⟨d, hdT, ha'd⟩ := hT a' + refine ⟨d, hdT, fun b hb ↦ ?_⟩ + let b' : s := ⟨b, hb⟩ + have hba : FiniteArchimedeanClass.mk (e b') (he b').ne ≤ a := + ha _ (Finset.mem_image.mpr ⟨b', Finset.mem_univ _, rfl⟩) + exact closedClassRestrict_eq_zero_of_support_subset_Iic (he b') + (hba.trans_lt (haa'.trans_le ha'd)) (hbe b') + +/-- Four refinement equations holding as germs hold exactly after restricting all representatives +at one sufficiently late class from any cofinal family. -/ +theorem exists_closedClassRestrict_fourFactor_eq + [UniformSpace G] [IsUniformAddGroup G] [OrderTopology G] [Nontrivial G] + [CompleteSpace G] [NoMaxOrder (FiniteArchimedeanClass G)] + [NoZeroDivisors R] [CharZero R] + {a b c d e f g h : Nonpositive G R} + (ha : Ideal.Quotient.mk (cantorBendixsonValuation (G := G) (R := R)).supp a = + Ideal.Quotient.mk (cantorBendixsonValuation (G := G) (R := R)).supp (e * f)) + (hb : Ideal.Quotient.mk (cantorBendixsonValuation (G := G) (R := R)).supp b = + Ideal.Quotient.mk (cantorBendixsonValuation (G := G) (R := R)).supp (g * h)) + (hc : Ideal.Quotient.mk (cantorBendixsonValuation (G := G) (R := R)).supp c = + Ideal.Quotient.mk (cantorBendixsonValuation (G := G) (R := R)).supp (e * g)) + (hd : Ideal.Quotient.mk (cantorBendixsonValuation (G := G) (R := R)).supp d = + Ideal.Quotient.mk (cantorBendixsonValuation (G := G) (R := R)).supp (f * h)) + {T : Set (FiniteArchimedeanClass G)} (hT : IsCofinal T) : + ∃ q ∈ T, + closedClassRestrict q a = closedClassRestrict q (e * f) ∧ + closedClassRestrict q b = closedClassRestrict q (g * h) ∧ + closedClassRestrict q c = closedClassRestrict q (e * g) ∧ + closedClassRestrict q d = closedClassRestrict q (f * h) := by + obtain ⟨q, hqT, hq⟩ := exists_closedClassRestrict_eq_zero_of_finset_mem_supp + (fourFactorErrors_mem_supp ha hb hc hd) hT + refine ⟨q, hqT, ?_, ?_, ?_, ?_⟩ + · have := hq (a - e * f) (by simp [fourFactorErrors]) + rw [closedClassRestrict_sub, sub_eq_zero] at this + exact this + · have := hq (b - g * h) (by simp [fourFactorErrors]) + rw [closedClassRestrict_sub, sub_eq_zero] at this + exact this + · have := hq (c - e * g) (by simp [fourFactorErrors]) + rw [closedClassRestrict_sub, sub_eq_zero] at this + exact this + · have := hq (d - f * h) (by simp [fourFactorErrors]) + rw [closedClassRestrict_sub, sub_eq_zero] at this + exact this + +/-- Four-factor refinement in the germ quotient yields an exact refinement after one sufficiently +late closed-class restriction. -/ +theorem exists_closedClassRestrict_refinement + [UniformSpace G] [IsUniformAddGroup G] [OrderTopology G] [Nontrivial G] + [CompleteSpace G] [NoMaxOrder (FiniteArchimedeanClass G)] + [NoZeroDivisors R] [CharZero R] + (hrefine : HasFourFactorRefinement + (Nonpositive G R ⧸ (cantorBendixsonValuation (G := G) (R := R)).supp)) + {a b c d : Nonpositive G R} (habcd : a * b = c * d) + {T : Set (FiniteArchimedeanClass G)} (hT : IsCofinal T) : + ∃ q ∈ T, ∃ e f g h : Nonpositive G R, + closedClassRestrict q a = closedClassRestrict q e * closedClassRestrict q f ∧ + closedClassRestrict q b = closedClassRestrict q g * closedClassRestrict q h ∧ + closedClassRestrict q c = closedClassRestrict q e * closedClassRestrict q g ∧ + closedClassRestrict q d = closedClassRestrict q f * closedClassRestrict q h := by + let J := (cantorBendixsonValuation (G := G) (R := R)).supp + have hquot : Ideal.Quotient.mk J a * Ideal.Quotient.mk J b = + Ideal.Quotient.mk J c * Ideal.Quotient.mk J d := by + simpa only [map_mul] using congrArg (Ideal.Quotient.mk J) habcd + obtain ⟨e', f', g', h', ha, hb, hc, hd⟩ := hrefine.refine hquot + obtain ⟨e, rfl⟩ := Ideal.Quotient.mk_surjective e' + obtain ⟨f, rfl⟩ := Ideal.Quotient.mk_surjective f' + obtain ⟨g, rfl⟩ := Ideal.Quotient.mk_surjective g' + obtain ⟨h, rfl⟩ := Ideal.Quotient.mk_surjective h' + obtain ⟨q, hqT, hqa, hqb, hqc, hqd⟩ := + exists_closedClassRestrict_fourFactor_eq ha hb hc hd hT + refine ⟨q, hqT, e, f, g, h, ?_, ?_, ?_, ?_⟩ + · rwa [closedClassRestrict_mul] at hqa + · rwa [closedClassRestrict_mul] at hqb + · rwa [closedClassRestrict_mul] at hqc + · rwa [closedClassRestrict_mul] at hqd + +end + +end HahnSeries.Nonpositive diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Refinement/LimitTailRefinement.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Refinement/LimitTailRefinement.lean new file mode 100644 index 0000000000..4fbd03743f --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Refinement/LimitTailRefinement.lean @@ -0,0 +1,286 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.LimitTailQuotient +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Refinement.CardinalGermRefinement +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.ConvexQuotientSplitting +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Refinement.FiniteGermError + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint + +/-! +# Cauchy-complete common-tail quotients + +A family of finite Archimedean classes determines a common convex tail and an ordered rational +quotient. This file gives that quotient its order topology and proves refinement when the quotient +is Cauchy complete for its additive uniformity. The resulting refinement is exact after +restriction at a coinitial family of quotient Archimedean classes in the magnitude order. +-/ + +open Cardinal Set + +universe u + +public noncomputable section + + + +namespace HahnSeries.Nonpositive + +variable {G : Type u} {K : Type*} +variable [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [Module ℚ G] [PosSMulMono ℚ G] + [Field K] [CharZero K] + +/-- Cauchy completeness of a common-tail quotient gives cardinal-bounded local refinement. -/ +@[blueprint "thm:complete-tail-quotient-refinement" + (phase := "Refinement over Archimedean classes") + (title := "Exact refinement over a Cauchy-complete common-tail quotient") + (statement := /-- + Let $T$ be a nonempty set of nonzero Archimedean classes with no least + member in the magnitude order, and let $C$ be the quotient of the exponent + group by the common tail below $T$. Assume that $C$ is Cauchy complete for + its additive uniformity and that $T$ has cardinality less than $\kappa$. + For every equation $ab=cd$ among four $\kappa$-bounded series in + $K((C^{\le0}))$ and every set $U$ of nonzero Archimedean classes of $C$ + coinitial in the magnitude order, there is $q\in U$ and a $\kappa$-bounded + four-factor refinement whose four equations hold exactly after restriction + to the closed ball of $q$. + -/) + (proof := /-- + Positive representatives of the classes in $T$ give a positive coinitial + subset of $C$ of cardinality less than $\kappa$. Apply + \ref{thm:cardinal-bounded-germ-refinement}; each of its four equations has + an error supported strictly below zero. Coinitiality of $U$ in the + magnitude order supplies a class $q$ smaller in magnitude than all four + errors, so closed-ball restriction makes the four equations exact + simultaneously. + -/)] +theorem exists_closed_class_refinement_of_complete_tail_quotient + {κ : Cardinal.{u}} [Fact (ℵ₀ < κ)] + (T : Set (FiniteArchimedeanClass G)) [Nonempty T] + (hT : ∀ c ∈ T, ∃ d ∈ T, c < d) + [CompleteSpace (FiniteArchimedeanClass.TailQuotient T)] + (hTcard : #T < κ) + (a b c d : Nonpositive (FiniteArchimedeanClass.TailQuotient T) K) + (ha : (a : HahnSeries (FiniteArchimedeanClass.TailQuotient T) K).cardSupp < κ) + (hb : (b : HahnSeries (FiniteArchimedeanClass.TailQuotient T) K).cardSupp < κ) + (hc : (c : HahnSeries (FiniteArchimedeanClass.TailQuotient T) K).cardSupp < κ) + (hd : (d : HahnSeries (FiniteArchimedeanClass.TailQuotient T) K).cardSupp < κ) + (habcd : a * b = c * d) + {U : Set (FiniteArchimedeanClass (FiniteArchimedeanClass.TailQuotient T))} + (hU : IsCofinal U) : + ∃ q ∈ U, ∃ e f g h : Nonpositive (FiniteArchimedeanClass.TailQuotient T) K, + closedClassRestrict q a = closedClassRestrict q e * closedClassRestrict q f ∧ + closedClassRestrict q b = closedClassRestrict q g * closedClassRestrict q h ∧ + closedClassRestrict q c = closedClassRestrict q e * closedClassRestrict q g ∧ + closedClassRestrict q d = closedClassRestrict q f * closedClassRestrict q h ∧ + (e : HahnSeries (FiniteArchimedeanClass.TailQuotient T) K).cardSupp < κ ∧ + (f : HahnSeries (FiniteArchimedeanClass.TailQuotient T) K).cardSupp < κ ∧ + (g : HahnSeries (FiniteArchimedeanClass.TailQuotient T) K).cardSupp < κ ∧ + (h : HahnSeries (FiniteArchimedeanClass.TailQuotient T) K).cardSupp < κ := by + let C := FiniteArchimedeanClass.TailQuotient T + let scale : T → C := fun c ↦ + Submodule.Quotient.mk (FiniteArchimedeanClass.positiveRepresentative c.1) + have hscalePos (c : T) : 0 < scale c := by + rw [← Submodule.Quotient.mk_zero] + apply ConvexQuotient.mk_lt_mk_iff.mpr + refine ⟨FiniteArchimedeanClass.positiveRepresentative_pos c.1, ?_⟩ + intro hmem + have htail : FiniteArchimedeanClass.positiveRepresentative c.1 ∈ + FiniteArchimedeanClass.tailKernel T := by + rw [← FiniteArchimedeanClass.tailSubmodule_toAddSubgroup ℚ T] + simpa using hmem + exact FiniteArchimedeanClass.positiveRepresentative_not_mem_tailKernel hT c htail + let : Nontrivial C := by + let c : T := Classical.arbitrary T + exact ⟨⟨0, scale c, (hscalePos c).ne⟩⟩ + let : NoMaxOrder (FiniteArchimedeanClass C) := + FiniteArchimedeanClass.quotient_noMax_of_eq_tailKernel T + (FiniteArchimedeanClass.tailSubmodule ℚ T).toAddSubgroup + (FiniteArchimedeanClass.tailSubmodule_toAddSubgroup ℚ T) hT + have hEcard : #(Set.range scale) < κ := Cardinal.mk_range_le.trans_lt hTcard + have hEcoinitial : ∀ y : C, 0 < y → + ∃ x ∈ Set.range scale, 0 < x ∧ x ≤ y := by + intro y hy + obtain ⟨c, hcy⟩ := + FiniteArchimedeanClass.exists_tailQuotient_positiveRepresentative_le (T := T) hy + exact ⟨scale c, Set.mem_range_self c, hscalePos c, hcy⟩ + obtain ⟨e, f, g, h, hea, heb, hec, hed, hecard, hfcard, hgcard, hhcard⟩ := + exists_cardinal_germ_refinement + (Set.range scale) hEcard hEcoinitial a b c d ha hb hc hd habcd + obtain ⟨q, hqU, hqa, hqb, hqc, hqd⟩ := exists_closedClassRestrict_fourFactor_eq + (cantorBendixson_germ_eq_iff a (e * f) |>.mpr hea) + (cantorBendixson_germ_eq_iff b (g * h) |>.mpr heb) + (cantorBendixson_germ_eq_iff c (e * g) |>.mpr hec) + (cantorBendixson_germ_eq_iff d (f * h) |>.mpr hed) hU + refine ⟨q, hqU, e, f, g, h, ?_, ?_, ?_, ?_, hecard, hfcard, hgcard, hhcard⟩ + · rwa [closedClassRestrict_mul] at hqa + · rwa [closedClassRestrict_mul] at hqb + · rwa [closedClassRestrict_mul] at hqc + · rwa [closedClassRestrict_mul] at hqd + +end HahnSeries.Nonpositive + +namespace HahnSeries + +variable {G : Type u} {R : Type*} +variable [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [Module ℚ G] [PosSMulMono ℚ G] + [Semiring R] + +/-- A quotient class met by the support bounds a strict initial segment of the original support +classes. -/ +@[blueprint "lem:tail-quotient-class-bounds-support-classes" + (phase := "Refinement over Archimedean classes") + (title := "Support classes beyond a quotient Archimedean ball") + (statement := /-- + Let $T$ be a family of nonzero Archimedean classes of an ordered rational + vector space $G$, and let $q$ be a nonzero Archimedean class of the quotient + by the common tail below $T$. Suppose $q$ is met by the image of a set + $S\subseteq G$. If every nonzero element of $W\subseteq G$ maps outside + the closed ball of $q$ and has an Archimedean class met by $S$, then there + is a nonzero class $c$ met by $S$ such that every class met by $W$ is + strictly below $c$ and is met by $S$. + -/) + (proof := /-- + Choose $y\in S$ whose image has class $q$. For $g\in W\setminus\{0\}$, + being outside the closed ball of $q$ says that the quotient class of $g$ is + strictly larger in magnitude than that of $y$. The common-tail quotient + reflects this strict comparison to the original Archimedean-class order, + so the class of $g$ lies strictly below the class of $y$. + -/)] +theorem exists_nonzeroSupportClass_bound_tailQuotient + (T : Set (FiniteArchimedeanClass G)) + (q : FiniteArchimedeanClass (FiniteArchimedeanClass.TailQuotient T)) + (S W : Set G) + (hqocc : q.1 ∈ ArchimedeanClass.mk '' + (Submodule.Quotient.mk (p := FiniteArchimedeanClass.tailSubmodule ℚ T) '' S)) + (hW : ∀ g ∈ W, g ≠ 0 → + Submodule.Quotient.mk g ∉ FiniteArchimedeanClass.closedBallAddSubgroup q) + (hWocc : ∀ g ∈ W, g ≠ 0 → + ArchimedeanClass.mk g ∈ ArchimedeanClass.mk '' S) : + ∃ c ∈ ArchimedeanClass.mk '' (S \ {0}), + ArchimedeanClass.mk '' (W \ {0}) ⊆ + (ArchimedeanClass.mk '' (S \ {0})) ∩ Set.Iio c := by + obtain ⟨yq, ⟨y, hyS, rfl⟩, hyq⟩ := hqocc + have hy0 : y ≠ 0 := by + intro hy + subst y + have hqtop : q.1 = ⊤ := by + rw [← hyq] + exact ArchimedeanClass.mk_eq_top_iff.mpr (Submodule.Quotient.mk_zero _) + exact q.2 hqtop + refine ⟨ArchimedeanClass.mk y, ⟨y, ⟨hyS, by simpa using hy0⟩, rfl⟩, ?_⟩ + rintro _ ⟨g, ⟨hgW, hg0⟩, rfl⟩ + rw [Set.mem_singleton_iff] at hg0 + obtain ⟨z, hzS, hzg⟩ := hWocc g hgW hg0 + have hz0 : z ≠ 0 := by + intro hz + subst z + rw [ArchimedeanClass.mk_zero] at hzg + exact hg0 (ArchimedeanClass.mk_eq_top_iff.mp hzg.symm) + refine ⟨⟨z, ⟨hzS, by simpa using hz0⟩, hzg⟩, ?_⟩ + have hgq : ArchimedeanClass.mk + (Submodule.Quotient.mk g : FiniteArchimedeanClass.TailQuotient T) < + ArchimedeanClass.mk + (Submodule.Quotient.mk y : FiniteArchimedeanClass.TailQuotient T) := by + apply ArchimedeanClass.mk_lt_of_not_mem_closedBallAddSubgroup + intro hmem + apply hW g hgW hg0 + apply FiniteArchimedeanClass.mem_closedBallAddSubgroup_iff.mpr + intro hgq0 + change q.1 ≤ ArchimedeanClass.mk + (Submodule.Quotient.mk g : FiniteArchimedeanClass.TailQuotient T) + rw [← hyq] + exact ArchimedeanClass.mem_closedBallAddSubgroup_iff.mp hmem + exact FiniteArchimedeanClass.archimedeanClass_mk_lt_of_tailQuotient_mk_lt T hgq + +/-- If the support meets every class of a limit block, its nonzero outer classes after tail +regrouping are cofinal in the tail quotient. -/ +theorem isCofinal_supportArchimedeanClasses_convexQuotientSplit + (T₀ T₁ : Set (ArchimedeanClass G)) + (hT₀gt : ∀ a ∈ T₀, ∃ b ∈ T₀, a < b) + (x : HahnSeries G R) + (hxclasses : ArchimedeanClass.mk '' x.support = T₀ ∪ T₁) : + let T : Set (FiniteArchimedeanClass G) := {c | c.1 ∈ T₀} + let P := FiniteArchimedeanClass.tailSubmodule ℚ T + let y := convexQuotientSplitRingEquiv P x + IsCofinal {q : FiniteArchimedeanClass (FiniteArchimedeanClass.TailQuotient T) | + q.1 ∈ ArchimedeanClass.mk '' y.support} := by + dsimp only + intro q + induction q using FiniteArchimedeanClass.ind with + | mk z hz => + obtain ⟨c, hcz⟩ := FiniteArchimedeanClass.exists_tailQuotient_positiveRepresentative_le + (T := {c : FiniteArchimedeanClass G | c.1 ∈ T₀}) (abs_pos.mpr hz) + obtain ⟨d, hdT₀, hcd⟩ := hT₀gt c.1 c.2 + obtain ⟨e, heT₀, hde⟩ := hT₀gt d hdT₀ + obtain ⟨f, _hfT₀, hef⟩ := hT₀gt e heT₀ + have hdOcc : d ∈ ArchimedeanClass.mk '' x.support := by + rw [hxclasses] + exact Or.inl hdT₀ + obtain ⟨g, hg, hgd⟩ := hdOcc + let P := FiniteArchimedeanClass.tailSubmodule ℚ + {c : FiniteArchimedeanClass G | c.1 ∈ T₀} + let qp : (FiniteArchimedeanClass.TailQuotient + {c : FiniteArchimedeanClass G | c.1 ∈ T₀}) × P := + ofLex ((Submodule.quotientLexEquiv P).symm g) + let zq : FiniteArchimedeanClass.TailQuotient + {c : FiniteArchimedeanClass G | c.1 ∈ T₀} := qp.1 + let p : P := qp.2 + have hzqmk : Submodule.Quotient.mk g = zq := by + have hrepr : Submodule.quotientLexEquiv P (toLex qp) = g := by + change Submodule.quotientLexEquiv P + ((Submodule.quotientLexEquiv P).symm g) = g + exact (Submodule.quotientLexEquiv P).apply_symm_apply g + rw [← hrepr, Submodule.quotientLexEquiv_apply, + Submodule.mk_quotientProdLinearEquiv] + rfl + have hzq0 : zq ≠ 0 := by + intro hzq + have hgP : g ∈ P := by + rw [← Submodule.Quotient.mk_eq_zero P, hzqmk, hzq] + have heleg : e ≤ ArchimedeanClass.mk g := + FiniteArchimedeanClass.mem_tailKernel_iff.mp + ((FiniteArchimedeanClass.mem_tailSubmodule_iff (K := ℚ)).mp hgP) + ⟨⟨e, ne_top_of_lt hef⟩, heT₀⟩ + rw [hgd] at heleg + exact (not_le_of_gt hde) heleg + have hzqsupp : zq ∈ (convexQuotientSplitRingEquiv P x).support := by + rw [mem_support] + intro hzero + have hcoeff := congrArg (fun s : R⟦P⟧ ↦ s.coeff p) hzero + rw [convexQuotientSplitRingEquiv_coeff] at hcoeff + have hlex : Submodule.quotientLexEquiv P (toLex (zq, p)) = g := by + change Submodule.quotientLexEquiv P (toLex qp) = g + exact (Submodule.quotientLexEquiv P).apply_symm_apply g + rw [hlex] at hcoeff + exact (mem_support _ _).mp hg hcoeff + refine ⟨FiniteArchimedeanClass.mk zq hzq0, ?_, ?_⟩ + · exact ⟨zq, hzqsupp, rfl⟩ + · change ArchimedeanClass.mk z ≤ ArchimedeanClass.mk zq + rw [ArchimedeanClass.mk_le_mk] + have habs : |zq| ≤ |z| := calc + |zq| = (Submodule.Quotient.mk |g| : FiniteArchimedeanClass.TailQuotient + {c : FiniteArchimedeanClass G | c.1 ∈ T₀}) := by + rw [← hzqmk] + exact FiniteArchimedeanClass.tailQuotient_abs + {c : FiniteArchimedeanClass G | c.1 ∈ T₀} g + _ ≤ (Submodule.Quotient.mk (FiniteArchimedeanClass.positiveRepresentative c.1) : + FiniteArchimedeanClass.TailQuotient + {c : FiniteArchimedeanClass G | c.1 ∈ T₀}) := by + apply ConvexQuotient.mk_le_mk + have hcg : c.1 < ArchimedeanClass.mk g := hcd.trans_eq hgd.symm + have hdom := ArchimedeanClass.mk_lt_mk.mp + (FiniteArchimedeanClass.mk_positiveRepresentative c.1 ▸ hcg) 1 + simpa only [one_nsmul, + abs_of_pos (FiniteArchimedeanClass.positiveRepresentative_pos c.1)] using hdom.le + _ ≤ |z| := hcz + exact ⟨1, by simpa only [one_nsmul] using habs⟩ + +end HahnSeries diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Refinement/SupportClassFactorization.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Refinement/SupportClassFactorization.lean new file mode 100644 index 0000000000..53efa29e08 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Refinement/SupportClassFactorization.lean @@ -0,0 +1,125 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Refinement.LimitTailRefinement +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Refinement.ConvexRestrictionFactorization +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Order.ArchimedeanBall + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint + +/-! +# Factoring at a support class in a tail quotient + +After regrouping along a common tail, a class met by the support determines a nonzero convex +restriction. Factoring off that restriction leaves an integral cofactor whose nonzero support +classes have strictly smaller order type. +-/ + +public noncomputable section + +open Cardinal +open scoped HahnSeries + +universe u v + +namespace HahnSeries.CardSuppLTTruncationIntegerPart + +open Classical in +/-- Factoring at a tail-quotient class met by the support strictly lowers the order type of the +nonzero support classes of the complementary factor. -/ +@[blueprint "lem:support-class-factorisation" + (phase := "Refinement over Archimedean classes") + (title := "Factorisation at a quotient Archimedean class") + (statement := /-- + Let $T$ be a set of nonzero Archimedean classes of an ordered rational + vector space $G$, and let $q$ be a nonzero Archimedean class of the quotient + of $G$ by the common tail below $T$. Suppose the support of + $b\in Z+R((G^{<0}))_\kappa$ meets $q$ and the restriction $t$ of $b$ to + the inverse image of the closed ball of $q$ is nonzero. Then + \[ + b=tw, + \] + where the order type of the nonzero Archimedean support classes of $w$ is + strictly smaller than that of $b$. + -/) + (proof := /-- + By \ref{lem:factorisation-by-convex-restriction}, the retained restriction + gives a factorisation $b=tw$, and every nonzero class met by $w$ is also met + by $b$. The quotient class $q$ and + \ref{lem:tail-quotient-class-bounds-support-classes} bound all those classes + strictly below one class met by $b$. The strict order-type inequality + follows from \ref{lem:support-class-order-type-strict-decrease}. + -/)] +theorem exists_factor_with_smaller_support_class_orderType + {G : Type u} {R : Type v} + [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [Module ℚ G] [PosSMulMono ℚ G] + [Field R] + {κ : Cardinal} [Fact (ℵ₀ < κ)] + (Z : Subring R) + (T : Set (FiniteArchimedeanClass G)) + (q : FiniteArchimedeanClass (FiniteArchimedeanClass.TailQuotient T)) + (b : HahnSeries.cardSuppLTTruncationIntegerPart + (G := G) (R := R) (κ := κ) Z) + (hqocc : q.1 ∈ ArchimedeanClass.mk '' + (Submodule.Quotient.mk (p := FiniteArchimedeanClass.tailSubmodule ℚ T) '' + (b : HahnSeries G R).support)) + (hne : HahnSeries.filter + (· ∈ (FiniteArchimedeanClass.closedBallAddSubgroup q).comap + (FiniteArchimedeanClass.tailSubmodule ℚ T).mkQ.toAddMonoidHom) + (b : HahnSeries G R) ≠ 0) : + ∃ t w : HahnSeries.cardSuppLTTruncationIntegerPart + (G := G) (R := R) (κ := κ) Z, + (t : HahnSeries G R) = HahnSeries.filter + (· ∈ (FiniteArchimedeanClass.closedBallAddSubgroup q).comap + (FiniteArchimedeanClass.tailSubmodule ℚ T).mkQ.toAddMonoidHom) + (b : HahnSeries G R) ∧ + b = t * w ∧ + (HahnSeries.Nonpositive.isPWO_nonzeroSupportArchimedeanClasses + (toNonpositiveRingHom Z w)).orderType < + (HahnSeries.Nonpositive.isPWO_nonzeroSupportArchimedeanClasses + (toNonpositiveRingHom Z b)).orderType := by + classical + let P := FiniteArchimedeanClass.tailSubmodule ℚ T + let C : AddSubgroup G := + (FiniteArchimedeanClass.closedBallAddSubgroup q).comap P.mkQ.toAddMonoidHom + let : C.IsConvex := by + constructor + exact (FiniteArchimedeanClass.closedBall_ordConnected q).preimage_mono + (fun _ _ h ↦ ConvexQuotient.mk_le_mk h) + obtain ⟨t, w, ht, hfac, _hw0, hwC, hwocc⟩ := + exists_factorization_by_restriction Z + (inferInstance : C.IsConvex).ordConnected b hne + refine ⟨t, w, ht, hfac, ?_⟩ + let bN := toNonpositiveRingHom Z b + let wN := toNonpositiveRingHom Z w + obtain ⟨c, hc, hsub⟩ := + HahnSeries.exists_nonzeroSupportClass_bound_tailQuotient + T q (b : HahnSeries G R).support (w : HahnSeries G R).support hqocc + (by + intro g hg hg0 + exact hwC g hg hg0) + hwocc + have hc' : c ∈ bN.nonzeroSupportArchimedeanClasses := by + rw [HahnSeries.Nonpositive.mem_nonzeroSupportArchimedeanClasses_iff] + obtain ⟨g, ⟨hg, hg0⟩, hgc⟩ := hc + exact ⟨g, by simpa only [bN, coe_toNonpositiveRingHom] using hg, + by simpa only [Set.mem_singleton_iff] using hg0, hgc⟩ + apply HahnSeries.Nonpositive.orderType_nonzeroSupportArchimedeanClasses_lt bN wN hc' + intro d hd + rw [HahnSeries.Nonpositive.mem_nonzeroSupportArchimedeanClasses_iff] at hd + obtain ⟨g, hg, hg0, hgd⟩ := hd + have hg' : g ∈ (w : HahnSeries G R).support := by + simpa only [wN, coe_toNonpositiveRingHom] using hg + have hd' := hsub ⟨g, ⟨hg', by simpa only [Set.mem_singleton_iff] using hg0⟩, hgd⟩ + refine ⟨?_, hd'.2⟩ + rw [HahnSeries.Nonpositive.mem_nonzeroSupportArchimedeanClasses_iff] + obtain ⟨z, ⟨hz, hz0⟩, hzd⟩ := hd'.1 + exact ⟨z, by simpa only [bN, coe_toNonpositiveRingHom] using hz, + by simpa only [Set.mem_singleton_iff] using hz0, hzd⟩ + +end HahnSeries.CardSuppLTTruncationIntegerPart diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Refinement/SupportClassRefinement.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Refinement/SupportClassRefinement.lean new file mode 100644 index 0000000000..95789f383a --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Refinement/SupportClassRefinement.lean @@ -0,0 +1,360 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Refinement.CardinalTruncationClosedClass +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.CardinalTruncationDomainEmbedding +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.CharZero +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Refinement.LimitTailRefinement +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.FiniteClassPrimality + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint + +/-! +# Exact refinement at a support class in a Hahn tail quotient + +Cauchy completeness gives refinement modulo series bounded away from zero in the common-tail +quotient. +Cofinality selects an outer support class where the four equations become exact. Finite-class +primality normalizes the inner residues. The normalization takes place when the bounded Hahn field +on the common tail is the fraction field of its bounded Hahn integer part. +-/ + +public noncomputable section + +open Cardinal FiniteArchimedeanClass +open scoped HahnSeries + +universe u v + +namespace HahnSeries.CardSuppLTTruncationIntegerPart + +private theorem mk_finiteArchimedeanClasses_lt + {G : Type u} {R : Type v} [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [Field R] {κ : Cardinal} [Fact (ℵ₀ < κ)] {Z : Subring R} + (a : HahnSeries.cardSuppLTTruncationIntegerPart + (G := G) (R := R) (κ := κ) Z) + (T₀ : Set (ArchimedeanClass G)) + (hT₀ : T₀ ⊆ ArchimedeanClass.mk '' (a : HahnSeries G R).support) : + #{q : FiniteArchimedeanClass G | q.1 ∈ T₀} < κ := by + let T : Set (FiniteArchimedeanClass G) := {q | q.1 ∈ T₀} + have supportRep_exists (q : T) : ∃ g : (a : HahnSeries G R).support, + ArchimedeanClass.mk (g : G) = q.1.1 := by + obtain ⟨g, hg, hgq⟩ := hT₀ q.2 + exact ⟨⟨g, hg⟩, hgq⟩ + let supportRep (q : T) : (a : HahnSeries G R).support := + Classical.choose (supportRep_exists q) + have supportRep_spec (q : T) : + ArchimedeanClass.mk (supportRep q : G) = q.1.1 := + Classical.choose_spec (supportRep_exists q) + have supportRep_injective : Function.Injective supportRep := by + intro q r hqr + apply Subtype.ext + apply Subtype.ext + exact (supportRep_spec q).symm.trans + ((congrArg (fun z : (a : HahnSeries G R).support ↦ + ArchimedeanClass.mk (z : G)) hqr).trans (supportRep_spec r)) + exact (Cardinal.mk_le_of_injective supportRep_injective).trans_lt a.1.2 + +/-- A bounded nonpositive four-factor refinement after restriction to one closed +Archimedean class in a specified family. -/ +private def HasNonpositiveClosedClassRefinement + {G : Type u} {K : Type v} + [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [Field K] {κ : Cardinal} [Fact (ℵ₀ < κ)] + (S : Subring K) (U : Set (FiniteArchimedeanClass G)) + (a b c d : HahnSeries.cardSuppLTTruncationIntegerPart + (G := G) (R := K) (κ := κ) S) : Prop := + ∃ q ∈ U, ∃ e f g h : HahnSeries.Nonpositive G K, + HahnSeries.Nonpositive.closedClassRestrict q + (HahnSeries.CardSuppLTTruncationIntegerPart.toNonpositiveRingHom S a) = + HahnSeries.Nonpositive.closedClassRestrict q e * + HahnSeries.Nonpositive.closedClassRestrict q f ∧ + HahnSeries.Nonpositive.closedClassRestrict q + (HahnSeries.CardSuppLTTruncationIntegerPart.toNonpositiveRingHom S b) = + HahnSeries.Nonpositive.closedClassRestrict q g * + HahnSeries.Nonpositive.closedClassRestrict q h ∧ + HahnSeries.Nonpositive.closedClassRestrict q + (HahnSeries.CardSuppLTTruncationIntegerPart.toNonpositiveRingHom S c) = + HahnSeries.Nonpositive.closedClassRestrict q e * + HahnSeries.Nonpositive.closedClassRestrict q g ∧ + HahnSeries.Nonpositive.closedClassRestrict q + (HahnSeries.CardSuppLTTruncationIntegerPart.toNonpositiveRingHom S d) = + HahnSeries.Nonpositive.closedClassRestrict q f * + HahnSeries.Nonpositive.closedClassRestrict q h ∧ + (e : HahnSeries G K).cardSupp < κ ∧ + (f : HahnSeries G K).cardSupp < κ ∧ + (g : HahnSeries G K).cardSupp < κ ∧ + (h : HahnSeries G K).cardSupp < κ + +/-- A bounded Hahn-integer-part equation over a complete tail quotient admits a bounded +nonpositive refinement after restriction to a coinitial closed class. -/ +private theorem exists_nonpositive_closed_class_refinement_of_complete_tail_quotient + {G : Type u} {K : Type v} + [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [Module ℚ G] [PosSMulMono ℚ G] + [Field K] [CharZero K] + {κ : Cardinal} [Fact (ℵ₀ < κ)] + (T : Set (FiniteArchimedeanClass G)) [Nonempty T] + (hT : ∀ c ∈ T, ∃ d ∈ T, c < d) + [CompleteSpace (FiniteArchimedeanClass.TailQuotient T)] + (hTcard : #T < κ) + (S : Subring K) + (a b c d : HahnSeries.cardSuppLTTruncationIntegerPart + (G := FiniteArchimedeanClass.TailQuotient T) (R := K) (κ := κ) S) + (habcd : a * b = c * d) + {U : Set (FiniteArchimedeanClass (FiniteArchimedeanClass.TailQuotient T))} + (hU : IsCofinal U) : + HasNonpositiveClosedClassRefinement S U a b c d := by + let toN := HahnSeries.CardSuppLTTruncationIntegerPart.toNonpositiveRingHom + (G := FiniteArchimedeanClass.TailQuotient T) (R := K) (κ := κ) S + have hnonpositive : toN a * toN b = toN c * toN d := by + simpa only [map_mul] using congrArg toN habcd + have cardSupp_toN_lt (x : HahnSeries.cardSuppLTTruncationIntegerPart + (G := FiniteArchimedeanClass.TailQuotient T) (R := K) (κ := κ) S) : + ((toN x : HahnSeries.Nonpositive + (FiniteArchimedeanClass.TailQuotient T) K) : + HahnSeries (FiniteArchimedeanClass.TailQuotient T) K).cardSupp < κ := by + have hx := (HahnSeries.mem_cardSuppLTSubfield + (Γ := FiniteArchimedeanClass.TailQuotient T) (R := K) (κ := κ)).mp x.1.2 + simpa only [toN, + HahnSeries.CardSuppLTTruncationIntegerPart.coe_toNonpositiveRingHom] using hx + rw [HasNonpositiveClosedClassRefinement] + exact HahnSeries.Nonpositive.exists_closed_class_refinement_of_complete_tail_quotient + T hT hTcard (toN a) (toN b) (toN c) (toN d) + (cardSupp_toN_lt a) (cardSupp_toN_lt b) (cardSupp_toN_lt c) (cardSupp_toN_lt d) + hnonpositive hU + +/-- Regrouping an equation along a limit tail produces a bounded nonpositive refinement at a +support class of the first factor. -/ +private theorem exists_nonpositive_refinement_at_support_class + {G : Type u} {R : Type v} + [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [Module ℚ G] [PosSMulMono ℚ G] + [Field R] [CharZero R] + {κ : Cardinal} [Fact (ℵ₀ < κ)] [Fact κ.IsRegular] + (Z : Subring R) + (T₀ T₁ : Set (ArchimedeanClass G)) + (hT₀gt : ∀ a ∈ T₀, ∃ b ∈ T₀, a < b) + (a b c d : HahnSeries.cardSuppLTTruncationIntegerPart + (G := G) (R := R) (κ := κ) Z) + (habcd : a * b = c * d) + (haclasses : ArchimedeanClass.mk '' (a : HahnSeries G R).support = T₀ ∪ T₁) + [Nonempty {q : FiniteArchimedeanClass G | q.1 ∈ T₀}] + [CompleteSpace (FiniteArchimedeanClass.TailQuotient + {q : FiniteArchimedeanClass G | q.1 ∈ T₀})] : + let T : Set (FiniteArchimedeanClass G) := {q | q.1 ∈ T₀} + let P := FiniteArchimedeanClass.tailSubmodule ℚ T + let S := HahnSeries.cardSuppLTTruncationIntegerPart (G := P) (R := R) (κ := κ) Z + let E := HahnSeries.cardSuppLTTruncationIntegerPartConvexQuotientSplitRingEquiv + (R := R) (κ := κ) P Z + let U : Set (FiniteArchimedeanClass (FiniteArchimedeanClass.TailQuotient T)) := + {q | q.1 ∈ ArchimedeanClass.mk '' + (HahnSeries.convexQuotientSplitRingEquiv P (a : HahnSeries G R)).support} + HasNonpositiveClosedClassRefinement S U (E a) (E b) (E c) (E d) := by + classical + let T : Set (FiniteArchimedeanClass G) := {q | q.1 ∈ T₀} + let P := FiniteArchimedeanClass.tailSubmodule ℚ T + let InnerField := HahnSeries.CardSuppLTField (G := P) (R := R) (κ := κ) + let S := HahnSeries.cardSuppLTTruncationIntegerPart (G := P) (R := R) (κ := κ) Z + let E := HahnSeries.cardSuppLTTruncationIntegerPartConvexQuotientSplitRingEquiv + (R := R) (κ := κ) P Z + let A := E a + let B := E b + let C := E c + let D := E d + have hABCD : A * B = C * D := by + simpa only [A, B, C, D, map_mul] using congrArg E habcd + have hT : ∀ x ∈ T, ∃ y ∈ T, x < y := by + intro x hx + obtain ⟨y, hy, hxy⟩ := hT₀gt x.1 hx + obtain ⟨z, hz, hyz⟩ := hT₀gt y hy + exact ⟨⟨y, ne_top_of_lt hyz⟩, hy, hxy⟩ + let U : Set (FiniteArchimedeanClass (FiniteArchimedeanClass.TailQuotient T)) := + {q | q.1 ∈ ArchimedeanClass.mk '' + (HahnSeries.convexQuotientSplitRingEquiv P (a : HahnSeries G R)).support} + have hU : IsCofinal U := HahnSeries.isCofinal_supportArchimedeanClasses_convexQuotientSplit + T₀ T₁ hT₀gt (a : HahnSeries G R) haclasses + have hTcard : #T < κ := by + apply mk_finiteArchimedeanClasses_lt (Z := Z) a T₀ + intro q hq + rw [haclasses] + exact Or.inl hq + exact exists_nonpositive_closed_class_refinement_of_complete_tail_quotient + T hT hTcard S A B C D hABCD hU + +/-- The first factor has the primal residue and nonvanishing closed-class restrictions needed +to normalize refinements over a specified family of classes. -/ +private def HasClosedClassNormalization + {G : Type u} {K : Type v} + [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [Field K] {κ : Cardinal} [Fact (ℵ₀ < κ)] + (S : Subring K) (U : Set (FiniteArchimedeanClass G)) + (a b c d : HahnSeries.cardSuppLTTruncationIntegerPart + (G := G) (R := K) (κ := κ) S) : Prop := + a * b = c * d ∧ + IsPrimal (⟨(a : K⟦G⟧).coeff 0, + ((HahnSeries.mem_cardSuppLTTruncationIntegerPart (Z := S)).mp a.2).2⟩ : S) ∧ + Subring.fracSubring S = ⊤ ∧ + ∀ q ∈ U, closedClassRestrict S q a ≠ 0 + +/-- The normalization hypotheses turn every bounded nonpositive closed-class refinement into one +inside the cardinal-bounded Hahn integer part. -/ +private theorem exists_integer_part_refinement_of_nonpositive_refinement + {G : Type u} {K : Type v} + [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [Field K] {κ : Cardinal} [Fact (ℵ₀ < κ)] + (S : Subring K) (U : Set (FiniteArchimedeanClass G)) + (a b c d : HahnSeries.cardSuppLTTruncationIntegerPart + (G := G) (R := K) (κ := κ) S) + (href : HasNonpositiveClosedClassRefinement S U a b c d) + (hnorm : HasClosedClassNormalization S U a b c d) : + ∃ q ∈ U, ∃ E F H₁ H₂ : HahnSeries.cardSuppLTTruncationIntegerPart + (G := G) (R := K) (κ := κ) S, + closedClassRestrict S q a = E * F ∧ + closedClassRestrict S q b = H₁ * H₂ ∧ + closedClassRestrict S q c = E * H₁ ∧ + closedClassRestrict S q d = F * H₂ := by + rw [HasNonpositiveClosedClassRefinement] at href + rw [HasClosedClassNormalization] at hnorm + obtain ⟨habcd, haS, hfrac, hnonzero⟩ := hnorm + obtain ⟨q, hq, e, f, g, h, hea, heb, hec, hed, hecard, hfcard, hgcard, hhcard⟩ := href + obtain ⟨E, F, H₁, H₂, hEA, hEB, hEC, hED⟩ := + exists_refinement_closedClassRestrict_of_ambient + S q a b c d haS hfrac (hnonzero q hq) habcd e f g h + hecard hfcard hgcard hhcard hea heb hec hed + exact ⟨q, hq, E, F, H₁, H₂, hEA, hEB, hEC, hED⟩ + +/-- Regrouping along the common tail supplies the normalization hypotheses at every support class +of the first factor. -/ +private theorem has_closed_class_normalization_at_support_classes + {G : Type u} {R : Type v} + [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [Module ℚ G] [PosSMulMono ℚ G] + [Field R] + {κ : Cardinal} [Fact (ℵ₀ < κ)] [Fact κ.IsRegular] + (Z : Subring R) + (hfinite : ∀ y : HahnSeries.cardSuppLTTruncationIntegerPart + (G := G) (R := R) (κ := κ) Z, + (ArchimedeanClass.mk '' (y : HahnSeries G R).support).Finite → IsPrimal y) + (T₀ T₁ : Set (ArchimedeanClass G)) + (hT₀gt : ∀ a ∈ T₀, ∃ b ∈ T₀, a < b) (hT₁ : T₁.Finite) + (a b c d : HahnSeries.cardSuppLTTruncationIntegerPart + (G := G) (R := R) (κ := κ) Z) + (habcd : a * b = c * d) + (haclasses : ArchimedeanClass.mk '' (a : HahnSeries G R).support = T₀ ∪ T₁) + (htailfrac : + Subring.fracSubring (HahnSeries.cardSuppLTTruncationIntegerPart + (G := FiniteArchimedeanClass.tailSubmodule ℚ + {q : FiniteArchimedeanClass G | q.1 ∈ T₀}) + (R := R) (κ := κ) Z) = ⊤) : + let T : Set (FiniteArchimedeanClass G) := {q | q.1 ∈ T₀} + let P := FiniteArchimedeanClass.tailSubmodule ℚ T + let S := HahnSeries.cardSuppLTTruncationIntegerPart + (G := P) (R := R) (κ := κ) Z + let E := HahnSeries.cardSuppLTTruncationIntegerPartConvexQuotientSplitRingEquiv + (R := R) (κ := κ) P Z + let U : Set (FiniteArchimedeanClass (FiniteArchimedeanClass.TailQuotient T)) := + {q | q.1 ∈ ArchimedeanClass.mk '' + (HahnSeries.convexQuotientSplitRingEquiv P (a : HahnSeries G R)).support} + HasClosedClassNormalization S U (E a) (E b) (E c) (E d) := by + let T : Set (FiniteArchimedeanClass G) := {q | q.1 ∈ T₀} + let P := FiniteArchimedeanClass.tailSubmodule ℚ T + let InnerField := HahnSeries.CardSuppLTField (G := P) (R := R) (κ := κ) + let S := HahnSeries.cardSuppLTTruncationIntegerPart (G := P) (R := R) (κ := κ) Z + let E := HahnSeries.cardSuppLTTruncationIntegerPartConvexQuotientSplitRingEquiv + (R := R) (κ := κ) P Z + let A := E a + let B := E b + let C := E c + let D := E d + rw [HasClosedClassNormalization] + refine ⟨?_, ?_, ?_, ?_⟩ + · simpa only [A, B, C, D, map_mul] using congrArg E habcd + · exact isPrimal_coeff_zero_convexQuotientSplitRingEquiv_of_ambient_finiteClasses + Z hfinite T₀ T₁ hT₀gt hT₁ a haclasses.le + · exact htailfrac + · intro q hq + apply closedClassRestrict_ne_zero_of_mem_image_mk_support S q A + rw [HahnSeries.support_cardSuppLTTruncationIntegerPartConvexQuotientSplitRingEquiv] + exact hq + +/-- Select an outer class met by the support and refine all four closed-class restrictions. -/ +@[blueprint "thm:support-class-refinement" + (phase := "Refinement over Archimedean classes") + (title := "Refinement at a quotient Archimedean class") + (statement := /-- + Let $a,b,c,d\in Z+R((G^{<0}))_\kappa$ satisfy $ab=cd$. Suppose that the + Archimedean classes met by the support of $a$ are $T_0\cup T_1$, where + $T_1$ is finite, and $T_0$ contains a non-zero class and has no greatest + element. Assume primality for every series whose support meets only + finitely many Archimedean classes. Assume that the quotient by the common + tail below $T_0$ is Cauchy complete for its additive uniformity, and that + the $\kappa$-bounded Hahn field on the common tail is the fraction field of + its corresponding $\kappa$-bounded integer part. Then some Archimedean + class of the quotient met by the support of $a$ admits an exact four-factor + refinement of the restrictions of $a,b,c,d$ to its closed Archimedean ball. + -/) + (proof := /-- + Regroup each series as a series on the common-tail quotient. The support + classes of $a$ are cofinal there, so + \ref{thm:complete-tail-quotient-refinement} gives an exact refinement at + one class met by that support. Primality of the inner constant term and + its descent to the convex common tail use + \ref{lem:convex-support-of-factors}: every nonzero factor of a series + supported in that tail is supported there. This primality together with + the common-tail fraction-field hypothesis supplies the hypotheses of + \ref{lem:closed-class-refinement-normalization}, which normalises the four + quotient factors inside the bounded Hahn integer part. + -/)] +theorem exists_closed_class_refinement_at_support_class + {G : Type u} {R : Type v} + [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [Module ℚ G] [PosSMulMono ℚ G] + [Field R] [CharZero R] + {κ : Cardinal} [Fact (ℵ₀ < κ)] [Fact κ.IsRegular] + (Z : Subring R) + (hfinite : ∀ y : HahnSeries.cardSuppLTTruncationIntegerPart + (G := G) (R := R) (κ := κ) Z, + (ArchimedeanClass.mk '' (y : HahnSeries G R).support).Finite → IsPrimal y) + (T₀ T₁ : Set (ArchimedeanClass G)) + (hT₀gt : ∀ a ∈ T₀, ∃ b ∈ T₀, a < b) (hT₁ : T₁.Finite) + (a b c d : HahnSeries.cardSuppLTTruncationIntegerPart + (G := G) (R := R) (κ := κ) Z) + (habcd : a * b = c * d) + (haclasses : ArchimedeanClass.mk '' (a : HahnSeries G R).support = T₀ ∪ T₁) + [Nonempty {q : FiniteArchimedeanClass G | q.1 ∈ T₀}] + [CompleteSpace (FiniteArchimedeanClass.TailQuotient + {q : FiniteArchimedeanClass G | q.1 ∈ T₀})] + (htailfrac : + Subring.fracSubring (HahnSeries.cardSuppLTTruncationIntegerPart + (G := FiniteArchimedeanClass.tailSubmodule ℚ + {q : FiniteArchimedeanClass G | q.1 ∈ T₀}) + (R := R) (κ := κ) Z) = ⊤) : + let T : Set (FiniteArchimedeanClass G) := {q | q.1 ∈ T₀} + let P := FiniteArchimedeanClass.tailSubmodule ℚ T + let S := HahnSeries.cardSuppLTTruncationIntegerPart + (G := P) (R := R) (κ := κ) Z + let E := HahnSeries.cardSuppLTTruncationIntegerPartConvexQuotientSplitRingEquiv + (R := R) (κ := κ) P Z + ∃ q : FiniteArchimedeanClass (FiniteArchimedeanClass.TailQuotient T), + q.1 ∈ ArchimedeanClass.mk '' + (HahnSeries.convexQuotientSplitRingEquiv P (a : HahnSeries G R)).support ∧ + ∃ e f g h : HahnSeries.cardSuppLTTruncationIntegerPart + (G := FiniteArchimedeanClass.TailQuotient T) + (R := HahnSeries.CardSuppLTField (G := P) (R := R) (κ := κ)) + (κ := κ) S, + closedClassRestrict S q (E a) = e * f ∧ + closedClassRestrict S q (E b) = g * h ∧ + closedClassRestrict S q (E c) = e * g ∧ + closedClassRestrict S q (E d) = f * h := by + apply exists_integer_part_refinement_of_nonpositive_refinement + · exact exists_nonpositive_refinement_at_support_class + Z T₀ T₁ hT₀gt a b c d habcd haclasses + · exact has_closed_class_normalization_at_support_classes + Z hfinite T₀ T₁ hT₀gt hT₁ a b c d habcd haclasses htailfrac + +end HahnSeries.CardSuppLTTruncationIntegerPart diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Refinement/TruncationIntegerPartFractionField.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Refinement/TruncationIntegerPartFractionField.lean new file mode 100644 index 0000000000..e82aa955d2 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Refinement/TruncationIntegerPartFractionField.lean @@ -0,0 +1,296 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Refinement.CompleteGermRefinement +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.TruncationIntegerPartPrimal + +import LeanPool.ConwayRefinement.ConwayRefinement.Topology.Order.ArchimedeanBallBase +import Mathlib.RingTheory.MvPolynomial.IrreducibleQuadratic +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint + +/-! +# The fraction-field condition for truncation integer parts + +Let `K` be a field of characteristic zero, let `G` be an ordered exponent group that is Cauchy +complete with no least nonzero Archimedean magnitude, and let `Z` be a subring of `K`. If the +generalised-power-series integer part `Z + K((G^{<0}))` has the refinement property, then `K` is +the fraction field of `Z`. + +The proof uses the polynomial presentation of the germ ring. A cofinal series shows that the +polynomial algebra has a variable. Translating a representative of that variable by its constant +coefficient gives an irreducible germ with constant coefficient zero. Primality of this series in +the integer part, applied to its scalar multiples by `x` and `x⁻¹`, writes every `x : K` as a +fraction of elements of `Z`. +-/ + +open Set +open scoped HahnSeries + +universe u v + +public noncomputable section + +namespace HahnSeries.Nonpositive + +variable {G : Type u} {K : Type v} +variable [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [UniformSpace G] [IsUniformAddGroup G] [OrderTopology G] [Nontrivial G] [CompleteSpace G] + [DenselyOrdered G] [NoMinOrder G] [NoMaxOrder G] + [NoMaxOrder (FiniteArchimedeanClass G)] + [Field K] [CharZero K] + +private def cofinalNegativeExponent (i : ArchimedeanClass.CofinalIndex G) : G := + -|ArchimedeanClass.CofinalIndex.representative i| + +omit [UniformSpace G] [IsUniformAddGroup G] [OrderTopology G] [Nontrivial G] + [CompleteSpace G] [DenselyOrdered G] [NoMinOrder G] [NoMaxOrder G] + [NoMaxOrder (FiniteArchimedeanClass G)] in +private theorem cofinalNegativeExponent_lt_zero (i : ArchimedeanClass.CofinalIndex G) : + cofinalNegativeExponent i < 0 := by + apply neg_lt_zero.mpr + apply abs_pos.mpr + exact ArchimedeanClass.CofinalIndex.representative_ne_zero i + +omit [UniformSpace G] [IsUniformAddGroup G] [OrderTopology G] [Nontrivial G] + [CompleteSpace G] [DenselyOrdered G] [NoMinOrder G] [NoMaxOrder G] + [NoMaxOrder (FiniteArchimedeanClass G)] in +private theorem cofinalNegativeExponent_strictMono : + StrictMono (cofinalNegativeExponent (G := G)) := by + intro i j hij + apply neg_lt_neg + have hclass : + ArchimedeanClass.mk (ArchimedeanClass.CofinalIndex.representative i) < + ArchimedeanClass.mk (ArchimedeanClass.CofinalIndex.representative j) := by + simpa only [ArchimedeanClass.CofinalIndex.mk_representative] using + ArchimedeanClass.CofinalIndex.underlyingClass_lt_of_lt hij + simpa using (ArchimedeanClass.mk_lt_mk.mp hclass 1) + +omit [UniformSpace G] [IsUniformAddGroup G] [OrderTopology G] [Nontrivial G] + [CompleteSpace G] [DenselyOrdered G] [NoMinOrder G] [NoMaxOrder G] + [NoMaxOrder (FiniteArchimedeanClass G)] in +private theorem cofinalNegativeExponent_isPWO : + (Set.range (cofinalNegativeExponent (G := G))).IsPWO := by + rw [show Set.range (cofinalNegativeExponent (G := G)) = + cofinalNegativeExponent (G := G) '' Set.univ by ext; simp] + exact (Set.IsPWO.of_linearOrder + (Set.univ : Set (ArchimedeanClass.CofinalIndex G))).image_of_monotone + cofinalNegativeExponent_strictMono.monotone + +private def cofinalGermSeries : HahnSeries G K := by + classical + exact HahnSeries.mk + (fun g => if g ∈ Set.range (cofinalNegativeExponent (G := G)) then 1 else 0) + (by + rw [show Function.support + (fun g => if g ∈ Set.range (cofinalNegativeExponent (G := G)) then + (1 : K) else 0) = Set.range (cofinalNegativeExponent (G := G)) by + ext g + simp [Function.mem_support]] + exact cofinalNegativeExponent_isPWO) + +omit [UniformSpace G] [IsUniformAddGroup G] [OrderTopology G] [Nontrivial G] + [CompleteSpace G] [DenselyOrdered G] [NoMinOrder G] [NoMaxOrder G] + [NoMaxOrder (FiniteArchimedeanClass G)] in +private theorem support_cofinalGermSeries : + (cofinalGermSeries (G := G) (K := K)).support = + Set.range (cofinalNegativeExponent (G := G)) := by + classical + ext g + simp [cofinalGermSeries] + +private def cofinalGermNonpositive : Nonpositive G K := + ⟨cofinalGermSeries (G := G) (K := K), by + intro g hg + rw [support_cofinalGermSeries] at hg + obtain ⟨i, rfl⟩ := hg + exact (cofinalNegativeExponent_lt_zero i).le⟩ + +omit [UniformSpace G] [IsUniformAddGroup G] [OrderTopology G] [Nontrivial G] + [CompleteSpace G] [DenselyOrdered G] [NoMinOrder G] [NoMaxOrder G] + [NoMaxOrder (FiniteArchimedeanClass G)] in +private theorem constantCoeff_cofinalGermNonpositive : + constantCoeff (cofinalGermNonpositive (G := G) (K := K)) = 0 := by + classical + rw [constantCoeff_apply] + change (cofinalGermSeries (G := G) (K := K)).coeff 0 = 0 + rw [cofinalGermSeries] + change (if 0 ∈ Set.range (cofinalNegativeExponent (G := G)) then 1 else 0) = 0 + rw [ite_eq_right] + rintro ⟨i, hi⟩ + exact (cofinalNegativeExponent_lt_zero i).ne hi + +omit [UniformSpace G] [IsUniformAddGroup G] [OrderTopology G] [Nontrivial G] + [CompleteSpace G] [DenselyOrdered G] [NoMinOrder G] [NoMaxOrder G] + [NoMaxOrder (FiniteArchimedeanClass G)] in +private theorem cofinalIndex_exists_ge (c : FiniteArchimedeanClass G) : + ∃ i : ArchimedeanClass.CofinalIndex G, + c ≤ ArchimedeanClass.CofinalIndex.archimedeanClass i := by + have hcof := ArchimedeanClass.CofinalIndex.isCofinal_range_archimedeanClass (G := G) + obtain ⟨d, ⟨i, rfl⟩, hci⟩ := hcof c + exact ⟨i, hci⟩ + +omit [UniformSpace G] [IsUniformAddGroup G] [OrderTopology G] [Nontrivial G] + [CompleteSpace G] [DenselyOrdered G] [NoMinOrder G] [NoMaxOrder G] in +private theorem exists_cofinalNegativeExponent_gt (e : G) (he : e < 0) : + ∃ i : ArchimedeanClass.CofinalIndex G, + e < cofinalNegativeExponent (G := G) i := by + obtain ⟨i, hi⟩ := ArchimedeanClass.exists_cofinalBallBase_subset_Ioo (-e) (neg_pos.mpr he) + obtain ⟨d, hid⟩ := + exists_gt (ArchimedeanClass.CofinalIndex.archimedeanClass i) + obtain ⟨j, hdj⟩ := cofinalIndex_exists_ge (G := G) d + have hijClass : ArchimedeanClass.CofinalIndex.archimedeanClass i < + ArchimedeanClass.CofinalIndex.archimedeanClass j := hid.trans_le hdj + have hij : i < j := + ArchimedeanClass.CofinalIndex.lt_iff_archimedeanClass_lt.mpr hijClass + have hjball : cofinalNegativeExponent (G := G) j ∈ + ArchimedeanClass.cofinalBallBase i := by + apply (ArchimedeanClass.mem_cofinalBallBase_iff i _).mpr + simpa [cofinalNegativeExponent, + ArchimedeanClass.CofinalIndex.mk_representative] using + ArchimedeanClass.CofinalIndex.underlyingClass_lt_of_lt hij + have hjinterval := hi hjball + exact ⟨j, by simpa using hjinterval.1⟩ + +omit [DenselyOrdered G] [NoMinOrder G] [NoMaxOrder G] in +private theorem cofinalGermNonpositive_germ_ne_zero : + Ideal.Quotient.mk (cantorBendixsonValuation (G := G) (R := K)).supp + (cofinalGermNonpositive (G := G) (K := K)) ≠ 0 := by + intro hzero + have heq : Ideal.Quotient.mk (cantorBendixsonValuation (G := G) (R := K)).supp + (cofinalGermNonpositive (G := G) (K := K)) = + Ideal.Quotient.mk (cantorBendixsonValuation (G := G) (R := K)).supp 0 := by + simpa using hzero + obtain ⟨e, he, hcoeff⟩ := + (cantorBendixson_germ_eq_iff (cofinalGermNonpositive (G := G) (K := K)) 0).mp heq + obtain ⟨i, hei⟩ := exists_cofinalNegativeExponent_gt (G := G) e he + have h := hcoeff (cofinalNegativeExponent (G := G) i) hei + simp [cofinalGermNonpositive, cofinalGermSeries] at h + +omit [DenselyOrdered G] [NoMinOrder G] [NoMaxOrder G] + [NoMaxOrder (FiniteArchimedeanClass G)] in +private theorem cofinalGermNonpositive_germ_not_isUnit : + ¬ IsUnit (Ideal.Quotient.mk (cantorBendixsonValuation (G := G) (R := K)).supp + (cofinalGermNonpositive (G := G) (K := K))) := by + intro hunit + exact (constantCoeff_ne_zero_of_isUnit_cantorBendixson_germ hunit) + constantCoeff_cofinalGermNonpositive + +/-- There is a series with zero constant coefficient whose germ at zero is irreducible. -/ +@[blueprint "lem:irreducible-zero-constant-germ" + (phase := "Refinement over Archimedean classes") + (title := "An irreducible germ with zero constant coefficient") + (statement := /-- + Let $K$ be a field of characteristic zero and let $G$ be a nontrivial, + densely ordered abelian group with no least or greatest element and no + least nonzero Archimedean magnitude. Assume that $G$ is Cauchy complete + for its additive uniformity. + Then some series $p\in K((G^{\le0}))$ has constant coefficient zero and + irreducible image in the germ ring at zero. + -/) + (proof := /-- + Choose a well-ordered support cofinal at $0$ that meets a cofinal family + of nonzero Archimedean classes. The resulting series has a nonzero, + nonunit germ. Hence \ref{thm:complete-hahn-germ-polynomial-algebra} has + a nonempty index set. Choose a + polynomial variable $X_i$ and a series $p$ representing it. Subtracting + the constant coefficient $r$ of $p$ gives a representative with constant + coefficient zero and germ corresponding to $X_i-r$, which is irreducible. + -/)] +theorem exists_irreducible_cantorBendixson_germ_with_constantCoeff_zero : + ∃ p : Nonpositive G K, + constantCoeff p = 0 ∧ + Irreducible + (Ideal.Quotient.mk (cantorBendixsonValuation (G := G) (R := K)).supp p) := by + let J := (cantorBendixsonValuation (G := G) (R := K)).supp + obtain ⟨ι, ⟨equiv⟩⟩ := exists_mvPolynomial_algEquiv_germ (G := G) (K := K) + have hι : Nonempty ι := by + by_contra h + let : IsEmpty ι := not_nonempty_iff.mp h + let q : MvPolynomial ι K := + equiv.symm (Ideal.Quotient.mk J (cofinalGermNonpositive (G := G) (K := K))) + have hq0 : q ≠ 0 := by + intro hq + apply cofinalGermNonpositive_germ_ne_zero (G := G) (K := K) + have heq := congrArg equiv hq + simpa only [q, equiv.apply_symm_apply, map_zero] using heq + have hqcoeff : q.coeff 0 ≠ 0 := by + intro hcoeff + apply hq0 + rw [MvPolynomial.eq_C_of_isEmpty q, hcoeff, map_zero] + have hqunit : IsUnit q := by + rw [MvPolynomial.eq_C_of_isEmpty q] + exact (isUnit_iff_ne_zero.mpr hqcoeff).map MvPolynomial.C + apply cofinalGermNonpositive_germ_not_isUnit (G := G) (K := K) + simpa [q] using hqunit.map equiv.toMulEquiv + let i : ι := hι.some + obtain ⟨p, hp⟩ := Ideal.Quotient.mk_surjective (equiv (MvPolynomial.X i)) + let r : K := constantCoeff p + let p₀ : Nonpositive G K := p - C r + have hp₀coeff : constantCoeff p₀ = 0 := by + simp [p₀, r] + have hpoly : Irreducible (MvPolynomial.X i - MvPolynomial.C r) := by + simpa [sub_eq_add_neg] using + (MvPolynomial.irreducible_mul_X_add (1 : MvPolynomial ι K) + (-MvPolynomial.C r) i (by simp) (by simp) (by simp) isRelPrime_one_left) + have hgerm : + Ideal.Quotient.mk J p₀ = equiv (MvPolynomial.X i - MvPolynomial.C r) := by + have hconst : Ideal.Quotient.mk J (C r) = equiv (MvPolynomial.C r) := by + change Ideal.Quotient.mk J (algebraMap K (Nonpositive G K) r) = + equiv (algebraMap K (MvPolynomial ι K) r) + rw [Ideal.Quotient.mk_algebraMap] + exact (equiv.commutes r).symm + dsimp [p₀] + rw [map_sub, hp, hconst, map_sub] + refine ⟨p₀, hp₀coeff, ?_⟩ + rw [hgerm] + exact hpoly.map equiv.toMulEquiv + +/-- If `Z + K((G^{<0}))` has the refinement property, then `K` is the fraction field of `Z`. -/ +@[blueprint "thm:refinement-forces-coefficient-fraction-field" + (phase := "Refinement over Archimedean classes") + (title := "Refinement forces $K=\\operatorname{Frac}(Z)$") + (statement := /-- + Let $K$ be a field of characteristic zero and let $G$ satisfy the + hypotheses of \ref{lem:irreducible-zero-constant-germ}. If + \[ + Z+K((G^{<0})) + \] + has the refinement property for a subring $Z\subseteq K$, then + $K=\operatorname{Frac}(Z)$. + -/) + (proof := /-- + Identify the integer part with the inverse image of $Z$ under the + constant-coefficient map. By + \ref{lem:irreducible-zero-constant-germ}, it contains a series $p$ whose + constant coefficient is zero and whose germ is irreducible. Every + representative of a unit germ has nonzero constant coefficient, and the + refinement property makes $p$ primal. The scalar argument in + \ref{lem:primal-zero-residue-fraction-field} therefore gives + $K=\operatorname{Frac}(Z)$. + -/)] +theorem fracSubring_eq_top_of_hasFourFactorRefinement_truncationIntegerPart + (Z : Subring K) (h : HasFourFactorRefinement (truncationIntegerPart G Z)) : + Subring.fracSubring Z = ⊤ := by + let pi := constantCoeffAlgHom (G := G) (L := K) + let J := (cantorBendixsonValuation (G := G) (R := K)).supp + let phi : Nonpositive G K →+* Nonpositive G K ⧸ J := Ideal.Quotient.mk J + let e := truncationIntegerPartEquivResidueSubring (G := G) (L := K) Z + have hrefinement : HasFourFactorRefinement (Subring.residueSubring pi Z) := + h.map_mulEquiv e.toMulEquiv + obtain ⟨p, hpcoeff, hpIrr⟩ := + exists_irreducible_cantorBendixson_germ_with_constantCoeff_zero (G := G) (K := K) + have hpπ : pi p = 0 := by + simpa [pi, constantCoeffAlgHom_apply] using hpcoeff + exact Subring.fracSubring_eq_top_of_isPrimal_of_irreducible_map phi + (p := p) (S := Z) (π := pi) hpπ + (by simpa [phi, J] using hpIrr) + (fun a ha ↦ by + simpa [pi, phi, J, constantCoeffAlgHom_apply] using + (constantCoeff_ne_zero_of_isUnit_cantorBendixson_germ ha)) + (hrefinement.isPrimal ⟨p, by simp [hpπ]⟩) + +end HahnSeries.Nonpositive diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/SplitTruncation.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/SplitTruncation.lean new file mode 100644 index 0000000000..4576ddc057 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/SplitTruncation.lean @@ -0,0 +1,130 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.TruncationIntegerPartPrimal +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.ReducedCharacterization + +/-! +# The LM24 split truncation + +At an Archimedean class `c`, the closed truncation becomes an iterated Hahn series whose outer +exponent group is the chosen stratum and whose coefficient field is the Hahn field on the open +ball. Its outer support is nonpositive, and its outer constant coefficient is exactly the open +truncation. This packages the object denoted by `ισ(Tσ(x))` in LM24, Proposition 9.2.2. +-/ + +public noncomputable section + +namespace HahnSeries.Nonpositive + +open FiniteArchimedeanClass + +variable {K G R : Type*} +variable [DivisionRing K] [LinearOrder K] [IsOrderedRing K] [Archimedean K] +variable [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] +variable [Module K G] [IsOrderedModule K G] +variable [Field R] + +/-- The split closed-class truncation as a nonpositive Hahn series in the stratum exponent. -/ +def splitTruncation (u : HahnEmbedding.ArchimedeanStrata K G) + (c : FiniteArchimedeanClass G) (x : Nonpositive G R) : + Nonpositive (u.stratum c) R⟦ball K c⟧ := + ⟨HahnSeries.archimedeanSplitRingEquiv u c (TClosed c x), + support_archimedeanSplitRingEquiv_TClosed_subset u c x⟩ + +@[simp] +theorem coe_splitTruncation (u : HahnEmbedding.ArchimedeanStrata K G) + (c : FiniteArchimedeanClass G) (x : Nonpositive G R) : + (splitTruncation u c x : (R⟦ball K c⟧)⟦u.stratum c⟧) = + HahnSeries.archimedeanSplitRingEquiv u c (TClosed c x) := + (rfl) + +/-- The constant coefficient of the split truncation is the open-class truncation. -/ +theorem constantCoeff_splitTruncation + (u : HahnEmbedding.ArchimedeanStrata K G) (c : FiniteArchimedeanClass G) + (x : Nonpositive G R) : + constantCoeff (splitTruncation u c x) = tauBall c x := + by + rw [constantCoeff_apply, coe_splitTruncation] + exact coeff_zero_archimedeanSplitRingEquiv_TClosed u c x + +/-- The split truncation in the coefficient-subring integer part selected by its open +truncation. -/ +def splitTruncationIntegerPart + (u : HahnEmbedding.ArchimedeanStrata K G) (c : FiniteArchimedeanClass G) + (S : Subring R⟦ball K c⟧) (x : Nonpositive G R) (htau : tauBall c x ∈ S) : + truncationIntegerPart (u.stratum c) S := + ⟨splitTruncation u c x, by + rw [mem_truncationIntegerPart, ← constantCoeff_apply, constantCoeff_splitTruncation] + exact htau⟩ + +theorem coe_splitTruncationIntegerPart_hahn + (u : HahnEmbedding.ArchimedeanStrata K G) (c : FiniteArchimedeanClass G) + (S : Subring R⟦ball K c⟧) (x : Nonpositive G R) (htau : tauBall c x ∈ S) : + ((splitTruncationIntegerPart u c S x htau : + Nonpositive (u.stratum c) R⟦ball K c⟧) : + (R⟦ball K c⟧)⟦u.stratum c⟧) = + HahnSeries.archimedeanSplitRingEquiv u c (TClosed c x) := + (rfl) + +@[simp] +theorem coe_splitTruncationIntegerPart + (u : HahnEmbedding.ArchimedeanStrata K G) (c : FiniteArchimedeanClass G) + (S : Subring R⟦ball K c⟧) (x : Nonpositive G R) (htau : tauBall c x ∈ S) : + (splitTruncationIntegerPart u c S x htau : + Nonpositive (u.stratum c) R⟦ball K c⟧) = splitTruncation u c x := + (rfl) + +/-- If the open truncation is one, primality of the split truncation in the corresponding +coefficient-subring integer part is exactly its ambient primality. -/ +theorem isPrimal_splitTruncationIntegerPart_iff_of_tau_eq_one + (u : HahnEmbedding.ArchimedeanStrata K G) (c : FiniteArchimedeanClass G) + (S : Subring R⟦ball K c⟧) (x : Nonpositive G R) (htau : tauBall c x = 1) : + IsPrimal (splitTruncationIntegerPart u c S x (htau.symm ▸ S.one_mem)) ↔ + IsPrimal (splitTruncation u c x) := by + apply isPrimal_truncationIntegerPart_iff_of_constantCoeff_eq_one + rw [constantCoeffAlgHom_apply, coe_splitTruncationIntegerPart, ← constantCoeff_apply, + constantCoeff_splitTruncation, htau] + +/-- If the open truncation is zero and the fraction field generated by the coefficient subring +is the whole coefficient Hahn field, primality of the split truncation in the integer part is +exactly its ambient primality. -/ +theorem isPrimal_splitTruncationIntegerPart_iff_of_tau_eq_zero + (u : HahnEmbedding.ArchimedeanStrata K G) (c : FiniteArchimedeanClass G) + (S : Subring R⟦ball K c⟧) (hfrac : Subring.fracSubring S = ⊤) + (x : Nonpositive G R) (htau : tauBall c x = 0) : + IsPrimal (splitTruncationIntegerPart u c S x (htau.symm ▸ S.zero_mem)) ↔ + IsPrimal (splitTruncation u c x) := by + apply isPrimal_truncationIntegerPart_iff_of_constantCoeff_eq_zero S hfrac + rw [constantCoeffAlgHom_apply, coe_splitTruncationIntegerPart, ← constantCoeff_apply, + constantCoeff_splitTruncation, htau] + +/-- For a reduced nonconstant series, the split truncation is primal in its +coefficient-subring integer part exactly when it is primal in the ambient split nonpositive Hahn +ring, provided the coefficient subring generates the whole coefficient field. This is the local +Lemma 9.2.1 step in LM24, Proposition 9.2.2. -/ +theorem isPrimal_splitTruncationIntegerPart_iff_of_isReduced + (u : HahnEmbedding.ArchimedeanStrata K G) (b : Nonpositive G R) (hb0 : b ≠ 0) + (horder : (b : R⟦G⟧).order ≠ 0) (hbReduced : IsReduced b) + (S : Subring R⟦ball K (leadingClass b horder)⟧) + (hfrac : Subring.fracSubring S = ⊤) + (htauMem : tauBall (leadingClass b horder) b ∈ S) : + IsPrimal (splitTruncationIntegerPart u (leadingClass b horder) S b htauMem) ↔ + IsPrimal (splitTruncation u (leadingClass b horder) b) := by + rcases (isReduced_iff_tau_leadingClass_eq_zero_or_one (K := K) b hb0 horder).mp + hbReduced with + htau | htau + · have htauBall : tauBall (leadingClass b horder) b = 0 := + (tauBall_eq_zero_iff (leadingClass b horder) b).mpr htau + convert isPrimal_splitTruncationIntegerPart_iff_of_tau_eq_zero + u (leadingClass b horder) S hfrac b htauBall using 1 + · have htauBall : tauBall (K := K) (leadingClass b horder) b = 1 := by + exact tauBall_eq_one_of_tau_eq_one (leadingClass b horder) b htau + convert isPrimal_splitTruncationIntegerPart_iff_of_tau_eq_one + u (leadingClass b horder) S b htauBall using 1 + +end HahnSeries.Nonpositive diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Tests.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Tests.lean new file mode 100644 index 0000000000..046b62e9e3 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Tests.lean @@ -0,0 +1,25 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Tests.Assumptions +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Tests.Basic +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Tests.CardinalPrimalityTransfer +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Tests.CardinalProposition922 +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Tests.ClassTruncation +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Tests.FiniteClassReduction +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Tests.IntegerPartSplitting +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Tests.PrimalityTransfer +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Tests.Reduced +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Tests.ReducedCharacterization +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Tests.ReducedDivisibility +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Tests.Reduction +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Tests.SplitTruncation +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Tests.TruncationDivisibility +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Tests.TruncationPrimality + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Tests/Assumptions.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Tests/Assumptions.lean new file mode 100644 index 0000000000..449062909d --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Tests/Assumptions.lean @@ -0,0 +1,92 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Assumptions + +/-! +# API checks for LM24 assumptions `(A1)_σ` and `(A2)_σ` + +This separately compiled client exercises both clauses of `(A1)_σ` and all three clauses of +`(A2)_σ`. The finite-class checks keep the real-stratum, cofinality, and degenerate +fraction-field alternatives distinct; the full-class checks confirm that the class of zero is +accepted independently. +-/ + +universe u v + +public noncomputable section + +open Cardinal + +namespace Tests + +theorem assumptionA1_zero_class + {K : Type*} {G : Type u} + [DivisionRing K] [LinearOrder K] [IsOrderedRing K] [Archimedean K] + [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [Module K G] [IsOrderedModule K G] + (s : HahnEmbedding.ArchimedeanStrata K G) : + LM24.AssumptionA1 s (⊤ : ArchimedeanClass G) := by + rw [LM24.assumptionA1_iff] + exact Or.inl rfl + +theorem assumptionA1_finite_of_orderAddMonoidIso_real + {K : Type*} {G : Type u} + [DivisionRing K] [LinearOrder K] [IsOrderedRing K] [Archimedean K] + [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [Module K G] [IsOrderedModule K G] + (s : HahnEmbedding.ArchimedeanStrata K G) (c : FiniteArchimedeanClass G) + (e : s.stratum c ≃+o ℝ) : + LM24.AssumptionA1AtFiniteClass s c := by + rw [LM24.assumptionA1AtFiniteClass_iff] + exact ⟨e⟩ + +theorem assumptionA2_zero_class + {G : Type u} {R : Type v} + [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] [Field R] + (κ : Cardinal.{u}) (Z : Subring R) : + LM24.AssumptionA2 κ Z (⊤ : ArchimedeanClass G) := by + rw [LM24.assumptionA2_iff] + exact Or.inr (Or.inr rfl) + +theorem assumptionA2_finite_of_cofinality + {K : Type*} {G : Type u} {R : Type v} + [DivisionRing K] [LinearOrder K] [IsOrderedRing K] [Archimedean K] + [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [Module K G] [IsOrderedModule K G] [Field R] + (κ : Cardinal.{u}) (Z : Subring R) (σ : FiniteArchimedeanClass G) + (hcof : κ ≤ Order.cof ↥(FiniteArchimedeanClass.ball K σ)) : + LM24.AssumptionA2AtFiniteClass (K := K) κ Z σ := by + rw [LM24.assumptionA2AtFiniteClass_iff] + exact Or.inl hcof + +theorem assumptionA2_finite_of_zero_inner_group + {K : Type*} {G : Type u} {R : Type v} + [DivisionRing K] [LinearOrder K] [IsOrderedRing K] [Archimedean K] + [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [Module K G] [IsOrderedModule K G] [Field R] + (κ : Cardinal.{u}) (Z : Subring R) (σ : FiniteArchimedeanClass G) + (hzero : Subsingleton ↥(FiniteArchimedeanClass.ball K σ)) + (hfrac : Subring.fracSubring Z = ⊤) : + LM24.AssumptionA2AtFiniteClass (K := K) κ Z σ := by + rw [LM24.assumptionA2AtFiniteClass_iff] + exact Or.inr ⟨hzero, hfrac⟩ + +theorem assumptionA2_finite_fraction_consequence + {K : Type*} {G : Type u} {R : Type v} {κ : Cardinal.{u}} + [DivisionRing K] [LinearOrder K] [IsOrderedRing K] [Archimedean K] + [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [Module K G] [IsOrderedModule K G] [Field R] [Fact (ℵ₀ < κ)] + (Z : Subring R) (σ : FiniteArchimedeanClass G) + (hA2 : LM24.AssumptionA2AtFiniteClass (K := K) κ Z σ) : + Subring.fracSubring + (HahnSeries.cardSuppLTTruncationIntegerPart + (G := ↥(FiniteArchimedeanClass.ball K σ)) (R := R) (κ := κ) Z) = ⊤ := + LM24.fracSubring_cardSuppLTTruncationIntegerPart_eq_top_of_assumptionA2AtFiniteClass + Z σ hA2 + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Tests/Basic.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Tests/Basic.lean new file mode 100644 index 0000000000..240f4b0289 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Tests/Basic.lean @@ -0,0 +1,90 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Nonpositive +public import Mathlib.Algebra.Order.Ring.Rat + +/-! +# Tests for nonpositive Hahn series and their integer parts + +The examples distinguish nonpositive support and integral constant coefficient from the nearby +unrestricted conditions. +-/ + +public noncomputable section + +namespace Tests + +open HahnSeries + +/-- A monomial with positive exponent does not belong to the nonpositive Hahn subring. -/ +theorem positiveMonomial_not_mem_nonpositiveSubring : + HahnSeries.single (1 : ℚ) (1 : ℚ) ∉ nonpositiveSubring ℚ ℚ := by + rw [mem_nonpositiveSubring] + intro h + have hsupport : (1 : ℚ) ∈ (HahnSeries.single (1 : ℚ) (1 : ℚ)).support := by + simp + exact (by norm_num : ¬(1 : ℚ) ≤ 0) (h hsupport) + +/-- A nonconstant rational Hahn series with integral constant coefficient. -/ +def nonconstantIntegerPartSeries : Nonpositive ℚ ℚ := + Nonpositive.C (Γ := ℚ) (R := ℚ) 2 + + Nonpositive.single (Γ := ℚ) (R := ℚ) (-1) 3 (by norm_num) + +theorem nonconstantIntegerPartSeries_coeff_neg_one : + (nonconstantIntegerPartSeries : HahnSeries ℚ ℚ).coeff (-1) = 3 := by + simp [nonconstantIntegerPartSeries] + +theorem nonconstantIntegerPartSeries_constantCoeff : + Nonpositive.constantCoeff (Γ := ℚ) (R := ℚ) nonconstantIntegerPartSeries = 2 := by + simp [nonconstantIntegerPartSeries] + +theorem nonconstantIntegerPartSeries_mem_truncationIntegerPart : + nonconstantIntegerPartSeries ∈ truncationIntegerPart ℚ (⊥ : Subring ℚ) := by + simp [nonconstantIntegerPartSeries] + +theorem nonconstantIntegerPartSeries_add_self_mem_truncationIntegerPart : + nonconstantIntegerPartSeries + nonconstantIntegerPartSeries ∈ + truncationIntegerPart ℚ (⊥ : Subring ℚ) := + (truncationIntegerPart ℚ (⊥ : Subring ℚ)).add_mem + nonconstantIntegerPartSeries_mem_truncationIntegerPart + nonconstantIntegerPartSeries_mem_truncationIntegerPart + +theorem nonconstantIntegerPartSeries_mul_self_mem_truncationIntegerPart : + nonconstantIntegerPartSeries * nonconstantIntegerPartSeries ∈ + truncationIntegerPart ℚ (⊥ : Subring ℚ) := + (truncationIntegerPart ℚ (⊥ : Subring ℚ)).mul_mem + nonconstantIntegerPartSeries_mem_truncationIntegerPart + nonconstantIntegerPartSeries_mem_truncationIntegerPart + +theorem nonconstantIntegerPartSeries_add_self_constantCoeff : + Nonpositive.constantCoeff (Γ := ℚ) (R := ℚ) + (nonconstantIntegerPartSeries + nonconstantIntegerPartSeries) = 4 := by + rw [map_add, nonconstantIntegerPartSeries_constantCoeff] + norm_num + +theorem nonconstantIntegerPartSeries_mul_self_constantCoeff : + Nonpositive.constantCoeff (Γ := ℚ) (R := ℚ) + (nonconstantIntegerPartSeries * nonconstantIntegerPartSeries) = 4 := by + rw [map_mul, nonconstantIntegerPartSeries_constantCoeff] + norm_num + +/-- A nonpositive rational Hahn series whose constant coefficient is not integral. -/ +def nonintegralConstantSeries : Nonpositive ℚ ℚ := + Nonpositive.C (Γ := ℚ) (R := ℚ) (1 / 2) + + Nonpositive.single (Γ := ℚ) (R := ℚ) (-1) 3 (by norm_num) + +theorem nonintegralConstantSeries_not_mem_truncationIntegerPart : + nonintegralConstantSeries ∉ truncationIntegerPart ℚ (⊥ : Subring ℚ) := by + norm_num [nonintegralConstantSeries, Subring.mem_bot] + intro z hz + have hz2 := congrArg (fun q : ℚ => q * 2) hz + norm_num at hz2 + norm_cast at hz2 + omega + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Tests/CardinalPrimalityTransfer.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Tests/CardinalPrimalityTransfer.lean new file mode 100644 index 0000000000..eba13579ad --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Tests/CardinalPrimalityTransfer.lean @@ -0,0 +1,60 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.CardinalPrimalityTransfer + +/-! +# API checks for cardinal-bounded local primality transfer + +This separately compiled client exercises both reduced-residue branches after the leading-class +split. The zero branch consumes the exact finite-class form of `(A2)_σ`; the one branch does not. +-/ + +universe u v + +public noncomputable section + +open Cardinal FiniteArchimedeanClass + +namespace Tests + +open HahnSeries HahnSeries.Nonpositive + +theorem cardinalPrimalityTransfer_residue_one + {K : Type*} {G : Type u} {R : Type v} {κ : Cardinal.{u}} + [DivisionRing K] [LinearOrder K] [IsOrderedRing K] [Archimedean K] + [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [Module K G] [IsOrderedModule K G] [Field R] [Fact (ℵ₀ < κ)] + (u : HahnEmbedding.ArchimedeanStrata K G) (c : FiniteArchimedeanClass G) + (Z : Subring R) + (b : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) + (htau : tauBall (K := K) c + (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b) = 1) : + IsPrimal (splitTruncationCardSuppLTIntegerPart u c Z b) ↔ + IsPrimal (splitTruncationCardSuppLT u c + (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b) + (CardSuppLTTruncationIntegerPart.cardSupp_toNonpositiveRingHom_lt Z b)) := + isPrimal_splitTruncationCardSuppLTIntegerPart_iff_of_tau_eq_one u c Z b htau + +theorem cardinalPrimalityTransfer_residue_zero + {K : Type*} {G : Type u} {R : Type v} {κ : Cardinal.{u}} + [DivisionRing K] [LinearOrder K] [IsOrderedRing K] [Archimedean K] + [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [Module K G] [IsOrderedModule K G] [Field R] [Fact (ℵ₀ < κ)] + (u : HahnEmbedding.ArchimedeanStrata K G) (c : FiniteArchimedeanClass G) + (Z : Subring R) (hA2 : LM24.AssumptionA2AtFiniteClass (K := K) κ Z c) + (b : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) + (htau : tauBall (K := K) c + (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b) = 0) : + IsPrimal (splitTruncationCardSuppLTIntegerPart u c Z b) ↔ + IsPrimal (splitTruncationCardSuppLT u c + (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b) + (CardSuppLTTruncationIntegerPart.cardSupp_toNonpositiveRingHom_lt Z b)) := + isPrimal_splitTruncationCardSuppLTIntegerPart_iff_of_tau_eq_zero + u c Z hA2 b htau + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Tests/CardinalProposition922.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Tests/CardinalProposition922.lean new file mode 100644 index 0000000000..d7afaef8a2 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Tests/CardinalProposition922.lean @@ -0,0 +1,74 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.CardinalProposition922 + +/-! +# API checks for cardinal-bounded LM24 Proposition 9.2.2 + +The reduced transfer requires `(A2)_σ` only at the leading Archimedean class. The bounded +fixed-ring equivalence exposes both directions under the explicit regularity hypothesis. +-/ + +universe u v + +public noncomputable section + +open Cardinal FiniteArchimedeanClass + +namespace Tests + +open HahnSeries HahnSeries.Nonpositive + +theorem cardinalProposition922 + {K : Type*} {G : Type u} {R : Type v} {κ : Cardinal.{u}} + [DivisionRing K] [LinearOrder K] [IsOrderedRing K] [Archimedean K] + [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [Module K G] [IsOrderedModule K G] [Field R] + [Fact (ℵ₀ < κ)] [Fact κ.IsRegular] + (u : HahnEmbedding.ArchimedeanStrata K G) (Z : Subring R) + (b : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) + (hb0 : CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b ≠ 0) + (horder : ((CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b : + Nonpositive G R) : R⟦G⟧).order ≠ 0) + (hbReduced : IsReduced (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b)) + (hA2 : LM24.AssumptionA2AtFiniteClass (K := K) κ Z + (leadingClass (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b) horder)) : + IsPrimal b ↔ + IsPrimal (splitTruncationCardSuppLT u + (leadingClass (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b) horder) + (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b) + (CardSuppLTTruncationIntegerPart.cardSupp_toNonpositiveRingHom_lt Z b)) := + isPrimal_iff_isPrimal_splitTruncationCardSuppLT_of_isReduced + u Z b hb0 horder hbReduced hA2 + +theorem cardinalProposition922_A2_only_if_zero + {K : Type*} {G : Type u} {R : Type v} {κ : Cardinal.{u}} + [DivisionRing K] [LinearOrder K] [IsOrderedRing K] [Archimedean K] + [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [Module K G] [IsOrderedModule K G] [Field R] + [Fact (ℵ₀ < κ)] [Fact κ.IsRegular] + (u : HahnEmbedding.ArchimedeanStrata K G) (Z : Subring R) + (b : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) + (hb0 : CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b ≠ 0) + (horder : ((CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b : + Nonpositive G R) : R⟦G⟧).order ≠ 0) + (hbReduced : IsReduced (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b)) + (hA2 : tauBall (K := K) + (leadingClass (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b) horder) + (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b) = 0 → + LM24.AssumptionA2AtFiniteClass (K := K) κ Z + (leadingClass (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b) horder)) : + IsPrimal b ↔ + IsPrimal (splitTruncationCardSuppLT u + (leadingClass (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b) horder) + (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b) + (CardSuppLTTruncationIntegerPart.cardSupp_toNonpositiveRingHom_lt Z b)) := + isPrimal_iff_isPrimal_splitTruncationCardSuppLT_of_isReduced_if_A2 + u Z b hb0 horder hbReduced hA2 + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Tests/ClassTruncation.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Tests/ClassTruncation.lean new file mode 100644 index 0000000000..3489829c93 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Tests/ClassTruncation.lean @@ -0,0 +1,67 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import Mathlib.Algebra.Order.Archimedean.Basic +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.ClassTruncation + +/-! +# API checks for Archimedean-class truncations + +In the Archimedean exponent group `ℚ`, the class of `-1` is the unique nonzero class. At that +class, `T` keeps the boundary monomial while `tau` removes it. This distinguishes LM24's weak and +strict class cuts; an ordinary exponent truncation at the representative `-1` would not provide +the same class-invariant interface. +-/ + +public noncomputable section + +namespace Tests + +open HahnSeries FiniteArchimedeanClass + +/-- The finite Archimedean class of the nonzero rational exponent `-1`. -/ +def rationalClass : FiniteArchimedeanClass ℚ := + FiniteArchimedeanClass.mk (-1 : ℚ) (by norm_num) + +/-- The monomial `5t⁻¹` with integer coefficients, at the boundary of the rational class ball. -/ +def rationalBoundarySeries : Nonpositive ℚ ℤ := + Nonpositive.single (-1) 5 (by norm_num) + +theorem negOne_mem_closedBall : (-1 : ℚ) ∈ closedBall ℚ rationalClass := by + rw [FiniteArchimedeanClass.mem_closedBall_iff] + intro h + simp [rationalClass] + +theorem negOne_not_mem_ball : (-1 : ℚ) ∉ ball ℚ rationalClass := by + rw [FiniteArchimedeanClass.mem_ball_iff] + simp only [not_forall] + exact ⟨by norm_num, by simp [rationalClass]⟩ + +theorem classTruncation_boundary_coefficients : + ((Nonpositive.T (K := ℚ) rationalClass rationalBoundarySeries : + Nonpositive ℚ ℤ) : ℤ⟦ℚ⟧).coeff (-1) = 5 ∧ + ((Nonpositive.tau (K := ℚ) rationalClass rationalBoundarySeries : + Nonpositive ℚ ℤ) : ℤ⟦ℚ⟧).coeff (-1) = 0 := by + constructor + · rw [Nonpositive.coeff_T_of_mem _ _ negOne_mem_closedBall] + simp [rationalBoundarySeries] + · rw [Nonpositive.coeff_tau_of_not_mem _ _ negOne_not_mem_ball] + +/-- The leading-class API retains a nonconstant boundary monomial. -/ +theorem T_rationalBoundarySeries_leadingClass : + Nonpositive.T (K := ℚ) + (Nonpositive.leadingClass rationalBoundarySeries (by + rw [rationalBoundarySeries, Nonpositive.coe_single, + HahnSeries.order_single (by norm_num)] + norm_num)) + rationalBoundarySeries = rationalBoundarySeries := + Nonpositive.T_leadingClass rationalBoundarySeries (by + rw [rationalBoundarySeries, Nonpositive.coe_single, + HahnSeries.order_single (by norm_num)] + norm_num) + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Tests/FiniteClassReduction.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Tests/FiniteClassReduction.lean new file mode 100644 index 0000000000..10655a489d --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Tests/FiniteClassReduction.lean @@ -0,0 +1,80 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.FiniteClassReduction +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OneRow + +/-! +# Checks for finite support classes + +These clients distinguish the support-class set from two nearby wrong definitions: discarding +the zero class, and asking that the support itself be finite. The series `2 + t⁻¹` meets both the +zero and nonzero real classes. Berarducci's row has infinite support but meets just one class. +The zero-series check is only an interface boundary check. +-/ + +public noncomputable section + +open HahnSeries HahnSeries.Nonpositive +open scoped HahnSeries + +namespace Tests.FiniteClassReduction + +/-- Zero meets no class, rather than meeting the zero class. -/ +theorem zero_support_classes : supportArchimedeanClasses (0 : Nonpositive ℝ ℝ) = ∅ := + supportArchimedeanClasses_zero + +/-- A nonzero ordinary constant meets the zero class. -/ +theorem constant_support_classes : + supportArchimedeanClasses (Nonpositive.single (0 : ℝ) (3 : ℝ) le_rfl) = {⊤} := by + ext c + simp [mem_supportArchimedeanClasses, eq_comm] + +/-- The two-class fixture `2 + t⁻¹`. -/ +def twoClassSeries : Nonpositive ℝ ℝ := + Nonpositive.single 0 2 le_rfl + Nonpositive.single (-1) 1 (by norm_num) + +/-- The zero exponent contributes a second class even though all nonzero real exponents are +Archimedean-equivalent. -/ +theorem twoClass_support_classes : + supportArchimedeanClasses twoClassSeries = {ArchimedeanClass.mk (-1 : ℝ), ⊤} := by + have hs : (twoClassSeries : ℝ⟦ℝ⟧).support = {0, -1} := by + ext g + by_cases hg0 : g = 0 <;> by_cases hg1 : g = -1 <;> + simp [HahnSeries.mem_support, twoClassSeries, hg0, hg1] + ext c + rw [mem_supportArchimedeanClasses, hs] + simp [eq_comm, or_comm] + +/-- Berarducci's row has infinitely many exponents. -/ +theorem oneRow_support_infinite : + (Berarducci.OneRow.withoutConstant (K := ℝ) : ℝ⟦ℝ⟧).support.Infinite := by + rw [Berarducci.OneRow.withoutConstant_support] + exact Set.infinite_range_of_injective Berarducci.OneRow.exponentEmbedding.injective + +/-- The same infinite support meets just one Archimedean class. -/ +theorem oneRow_support_classes : + supportArchimedeanClasses (Berarducci.OneRow.withoutConstant (K := ℝ)) = + {ArchimedeanClass.mk (-1 : ℝ)} := by + ext c + rw [mem_supportArchimedeanClasses, Set.mem_singleton_iff] + constructor + · rintro ⟨g, hg, rfl⟩ + have hg0 : g ≠ 0 := by + intro hzero + subst g + exact (HahnSeries.mem_support _ _).mp hg Berarducci.OneRow.withoutConstant_coeff_zero + exact ArchimedeanClass.mk_eq_mk_of_archimedean hg0 (by norm_num) + · rintro rfl + refine ⟨-1, ?_, rfl⟩ + rw [HahnSeries.mem_support] + have hcoeff := Berarducci.OneRow.withoutConstant_coeff_exponent (K := ℝ) 0 + norm_num [Berarducci.OneRow.exponent_apply] at hcoeff + rw [hcoeff] + exact one_ne_zero + +end Tests.FiniteClassReduction diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Tests/IntegerPartSplitting.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Tests/IntegerPartSplitting.lean new file mode 100644 index 0000000000..a812101974 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Tests/IntegerPartSplitting.lean @@ -0,0 +1,53 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.IntegerPartSplitting + +/-! +# API checks for LM24 integer-part splitting + +This separately compiled client checks the exact source and target rings in LM24, +Fact 2.4.2(5), and verifies that the equivalence sends a fixed source series to its split +truncation. The nested coefficient subring excludes the nearby wrong target using the whole +inner Hahn field. +-/ + +public noncomputable section + +namespace Tests + +open HahnSeries FiniteArchimedeanClass + +theorem integerPartSplitting_apply + {K G R : Type*} + [DivisionRing K] [LinearOrder K] [IsOrderedRing K] [Archimedean K] + [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [Module K G] [IsOrderedModule K G] [Field R] + (u : HahnEmbedding.ArchimedeanStrata K G) (c : FiniteArchimedeanClass G) + (Z : Subring R) + (x : Nonpositive.fixedIntegerPartSubring (K := K) (G := G) (R := R) c Z) : + ((Nonpositive.splitFixedIntegerPartRingEquiv u c Z x : + truncationIntegerPart (u.stratum c) + (Nonpositive.innerIntegerPartSubring (K := K) (G := G) c Z)) : + Nonpositive (u.stratum c) R⟦ball K c⟧) = + Nonpositive.splitTruncation u c (x : Nonpositive G R) := + Nonpositive.coe_splitFixedIntegerPartRingEquiv u c Z x + +theorem integerPartSplitting_round_trip + {K G R : Type*} + [DivisionRing K] [LinearOrder K] [IsOrderedRing K] [Archimedean K] + [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [Module K G] [IsOrderedModule K G] [Field R] + (u : HahnEmbedding.ArchimedeanStrata K G) (c : FiniteArchimedeanClass G) + (Z : Subring R) + (y : truncationIntegerPart (u.stratum c) + (Nonpositive.innerIntegerPartSubring (K := K) (G := G) c Z)) : + Nonpositive.splitFixedIntegerPartRingEquiv u c Z + ((Nonpositive.splitFixedIntegerPartRingEquiv u c Z).symm y) = y := + (Nonpositive.splitFixedIntegerPartRingEquiv u c Z).apply_symm_apply y + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Tests/PrimalityTransfer.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Tests/PrimalityTransfer.lean new file mode 100644 index 0000000000..2fc7e045b0 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Tests/PrimalityTransfer.lean @@ -0,0 +1,85 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.PrimalityTransfer + +/-! +# API checks for leading-class primality transfer + +This separately compiled client exercises both residue branches of the generic set-level core of +LM24, Proposition 9.2.2. The residue-one branch needs no fraction-field hypothesis; the +residue-zero branch requires exactly that the embedded inner integer part generate the coefficient +Hahn field. +-/ + +public noncomputable section + +namespace Tests + +open HahnSeries FiniteArchimedeanClass + +theorem primalityTransfer_residue_one + {K G R : Type*} + [DivisionRing K] [LinearOrder K] [IsOrderedRing K] [Archimedean K] + [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [Module K G] [IsOrderedModule K G] [Field R] + (u : HahnEmbedding.ArchimedeanStrata K G) (Z : Subring R) + (b : truncationIntegerPart G Z) (hb0 : (b : Nonpositive G R) ≠ 0) + (horder : ((b : Nonpositive G R) : R⟦G⟧).order ≠ 0) + (htau : Nonpositive.tauBall (K := K) + (Nonpositive.leadingClass (b : Nonpositive G R) horder) + (b : Nonpositive G R) = 1) : + IsPrimal b ↔ + IsPrimal (Nonpositive.splitTruncation u + (Nonpositive.leadingClass (b : Nonpositive G R) horder) + (b : Nonpositive G R)) := + Nonpositive.isPrimal_iff_isPrimal_splitTruncation_of_tau_eq_one + u Z b hb0 horder htau + +theorem primalityTransfer_residue_zero + {K G R : Type*} + [DivisionRing K] [LinearOrder K] [IsOrderedRing K] [Archimedean K] + [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [Module K G] [IsOrderedModule K G] [Field R] + (u : HahnEmbedding.ArchimedeanStrata K G) (Z : Subring R) + (b : truncationIntegerPart G Z) (hb0 : (b : Nonpositive G R) ≠ 0) + (horder : ((b : Nonpositive G R) : R⟦G⟧).order ≠ 0) + (hfrac : Subring.fracSubring + (Nonpositive.innerIntegerPartSubring (K := K) (G := G) + (Nonpositive.leadingClass (b : Nonpositive G R) horder) Z) = ⊤) + (htau : Nonpositive.tauBall (K := K) + (Nonpositive.leadingClass (b : Nonpositive G R) horder) + (b : Nonpositive G R) = 0) : + IsPrimal b ↔ + IsPrimal (Nonpositive.splitTruncation u + (Nonpositive.leadingClass (b : Nonpositive G R) horder) + (b : Nonpositive G R)) := + Nonpositive.isPrimal_iff_isPrimal_splitTruncation_of_tau_eq_zero + u Z b hb0 horder hfrac htau + +theorem primalityTransfer_reduced + {K G R : Type*} + [DivisionRing K] [LinearOrder K] [IsOrderedRing K] [Archimedean K] + [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [Module K G] [IsOrderedModule K G] [Field R] + (u : HahnEmbedding.ArchimedeanStrata K G) (Z : Subring R) + (b : truncationIntegerPart G Z) (hb0 : (b : Nonpositive G R) ≠ 0) + (horder : ((b : Nonpositive G R) : R⟦G⟧).order ≠ 0) + (hbReduced : Nonpositive.IsReduced (b : Nonpositive G R)) + (hfrac : Nonpositive.tauBall (K := K) + (Nonpositive.leadingClass (b : Nonpositive G R) horder) + (b : Nonpositive G R) = 0 → + Subring.fracSubring (Nonpositive.innerIntegerPartSubring (K := K) (G := G) + (Nonpositive.leadingClass (b : Nonpositive G R) horder) Z) = ⊤) : + IsPrimal b ↔ + IsPrimal (Nonpositive.splitTruncation u + (Nonpositive.leadingClass (b : Nonpositive G R) horder) + (b : Nonpositive G R)) := + Nonpositive.isPrimal_iff_isPrimal_splitTruncation_of_isReduced + u Z b hb0 horder hbReduced hfrac + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Tests/Reduced.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Tests/Reduced.lean new file mode 100644 index 0000000000..f4f5df3aca --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Tests/Reduced.lean @@ -0,0 +1,79 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Reduced +public import Mathlib.Algebra.Order.Group.Int + +/-! +# API checks for LM24 reducedness + +The constant series `3` is reduced because the relevant intersection is supported only at zero. +The two-term series `2 + t⁻¹` is not reduced: both zero and `-1` occur in the support before and +after subtracting one, but zero and a nonzero exponent have different Archimedean classes. This is +the Hahn-series analogue of LM24, Example 8.2.7's non-reduced omnific integer `ω + 2`. +-/ + +public noncomputable section + +namespace Tests + +open HahnSeries + +/-- The constant nonpositive integer Hahn series `3`. -/ +def reducedConstant : Nonpositive ℤ ℤ := Nonpositive.single 0 3 le_rfl + +theorem reducedConstant_isReduced : Nonpositive.IsReduced reducedConstant := by + refine Nonpositive.isReduced_of_support_inter_support_sub_one_subset ?_ ⊤ ?_ + · intro hzero + have hcoeff := congrArg (fun x : Nonpositive ℤ ℤ ↦ (x : ℤ⟦ℤ⟧).coeff 0) hzero + rw [show (reducedConstant : ℤ⟦ℤ⟧) = HahnSeries.single 0 3 by + exact Nonpositive.coe_single 0 3 le_rfl] at hcoeff + rw [HahnSeries.coeff_single_same] at hcoeff + norm_num at hcoeff + · rintro x ⟨hx, _⟩ + have hx0 : x = 0 := by + apply support_single_subset (R := ℤ) + rw [show (reducedConstant : ℤ⟦ℤ⟧) = HahnSeries.single 0 3 by + exact Nonpositive.coe_single 0 3 le_rfl] at hx + exact hx + simp [hx0] + +/-- The nonpositive Hahn series `2 + t⁻¹`. -/ +def nonreducedTwoClass : Nonpositive ℤ ℤ := + Nonpositive.single 0 2 le_rfl + Nonpositive.single (-1) 1 (by omega) + +theorem nonreducedTwoClass_not_isReduced : ¬Nonpositive.IsReduced nonreducedTwoClass := by + intro h + obtain ⟨_, c, hc⟩ := h.elim + have hzero : ArchimedeanClass.mk (0 : ℤ) = c := hc ⟨by + rw [HahnSeries.mem_support] + rw [show (nonreducedTwoClass : ℤ⟦ℤ⟧) = + HahnSeries.single 0 2 + HahnSeries.single (-1) 1 by + simp [nonreducedTwoClass]] + simp, by + rw [HahnSeries.mem_support] + rw [show ((nonreducedTwoClass - 1 : Nonpositive ℤ ℤ) : ℤ⟦ℤ⟧) = + (HahnSeries.single 0 2 + HahnSeries.single (-1) 1) - 1 by + simp [nonreducedTwoClass]] + simp⟩ + have hneg : ArchimedeanClass.mk (-1 : ℤ) = c := hc ⟨by + rw [HahnSeries.mem_support] + rw [show (nonreducedTwoClass : ℤ⟦ℤ⟧) = + HahnSeries.single 0 2 + HahnSeries.single (-1) 1 by + simp [nonreducedTwoClass]] + simp, by + rw [HahnSeries.mem_support] + rw [show ((nonreducedTwoClass - 1 : Nonpositive ℤ ℤ) : ℤ⟦ℤ⟧) = + (HahnSeries.single 0 2 + HahnSeries.single (-1) 1) - 1 by + simp [nonreducedTwoClass]] + simp⟩ + have hcTop : c = ⊤ := hzero.symm.trans ArchimedeanClass.mk_zero + have hnegTop : ArchimedeanClass.mk (-1 : ℤ) = ⊤ := hneg.trans hcTop + have := ArchimedeanClass.mk_eq_top_iff.mp hnegTop + omega + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Tests/ReducedCharacterization.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Tests/ReducedCharacterization.lean new file mode 100644 index 0000000000..dc1b7a731d --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Tests/ReducedCharacterization.lean @@ -0,0 +1,100 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import Mathlib.Algebra.Order.Archimedean.Basic + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.ReducedCharacterization + +/-! +# API checks for the leading-class characterization of reducedness + +The boundary monomial `5t⁻¹` exercises the `tau = 0` branch. The series `1 + 5t⁻¹` +exercises the `tau = 1` branch. Both are nonconstant and reduced, so together they certify the +two alternatives in LM24, Proposition 8.2.5 `(4) ↔ (5)` through the public API. +-/ + +public noncomputable section + +namespace Tests + +open HahnSeries + +/-- The rational monomial `5t⁻¹`, whose strict class truncation is zero. -/ +def reducedZeroTauSeries : Nonpositive ℚ ℚ := + Nonpositive.single (-1) 5 (by norm_num) + +/-- The rational series `1 + 5t⁻¹`, whose strict class truncation is one. -/ +def reducedOneTauSeries : Nonpositive ℚ ℚ := + 1 + reducedZeroTauSeries + +private theorem reducedZeroTauSeries_ne_zero : reducedZeroTauSeries ≠ 0 := by + intro h + have hcoeff := congrArg (fun x : Nonpositive ℚ ℚ ↦ (x : ℚ⟦ℚ⟧).coeff (-1)) h + simp [reducedZeroTauSeries] at hcoeff + +private theorem reducedZeroTauSeries_order : + (reducedZeroTauSeries : ℚ⟦ℚ⟧).order = -1 := by + rw [reducedZeroTauSeries, Nonpositive.coe_single, HahnSeries.order_single (by norm_num)] + +private theorem reducedOneTauSeries_ne_zero : reducedOneTauSeries ≠ 0 := by + intro h + have hcoeff := congrArg (fun x : Nonpositive ℚ ℚ ↦ (x : ℚ⟦ℚ⟧).coeff (-1)) h + simp [reducedOneTauSeries, reducedZeroTauSeries] at hcoeff + +private theorem reducedOneTauSeries_order : + (reducedOneTauSeries : ℚ⟦ℚ⟧).order = -1 := by + have htop : (reducedOneTauSeries : ℚ⟦ℚ⟧).orderTop = (-1 : ℚ) := by + apply HahnSeries.orderTop_eq_of_le + · rw [HahnSeries.mem_support] + simp [reducedOneTauSeries, reducedZeroTauSeries] + · intro g hg + have hgNonpos := Nonpositive.support_subset reducedOneTauSeries hg + by_contra hnot + have hgLt : g < (-1 : ℚ) := lt_of_not_ge hnot + have hgZero : g ≠ 0 := by linarith + have hgNegOne : g ≠ -1 := by linarith + rw [HahnSeries.mem_support] at hg + simp [reducedOneTauSeries, reducedZeroTauSeries, hgZero, hgNegOne] at hg + exact WithTop.coe_injective + ((HahnSeries.order_eq_orderTop_of_ne_zero (fun h ↦ + reducedOneTauSeries_ne_zero (Subtype.ext h))).trans htop) + +theorem reducedZeroTauSeries_characterization : + Nonpositive.IsReduced reducedZeroTauSeries ↔ + Nonpositive.tau (K := ℚ) + (Nonpositive.leadingClass reducedZeroTauSeries (by + rw [reducedZeroTauSeries_order] + norm_num)) + reducedZeroTauSeries = 0 ∨ + Nonpositive.tau (K := ℚ) + (Nonpositive.leadingClass reducedZeroTauSeries (by + rw [reducedZeroTauSeries_order] + norm_num)) + reducedZeroTauSeries = 1 := + Nonpositive.isReduced_iff_tau_leadingClass_eq_zero_or_one + reducedZeroTauSeries reducedZeroTauSeries_ne_zero (by + rw [reducedZeroTauSeries_order] + norm_num) + +theorem reducedOneTauSeries_characterization : + Nonpositive.IsReduced reducedOneTauSeries ↔ + Nonpositive.tau (K := ℚ) + (Nonpositive.leadingClass reducedOneTauSeries (by + rw [reducedOneTauSeries_order] + norm_num)) + reducedOneTauSeries = 0 ∨ + Nonpositive.tau (K := ℚ) + (Nonpositive.leadingClass reducedOneTauSeries (by + rw [reducedOneTauSeries_order] + norm_num)) + reducedOneTauSeries = 1 := + Nonpositive.isReduced_iff_tau_leadingClass_eq_zero_or_one + reducedOneTauSeries reducedOneTauSeries_ne_zero (by + rw [reducedOneTauSeries_order] + norm_num) + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Tests/ReducedDivisibility.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Tests/ReducedDivisibility.lean new file mode 100644 index 0000000000..a394429d5d --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Tests/ReducedDivisibility.lean @@ -0,0 +1,46 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.ReducedDivisibility + +/-! +# API checks for reduced divisibility + +This separately compiled client checks both public conclusions needed from the reduction-algebra +core of LM24, Proposition 8.2.8: `rho(c)` divides `T(c)`, and for a reduced nonconstant divisor +`b`, divisibility of `T(c)` by `b` is equivalent to divisibility of `rho(c)` by `b`. +-/ + +public noncomputable section + +namespace Tests + +open HahnSeries + +theorem rho_dvd_closed_truncation + {K G R : Type*} + [DivisionRing K] [LinearOrder K] [IsOrderedRing K] [Archimedean K] + [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [Module K G] [IsOrderedModule K G] [Field R] + (u : HahnEmbedding.ArchimedeanStrata K G) (sigma : FiniteArchimedeanClass G) + (c : Nonpositive G R) : + Nonpositive.rho u sigma c ∣ Nonpositive.T (K := K) sigma c := + Nonpositive.rho_dvd_T u sigma c + +theorem reduced_divisor_dvd_closed_iff_dvd_rho + {K G R : Type*} + [DivisionRing K] [LinearOrder K] [IsOrderedRing K] [Archimedean K] + [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [Module K G] [IsOrderedModule K G] [Field R] + (u : HahnEmbedding.ArchimedeanStrata K G) (b : Nonpositive G R) (hb0 : b ≠ 0) + (horder : (b : R⟦G⟧).order ≠ 0) (hbReduced : Nonpositive.IsReduced b) + (c : Nonpositive G R) : + b ∣ Nonpositive.T (K := K) (Nonpositive.leadingClass b horder) c ↔ + b ∣ Nonpositive.rho u (Nonpositive.leadingClass b horder) c := + Nonpositive.dvd_T_iff_dvd_rho_leadingClass u b hb0 horder hbReduced c + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Tests/Reduction.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Tests/Reduction.lean new file mode 100644 index 0000000000..83abaa36bd --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Tests/Reduction.lean @@ -0,0 +1,87 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Tests.ClassTruncation +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Reduction + +/-! +# API checks for LM24 reduction + +The zero-`τ` check uses the nonzero boundary monomial from the class-truncation certificate: +`T` retains it while `τ` removes it, so `ρ` must take the zero branch. The nonzero-`τ` check is +polymorphic and verifies that `ρ` selects the quotient construction whenever the open truncation +is nonzero. These checks distinguish both clauses of LM24, Definition 8.2.4. +-/ + +public noncomputable section + +namespace Tests + +open HahnSeries FiniteArchimedeanClass + +/-- The rational-coefficient monomial `5t⁻¹` used to compare class projection and closed-class +truncation. -/ +def rationalBoundaryFieldSeries : Nonpositive ℚ ℚ := + Nonpositive.single (-1) 5 (by norm_num) + +theorem rho_rationalBoundarySeries_eq_T + (u : HahnEmbedding.ArchimedeanStrata ℚ ℚ) : + Nonpositive.rho u rationalClass rationalBoundaryFieldSeries = + Nonpositive.T (K := ℚ) rationalClass rationalBoundaryFieldSeries := by + apply Nonpositive.rho_of_tau_eq_zero + apply Subtype.ext + ext g + by_cases hg : g = -1 + · subst g + rw [Nonpositive.coeff_tau_of_not_mem _ _ negOne_not_mem_ball] + simp + · have hcoeff : (rationalBoundaryFieldSeries : ℚ⟦ℚ⟧).coeff g = 0 := by + rw [rationalBoundaryFieldSeries, Nonpositive.coe_single] + simp [hg] + by_cases hball : g ∈ ball ℚ rationalClass + · rw [Nonpositive.coeff_tau_of_mem _ _ hball, hcoeff] + rfl + · rw [Nonpositive.coeff_tau_of_not_mem _ _ hball] + rfl + +theorem rho_eq_reductionQuotient_of_tau_ne_zero + {K G R : Type*} + [DivisionRing K] [LinearOrder K] [IsOrderedRing K] [Archimedean K] + [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [Module K G] [IsOrderedModule K G] [Field R] + (u : HahnEmbedding.ArchimedeanStrata K G) (c : FiniteArchimedeanClass G) + (x : Nonpositive G R) (htau : Nonpositive.tau (K := K) c x ≠ 0) : + Nonpositive.rho u c x = Nonpositive.reductionQuotient u c x + (fun hzero ↦ htau ((Nonpositive.tauBall_eq_zero_iff c x).mp hzero)) := + Nonpositive.rho_of_tau_ne_zero u c x htau + +/-- The fixed-class characterization in LM24, Proposition 8.2.5. -/ +theorem rho_fixed_at_containing_class_iff + {K G R : Type*} + [DivisionRing K] [LinearOrder K] [IsOrderedRing K] [Archimedean K] + [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [Module K G] [IsOrderedModule K G] [Field R] + (u : HahnEmbedding.ArchimedeanStrata K G) (c : FiniteArchimedeanClass G) + (x : Nonpositive G R) (hx : x ≠ 0) (hT : Nonpositive.T (K := K) c x = x) : + Nonpositive.rho u c x = x ↔ + Nonpositive.tau (K := K) c x = 0 ∨ Nonpositive.tau (K := K) c x = 1 := + Nonpositive.rho_eq_self_iff_tau_eq_zero_or_one u c x hx hT + +/-- LM24, Proposition 8.2.5 `(3) ↔ (4)` at the leading class. -/ +theorem rho_fixed_at_leading_class_iff + {K G R : Type*} + [DivisionRing K] [LinearOrder K] [IsOrderedRing K] [Archimedean K] + [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [Module K G] [IsOrderedModule K G] [Field R] + (u : HahnEmbedding.ArchimedeanStrata K G) (x : Nonpositive G R) (hx : x ≠ 0) + (horder : (x : R⟦G⟧).order ≠ 0) : + Nonpositive.rho u (Nonpositive.leadingClass x horder) x = x ↔ + Nonpositive.tau (K := K) (Nonpositive.leadingClass x horder) x = 0 ∨ + Nonpositive.tau (K := K) (Nonpositive.leadingClass x horder) x = 1 := + Nonpositive.rho_leadingClass_eq_self_iff_tau_eq_zero_or_one u x hx horder + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Tests/SplitTruncation.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Tests/SplitTruncation.lean new file mode 100644 index 0000000000..4bf6f4a0f7 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Tests/SplitTruncation.lean @@ -0,0 +1,77 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.SplitTruncation + +/-! +# API checks for the LM24 split truncation + +This separately compiled client checks the constant-coefficient interface used by LM24, +Proposition 9.2.2. +-/ + +public noncomputable section + +namespace Tests + +open HahnSeries FiniteArchimedeanClass + +theorem splitTruncation_constantCoeff + {K G R : Type*} + [DivisionRing K] [LinearOrder K] [IsOrderedRing K] [Archimedean K] + [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [Module K G] [IsOrderedModule K G] [Field R] + (u : HahnEmbedding.ArchimedeanStrata K G) (c : FiniteArchimedeanClass G) + (x : Nonpositive G R) : + Nonpositive.constantCoeff (Nonpositive.splitTruncation u c x) = + Nonpositive.tauBall c x := + Nonpositive.constantCoeff_splitTruncation u c x + +theorem splitTruncation_primality_at_one + {K G R : Type*} + [DivisionRing K] [LinearOrder K] [IsOrderedRing K] [Archimedean K] + [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [Module K G] [IsOrderedModule K G] [Field R] + (u : HahnEmbedding.ArchimedeanStrata K G) (c : FiniteArchimedeanClass G) + (S : Subring R⟦ball K c⟧) (x : Nonpositive G R) + (htau : Nonpositive.tauBall c x = 1) : + IsPrimal (Nonpositive.splitTruncationIntegerPart u c S x + (htau.symm ▸ S.one_mem)) ↔ + IsPrimal (Nonpositive.splitTruncation u c x) := + Nonpositive.isPrimal_splitTruncationIntegerPart_iff_of_tau_eq_one u c S x htau + +theorem splitTruncation_primality_at_zero + {K G R : Type*} + [DivisionRing K] [LinearOrder K] [IsOrderedRing K] [Archimedean K] + [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [Module K G] [IsOrderedModule K G] [Field R] + (u : HahnEmbedding.ArchimedeanStrata K G) (c : FiniteArchimedeanClass G) + (S : Subring R⟦ball K c⟧) (hfrac : Subring.fracSubring S = ⊤) + (x : Nonpositive G R) (htau : Nonpositive.tauBall c x = 0) : + IsPrimal (Nonpositive.splitTruncationIntegerPart u c S x + (htau.symm ▸ S.zero_mem)) ↔ + IsPrimal (Nonpositive.splitTruncation u c x) := + Nonpositive.isPrimal_splitTruncationIntegerPart_iff_of_tau_eq_zero + u c S hfrac x htau + +theorem reduced_splitTruncation_primality + {K G R : Type*} + [DivisionRing K] [LinearOrder K] [IsOrderedRing K] [Archimedean K] + [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [Module K G] [IsOrderedModule K G] [Field R] + (u : HahnEmbedding.ArchimedeanStrata K G) (b : Nonpositive G R) (hb0 : b ≠ 0) + (horder : (b : R⟦G⟧).order ≠ 0) (hbReduced : Nonpositive.IsReduced b) + (S : Subring R⟦ball K (Nonpositive.leadingClass b horder)⟧) + (hfrac : Subring.fracSubring S = ⊤) + (htauMem : Nonpositive.tauBall (Nonpositive.leadingClass b horder) b ∈ S) : + IsPrimal (Nonpositive.splitTruncationIntegerPart u + (Nonpositive.leadingClass b horder) S b htauMem) ↔ + IsPrimal (Nonpositive.splitTruncation u (Nonpositive.leadingClass b horder) b) := + Nonpositive.isPrimal_splitTruncationIntegerPart_iff_of_isReduced + u b hb0 horder hbReduced S hfrac htauMem + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Tests/TruncationDivisibility.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Tests/TruncationDivisibility.lean new file mode 100644 index 0000000000..1d648a5fbd --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Tests/TruncationDivisibility.lean @@ -0,0 +1,54 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.TruncationDivisibility + +/-! +# API checks for LM24 truncation divisibility + +This separately compiled client certifies Proposition 8.2.1 at the leading class and the full +nonconstant reduced case of Proposition 8.2.8 through their public APIs. +-/ + +public noncomputable section + +namespace Tests + +open HahnSeries + +theorem leading_truncation_fixes_divisor + {K G R : Type*} + [DivisionRing K] [LinearOrder K] [IsOrderedRing K] [Archimedean K] + [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [Module K G] [IsOrderedModule K G] [Field R] + (b : Nonpositive G R) (hb0 : b ≠ 0) (horder : (b : R⟦G⟧).order ≠ 0) + {a : Nonpositive G R} (ha : a ∣ b) : + Nonpositive.T (K := K) (Nonpositive.leadingClass b horder) a = a := + Nonpositive.T_leadingClass_of_dvd b hb0 horder ha + +theorem dvd_iff_dvd_leading_truncation + {K G R : Type*} + [DivisionRing K] [LinearOrder K] [IsOrderedRing K] [Archimedean K] + [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [Module K G] [IsOrderedModule K G] [Field R] + (b : Nonpositive G R) (hb0 : b ≠ 0) (horder : (b : R⟦G⟧).order ≠ 0) + (c : Nonpositive G R) : + b ∣ c ↔ b ∣ Nonpositive.T (K := K) (Nonpositive.leadingClass b horder) c := + Nonpositive.dvd_iff_dvd_T_leadingClass b hb0 horder c + +theorem reduced_dvd_iff_dvd_leading_reduction + {K G R : Type*} + [DivisionRing K] [LinearOrder K] [IsOrderedRing K] [Archimedean K] + [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [Module K G] [IsOrderedModule K G] [Field R] + (u : HahnEmbedding.ArchimedeanStrata K G) (b : Nonpositive G R) (hb0 : b ≠ 0) + (horder : (b : R⟦G⟧).order ≠ 0) (hbReduced : Nonpositive.IsReduced b) + (c : Nonpositive G R) : + b ∣ c ↔ b ∣ Nonpositive.rho u (Nonpositive.leadingClass b horder) c := + Nonpositive.dvd_iff_dvd_rho_leadingClass u b hb0 horder hbReduced c + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Tests/TruncationPrimality.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Tests/TruncationPrimality.lean new file mode 100644 index 0000000000..f1810f547b --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/Tests/TruncationPrimality.lean @@ -0,0 +1,32 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.TruncationPrimality + +/-! +# API checks for primality in a leading-class truncation ring + +This separately compiled client checks the source-side localization step used in LM24, +Proposition 9.2.2. +-/ + +public noncomputable section + +namespace Tests + +open HahnSeries + +theorem primality_in_leading_truncation_subring + {K G R : Type*} + [DivisionRing K] [LinearOrder K] [IsOrderedRing K] [Archimedean K] + [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [Module K G] [IsOrderedModule K G] [Field R] + (b : Nonpositive G R) (hb0 : b ≠ 0) (horder : (b : R⟦G⟧).order ≠ 0) : + IsPrimal (Nonpositive.leadingTruncationElement (K := K) b horder) ↔ IsPrimal b := + Nonpositive.isPrimal_leadingTruncationElement_iff b hb0 horder + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/TruncationDivisibility.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/TruncationDivisibility.lean new file mode 100644 index 0000000000..b15d3ba701 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/TruncationDivisibility.lean @@ -0,0 +1,218 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.ReducedDivisibility + +/-! +# Divisibility and leading-class truncation + +This module formalizes LM24, Proposition 8.2.1 at the leading class of a nonconstant +nonpositive Hahn series. The discarded tail is divisible by the original series: restrict the +divisor to its closed Archimedean ball, invert it in that Hahn field, and embed the inverse back. +If `x` is a discarded negative exponent and `y` belongs to the embedded inverse, then the class +of `x` strictly dominates that of `y`; consequently `x < -y` and `x + y < 0`. +-/ + +public noncomputable section + +namespace HahnSeries.Nonpositive + +open FiniteArchimedeanClass + +variable {K G R : Type*} +variable [DivisionRing K] [LinearOrder K] [IsOrderedRing K] [Archimedean K] +variable [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] +variable [Module K G] [IsOrderedModule K G] +variable [Field R] + +private def closedBallEmbedding (c : FiniteArchimedeanClass G) : closedBall K c ↪o G where + toFun := (↑) + inj' := Subtype.val_injective + map_rel_iff' := Iff.rfl + +private theorem support_T_subset_closedBall (c : FiniteArchimedeanClass G) + (x : Nonpositive G R) : + ((T (K := K) c x : Nonpositive G R) : R⟦G⟧).support ⊆ closedBall K c := by + intro g hg + by_contra hnot + exact hg (coeff_T_of_not_mem (K := K) c x hnot) + +private theorem support_sub_T_disjoint_closedBall (c : FiniteArchimedeanClass G) + (x : Nonpositive G R) : + (((x - T (K := K) c x : Nonpositive G R) : R⟦G⟧).support) ∩ + closedBall K c = ∅ := by + apply Set.eq_empty_iff_forall_notMem.mpr + intro g hg + rw [Set.mem_inter_iff] at hg + obtain ⟨hgSupport, hgClosed⟩ := hg + rw [HahnSeries.mem_support] at hgSupport + change (((x : R⟦G⟧) - (T (K := K) c x : Nonpositive G R)).coeff g) ≠ 0 at hgSupport + rw [HahnSeries.coeff_sub, coeff_T_of_mem (K := K) c x hgClosed, + sub_self] at hgSupport + exact hgSupport rfl + +private theorem support_embeddedClosedBallInverse_add_tail_subset_Iio + (c : FiniteArchimedeanClass G) (b x : Nonpositive G R) : + ((HahnSeries.embDomain (closedBallEmbedding (K := K) c) + (HahnSeries.restrictDomain (closedBallEmbedding (K := K) c) (b : R⟦G⟧))⁻¹) * + ((x - T (K := K) c x : Nonpositive G R) : R⟦G⟧)).support ⊆ Set.Iio 0 := by + intro g hg + obtain ⟨y, hy, z, hz, rfl⟩ := HahnSeries.support_mul_subset hg + obtain ⟨y', _, hy'⟩ := HahnSeries.support_embDomain_subset hy + subst y + have hyClosed : (y' : G) ∈ closedBall K c := y'.2 + have hzTail : z ∉ closedBall K c := by + intro hzClosed + have hdisjoint := support_sub_T_disjoint_closedBall (K := K) c x + have : z ∈ (((x - T (K := K) c x : Nonpositive G R) : R⟦G⟧).support) ∩ + closedBall K c := ⟨hz, hzClosed⟩ + rw [hdisjoint] at this + exact this + have hzNonpos : z ≤ 0 := support_subset (x - T (K := K) c x) hz + have hz0 : z ≠ 0 := fun h ↦ hzTail (h ▸ zero_mem _) + by_cases hy0 : (y' : G) = 0 + · change (y' : G) + z < 0 + simpa [hy0] using lt_of_le_of_ne hzNonpos hz0 + have hclassZ : ArchimedeanClass.mk z < c.val := by + have hnotle : ¬ c ≤ FiniteArchimedeanClass.mk z hz0 := by + intro hle + exact hzTail ((FiniteArchimedeanClass.mem_closedBall_iff K).mpr fun _ ↦ hle) + exact not_le.mp hnotle + have hclassY : c.val ≤ ArchimedeanClass.mk (y' : G) := by + exact (FiniteArchimedeanClass.mem_closedBall_iff K).mp hyClosed hy0 + have hzyClass : ArchimedeanClass.mk z < ArchimedeanClass.mk (-(y' : G)) := by + rw [ArchimedeanClass.mk_neg] + exact hclassZ.trans_le hclassY + have hzy : z < -(y' : G) := + ArchimedeanClass.lt_of_mk_lt_mk_of_nonpos hzyClass hzNonpos + change (y' : G) + z < 0 + have := add_lt_add_left hzy (y' : G) + simpa [add_comm] using this + +/-- Every divisor of a nonzero nonconstant series is supported in the closed ball at the +dividend's leading Archimedean class. Equivalently, truncation at that class fixes the divisor. +This is the factor-control observation used in the first paragraph of LM24, Proposition 9.2.2. -/ +theorem T_leadingClass_of_dvd (b : Nonpositive G R) (hb0 : b ≠ 0) + (horder : (b : R⟦G⟧).order ≠ 0) {a : Nonpositive G R} (ha : a ∣ b) : + T (K := K) (leadingClass b horder) a = a := by + obtain ⟨q, hb⟩ := ha + have ha0 : a ≠ 0 := by + intro hzero + apply hb0 + rw [hb, hzero, zero_mul] + have hq0 : q ≠ 0 := by + intro hzero + apply hb0 + rw [hb, hzero, mul_zero] + apply Subtype.ext + ext g + by_cases hcoeff : (a : R⟦G⟧).coeff g = 0 + · by_cases hg : g ∈ closedBall K (leadingClass b horder) + · rw [coeff_T_of_mem _ a hg, hcoeff] + · rw [coeff_T_of_not_mem _ a hg, hcoeff] + · rw [coeff_T_of_mem] + apply (FiniteArchimedeanClass.mem_closedBall_iff K).mpr + intro hg0 + apply Subtype.coe_le_coe.mp + rw [leadingClass_val, FiniteArchimedeanClass.val_mk] + have haOrderNonpos : (a : R⟦G⟧).order ≤ 0 := by + exact support_subset a + ((HahnSeries.mem_support _ _).mpr (HahnSeries.coeff_order_eq_zero.not.mpr + (fun h ↦ ha0 (Subtype.ext h)))) + have hqOrderNonpos : (q : R⟦G⟧).order ≤ 0 := by + exact support_subset q + ((HahnSeries.mem_support _ _).mpr (HahnSeries.coeff_order_eq_zero.not.mpr + (fun h ↦ hq0 (Subtype.ext h)))) + have hsumLe : (a : R⟦G⟧).order + (q : R⟦G⟧).order ≤ + (a : R⟦G⟧).order := by + simpa using add_le_add_left hqOrderNonpos (a : R⟦G⟧).order + have haOrderLe : (a : R⟦G⟧).order ≤ g := + HahnSeries.order_le_of_coeff_ne_zero hcoeff + have hgNonpos : g ≤ 0 := + support_subset a ((HahnSeries.mem_support _ _).mpr hcoeff) + have horderMul : ((a * q : Nonpositive G R) : R⟦G⟧).order = + (a : R⟦G⟧).order + (q : R⟦G⟧).order := by + exact HahnSeries.order_mul (fun h ↦ ha0 (Subtype.ext h)) + (fun h ↦ hq0 (Subtype.ext h)) + rw [hb, horderMul] + have hsumNonzero : (a : R⟦G⟧).order + (q : R⟦G⟧).order ≠ 0 := by + rw [← horderMul, ← hb] + exact horder + simpa [ArchimedeanClass.mk_eq_top_iff.not.mpr hsumNonzero] using + ArchimedeanClass.min_le_mk_of_le_of_le (hsumLe.trans haOrderLe) hgNonpos + +/-- Divisibility by a nonzero series fixed by a closed-class truncation can be tested after that +truncation. The inverse is formed in the Hahn field on the closed ball and embedded back. -/ +theorem dvd_iff_dvd_T_of_fixed (sigma : FiniteArchimedeanClass G) + (b : Nonpositive G R) (hb0 : b ≠ 0) (hbFixed : T (K := K) sigma b = b) + (c : Nonpositive G R) : + b ∣ c ↔ b ∣ T (K := K) sigma c := by + let f := closedBallEmbedding (K := K) sigma + let br : R⟦closedBall K sigma⟧ := HahnSeries.restrictDomain f (b : R⟦G⟧) + have hbSupport : (b : R⟦G⟧).support ⊆ Set.range f := by + rw [← hbFixed] + intro g hg + exact ⟨⟨g, support_T_subset_closedBall (K := K) sigma b hg⟩, rfl⟩ + have hembBr : HahnSeries.embDomain f br = (b : R⟦G⟧) := + HahnSeries.embDomain_restrictDomain f (b : R⟦G⟧) hbSupport + have hbr0 : br ≠ 0 := by + intro hzero + apply hb0 + apply Subtype.ext + rw [← hembBr, hzero] + exact HahnSeries.embDomain_zero + let qFull : R⟦G⟧ := HahnSeries.embDomain f br⁻¹ + have hbq : (b : R⟦G⟧) * qFull = 1 := by + rw [← hembBr] + change HahnSeries.embDomain f br * HahnSeries.embDomain f br⁻¹ = 1 + rw [← HahnSeries.embDomain_mul] + · rw [mul_inv_cancel₀ hbr0, HahnSeries.embDomain_one] + rfl + · intro x y + rfl + constructor + · rintro ⟨e, hce⟩ + refine ⟨T (K := K) sigma e, ?_⟩ + calc + T (K := K) sigma c = T (K := K) sigma (b * e) := by rw [hce] + _ = T (K := K) sigma b * T (K := K) sigma e := + (T (K := K) sigma).map_mul b e + _ = b * T (K := K) sigma e := by rw [hbFixed] + · rintro ⟨e, hTe⟩ + let tail : Nonpositive G R := c - T (K := K) sigma c + let qTail : Nonpositive G R := ⟨qFull * (tail : R⟦G⟧), by + intro g hg + exact (support_embeddedClosedBallInverse_add_tail_subset_Iio sigma b c hg).le⟩ + refine ⟨e + qTail, ?_⟩ + apply Subtype.ext + change (c : R⟦G⟧) = + (b : R⟦G⟧) * ((e : R⟦G⟧) + qFull * (tail : R⟦G⟧)) + rw [mul_add, ← mul_assoc, hbq, one_mul] + change (c : R⟦G⟧) = (b : R⟦G⟧) * (e : R⟦G⟧) + + ((c : R⟦G⟧) - (T (K := K) sigma c : Nonpositive G R)) + have hTeCoe : ((T (K := K) sigma c : Nonpositive G R) : R⟦G⟧) = + (b : R⟦G⟧) * (e : R⟦G⟧) := congrArg Subtype.val hTe + rw [← hTeCoe] + abel + +/-- LM24, Proposition 8.2.1 at the lowest nonzero exponent's Archimedean class. -/ +theorem dvd_iff_dvd_T_leadingClass (b : Nonpositive G R) (hb0 : b ≠ 0) + (horder : (b : R⟦G⟧).order ≠ 0) (c : Nonpositive G R) : + b ∣ c ↔ b ∣ T (K := K) (leadingClass b horder) c := + dvd_iff_dvd_T_of_fixed (leadingClass b horder) b hb0 (T_leadingClass b horder) c + +/-- LM24, Proposition 8.2.8 for a reduced series with nonzero lowest exponent: reduction at its +leading Archimedean class preserves exactly the multiples of the series. -/ +theorem dvd_iff_dvd_rho_leadingClass + (u : HahnEmbedding.ArchimedeanStrata K G) (b : Nonpositive G R) (hb0 : b ≠ 0) + (horder : (b : R⟦G⟧).order ≠ 0) (hbReduced : IsReduced b) + (c : Nonpositive G R) : + b ∣ c ↔ b ∣ rho u (leadingClass b horder) c := + (dvd_iff_dvd_T_leadingClass b hb0 horder c).trans + (dvd_T_iff_dvd_rho_leadingClass u b hb0 horder hbReduced c) + +end HahnSeries.Nonpositive diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/TruncationPrimality.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/TruncationPrimality.lean new file mode 100644 index 0000000000..877993c08f --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IntegerPart/TruncationPrimality.lean @@ -0,0 +1,164 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.TruncationDivisibility + +/-! +# Primality in a leading-class truncation ring + +The fixed points of a closed Archimedean-class truncation form a subring. At the leading class +of a nonzero nonconstant series, every divisor of that series belongs to this subring. Hence the +series is primal in the full nonpositive Hahn ring exactly when it is primal in the fixed-point +subring. This is the source-side localization step in LM24, Proposition 9.2.2. +-/ + +public noncomputable section + +namespace HahnSeries.Nonpositive + +open FiniteArchimedeanClass + +variable {K G R : Type*} +variable [DivisionRing K] [LinearOrder K] [IsOrderedRing K] [Archimedean K] +variable [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] +variable [Module K G] [IsOrderedModule K G] +variable [Field R] + +/-- Nonpositive Hahn series fixed by closed truncation at `c`. -/ +def truncationSubring (c : FiniteArchimedeanClass G) : Subring (Nonpositive G R) := + RingHom.range (T (K := K) c) + +/-- Membership in the truncation subring is exactly being fixed by the truncation. -/ +theorem mem_truncationSubring_iff (c : FiniteArchimedeanClass G) + (x : Nonpositive G R) : + x ∈ truncationSubring (K := K) (R := R) c ↔ T (K := K) c x = x := by + constructor + · rintro ⟨y, rfl⟩ + exact T_T c y + · intro hx + exact ⟨x, hx⟩ + +/-- A nonzero nonconstant series, regarded in its leading-class truncation subring. -/ +def leadingTruncationElement (b : Nonpositive G R) + (horder : (b : R⟦G⟧).order ≠ 0) : + truncationSubring (K := K) (R := R) (leadingClass b horder) := + ⟨b, (mem_truncationSubring_iff (leadingClass b horder) b).mpr + (T_leadingClass b horder)⟩ + +@[simp] +theorem coe_leadingTruncationElement (b : Nonpositive G R) + (horder : (b : R⟦G⟧).order ≠ 0) : + (leadingTruncationElement (K := K) b horder : Nonpositive G R) = b := + (rfl) + +/-- Primality of a nonzero nonconstant series is unchanged when it is restricted to its +leading-class truncation subring. -/ +theorem isPrimal_leadingTruncationElement_iff + (b : Nonpositive G R) (hb0 : b ≠ 0) + (horder : (b : R⟦G⟧).order ≠ 0) : + IsPrimal (leadingTruncationElement (K := K) b horder) ↔ IsPrimal b := by + constructor + · intro h c d hdvd + have hdivT : b ∣ T (K := K) (leadingClass b horder) (c * d) := + (dvd_iff_dvd_T_leadingClass b hb0 horder (c * d)).mp hdvd + have hdivLocal : leadingTruncationElement (K := K) b horder ∣ + ⟨T (K := K) (leadingClass b horder) c, + ⟨c, rfl⟩⟩ * + ⟨T (K := K) (leadingClass b horder) d, + ⟨d, rfl⟩⟩ := by + obtain ⟨q, hq⟩ := hdivT + have hqFixed : T (K := K) (leadingClass b horder) q = q := by + apply mul_left_cancel₀ hb0 + calc + b * T (K := K) (leadingClass b horder) q = + T (K := K) (leadingClass b horder) b * + T (K := K) (leadingClass b horder) q := by + rw [T_leadingClass b horder] + _ = T (K := K) (leadingClass b horder) (b * q) := by rw [map_mul] + _ = T (K := K) (leadingClass b horder) + (T (K := K) (leadingClass b horder) (c * d)) := by rw [hq] + _ = T (K := K) (leadingClass b horder) (c * d) := T_T _ _ + _ = b * q := hq + refine ⟨⟨T (K := K) (leadingClass b horder) q, + ⟨q, rfl⟩⟩, ?_⟩ + apply Subtype.ext + change T (K := K) (leadingClass b horder) c * + T (K := K) (leadingClass b horder) d = + b * T (K := K) (leadingClass b horder) q + rw [← map_mul, hq, hqFixed] + obtain ⟨b₁, b₂, h₁, h₂, hprod⟩ := h hdivLocal + refine ⟨(b₁ : Nonpositive G R), (b₂ : Nonpositive G R), ?_, ?_, ?_⟩ + · have hb₁Ne : (b₁ : Nonpositive G R) ≠ 0 := by + intro hb₁Zero + have hb₁Zero' : b₁ = 0 := Subtype.ext hb₁Zero + apply hb0 + have hzero := congrArg Subtype.val hprod + rw [hb₁Zero', zero_mul] at hzero + exact hzero + apply (dvd_iff_dvd_T_of_fixed (leadingClass b horder) b₁.1 hb₁Ne + ((mem_truncationSubring_iff _ _).mp b₁.2) c).mpr + exact map_dvd (truncationSubring (K := K) (R := R) + (leadingClass b horder)).subtype h₁ + · have hb₂Ne : (b₂ : Nonpositive G R) ≠ 0 := by + intro hb₂Zero + have hb₂Zero' : b₂ = 0 := Subtype.ext hb₂Zero + apply hb0 + have hzero := congrArg Subtype.val hprod + rw [hb₂Zero', mul_zero] at hzero + exact hzero + apply (dvd_iff_dvd_T_of_fixed (leadingClass b horder) b₂.1 hb₂Ne + ((mem_truncationSubring_iff _ _).mp b₂.2) d).mpr + exact map_dvd (truncationSubring (K := K) (R := R) + (leadingClass b horder)).subtype h₂ + · exact congrArg Subtype.val hprod + · intro h c d hdvd + have hdvdAmbient : b ∣ (c : Nonpositive G R) * (d : Nonpositive G R) := + map_dvd (truncationSubring (K := K) (R := R) + (leadingClass b horder)).subtype hdvd + obtain ⟨b₁, b₂, h₁, h₂, hprod⟩ := h hdvdAmbient + have hb₁Mem : b₁ ∈ truncationSubring (K := K) (R := R) (leadingClass b horder) := + (mem_truncationSubring_iff _ _).mpr (T_leadingClass_of_dvd b hb0 horder + (hprod.symm ▸ dvd_mul_right b₁ b₂)) + have hb₂Mem : b₂ ∈ truncationSubring (K := K) (R := R) (leadingClass b horder) := + (mem_truncationSubring_iff _ _).mpr (T_leadingClass_of_dvd b hb0 horder + (hprod.symm ▸ dvd_mul_left b₂ b₁)) + have hb₁Ne : b₁ ≠ 0 := by + intro hz + apply hb0 + rw [hprod, hz, zero_mul] + have hb₂Ne : b₂ ≠ 0 := by + intro hz + apply hb0 + rw [hprod, hz, mul_zero] + have hq₁Mem : h₁.choose ∈ + truncationSubring (K := K) (R := R) (leadingClass b horder) := by + apply (mem_truncationSubring_iff _ _).mpr + apply mul_left_cancel₀ hb₁Ne + calc + b₁ * T (K := K) (leadingClass b horder) h₁.choose = + T (K := K) (leadingClass b horder) (b₁ * h₁.choose) := by + rw [map_mul, (mem_truncationSubring_iff _ _).mp hb₁Mem] + _ = T (K := K) (leadingClass b horder) c := by rw [← h₁.choose_spec] + _ = c := (mem_truncationSubring_iff _ _).mp c.2 + _ = b₁ * h₁.choose := h₁.choose_spec + have hq₂Mem : h₂.choose ∈ + truncationSubring (K := K) (R := R) (leadingClass b horder) := by + apply (mem_truncationSubring_iff _ _).mpr + apply mul_left_cancel₀ hb₂Ne + calc + b₂ * T (K := K) (leadingClass b horder) h₂.choose = + T (K := K) (leadingClass b horder) (b₂ * h₂.choose) := by + rw [map_mul, (mem_truncationSubring_iff _ _).mp hb₂Mem] + _ = T (K := K) (leadingClass b horder) d := by rw [← h₂.choose_spec] + _ = d := (mem_truncationSubring_iff _ _).mp d.2 + _ = b₂ * h₂.choose := h₂.choose_spec + refine ⟨⟨b₁, hb₁Mem⟩, ⟨b₂, hb₂Mem⟩, ?_, ?_, ?_⟩ + · exact ⟨⟨h₁.choose, hq₁Mem⟩, Subtype.ext h₁.choose_spec⟩ + · exact ⟨⟨h₂.choose, hq₂Mem⟩, Subtype.ext h₂.choose_spec⟩ + · exact Subtype.ext hprod + +end HahnSeries.Nonpositive diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Iterate.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Iterate.lean new file mode 100644 index 0000000000..dd422b328d --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Iterate.lean @@ -0,0 +1,172 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import Mathlib.RingTheory.HahnSeries.Multiplication +public import Mathlib.RingTheory.HahnSeries.Cardinal +public import Mathlib.Algebra.Order.Monoid.Prod +public import Mathlib.SetTheory.Cardinal.Regular +import Mathlib.Algebra.BigOperators.Group.Finset.Sigma + +/-! +# Iterated Hahn series as Hahn series on a lexicographic product + +Mathlib's `HahnSeries.iterateEquiv` identifies an iterated Hahn series with a Hahn series whose +exponent group is a lexicographic product, but provides only an equivalence of the underlying +types. This file proves that flattening preserves addition and multiplication and packages the +identification as a ring equivalence. + +The outer exponent is the dominant coordinate. Multiplicativity reindexes the nested finite sums +over the outer and inner additive antidiagonals by the single additive antidiagonal in the +lexicographic product. +-/ + +public section + +namespace HahnSeries + +open Finset + +variable {R Γ Γ' : Type*} +variable [Semiring R] +variable [AddCommMonoid Γ] [LinearOrder Γ] [IsOrderedCancelAddMonoid Γ] +variable [AddCommMonoid Γ'] [LinearOrder Γ'] [IsOrderedCancelAddMonoid Γ'] + +omit [AddCommMonoid Γ] [IsOrderedCancelAddMonoid Γ] + [AddCommMonoid Γ'] [IsOrderedCancelAddMonoid Γ'] in +private theorem ofIterate_add (x y : R⟦Γ'⟧⟦Γ⟧) : + ofIterate (x + y) = ofIterate x + ofIterate y := by + ext g + simp [ofIterate] + +private theorem ofIterate_mul (x y : R⟦Γ'⟧⟦Γ⟧) : + ofIterate (x * y) = ofIterate x * ofIterate y := by + ext g + rcases g with ⟨g, g'⟩ + change ((x * y).coeff g).coeff g' = + (ofIterate x * ofIterate y).coeff (toLex (g, g')) + rw [coeff_mul, coeff_sum] + simp only [coeff_mul] + rw [Finset.sum_sigma'] + apply Finset.sum_bij + (fun z _ ↦ (toLex (z.1.1, z.2.1), toLex (z.1.2, z.2.2))) + · intro z hz + rw [Finset.mem_sigma] at hz + rw [Finset.mem_antidiagonal] at hz + rw [Finset.mem_antidiagonal] at hz + rw [Finset.mem_antidiagonal] + exact ⟨hz.2.1, hz.2.2.1, Prod.ext hz.1.2.2 hz.2.2.2⟩ + · intro z₁ hz₁ z₂ hz₂ heq + have hbase : z₁.1 = z₂.1 := + Prod.ext (congrArg (fun z ↦ (ofLex z.1).1) heq) + (congrArg (fun z ↦ (ofLex z.2).1) heq) + have hfiber : z₁.2 = z₂.2 := + Prod.ext (congrArg (fun z ↦ (ofLex z.1).2) heq) + (congrArg (fun z ↦ (ofLex z.2).2) heq) + exact Sigma.ext hbase (heq_of_eq hfiber) + · intro z hz + rw [Finset.mem_antidiagonal] at hz + refine ⟨⟨((ofLex z.1).1, (ofLex z.2).1), ((ofLex z.1).2, (ofLex z.2).2)⟩, ?_, ?_⟩ + · rw [Finset.mem_sigma, Finset.mem_antidiagonal, Finset.mem_antidiagonal] + exact ⟨⟨ne_zero_of_coeff_ne_zero hz.1, ne_zero_of_coeff_ne_zero hz.2.1, + congrArg Prod.fst hz.2.2⟩, hz.1, hz.2.1, congrArg Prod.snd hz.2.2⟩ + · rfl + · intro z hz + rfl + +/-- The equivalence between iterated Hahn series and Hahn series on the lexicographic product, +as a ring equivalence. The outer exponent is the dominant coordinate. -/ +noncomputable def iterateRingEquiv : R⟦Γ'⟧⟦Γ⟧ ≃+* R⟦Γ ×ₗ Γ'⟧ := + { iterateEquiv with + map_add' := ofIterate_add + map_mul' := ofIterate_mul } + +@[simp] +theorem iterateRingEquiv_coeff (x : R⟦Γ'⟧⟦Γ⟧) (g : Γ) (g' : Γ') : + (iterateRingEquiv x).coeff (toLex (g, g')) = (x.coeff g).coeff g' := (rfl) + +section Cardinal + +open Cardinal + +universe u v + +variable {S : Type v} {Λ Λ' : Type u} +variable [Semiring S] +variable [AddCommMonoid Λ] [LinearOrder Λ] [IsOrderedCancelAddMonoid Λ] +variable [AddCommMonoid Λ'] [LinearOrder Λ'] [IsOrderedCancelAddMonoid Λ'] + +/-- The outer support of an iterated Hahn series is no larger than the support of its +flattening. -/ +theorem cardSupp_outer_le_cardSupp_iterateRingEquiv (x : S⟦Λ'⟧⟦Λ⟧) : + x.cardSupp ≤ (iterateRingEquiv x).cardSupp := by + rw [cardSupp, cardSupp] + let f : (Λ ×ₗ Λ') → Λ := fun p ↦ (ofLex p).1 + have hsubset : x.support ⊆ f '' (iterateRingEquiv x).support := by + intro g hg + have hg0 : x.coeff g ≠ 0 := (mem_support x g).mp hg + have hfun : (x.coeff g).coeff ≠ 0 := coeff_fun_eq_zero_iff.not.mpr hg0 + obtain ⟨g', hg'⟩ := Function.ne_iff.mp hfun + refine ⟨toLex (g, g'), ?_, rfl⟩ + rw [mem_support, iterateRingEquiv_coeff] + exact hg' + exact (Cardinal.mk_le_mk_of_subset hsubset).trans Cardinal.mk_image_le + +/-- Each coefficient support of an iterated Hahn series is no larger than the support of its +flattening. -/ +theorem cardSupp_coeff_le_cardSupp_iterateRingEquiv (x : S⟦Λ'⟧⟦Λ⟧) (g : Λ) : + (x.coeff g).cardSupp ≤ (iterateRingEquiv x).cardSupp := by + rw [cardSupp, cardSupp] + let f : Λ' → (Λ ×ₗ Λ') := fun g' ↦ toLex (g, g') + have hsubset : f '' (x.coeff g).support ⊆ (iterateRingEquiv x).support := by + rintro _ ⟨g', hg', rfl⟩ + rw [mem_support, iterateRingEquiv_coeff] + exact (mem_support (x.coeff g) g').mp hg' + have hf : Function.Injective f := by + intro a b h + exact congrArg (fun p : Λ ×ₗ Λ' ↦ (ofLex p).2) h + rw [← Cardinal.mk_image_eq hf] + exact Cardinal.mk_le_mk_of_subset hsubset + +/-- If `κ` is regular, flattening preserves the bound `< κ` when both the outer support and +all coefficient supports satisfy that bound. -/ +theorem cardSupp_iterateRingEquiv_lt_of_isRegular {κ : Cardinal.{u}} + (hκ : κ.IsRegular) (x : S⟦Λ'⟧⟦Λ⟧) (houter : x.cardSupp < κ) + (hcoeff : ∀ g, (x.coeff g).cardSupp < κ) : + (iterateRingEquiv x).cardSupp < κ := by + let t : ↥x.support → Set (Λ ×ₗ Λ') := fun g ↦ + (fun g' ↦ toLex (g.1, g')) '' (x.coeff g.1).support + have hsupport : (iterateRingEquiv x).support = ⋃ g, t g := by + ext p + constructor + · intro hp + have hp' : (x.coeff (ofLex p).1).coeff (ofLex p).2 ≠ 0 := by + have hpCoeff := (mem_support _ _).mp hp + rw [show p = toLex ((ofLex p).1, (ofLex p).2) by simp] at hpCoeff + rwa [iterateRingEquiv_coeff] at hpCoeff + have hg : (ofLex p).1 ∈ x.support := by + rw [mem_support] + exact ne_zero_of_coeff_ne_zero hp' + rw [Set.mem_iUnion] + refine ⟨⟨(ofLex p).1, hg⟩, ?_⟩ + exact ⟨(ofLex p).2, (mem_support _ _).mpr hp', by simp⟩ + · rw [Set.mem_iUnion] + rintro ⟨g, b, hb, rfl⟩ + rw [mem_support, iterateRingEquiv_coeff] + exact (mem_support _ _).mp hb + rw [cardSupp, hsupport] + apply (Cardinal.card_iUnion_lt_iff_forall_of_isRegular hκ houter).mpr + intro g + let f : Λ' → (Λ ×ₗ Λ') := fun g' ↦ toLex (g.1, g') + have hf : Function.Injective f := by + intro a b h + exact congrArg (fun p : Λ ×ₗ Λ' ↦ (ofLex p).2) h + rw [show t g = f '' (x.coeff g.1).support from rfl, Cardinal.mk_image_eq hf] + exact hcoeff g.1 + +end Cardinal + +end HahnSeries diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IterateOrderType.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IterateOrderType.lean new file mode 100644 index 0000000000..407f47018f --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/IterateOrderType.lean @@ -0,0 +1,64 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Iterate +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrderType + +/-! +# Support order type of iterated Hahn series + +Flattening an iterated Hahn series orders its support lexicographically, with the outer exponent +dominant. Choosing one nonzero inner coefficient over each outer support point therefore embeds +the outer support into the flattened support. In particular, flattening cannot decrease the +ordinary support order type contributed by the outer series. +-/ + +public noncomputable section + +open Ordinal + +namespace HahnSeries + +universe u v + +variable {R : Type v} {Γ Γ' : Type u} +variable [Semiring R] +variable [AddCommMonoid Γ] [LinearOrder Γ] [IsOrderedCancelAddMonoid Γ] +variable [AddCommMonoid Γ'] [LinearOrder Γ'] [IsOrderedCancelAddMonoid Γ'] + +/-- The outer support order type of an iterated Hahn series is no larger than the support order +type of its flattening. -/ +theorem supportOrderType_outer_le_iterateRingEquiv (x : R⟦Γ'⟧⟦Γ⟧) : + x.supportOrderType ≤ (iterateRingEquiv x).supportOrderType := by + let inner : ↑x.support → Γ' := fun g ↦ Classical.choose + (Function.ne_iff.mp (coeff_fun_eq_zero_iff.not.mpr ((mem_support x g).mp g.2))) + have hinner (g : ↑x.support) : (x.coeff g.1).coeff (inner g) ≠ 0 := + Classical.choose_spec + (Function.ne_iff.mp (coeff_fun_eq_zero_iff.not.mpr ((mem_support x g).mp g.2))) + let f : ↑x.support → ↑(iterateRingEquiv x).support := fun g ↦ + ⟨toLex (g.1, inner g), by + rw [mem_support, iterateRingEquiv_coeff] + exact hinner g⟩ + have hf : StrictMono f := by + intro a b hab + change toLex (a.1, inner a) < toLex (b.1, inner b) + rw [Prod.Lex.toLex_lt_toLex] + exact Or.inl hab + let : WellFoundedLT ↑x.support := x.isPWO_support.isWF + let : WellFoundedLT ↑(iterateRingEquiv x).support := + (iterateRingEquiv x).isPWO_support.isWF + rw [supportOrderType_eq_setOrderType, supportOrderType_eq_setOrderType] + calc + x.isPWO_support.orderType = typeLT ↑x.support := + x.isPWO_support.orderType_eq_typeLT_of_orderIso (OrderIso.refl ↑x.support) + _ ≤ typeLT ↑(iterateRingEquiv x).support := + (OrderEmbedding.ofStrictMono f hf).ltEmbedding.ordinal_type_le + _ = (iterateRingEquiv x).isPWO_support.orderType := + ((iterateRingEquiv x).isPWO_support.orderType_eq_typeLT_of_orderIso + (OrderIso.refl ↑(iterateRingEquiv x).support)).symm + +end HahnSeries diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/LimitTailQuotient.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/LimitTailQuotient.lean new file mode 100644 index 0000000000..2d4b0a0252 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/LimitTailQuotient.lean @@ -0,0 +1,146 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import Mathlib.Algebra.Order.Archimedean.Basic +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Order.Module.ConvexQuotientSplitting +public import LeanPool.ConwayRefinement.ConwayRefinement.Topology.Order.OrderedAddGroup +public import Mathlib.Algebra.Algebra.Rat +public import Mathlib.Algebra.Order.Module.Rat +public import Mathlib.Topology.Algebra.IsUniformGroup.Basic + +/-! +# Ordered common-tail quotients + +A family of finite Archimedean classes determines a common convex rational subspace. Its quotient +is ordered by representatives and carries its order topology and right uniformity. These are the +explicit Hahn exponent quotients used in the limit hypothesis of the standalone Conway theorem. +-/ + +open Set + +universe u + +public noncomputable section + +namespace FiniteArchimedeanClass + +variable {G : Type u} [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [Module ℚ G] [PosSMulMono ℚ G] + +/-- The ordered rational quotient by the common tail of a family of finite Archimedean +classes. -/ +abbrev TailQuotient (T : Set (FiniteArchimedeanClass G)) := G ⧸ tailSubmodule ℚ T + +noncomputable instance tailQuotientLinearOrder (T : Set (FiniteArchimedeanClass G)) : + LinearOrder (TailQuotient T) := + ConvexQuotient.instLinearOrder (H := (tailSubmodule ℚ T).toAddSubgroup) + +instance tailQuotientIsOrderedAddMonoid (T : Set (FiniteArchimedeanClass G)) : + IsOrderedAddMonoid (TailQuotient T) := + ConvexQuotient.instIsOrderedAddMonoid (H := (tailSubmodule ℚ T).toAddSubgroup) + +instance tailQuotientPosSMulMono (T : Set (FiniteArchimedeanClass G)) : + PosSMulMono ℚ (TailQuotient T) where + smul_le_smul_of_nonneg_left q hq x y hxy := by + change ∃ a b : G, Submodule.Quotient.mk a = x ∧ + Submodule.Quotient.mk b = y ∧ a ≤ b at hxy + obtain ⟨a, b, ha, hb, hab⟩ := hxy + change ∃ a b : G, Submodule.Quotient.mk a = q • x ∧ + Submodule.Quotient.mk b = q • y ∧ a ≤ b + refine ⟨q • a, q • b, ?_, ?_, smul_le_smul_of_nonneg_left hab hq⟩ + · simpa only [Submodule.Quotient.mk_smul] using congrArg (q • ·) ha + · simpa only [Submodule.Quotient.mk_smul] using congrArg (q • ·) hb + +instance tailQuotientPosSMulStrictMono (T : Set (FiniteArchimedeanClass G)) : + PosSMulStrictMono ℚ (TailQuotient T) := PosSMulMono.toPosSMulStrictMono + +noncomputable instance tailQuotientTopologicalSpace (T : Set (FiniteArchimedeanClass G)) : + TopologicalSpace (TailQuotient T) := Preorder.topology (TailQuotient T) + +instance tailQuotientOrderTopology (T : Set (FiniteArchimedeanClass G)) : + OrderTopology (TailQuotient T) := ⟨rfl⟩ + +instance tailQuotientDenselyOrdered (T : Set (FiniteArchimedeanClass G)) : + DenselyOrdered (TailQuotient T) := by + constructor + intro a b hab + refine ⟨(2 : ℚ)⁻¹ • (a + b), ?_, ?_⟩ + · calc + a = (2 : ℚ)⁻¹ • (a + a) := by rw [smul_add, ← add_smul]; norm_num + _ < (2 : ℚ)⁻¹ • (a + b) := smul_lt_smul_of_pos_left + (add_lt_add_left hab a |>.trans_eq (add_comm _ _)) (by norm_num) + · calc + (2 : ℚ)⁻¹ • (a + b) < (2 : ℚ)⁻¹ • (b + b) := + smul_lt_smul_of_pos_left + (by simpa [add_comm] using add_lt_add_left hab b) (by norm_num) + _ = b := by rw [smul_add, ← add_smul]; norm_num + +instance tailQuotientIsTopologicalAddGroup (T : Set (FiniteArchimedeanClass G)) : + IsTopologicalAddGroup (TailQuotient T) where + toContinuousAdd := continuousAdd_of_orderTopology (TailQuotient T) + toContinuousNeg := continuousNeg_of_orderTopology (TailQuotient T) + +noncomputable instance tailQuotientUniformSpace (T : Set (FiniteArchimedeanClass G)) : + UniformSpace (TailQuotient T) := + IsTopologicalAddGroup.rightUniformSpace (TailQuotient T) + +instance tailQuotientIsUniformAddGroup (T : Set (FiniteArchimedeanClass G)) : + IsUniformAddGroup (TailQuotient T) := isUniformAddGroup_of_addCommGroup + +/-- Absolute value commutes with projection to a rational tail quotient. -/ +theorem tailQuotient_abs (T : Set (FiniteArchimedeanClass G)) (x : G) : + |(Submodule.Quotient.mk x : TailQuotient T)| = Submodule.Quotient.mk |x| := by + rcases le_total 0 x with hx | hx + · have hxq : (0 : TailQuotient T) ≤ Submodule.Quotient.mk x := by + rw [← Submodule.Quotient.mk_zero] + exact ConvexQuotient.mk_le_mk hx + rw [abs_of_nonneg hx, abs_of_nonneg hxq] + · have hxq : (Submodule.Quotient.mk x : TailQuotient T) ≤ 0 := by + rw [← Submodule.Quotient.mk_zero] + exact ConvexQuotient.mk_le_mk hx + rw [abs_of_nonpos hx, abs_of_nonpos hxq, ← Submodule.Quotient.mk_neg] + +/-- A strict class comparison in a rational tail quotient reflects to representatives. -/ +theorem archimedeanClass_mk_lt_of_tailQuotient_mk_lt + (T : Set (FiniteArchimedeanClass G)) {x y : G} + (h : ArchimedeanClass.mk (Submodule.Quotient.mk x : TailQuotient T) < + ArchimedeanClass.mk (Submodule.Quotient.mk y : TailQuotient T)) : + ArchimedeanClass.mk x < ArchimedeanClass.mk y := by + rw [ArchimedeanClass.mk_lt_mk] at h ⊢ + intro n + have hn := h n + have hn' : (Submodule.Quotient.mk (n • |y|) : TailQuotient T) < + Submodule.Quotient.mk |x| := by + have heq : (Submodule.Quotient.mk (n • |y|) : TailQuotient T) = + n • Submodule.Quotient.mk |y| := by + change QuotientAddGroup.mk' _ (n • |y|) = n • QuotientAddGroup.mk' _ |y| + exact map_nsmul (QuotientAddGroup.mk' _) n |y| + rw [heq] + simpa only [tailQuotient_abs] using hn + exact ConvexQuotient.lt_of_mk_lt_mk hn' + +/-- Canonical representatives of a limit family are coinitial in its rational tail quotient. -/ +theorem exists_tailQuotient_positiveRepresentative_le + {T : Set (FiniteArchimedeanClass G)} + {x : TailQuotient T} (hx : 0 < x) : + ∃ c : T, (Submodule.Quotient.mk (positiveRepresentative c.1) : TailQuotient T) ≤ x := by + induction x using Submodule.Quotient.induction_on with + | H x => + have hxq : (Submodule.Quotient.mk (0 : G) : TailQuotient T) < + Submodule.Quotient.mk x := by + simpa using hx + have hx0 : 0 < x := ConvexQuotient.lt_of_mk_lt_mk hxq + have hxP : x ∉ tailSubmodule ℚ T := by + simpa using (ConvexQuotient.mk_lt_mk_iff.mp hxq).2 + rw [mem_tailSubmodule_iff, mem_tailKernel_iff] at hxP + push Not at hxP + obtain ⟨c, hxc⟩ := hxP + refine ⟨c, ConvexQuotient.mk_le_mk ?_⟩ + apply (ArchimedeanClass.lt_of_mk_lt_mk_of_nonneg ?_ hx0.le).le + rwa [mk_positiveRepresentative] + +end FiniteArchimedeanClass diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Monomial.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Monomial.lean new file mode 100644 index 0000000000..22d1815588 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Monomial.lean @@ -0,0 +1,173 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Nonpositive + +import Mathlib.Algebra.GroupWithZero.Divisibility + +/-! +# Monomials in a nonpositive Hahn-series ring + +A monomial is a nonzero scalar multiple of a single group monomial. This is the notion used +throughout LM24 and, in particular, in Section 6.5. The support-singleton characterization is +intrinsic and avoids exposing the proof that the exponent is nonpositive. + +The unit lemmas record a boundary specific to the nonpositive ring: every unit has support +exactly `{0}`, and hence a nonzero monomial is a unit precisely when its exponent is zero. +-/ + +open scoped HahnSeries + +universe u v + +public noncomputable section + +namespace HahnSeries.Nonpositive + +variable {G : Type u} {K : Type v} + [LinearOrder G] [AddCommGroup G] [IsOrderedAddMonoid G] + [Field K] + +/-- A nonzero scalar multiple of one group monomial. -/ +def IsMonomial (b : Nonpositive G K) : Prop := + ∃ (g : G) (k : K) (hg : g ≤ 0), k ≠ 0 ∧ b = single g k hg + +/-- Characterization of a monomial by an exponent, a nonzero coefficient, and a single Hahn +monomial. -/ +theorem isMonomial_iff {b : Nonpositive G K} : + IsMonomial b ↔ + ∃ (g : G) (k : K) (hg : g ≤ 0), k ≠ 0 ∧ b = single g k hg := + Iff.rfl + +/-- A nonpositive Hahn series is a monomial exactly when its support is a singleton. -/ +theorem isMonomial_iff_support_eq_singleton {b : Nonpositive G K} : + IsMonomial b ↔ ∃ g : G, (b : K⟦G⟧).support = {g} := by + constructor + · rintro ⟨g, k, hg, hk, rfl⟩ + exact ⟨g, by simp [coe_single, hk]⟩ + · rintro ⟨g, hsupport⟩ + have hgmem : g ∈ (b : K⟦G⟧).support := by simp [hsupport] + have hg : g ≤ 0 := support_subset b hgmem + have hk : (b : K⟦G⟧).coeff g ≠ 0 := by + rwa [HahnSeries.mem_support] at hgmem + refine ⟨g, (b : K⟦G⟧).coeff g, hg, hk, ?_⟩ + apply Subtype.ext + ext h + by_cases hh : h = g + · subst h + simp [coe_single] + · have hhmem : h ∉ (b : K⟦G⟧).support := by simp [hsupport, hh] + rw [HahnSeries.mem_support, not_ne_iff] at hhmem + simp [coe_single, hh, hhmem] + +/-- A monomial is nonzero. -/ +theorem IsMonomial.ne_zero {b : Nonpositive G K} (hb : IsMonomial b) : b ≠ 0 := by + rw [isMonomial_iff_support_eq_singleton] at hb + obtain ⟨g, hg⟩ := hb + intro hzero + subst b + simp at hg + +/-- A monomial has finite support. -/ +theorem IsMonomial.support_finite {b : Nonpositive G K} (hb : IsMonomial b) : + (b : K⟦G⟧).support.Finite := by + obtain ⟨g, hg⟩ := isMonomial_iff_support_eq_singleton.mp hb + rw [hg] + exact Set.finite_singleton g + +/-- Every unit of the nonpositive Hahn-series ring has support exactly `{0}`. -/ +theorem support_eq_singleton_zero_of_isUnit {b : Nonpositive G K} (hb : IsUnit b) : + (b : K⟦G⟧).support = {0} := by + obtain ⟨u, rfl⟩ := hb + let c : Nonpositive G K := ↑u⁻¹ + have hbNe : (↑u : Nonpositive G K) ≠ 0 := IsUnit.ne_zero u.isUnit + have hcNe : c ≠ 0 := IsUnit.ne_zero (u⁻¹).isUnit + have hbNe' : ((↑u : Nonpositive G K) : K⟦G⟧) ≠ 0 := + fun h ↦ hbNe (Subtype.ext h) + have hcNe' : (c : K⟦G⟧) ≠ 0 := fun h ↦ hcNe (Subtype.ext h) + have hproduct : (↑u : Nonpositive G K) * c = 1 := by + simp [c] + have horder := congrArg HahnSeries.order (congrArg Subtype.val hproduct) + have horder' : (↑u : K⟦G⟧).order + (c : K⟦G⟧).order = 0 := by + simpa [HahnSeries.order_mul hbNe' hcNe'] using horder + have hbOrderMem : (↑u : K⟦G⟧).order ∈ (↑u : K⟦G⟧).support := by + rw [HahnSeries.mem_support] + exact HahnSeries.coeff_order_eq_zero.not.mpr hbNe' + have hcOrderMem : (c : K⟦G⟧).order ∈ (c : K⟦G⟧).support := by + rw [HahnSeries.mem_support] + exact HahnSeries.coeff_order_eq_zero.not.mpr hcNe' + have hbOrderNonpos := support_subset (↑u : Nonpositive G K) hbOrderMem + have hcOrderNonpos := support_subset c hcOrderMem + have hbOrderZero : (↑u : K⟦G⟧).order = 0 := + eq_zero_of_add_nonneg_left hbOrderNonpos hcOrderNonpos horder'.ge + apply Set.Subset.antisymm + · intro g hg + rw [Set.mem_singleton_iff] + apply le_antisymm (support_subset (↑u : Nonpositive G K) hg) + rw [← hbOrderZero] + rw [HahnSeries.mem_support] at hg + exact HahnSeries.order_le_of_coeff_ne_zero hg + · intro g hg + rw [Set.mem_singleton_iff] at hg + subst g + simpa [hbOrderZero] using hbOrderMem + +/-- Every unit is the constant series determined by its coefficient at zero. -/ +theorem eq_C_constantCoeff_of_isUnit {b : Nonpositive G K} (hb : IsUnit b) : + b = C (constantCoeff b) := by + have hsupport := support_eq_singleton_zero_of_isUnit hb + apply Subtype.ext + apply HahnSeries.coeff_injective + funext g + by_cases hg : g = 0 + · subst g + simp [constantCoeff_apply] + · have hgNotMem : g ∉ (b : K⟦G⟧).support := by + rw [hsupport] + simpa using hg + rw [HahnSeries.mem_support, not_ne_iff] at hgNotMem + simp [hg, hgNotMem] + +/-- Every unit of the nonpositive Hahn-series ring is a monomial. -/ +theorem isMonomial_of_isUnit {b : Nonpositive G K} (hb : IsUnit b) : + IsMonomial b := + isMonomial_iff_support_eq_singleton.mpr + ⟨0, support_eq_singleton_zero_of_isUnit hb⟩ + +/-- A unit with constant coefficient one is the multiplicative identity. -/ +theorem eq_one_of_isUnit_of_constantCoeff_eq_one {b : Nonpositive G K} + (hbUnit : IsUnit b) (hbConstant : constantCoeff b = 1) : b = 1 := by + have hsupport := support_eq_singleton_zero_of_isUnit hbUnit + apply Subtype.ext + apply HahnSeries.coeff_injective + funext g + by_cases hg : g = 0 + · subst g + simpa [constantCoeff_apply] using hbConstant + · have hgNotMem : g ∉ (b : K⟦G⟧).support := by + rw [hsupport] + simpa using hg + rw [HahnSeries.mem_support, not_ne_iff] at hgNotMem + simp [hg, hgNotMem] + +/-- A nonzero monomial in the nonpositive ring is a unit exactly at exponent zero. -/ +theorem isUnit_single_iff {g : G} {k : K} (hk : k ≠ 0) (hg : g ≤ 0) : + IsUnit (single g k hg) ↔ g = 0 := by + constructor + · intro hunit + have hsupport := support_eq_singleton_zero_of_isUnit hunit + rw [coe_single, HahnSeries.support_single_of_ne hk] at hsupport + exact Set.singleton_injective hsupport + · rintro rfl + have hconstant : single (0 : G) k le_rfl = (C : K →+* Nonpositive G K) k := by + apply Subtype.ext + rw [coe_single, coe_C] + rfl + rw [hconstant] + exact (isUnit_iff_ne_zero.mpr hk).map C + +end HahnSeries.Nonpositive diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Multiplicativity.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Multiplicativity.lean new file mode 100644 index 0000000000..cc276fa6fd --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Multiplicativity.lean @@ -0,0 +1,572 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.NormalForm + +/-! +# Multiplicativity of support order type and degree + +LM24, Fact 3.4.1 imports Berarducci's theorem that support order type is multiplicative on +weakly principal nonpositive real Hahn series. The predicate +`OrderTypeMultiplicativeOnWeaklyPrincipal` records that exact mathematical law. Its proof in +characteristic zero is in `ConwayRefinement.HahnSeries.OrdinalValue.OrderTypeMultiplicativity`. + +The repaired `degree_truncLE_mul_lt` formalizes LM24, Lemma 3.4.2. The printed statement omits +`c ≠ 0`: its first support condition holds vacuously for `c = 0`, whereas the asserted strict +inequality then reads `⊥ < ⊥`. The additional hypothesis is necessary and is already implicit in +the printed proof when it chooses an exponent strictly below the support of `c`. + +Assuming the Berarducci law, `degree_mul_of_orderTypeMultiplicativeOnWeaklyPrincipal` proves +LM24, Proposition 3.4.3. Its proof uses the principal head decomposition from Proposition 3.3.7 +and the repaired truncation lemma. In the branch where a remainder has smaller degree, the proof +uses the strict upper bound with the degree of the original factor; this repairs the repeated +right-hand side in the displayed inequality on published page 30. + +Mathlib contains no corresponding Hahn-series multiplicativity theorem. +CombinatorialGames supplies `NatOrdinal.wpow_add`, which is used to show that the natural product +of two powers of `ω` is again a power of `ω`. The order-type law itself remains precisely the +Berarducci prerequisite imported by LM24. +-/ + +universe v + +public noncomputable section + +namespace HahnSeries + +open Ordinal + +variable {R : Type v} [Ring R] + +private theorem naturalMul_isAdditivelyPrincipal {a b : Ordinal} + (ha : a.IsAdditivelyPrincipal) (hb : b.IsAdditivelyPrincipal) : + (NatOrdinal.of a * NatOrdinal.of b).val.IsAdditivelyPrincipal := by + obtain ⟨e, rfl⟩ := Ordinal.isAdditivelyPrincipal_iff.mp ha + obtain ⟨f, rfl⟩ := Ordinal.isAdditivelyPrincipal_iff.mp hb + apply Ordinal.isAdditivelyPrincipal_iff.mpr + refine ⟨(NatOrdinal.of e + NatOrdinal.of f).val, ?_⟩ + have he : NatOrdinal.of (Ordinal.omega0 ^ e) = + (ω^ (NatOrdinal.of e) : NatOrdinal) := by + apply NatOrdinal.val.injective + simp only [NatOrdinal.val_of, NatOrdinal.val_wpow] + have hf : NatOrdinal.of (Ordinal.omega0 ^ f) = + (ω^ (NatOrdinal.of f) : NatOrdinal) := by + apply NatOrdinal.val.injective + simp only [NatOrdinal.val_of, NatOrdinal.val_wpow] + rw [he, hf, ← NatOrdinal.wpow_add, NatOrdinal.val_wpow] + +/-- A Hahn series whose support order type is strictly below a weakly principal support has +strictly smaller degree. -/ +theorem degree_lt_of_supportOrderType_lt_of_isWeaklyPrincipal + {x y : R⟦ℝ⟧} (hx : IsWeaklyPrincipal x) + (hyx : y.supportOrderType < x.supportOrderType) : + y.degree < x.degree := by + obtain ⟨e, he⟩ := + Ordinal.isAdditivelyPrincipal_iff.mp (isWeaklyPrincipal_iff.mp hx) + rw [he] at hyx + rw [degree_eq_cantorDegree, degree_eq_cantorDegree, he] + have hpower : Ordinal.cantorDegree (Ordinal.omega0 ^ e) = NatOrdinal.of e := by + rw [Ordinal.cantorDegree_of_ne_zero + (Ordinal.opow_ne_zero e Ordinal.omega0_ne_zero), + Ordinal.log_opow Ordinal.one_lt_omega0] + by_cases hy : y = 0 + · rw [hy, supportOrderType_zero, Ordinal.cantorDegree_zero, hpower] + exact WithBot.bot_lt_coe _ + rw [Ordinal.cantorDegree_of_ne_zero (supportOrderType_eq_zero.not.mpr hy), hpower, + WithBot.coe_lt_coe, NatOrdinal.of_lt_iff] + exact (Ordinal.lt_opow_iff_log_lt Ordinal.one_lt_omega0 + (supportOrderType_eq_zero.not.mpr hy)).mp hyx + +namespace Nonpositive + +variable {K : Type v} [Field K] + +/-- Support order type is multiplicative, using Hessenberg multiplication, on weakly principal +nonpositive real Hahn series over `K`. This is the exact law imported as LM24, Fact 3.4.1. + +The predicate is meaningful over any field. Its proof from Berarducci's result retains the +characteristic-zero hypothesis in LM24's ambient assumptions. -/ +def OrderTypeMultiplicativeOnWeaklyPrincipal (K : Type v) [Field K] : Prop := + ∀ b c : Nonpositive ℝ K, + IsWeaklyPrincipal (b : K⟦ℝ⟧) → + IsWeaklyPrincipal (c : K⟦ℝ⟧) → + ((b * c : Nonpositive ℝ K) : K⟦ℝ⟧).supportOrderType = + (NatOrdinal.of (b : K⟦ℝ⟧).supportOrderType * + NatOrdinal.of (c : K⟦ℝ⟧).supportOrderType).val + +/-- Characterization of multiplicativity on weakly principal series. -/ +theorem orderTypeMultiplicativeOnWeaklyPrincipal_iff : + OrderTypeMultiplicativeOnWeaklyPrincipal K ↔ + ∀ b c : Nonpositive ℝ K, + IsWeaklyPrincipal (b : K⟦ℝ⟧) → + IsWeaklyPrincipal (c : K⟦ℝ⟧) → + ((b * c : Nonpositive ℝ K) : K⟦ℝ⟧).supportOrderType = + (NatOrdinal.of (b : K⟦ℝ⟧).supportOrderType * + NatOrdinal.of (c : K⟦ℝ⟧).supportOrderType).val := + Iff.rfl + +/-- Apply support-order-type multiplicativity to two weakly principal series. -/ +theorem OrderTypeMultiplicativeOnWeaklyPrincipal.supportOrderType_mul + (h : OrderTypeMultiplicativeOnWeaklyPrincipal K) + {b c : Nonpositive ℝ K} + (hb : IsWeaklyPrincipal (b : K⟦ℝ⟧)) + (hc : IsWeaklyPrincipal (c : K⟦ℝ⟧)) : + ((b * c : Nonpositive ℝ K) : K⟦ℝ⟧).supportOrderType = + (NatOrdinal.of (b : K⟦ℝ⟧).supportOrderType * + NatOrdinal.of (c : K⟦ℝ⟧).supportOrderType).val := + (orderTypeMultiplicativeOnWeaklyPrincipal_iff.mp h) b c hb hc + +/-- Under support-order-type multiplicativity, degree is multiplicative on weakly principal +series. -/ +theorem OrderTypeMultiplicativeOnWeaklyPrincipal.degree_mul + (h : OrderTypeMultiplicativeOnWeaklyPrincipal K) + {b c : Nonpositive ℝ K} + (hb : IsWeaklyPrincipal (b : K⟦ℝ⟧)) + (hc : IsWeaklyPrincipal (c : K⟦ℝ⟧)) : + ((b * c : Nonpositive ℝ K) : K⟦ℝ⟧).degree = + (b : K⟦ℝ⟧).degree + (c : K⟦ℝ⟧).degree := by + rw [degree_eq_cantorDegree, h.supportOrderType_mul hb hc, + ← NatOrdinal.cantorDegree_eq_ordinalCantorDegree, + NatOrdinal.cantorDegree_mul, NatOrdinal.cantorDegree_of, + NatOrdinal.cantorDegree_of, ← degree_eq_cantorDegree, + ← degree_eq_cantorDegree] + +/-- Under support-order-type multiplicativity, the product of weakly principal series is weakly +principal. -/ +theorem OrderTypeMultiplicativeOnWeaklyPrincipal.isWeaklyPrincipal_mul + (h : OrderTypeMultiplicativeOnWeaklyPrincipal K) + {b c : Nonpositive ℝ K} + (hb : IsWeaklyPrincipal (b : K⟦ℝ⟧)) + (hc : IsWeaklyPrincipal (c : K⟦ℝ⟧)) : + IsWeaklyPrincipal ((b * c : Nonpositive ℝ K) : K⟦ℝ⟧) := by + rw [isWeaklyPrincipal_iff, h.supportOrderType_mul hb hc] + exact naturalMul_isAdditivelyPrincipal + (isWeaklyPrincipal_iff.mp hb) (isWeaklyPrincipal_iff.mp hc) + +private theorem truncLE_eq_zero_of_support_subset_Ioi + {x : K⟦ℝ⟧} {a : ℝ} (h : x.support ⊆ Set.Ioi a) : + truncLE a x = 0 := by + rw [← support_eq_empty_iff, support_truncLE] + ext i + simp only [Set.mem_ofPred_eq, Set.mem_empty_iff_false, iff_false, not_and] + exact fun hi hia ↦ (not_lt_of_ge hia) (h hi) + +private theorem support_mul_subset_Ici_add + {b c : K⟦ℝ⟧} {x y : ℝ} + (hb : b.support ⊆ Set.Ici x) (hc : c.support ⊆ Set.Ici y) : + (b * c).support ⊆ Set.Ici (x + y) := by + intro z hz + obtain ⟨i, hi, j, hj, rfl⟩ := support_mul_subset hz + have hxi : x ≤ i := hb hi + have hyj : y ≤ j := hc hj + exact add_le_add hxi hyj + +private theorem support_mul_subset_Ioi_add + {b c : K⟦ℝ⟧} {x y : ℝ} + (hb : b.support ⊆ Set.Ioi x) (hc : c.support ⊆ Set.Ioi y) : + (b * c).support ⊆ Set.Ioi (x + y) := by + intro z hz + obtain ⟨i, hi, j, hj, rfl⟩ := support_mul_subset hz + have hxi : x < i := hb hi + have hyj : y < j := hc hj + exact add_lt_add hxi hyj + +/-- The strict-support case of the repaired LM24, Lemma 3.4.2. The nonzero hypothesis is necessary +because strict support containment is vacuous for the zero series. -/ +theorem degree_truncLE_mul_lt_of_isPrincipal_of_support_subset_Ioi + {b c : Nonpositive ℝ K} {x : ℝ} + (hb : IsPrincipal b) (hcne : c ≠ 0) + (hc : (c : K⟦ℝ⟧).support ⊆ Set.Ioi x) : + (truncLE x ((b * c : Nonpositive ℝ K) : K⟦ℝ⟧)).degree < + (b : K⟦ℝ⟧).degree + (c : K⟦ℝ⟧).degree := by + have hcne' : (c : K⟦ℝ⟧) ≠ 0 := by simpa using hcne + have horderMem : (c : K⟦ℝ⟧).order ∈ (c : K⟦ℝ⟧).support := + (mem_support _ _).mpr (coeff_order_eq_zero.not.mpr hcne') + have hxorder : x < (c : K⟦ℝ⟧).order := hc horderMem + let y : ℝ := (x + (c : K⟦ℝ⟧).order) / 2 + have hxy : x < y := by + dsimp [y] + linarith + have hyorder : y < (c : K⟦ℝ⟧).order := by + dsimp [y] + linarith + have hcAboveY : (c : K⟦ℝ⟧).support ⊆ Set.Ioi y := by + intro i hi + exact hyorder.trans_le + (order_le_of_coeff_ne_zero ((mem_support _ _).mp hi)) + let a : ℝ := x - y + let d : K⟦ℝ⟧ := truncLE a (b : K⟦ℝ⟧) + let e : K⟦ℝ⟧ := truncGT a (b : K⟦ℝ⟧) + have ha : a < 0 := by + dsimp [a] + linarith + have hbLUB : IsLUB (b : K⟦ℝ⟧).support 0 := + (supportSup_eq_coe_iff.mp hb.supportSup_eq_zero).2 + obtain ⟨g, hg, hag, _⟩ := hbLUB.exists_between ha + have hdne : d ≠ (b : K⟦ℝ⟧) := by + intro hdb + have hcoeff := congrArg (fun z : K⟦ℝ⟧ ↦ z.coeff g) hdb + have hzero : d.coeff g = 0 := + coeff_truncLE_of_lt hag (b : K⟦ℝ⟧) + exact (mem_support _ _).mp hg (hcoeff.symm.trans hzero) + have hecAbove : (e * (c : K⟦ℝ⟧)).support ⊆ Set.Ioi x := by + intro z hz + obtain ⟨i, hi, j, hj, hij⟩ := support_mul_subset hz + rw [support_truncGT] at hi + have hji : y < j := hcAboveY hj + have hia : a < i := hi.2 + change x < z + rw [← hij] + dsimp [a] at hia + linarith + have htruncProduct : + truncLE x ((b * c : Nonpositive ℝ K) : K⟦ℝ⟧) = + truncLE x (d * (c : K⟦ℝ⟧)) := by + change truncLE x ((b : K⟦ℝ⟧) * (c : K⟦ℝ⟧)) = _ + calc + truncLE x ((b : K⟦ℝ⟧) * (c : K⟦ℝ⟧)) = + truncLE x ((d + e) * (c : K⟦ℝ⟧)) := by + rw [truncLE_add_truncGT a (b : K⟦ℝ⟧)] + _ = truncLE x (d * (c : K⟦ℝ⟧) + e * (c : K⟦ℝ⟧)) := by + rw [add_mul] + _ = truncLE x (d * (c : K⟦ℝ⟧)) + + truncLE x (e * (c : K⟦ℝ⟧)) := truncLE_add _ _ _ + _ = truncLE x (d * (c : K⟦ℝ⟧)) := by + rw [truncLE_eq_zero_of_support_subset_Ioi hecAbove, add_zero] + rw [htruncProduct] + calc + (truncLE x (d * (c : K⟦ℝ⟧))).degree ≤ + (d * (c : K⟦ℝ⟧)).degree := + degree_truncLE_le _ _ + _ ≤ d.degree + (c : K⟦ℝ⟧).degree := degree_mul_le _ _ + _ < (b : K⟦ℝ⟧).degree + (c : K⟦ℝ⟧).degree := by + rw [WithBot.add_lt_add_iff_right (degree_eq_bot.not.mpr hcne')] + exact degree_lt_of_supportOrderType_lt_of_isWeaklyPrincipal + hb.isWeaklyPrincipal (supportOrderType_truncLE_lt a hdne) + +private theorem degree_truncLE_le_zero_of_support_subset_Ici + {c : K⟦ℝ⟧} {x : ℝ} (hc : c.support ⊆ Set.Ici x) : + (truncLE x c).degree ≤ 0 := by + have hsupport : (truncLE x c).support ⊆ {x} := by + rw [support_truncLE] + rintro i ⟨hi, hix⟩ + exact Set.mem_singleton_iff.mpr (le_antisymm hix (hc hi)) + have hfinite : (truncLE x c).support.Finite := + Set.finite_singleton x |>.subset hsupport + by_cases hzero : truncLE x c = 0 + · simp [hzero] + · rw [(degree_eq_zero.mpr ⟨hzero, hfinite⟩)] + +/-- The weak-support, positive-degree case of the repaired LM24, Lemma 3.4.2. -/ +theorem degree_truncLE_mul_lt_of_isPrincipal_of_support_subset_Ici_of_degree_pos + {b c : Nonpositive ℝ K} {x : ℝ} + (hb : IsPrincipal b) (hc : (c : K⟦ℝ⟧).support ⊆ Set.Ici x) + (hcDegree : 0 < (c : K⟦ℝ⟧).degree) : + (truncLE x ((b * c : Nonpositive ℝ K) : K⟦ℝ⟧)).degree < + (b : K⟦ℝ⟧).degree + (c : K⟦ℝ⟧).degree := by + let cLower : Nonpositive ℝ K := + ⟨truncLE x (c : K⟦ℝ⟧), + (mem_nonpositiveSubring (x := truncLE x (c : K⟦ℝ⟧))).mpr + ((support_truncLE_subset x (c : K⟦ℝ⟧)).trans (support_subset c))⟩ + let cUpper : Nonpositive ℝ K := + ⟨truncGT x (c : K⟦ℝ⟧), + (mem_nonpositiveSubring (x := truncGT x (c : K⟦ℝ⟧))).mpr + ((support_truncGT_subset x (c : K⟦ℝ⟧)).trans (support_subset c))⟩ + have hcLowerDegree : (cLower : K⟦ℝ⟧).degree ≤ 0 := + degree_truncLE_le_zero_of_support_subset_Ici hc + have hcUpperNe : cUpper ≠ 0 := by + intro hzero + have hzero' : truncGT x (c : K⟦ℝ⟧) = 0 := + congrArg Subtype.val hzero + have hcEq : (c : K⟦ℝ⟧) = (cLower : K⟦ℝ⟧) := by + calc + (c : K⟦ℝ⟧) = + truncLE x (c : K⟦ℝ⟧) + truncGT x (c : K⟦ℝ⟧) := + (truncLE_add_truncGT x (c : K⟦ℝ⟧)).symm + _ = (cLower : K⟦ℝ⟧) := by rw [hzero', add_zero] + exact (not_lt_of_ge (hcEq ▸ hcLowerDegree)) hcDegree + have hcUpperSupport : (cUpper : K⟦ℝ⟧).support ⊆ Set.Ioi x := by + rw [show (cUpper : K⟦ℝ⟧) = truncGT x (c : K⟦ℝ⟧) from rfl, + support_truncGT] + exact fun _ hi ↦ hi.2 + have hcUpperDegree : + (cUpper : K⟦ℝ⟧).degree ≤ (c : K⟦ℝ⟧).degree := + degree_mono_support (support_truncGT_subset x (c : K⟦ℝ⟧)) + have hLower : + (truncLE x ((b : K⟦ℝ⟧) * (cLower : K⟦ℝ⟧))).degree < + (b : K⟦ℝ⟧).degree + (c : K⟦ℝ⟧).degree := by + calc + (truncLE x ((b : K⟦ℝ⟧) * (cLower : K⟦ℝ⟧))).degree ≤ + ((b : K⟦ℝ⟧) * (cLower : K⟦ℝ⟧)).degree := + degree_truncLE_le _ _ + _ ≤ (b : K⟦ℝ⟧).degree + (cLower : K⟦ℝ⟧).degree := + degree_mul_le _ _ + _ < (b : K⟦ℝ⟧).degree + (c : K⟦ℝ⟧).degree := by + rw [WithBot.add_lt_add_iff_left + (degree_eq_bot.not.mpr (by simpa using hb.ne_zero))] + exact hcLowerDegree.trans_lt hcDegree + have hUpper : + (truncLE x ((b : K⟦ℝ⟧) * (cUpper : K⟦ℝ⟧))).degree < + (b : K⟦ℝ⟧).degree + (c : K⟦ℝ⟧).degree := by + exact (degree_truncLE_mul_lt_of_isPrincipal_of_support_subset_Ioi + hb hcUpperNe hcUpperSupport).trans_le + (add_le_add_right hcUpperDegree _) + have hProduct : + (b : K⟦ℝ⟧) * (c : K⟦ℝ⟧) = + (b : K⟦ℝ⟧) * (cLower : K⟦ℝ⟧) + + (b : K⟦ℝ⟧) * (cUpper : K⟦ℝ⟧) := by + rw [show (c : K⟦ℝ⟧) = + (cLower : K⟦ℝ⟧) + (cUpper : K⟦ℝ⟧) from + (truncLE_add_truncGT x (c : K⟦ℝ⟧)).symm, mul_add] + change (truncLE x ((b : K⟦ℝ⟧) * (c : K⟦ℝ⟧))).degree < _ + calc + (truncLE x ((b : K⟦ℝ⟧) * (c : K⟦ℝ⟧))).degree = + (truncLE x ((b : K⟦ℝ⟧) * (cLower : K⟦ℝ⟧) + + (b : K⟦ℝ⟧) * (cUpper : K⟦ℝ⟧))).degree := + congrArg degree (congrArg (truncLE x) hProduct) + _ = (truncLE x ((b : K⟦ℝ⟧) * (cLower : K⟦ℝ⟧)) + + truncLE x ((b : K⟦ℝ⟧) * (cUpper : K⟦ℝ⟧))).degree := by + rw [truncLE_add] + _ ≤ max + (truncLE x ((b : K⟦ℝ⟧) * (cLower : K⟦ℝ⟧))).degree + (truncLE x ((b : K⟦ℝ⟧) * (cUpper : K⟦ℝ⟧))).degree := + degree_add_le _ _ + _ < (b : K⟦ℝ⟧).degree + (c : K⟦ℝ⟧).degree := + max_lt hLower hUpper + +/-- Repaired LM24, Lemma 3.4.2. If `b` is principal, `c` is nonzero, and the support of `c` is +strictly above `x`, or is weakly above `x` with positive degree, then the degree of the weak lower +truncation of `b * c` is strictly below the natural sum of the factor degrees. -/ +theorem degree_truncLE_mul_lt + {b c : Nonpositive ℝ K} {x : ℝ} + (hb : IsPrincipal b) (hcne : c ≠ 0) + (hc : (c : K⟦ℝ⟧).support ⊆ Set.Ioi x ∨ + (c : K⟦ℝ⟧).support ⊆ Set.Ici x ∧ + 0 < (c : K⟦ℝ⟧).degree) : + (truncLE x ((b * c : Nonpositive ℝ K) : K⟦ℝ⟧)).degree < + (b : K⟦ℝ⟧).degree + (c : K⟦ℝ⟧).degree := by + rcases hc with hc | ⟨hc, hcDegree⟩ + · exact degree_truncLE_mul_lt_of_isPrincipal_of_support_subset_Ioi + hb hcne hc + · exact + degree_truncLE_mul_lt_of_isPrincipal_of_support_subset_Ici_of_degree_pos + hb hc hcDegree + +private theorem degree_truncLE_principal_mul_remainder_lt + {p r c : Nonpositive ℝ K} {x : ℝ} + (hp : IsPrincipal p) (hcne : c ≠ 0) + (hrSupport : (r : K⟦ℝ⟧).support ⊆ Set.Ici x) + (hrDegree : (r : K⟦ℝ⟧).degree ≤ (c : K⟦ℝ⟧).degree) + (hrStrict : (c : K⟦ℝ⟧).degree = 0 → + (r : K⟦ℝ⟧).support ⊆ Set.Ioi x) : + (truncLE x ((p * r : Nonpositive ℝ K) : K⟦ℝ⟧)).degree < + (p : K⟦ℝ⟧).degree + (c : K⟦ℝ⟧).degree := by + rcases hrDegree.lt_or_eq with hrDegree | hrDegree + · calc + (truncLE x ((p * r : Nonpositive ℝ K) : K⟦ℝ⟧)).degree ≤ + ((p : K⟦ℝ⟧) * (r : K⟦ℝ⟧)).degree := + degree_truncLE_le _ _ + _ ≤ (p : K⟦ℝ⟧).degree + (r : K⟦ℝ⟧).degree := + degree_mul_le _ _ + _ < (p : K⟦ℝ⟧).degree + (c : K⟦ℝ⟧).degree := by + rw [WithBot.add_lt_add_iff_left + (degree_eq_bot.not.mpr (by simpa using hp.ne_zero))] + exact hrDegree + · have hrne : r ≠ 0 := by + intro hzero + have hcDegreeBot : (c : K⟦ℝ⟧).degree = ⊥ := by + rw [← hrDegree, hzero] + exact degree_zero + exact hcne (by + apply Subtype.ext + exact degree_eq_bot.mp hcDegreeBot) + have hcne' : (c : K⟦ℝ⟧) ≠ 0 := by simpa using hcne + rcases (zero_le_degree_of_ne_zero hcne').eq_or_lt with + hcDegree | hcDegree + · have h := degree_truncLE_mul_lt hp hrne + (Or.inl (hrStrict hcDegree.symm)) + simpa [hrDegree] using h + · have h := degree_truncLE_mul_lt hp hrne + (Or.inr ⟨hrSupport, hrDegree ▸ hcDegree⟩) + simpa [hrDegree] using h + +/-- The weak lower truncation at `x + y` of a product of two head decompositions +`translate x b₁ + b'` and `translate y c₁ + c'`. The head term `translate (x + y) (b₁ * c₁)` +survives the truncation unchanged, since `b₁ * c₁` is nonpositive; the two cross terms are +truncated at the shifted cutoffs `y` and `x`; the remainder product is truncated at `x + y`. -/ +private theorem truncLE_add_mul_add_of_head_decomposition + (b₁ b' c₁ c' : Nonpositive ℝ K) (x y : ℝ) : + truncLE (x + y) ((translate x (b₁ : K⟦ℝ⟧) + (b' : K⟦ℝ⟧)) * + (translate y (c₁ : K⟦ℝ⟧) + (c' : K⟦ℝ⟧))) = + translate (x + y) ((b₁ * c₁ : Nonpositive ℝ K) : K⟦ℝ⟧) + + (translate x (truncLE y ((b₁ * c' : Nonpositive ℝ K) : K⟦ℝ⟧)) + + (translate y (truncLE x ((c₁ * b' : Nonpositive ℝ K) : K⟦ℝ⟧)) + + truncLE (x + y) ((b' * c' : Nonpositive ℝ K) : K⟦ℝ⟧))) := by + have hHeadProduct : + translate x (b₁ : K⟦ℝ⟧) * translate y (c₁ : K⟦ℝ⟧) = + translate (x + y) ((b₁ * c₁ : Nonpositive ℝ K) : K⟦ℝ⟧) := + translate_mul_translate x y (b₁ : K⟦ℝ⟧) (c₁ : K⟦ℝ⟧) + have hSecondProduct : + translate x (b₁ : K⟦ℝ⟧) * (c' : K⟦ℝ⟧) = + translate x ((b₁ * c' : Nonpositive ℝ K) : K⟦ℝ⟧) := by + simpa using translate_mul_translate + x 0 (b₁ : K⟦ℝ⟧) (c' : K⟦ℝ⟧) + have hThirdProduct : + (b' : K⟦ℝ⟧) * translate y (c₁ : K⟦ℝ⟧) = + translate y ((c₁ * b' : Nonpositive ℝ K) : K⟦ℝ⟧) := by + rw [mul_comm] + simpa using translate_mul_translate + y 0 (c₁ : K⟦ℝ⟧) (b' : K⟦ℝ⟧) + have hHeadTrunc : + truncLE (x + y) (translate (x + y) ((b₁ * c₁ : Nonpositive ℝ K) : K⟦ℝ⟧)) = + translate (x + y) ((b₁ * c₁ : Nonpositive ℝ K) : K⟦ℝ⟧) := by + rw [truncLE_translate, _root_.sub_self] + rw [truncLE_eq_self_of_support_subset_Iic (support_subset (b₁ * c₁))] + have hSecondTrunc : + truncLE (x + y) (translate x ((b₁ * c' : Nonpositive ℝ K) : K⟦ℝ⟧)) = + translate x (truncLE y ((b₁ * c' : Nonpositive ℝ K) : K⟦ℝ⟧)) := by + rw [truncLE_translate] + simp only [add_sub_cancel_left] + have hThirdTrunc : + truncLE (x + y) (translate y ((c₁ * b' : Nonpositive ℝ K) : K⟦ℝ⟧)) = + translate y (truncLE x ((c₁ * b' : Nonpositive ℝ K) : K⟦ℝ⟧)) := by + rw [truncLE_translate] + simp only [add_sub_cancel_right] + rw [add_mul, mul_add, mul_add, hHeadProduct, hSecondProduct, hThirdProduct, + truncLE_add, truncLE_add, truncLE_add, hHeadTrunc, hSecondTrunc, hThirdTrunc] + simp only [add_assoc] + rfl + +/-- The remainder-times-remainder term of the head expansion has degree strictly below the sum of +the factor degrees. When that sum is positive, the truncation of a series supported weakly above +the cutoff has degree at most `0`. When both degrees are `0`, both remainders are supported +strictly above their cutoffs, so the truncated product vanishes and its degree is `⊥`. -/ +private theorem degree_truncLE_remainder_mul_remainder_lt + {b c b' c' : Nonpositive ℝ K} {x y : ℝ} (hbne : b ≠ 0) (hcne : c ≠ 0) + (hb'Support : (b' : K⟦ℝ⟧).support ⊆ Set.Ici x) + (hc'Support : (c' : K⟦ℝ⟧).support ⊆ Set.Ici y) + (hb'Strict : (b : K⟦ℝ⟧).degree = 0 → (b' : K⟦ℝ⟧).support ⊆ Set.Ioi x) + (hc'Strict : (c : K⟦ℝ⟧).degree = 0 → (c' : K⟦ℝ⟧).support ⊆ Set.Ioi y) : + (truncLE (x + y) ((b' * c' : Nonpositive ℝ K) : K⟦ℝ⟧)).degree < + (b : K⟦ℝ⟧).degree + (c : K⟦ℝ⟧).degree := by + have hbne' : (b : K⟦ℝ⟧) ≠ 0 := by simpa using hbne + have hcne' : (c : K⟦ℝ⟧) ≠ 0 := by simpa using hcne + have hFourthSupport : + ((b' : K⟦ℝ⟧) * (c' : K⟦ℝ⟧)).support ⊆ Set.Ici (x + y) := + support_mul_subset_Ici_add hb'Support hc'Support + have hFourthDegreeLe : + (truncLE (x + y) ((b' : K⟦ℝ⟧) * (c' : K⟦ℝ⟧))).degree ≤ 0 := + degree_truncLE_le_zero_of_support_subset_Ici hFourthSupport + have hsumDegreeNonnegative : + 0 ≤ (b : K⟦ℝ⟧).degree + (c : K⟦ℝ⟧).degree := + add_nonneg (zero_le_degree_of_ne_zero hbne') (zero_le_degree_of_ne_zero hcne') + change (truncLE (x + y) ((b' : K⟦ℝ⟧) * (c' : K⟦ℝ⟧))).degree < _ + rcases hsumDegreeNonnegative.eq_or_lt with hzero | hpos + · obtain ⟨db, hdb⟩ := WithBot.ne_bot_iff_exists.mp + (degree_eq_bot.not.mpr hbne') + obtain ⟨dc, hdc⟩ := WithBot.ne_bot_iff_exists.mp + (degree_eq_bot.not.mpr hcne') + have hsum : db + dc = 0 := by + apply WithBot.coe_injective + simpa [WithBot.coe_add, hdb, hdc] using hzero.symm + have hdegrees := NatOrdinal.add_eq_zero_iff.mp hsum + have hbDegree : (b : K⟦ℝ⟧).degree = 0 := + hdb.symm.trans + (congrArg ((↑·) : NatOrdinal → WithBot NatOrdinal) hdegrees.1) + have hcDegree : (c : K⟦ℝ⟧).degree = 0 := + hdc.symm.trans + (congrArg ((↑·) : NatOrdinal → WithBot NatOrdinal) hdegrees.2) + have hstrictSupport : + ((b' : K⟦ℝ⟧) * (c' : K⟦ℝ⟧)).support ⊆ Set.Ioi (x + y) := + support_mul_subset_Ioi_add + (hb'Strict hbDegree) (hc'Strict hcDegree) + rw [truncLE_eq_zero_of_support_subset_Ioi hstrictSupport, degree_zero, + ← hzero] + exact WithBot.bot_lt_coe 0 + · exact hFourthDegreeLe.trans_lt hpos + +/-- In the head expansion of `b * c`, the three terms other than the head have degree strictly +below the sum of the factor degrees: each cross term is a principal head times a remainder, +bounded by the repaired truncation lemma, and the remainder product is handled separately. -/ +private theorem degree_head_expansion_remainder_lt + {b c b₁ b' c₁ c' : Nonpositive ℝ K} {x y : ℝ} (hbne : b ≠ 0) (hcne : c ≠ 0) + (hb₁Principal : IsPrincipal b₁) (hc₁Principal : IsPrincipal c₁) + (hb'Support : (b' : K⟦ℝ⟧).support ⊆ Set.Ici x) + (hc'Support : (c' : K⟦ℝ⟧).support ⊆ Set.Ici y) + (hb₁Degree : (b₁ : K⟦ℝ⟧).degree = (b : K⟦ℝ⟧).degree) + (hc₁Degree : (c₁ : K⟦ℝ⟧).degree = (c : K⟦ℝ⟧).degree) + (hb'Degree : (b' : K⟦ℝ⟧).degree ≤ (b : K⟦ℝ⟧).degree) + (hc'Degree : (c' : K⟦ℝ⟧).degree ≤ (c : K⟦ℝ⟧).degree) + (hb'Strict : (b : K⟦ℝ⟧).degree = 0 → (b' : K⟦ℝ⟧).support ⊆ Set.Ioi x) + (hc'Strict : (c : K⟦ℝ⟧).degree = 0 → (c' : K⟦ℝ⟧).support ⊆ Set.Ioi y) : + (translate x (truncLE y ((b₁ * c' : Nonpositive ℝ K) : K⟦ℝ⟧)) + + (translate y (truncLE x ((c₁ * b' : Nonpositive ℝ K) : K⟦ℝ⟧)) + + truncLE (x + y) ((b' * c' : Nonpositive ℝ K) : K⟦ℝ⟧))).degree < + (b : K⟦ℝ⟧).degree + (c : K⟦ℝ⟧).degree := by + have hSecondDegree : + (translate x (truncLE y ((b₁ * c' : Nonpositive ℝ K) : K⟦ℝ⟧))).degree < + (b : K⟦ℝ⟧).degree + (c : K⟦ℝ⟧).degree := by + rw [degree_translate, ← hb₁Degree] + exact degree_truncLE_principal_mul_remainder_lt + hb₁Principal hcne hc'Support hc'Degree hc'Strict + have hThirdDegree : + (translate y (truncLE x ((c₁ * b' : Nonpositive ℝ K) : K⟦ℝ⟧))).degree < + (b : K⟦ℝ⟧).degree + (c : K⟦ℝ⟧).degree := by + rw [degree_translate, ← hc₁Degree, add_comm] + exact degree_truncLE_principal_mul_remainder_lt + hc₁Principal hbne hb'Support hb'Degree hb'Strict + have hFourthDegree := + degree_truncLE_remainder_mul_remainder_lt hbne hcne hb'Support hc'Support + hb'Strict hc'Strict + exact (degree_add_le _ _).trans_lt + (max_lt hSecondDegree ((degree_add_le _ _).trans_lt (max_lt hThirdDegree hFourthDegree))) + +/-- Assuming the Berarducci weakly-principal order-type law, degree is multiplicative on all +nonpositive real Hahn series. This is LM24, Proposition 3.4.3, with Hessenberg addition on the +degrees and its absorbing bottom convention at zero. -/ +theorem degree_mul_of_orderTypeMultiplicativeOnWeaklyPrincipal + (h : OrderTypeMultiplicativeOnWeaklyPrincipal K) + (b c : Nonpositive ℝ K) : + ((b * c : Nonpositive ℝ K) : K⟦ℝ⟧).degree = + (b : K⟦ℝ⟧).degree + (c : K⟦ℝ⟧).degree := by + obtain rfl | hbne := eq_or_ne b 0 + · simp + obtain rfl | hcne := eq_or_ne c 0 + · simp + obtain ⟨b₁, x, b', hb₁Principal, hbEq, hb'Support, hb₁Degree, + hb'Degree, hb'Strict⟩ := exists_principal_head_decomposition hbne + obtain ⟨c₁, y, c', hc₁Principal, hcEq, hc'Support, hc₁Degree, + hc'Degree, hc'Strict⟩ := exists_principal_head_decomposition hcne + have hExpansion : + truncLE (x + y) ((b : K⟦ℝ⟧) * (c : K⟦ℝ⟧)) = + translate (x + y) ((b₁ * c₁ : Nonpositive ℝ K) : K⟦ℝ⟧) + + (translate x (truncLE y ((b₁ * c' : Nonpositive ℝ K) : K⟦ℝ⟧)) + + (translate y (truncLE x ((c₁ * b' : Nonpositive ℝ K) : K⟦ℝ⟧)) + + truncLE (x + y) ((b' * c' : Nonpositive ℝ K) : K⟦ℝ⟧))) := by + rw [hbEq, hcEq] + exact truncLE_add_mul_add_of_head_decomposition b₁ b' c₁ c' x y + have hHeadDegree : + (translate (x + y) ((b₁ * c₁ : Nonpositive ℝ K) : K⟦ℝ⟧)).degree = + (b : K⟦ℝ⟧).degree + (c : K⟦ℝ⟧).degree := by + rw [degree_translate, + h.degree_mul hb₁Principal.isWeaklyPrincipal hc₁Principal.isWeaklyPrincipal, + hb₁Degree, hc₁Degree] + have hRemainderDegree := degree_head_expansion_remainder_lt hbne hcne hb₁Principal + hc₁Principal hb'Support hc'Support hb₁Degree hc₁Degree hb'Degree hc'Degree + hb'Strict hc'Strict + have hTruncDegree : + (truncLE (x + y) ((b : K⟦ℝ⟧) * (c : K⟦ℝ⟧))).degree = + (b : K⟦ℝ⟧).degree + (c : K⟦ℝ⟧).degree := by + rw [hExpansion] + exact (degree_add_eq_left_of_lt (hHeadDegree.symm ▸ hRemainderDegree)).trans hHeadDegree + change ((b : K⟦ℝ⟧) * (c : K⟦ℝ⟧)).degree = + (b : K⟦ℝ⟧).degree + (c : K⟦ℝ⟧).degree + exact le_antisymm (degree_mul_le _ _) (hTruncDegree ▸ degree_truncLE_le _ _) + +end Nonpositive + +end HahnSeries diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Negative.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Negative.lean new file mode 100644 index 0000000000..cb7358f897 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Negative.lean @@ -0,0 +1,256 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Nonpositive +public import Mathlib.Algebra.Group.Pointwise.Set.Basic +public import Mathlib.RingTheory.Ideal.Maps + +/-! +# Hahn series with strictly negative support + +This file defines the series denoted by `K((G^{<0}))` in LM24, Section 2.1. Inside the ring of +nonpositive Hahn series, they are exactly the kernel of the constant-coefficient homomorphism. +This realizes them simultaneously as a two-sided ideal and as a nonunital ring. + +For a coefficient subring `Z`, the truncation integer part is proved to have the source +presentation `Z + K((G^{<0}))`. The Lean definition remains the intrinsic pullback along the +constant-coefficient homomorphism; the presentation theorem supplies the exact printed form +without replacing the carrier by a chosen pair of summands. +-/ + +open scoped Pointwise + +universe u v + +public noncomputable section + +namespace HahnSeries + +variable (Γ : Type u) (R : Type v) +variable [AddCommGroup Γ] [PartialOrder Γ] [IsOrderedAddMonoid Γ] [Ring R] + +/-- The ideal of nonpositive Hahn series with zero constant coefficient. Its elements are exactly +the Hahn series with strictly negative support. -/ +def negativeIdeal : Ideal (Nonpositive Γ R) := + RingHom.ker (Nonpositive.constantCoeff (Γ := Γ) (R := R)) + +/-- Membership in `negativeIdeal` means that every support exponent is strictly negative. -/ +@[simp] +theorem mem_negativeIdeal {x : Nonpositive Γ R} : + x ∈ negativeIdeal Γ R ↔ (x : R⟦Γ⟧).support ⊆ Set.Iio 0 := by + rw [negativeIdeal, RingHom.mem_ker, Nonpositive.constantCoeff_apply] + constructor + · intro hx g hg + have hg_nonpos := Nonpositive.support_subset x hg + have hg_ne : g ≠ 0 := by + intro hg0 + subst g + exact (HahnSeries.mem_support (x : R⟦Γ⟧) 0).mp hg hx + exact lt_of_le_of_ne hg_nonpos hg_ne + · intro hx + by_contra h0 + exact (hx ((HahnSeries.mem_support (x : R⟦Γ⟧) 0).mpr h0)).ne rfl + +/-- Strictly negative Hahn series, represented as the subtype of `negativeIdeal`. -/ +abbrev Negative := ↥(negativeIdeal Γ R) + +instance negativeIdealIsTwoSided : (negativeIdeal Γ R).IsTwoSided := by + change (RingHom.ker (Nonpositive.constantCoeff (Γ := Γ) (R := R))).IsTwoSided + infer_instance + +namespace Negative + +variable {Γ R} + +/-- A strictly negative Hahn series has zero constant coefficient. -/ +theorem constantCoeff_eq_zero (x : Negative Γ R) : + Nonpositive.constantCoeff (Γ := Γ) (R := R) x = 0 := + RingHom.mem_ker.mp x.2 + +/-- The coefficient at exponent zero of a strictly negative Hahn series is zero. -/ +@[simp] +theorem coeff_zero (x : Negative Γ R) : (x : R⟦Γ⟧).coeff 0 = 0 := by + rw [← Nonpositive.constantCoeff_apply] + exact constantCoeff_eq_zero x + +/-- The support of a strictly negative Hahn series is contained in `Set.Iio 0`. -/ +theorem support_subset (x : Negative Γ R) : + (x : R⟦Γ⟧).support ⊆ Set.Iio 0 := + (mem_negativeIdeal (Γ := Γ) (R := R)).mp x.2 + +/-- A single monomial with strictly negative exponent, regarded as a strictly negative Hahn +series. -/ +def single (g : Γ) (r : R) (hg : g < 0) : Negative Γ R := + ⟨Nonpositive.single g r hg.le, by + rw [negativeIdeal, RingHom.mem_ker, Nonpositive.constantCoeff_apply, + Nonpositive.coe_single] + exact HahnSeries.coeff_single_of_ne hg.ne'⟩ + +@[simp] +theorem coe_single (g : Γ) (r : R) (hg : g < 0) : + (single g r hg : R⟦Γ⟧) = HahnSeries.single g r := + Nonpositive.coe_single g r hg.le + +end Negative + +namespace Nonpositive + +/-- Remove the constant coefficient from a nonpositive Hahn series. -/ +def negativePart : Nonpositive Γ R →+ Negative Γ R where + toFun x := ⟨x - C (constantCoeff x), by + rw [negativeIdeal, RingHom.mem_ker] + simp⟩ + map_zero' := by ext; simp + map_add' x y := by + apply Subtype.ext + change x + y - C (constantCoeff (x + y)) = + (x - C (constantCoeff x)) + (y - C (constantCoeff y)) + rw [map_add, map_add] + abel + +@[simp] +theorem coe_negativePart (x : Nonpositive Γ R) : + (negativePart Γ R x : Nonpositive Γ R) = x - C (constantCoeff x) := + (rfl) + +/-- The support of the strictly negative part is the intersection of the original support with +the strict negative cone. -/ +theorem support_negativePart (x : Nonpositive Γ R) : + ((negativePart Γ R x : Negative Γ R) : R⟦Γ⟧).support = + (x : R⟦Γ⟧).support ∩ Set.Iio 0 := by + ext g + rw [HahnSeries.mem_support] + by_cases hg : g = 0 + · subst g + simp + · have hnegativePart := congrArg Subtype.val (coe_negativePart Γ R x) + have hsub := map_sub (nonpositiveSubring Γ R).subtype x (C (constantCoeff x)) + rw [hnegativePart] + change + (((nonpositiveSubring Γ R).subtype (x - C (constantCoeff x))).coeff g ≠ 0) ↔ + g ∈ (x : R⟦Γ⟧).support ∩ Set.Iio 0 + rw [hsub, HahnSeries.coeff_sub] + simp only [Subring.coe_subtype] + rw [coe_C] + change + ((x : R⟦Γ⟧).coeff g - + (HahnSeries.C (constantCoeff x) : R⟦Γ⟧).coeff g ≠ 0) ↔ + g ∈ (x : R⟦Γ⟧).support ∩ Set.Iio 0 + rw [HahnSeries.C_apply, HahnSeries.coeff_single_of_ne hg, sub_zero, + Set.mem_inter_iff, Set.mem_Iio] + rw [HahnSeries.mem_support] + constructor + · intro hx + exact ⟨hx, lt_of_le_of_ne (support_subset x hx) hg⟩ + · exact fun hx ↦ hx.1 + +/-- A nonpositive Hahn series is the sum of its constant term and its strictly negative part. -/ +theorem constant_add_negativePart (x : Nonpositive Γ R) : + C (constantCoeff x) + (negativePart Γ R x : Nonpositive Γ R) = x := by + rw [coe_negativePart] + abel + +/-- The strictly negative part of a constant series is zero. -/ +@[simp] +theorem negativePart_C (r : R) : + negativePart Γ R (C (Γ := Γ) (R := R) r) = 0 := by + apply Subtype.ext + rw [coe_negativePart] + simp + +/-- Removing the constant coefficient from a strictly negative series leaves it unchanged. -/ +@[simp] +theorem negativePart_coe (x : Negative Γ R) : + negativePart Γ R (x : Nonpositive Γ R) = x := by + apply Subtype.ext + rw [coe_negativePart, Negative.constantCoeff_eq_zero] + simp + +end Nonpositive + +/-- The image in the nonpositive Hahn ring of a subring of the coefficient ring. -/ +def constantSubring (Z : Subring R) : Subring (Nonpositive Γ R) := + Z.map (Nonpositive.C (Γ := Γ) (R := R)) + +/-- Membership in the constant copy of `Z` means equality with the constant series attached to +some element of `Z`. -/ +theorem mem_constantSubring {Z : Subring R} {x : Nonpositive Γ R} : + x ∈ constantSubring Γ R Z ↔ + ∃ z : Z, Nonpositive.C (Γ := Γ) (R := R) z = x := by + constructor + · rintro ⟨r, hr, rfl⟩ + exact ⟨⟨r, hr⟩, rfl⟩ + · rintro ⟨z, rfl⟩ + exact Subring.mem_map.mpr ⟨z, z.2, rfl⟩ + +/-- A nonpositive Hahn series belongs to the truncation integer part exactly when it is the sum +of a constant series from `Z` and a strictly negative Hahn series. -/ +theorem mem_truncationIntegerPart_iff_exists_add_negative {Z : Subring R} + {x : Nonpositive Γ R} : + x ∈ truncationIntegerPart Γ Z ↔ + ∃ z : Z, ∃ n : Negative Γ R, + x = Nonpositive.C (Γ := Γ) (R := R) z + (n : Nonpositive Γ R) := by + constructor + · intro hx + have hz : Nonpositive.constantCoeff x ∈ Z := by + rw [Nonpositive.constantCoeff_apply] + exact (mem_truncationIntegerPart (Γ := Γ) (R := R)).mp hx + let z : Z := ⟨Nonpositive.constantCoeff x, hz⟩ + exact ⟨z, Nonpositive.negativePart Γ R x, by + exact (Nonpositive.constant_add_negativePart Γ R x).symm⟩ + · rintro ⟨z, n, rfl⟩ + rw [mem_truncationIntegerPart, ← Nonpositive.constantCoeff_apply, map_add] + rw [Negative.constantCoeff_eq_zero] + simp + +/-- The expression of a nonpositive Hahn series as a constant series from `Z` plus a strictly +negative series is unique. -/ +theorem constant_add_negative_eq_iff {Z : Subring R} {z z' : Z} {n n' : Negative Γ R} : + Nonpositive.C (Γ := Γ) (R := R) z + (n : Nonpositive Γ R) = + Nonpositive.C (Γ := Γ) (R := R) z' + (n' : Nonpositive Γ R) ↔ + z = z' ∧ n = n' := by + constructor + · intro h + have hz : (z : R) = z' := by + calc + (z : R) = Nonpositive.constantCoeff (Γ := Γ) (R := R) + (Nonpositive.C (Γ := Γ) (R := R) z + n) := by + rw [map_add, Negative.constantCoeff_eq_zero] + simp + _ = Nonpositive.constantCoeff (Γ := Γ) (R := R) + (Nonpositive.C (Γ := Γ) (R := R) z' + n') := congrArg _ h + _ = (z' : R) := by + rw [map_add, Negative.constantCoeff_eq_zero] + simp + have hzz : z = z' := Subtype.ext hz + subst z' + exact ⟨rfl, Subtype.ext (add_left_cancel h)⟩ + · rintro ⟨rfl, rfl⟩ + rfl + +/-- The carrier of a truncation integer part is the pointwise sum of the constant copy of `Z` +and the ideal of strictly negative Hahn series. This is the equality +`Z + K((G^{<0}))` used in LM24. -/ +theorem coe_truncationIntegerPart_eq_constantSubring_add_negativeIdeal (Z : Subring R) : + (truncationIntegerPart Γ Z : Set (Nonpositive Γ R)) = + (constantSubring Γ R Z : Set (Nonpositive Γ R)) + + (negativeIdeal Γ R : Set (Nonpositive Γ R)) := by + ext x + rw [Set.mem_add] + constructor + · intro hx + rcases (mem_truncationIntegerPart_iff_exists_add_negative + (Γ := Γ) (R := R)).mp hx with ⟨z, n, rfl⟩ + exact ⟨Nonpositive.C (Γ := Γ) (R := R) z, + (mem_constantSubring (Γ := Γ) (R := R)).mpr ⟨z, rfl⟩, n, n.2, rfl⟩ + · rintro ⟨c, hc, n, hn, rfl⟩ + rcases (mem_constantSubring (Γ := Γ) (R := R)).mp hc with ⟨z, rfl⟩ + exact (mem_truncationIntegerPart_iff_exists_add_negative + (Γ := Γ) (R := R)).mpr + ⟨z, ⟨n, hn⟩, rfl⟩ + +end HahnSeries diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/NegativeMonomialIdeal.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/NegativeMonomialIdeal.lean new file mode 100644 index 0000000000..af849c0219 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/NegativeMonomialIdeal.lean @@ -0,0 +1,147 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.SupportSupremum +public import Mathlib.RingTheory.Ideal.Span + +/-! +# The ideal generated by negative monomials + +For a coefficient field `K`, `HahnSeries.Nonpositive.negativeMonomialIdeal K` is the ideal +generated by the monomials `t^x` with `x < 0` in the nonpositive real Hahn-series ring. This is +Berarducci's ideal `J`, used as the cited prerequisite for LM24, Proposition 3.5.1. The paper's +description “generated by the monomials” is represented literally by `Ideal.span`. + +Membership has the intrinsic characterization + +``` +b ∈ negativeMonomialIdeal K ↔ supportSup b < 0. +``` + +The reverse implication factors `b` as the monomial at its support supremum times its normalized +translate. This characterization also records an important boundary: a series may have zero +constant coefficient and support supremum zero, and therefore need not belong to `J`. + +This module defines `J` and proves its membership API. Berarducci, Corollary 9.8 proves primeness +over a characteristic-zero field; that theorem is formalized in +`ConwayRefinement.HahnSeries.OrdinalValue.Statements.ProductValue`. The definition and the +lemmas below remain valid over any field. + +The definition uses `Ideal.span`; the intrinsic membership theorem is the main interface for +working with the ideal. +-/ + +universe v + +public noncomputable section + +namespace HahnSeries.Nonpositive + +variable {K : Type v} [Field K] + +/-- The coefficient-one monomials at strictly negative real exponents. -/ +def negativeMonomials (K : Type v) [Field K] : Set (Nonpositive ℝ K) := + Set.range fun x : Set.Iio (0 : ℝ) => single x 1 x.2.le + +/-- The ideal generated by the strictly negative monomials in the nonpositive real Hahn ring. -/ +def negativeMonomialIdeal (K : Type v) [Field K] : Ideal (Nonpositive ℝ K) := + Ideal.span (negativeMonomials K) + +theorem negativeMonomialIdeal_def : + negativeMonomialIdeal K = Ideal.span (negativeMonomials K) := + (rfl) + +theorem mem_negativeMonomials_iff {m : Nonpositive ℝ K} : + m ∈ negativeMonomials K ↔ ∃ x : Set.Iio (0 : ℝ), single x.1 1 x.2.le = m := + (Iff.rfl) + +/-- A coefficient-one monomial at a strictly negative exponent belongs to the negative-monomial +ideal. -/ +theorem single_one_mem_negativeMonomialIdeal {x : ℝ} (hx : x < 0) : + single x (1 : K) hx.le ∈ negativeMonomialIdeal K := by + apply Ideal.subset_span + exact ⟨⟨x, hx⟩, rfl⟩ + +private def supportSupLTZeroIdeal (K : Type v) [Field K] : + Ideal (Nonpositive ℝ K) where + carrier := {b | supportSup b < 0} + zero_mem' := by simp + add_mem' := by + intro b c hb hc + exact (supportSup_add_le b c).trans_lt (max_lt hb hc) + smul_mem' := by + intro b c hc + change supportSup (b * c) < 0 + calc + supportSup (b * c) ≤ supportSup b + supportSup c := + supportSup_mul_le b c + _ ≤ 0 + supportSup c := by + simpa [add_comm] using + (add_le_add_right (supportSup_le_zero b) (supportSup c)) + _ = supportSup c := zero_add _ + _ < 0 := hc + +private theorem negativeMonomialIdeal_le_supportSupLTZeroIdeal : + negativeMonomialIdeal K ≤ supportSupLTZeroIdeal K := by + rw [negativeMonomialIdeal, Ideal.span_le] + rintro _ ⟨x, rfl⟩ + change supportSup (single (x : ℝ) (1 : K) x.2.le) < 0 + rw [supportSup_single one_ne_zero] + exact WithBot.coe_lt_coe.mpr x.2 + +private theorem mem_negativeMonomialIdeal_of_supportSup_lt_zero + {b : Nonpositive ℝ K} (hb : supportSup b < 0) : + b ∈ negativeMonomialIdeal K := by + by_cases hbzero : b = 0 + · rw [hbzero] + exact (negativeMonomialIdeal K).zero_mem + have hsup : sSup (b : K⟦ℝ⟧).support < 0 := by + rw [supportSup_of_ne hbzero] at hb + exact WithBot.coe_lt_coe.mp hb + have hgenerator : + single (sSup (b : K⟦ℝ⟧).support) (1 : K) hsup.le ∈ + negativeMonomialIdeal K := + single_one_mem_negativeMonomialIdeal hsup + have hfactor : + single (sSup (b : K⟦ℝ⟧).support) (1 : K) hsup.le * normalize b = b := by + apply Subtype.ext + simpa only [Subring.coe_mul, coe_single, + HahnSeries.single_one_mul_eq_translate] using + translate_csSup_normalize b + rw [← hfactor] + exact Ideal.mul_mem_right (normalize b) (negativeMonomialIdeal K) hgenerator + +/-- A nonpositive real Hahn series belongs to the negative-monomial ideal exactly when its +support supremum is strictly negative. -/ +theorem mem_negativeMonomialIdeal_iff_supportSup_lt_zero + {b : Nonpositive ℝ K} : + b ∈ negativeMonomialIdeal K ↔ supportSup b < 0 := by + constructor + · exact fun hb => negativeMonomialIdeal_le_supportSupLTZeroIdeal hb + · exact mem_negativeMonomialIdeal_of_supportSup_lt_zero + +/-- A series with support supremum zero does not belong to the negative-monomial ideal. -/ +theorem not_mem_negativeMonomialIdeal_of_supportSup_eq_zero + {b : Nonpositive ℝ K} (hb : supportSup b = 0) : + b ∉ negativeMonomialIdeal K := by + rw [mem_negativeMonomialIdeal_iff_supportSup_lt_zero, hb] + exact lt_irrefl 0 + +/-- The negative-monomial ideal is proper. This does not assert that it is prime. -/ +theorem negativeMonomialIdeal_ne_top : negativeMonomialIdeal K ≠ ⊤ := by + intro htop + have hone : (1 : Nonpositive ℝ K) ∈ negativeMonomialIdeal K := by + rw [htop] + trivial + rw [mem_negativeMonomialIdeal_iff_supportSup_lt_zero] at hone + have honeEq : single 0 (1 : K) le_rfl = (1 : Nonpositive ℝ K) := by + apply Subtype.ext + simp + rw [← honeEq, supportSup_single one_ne_zero] at hone + exact (lt_irrefl (0 : WithBot ℝ)) hone + +end HahnSeries.Nonpositive diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Nonpositive.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Nonpositive.lean new file mode 100644 index 0000000000..a1fb309c40 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Nonpositive.lean @@ -0,0 +1,152 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import Mathlib.RingTheory.HahnSeries.Multiplication + +/-! +# Hahn series with nonpositive support + +This file constructs the subring of Hahn series supported on the nonpositive cone of a partially +ordered additive commutative group. On this subring, evaluation at exponent zero is a ring +homomorphism. Pulling a coefficient subring back along that homomorphism gives an intrinsic model +of a truncation integer part. + +For a linearly ordered exponent group and a coefficient field, the construction is the ring used +in LM24, Section 2.1, especially Remark 2.1.2. Mathlib's `IsPWO` support condition then agrees with +the paper's well-ordered-support convention, so `K((G^{≤ 0}))` is represented without reversing +the order on `G`. The declarations below generalize the coefficient field to a ring and the linear +order to a partial order because the constructions and proofs require only those assumptions. +-/ + +universe u v + +public noncomputable section + +namespace HahnSeries + +variable (Γ : Type u) (R : Type v) +variable [AddCommGroup Γ] [PartialOrder Γ] [IsOrderedAddMonoid Γ] [Ring R] + +/-- The subring of Hahn series whose support consists of nonpositive exponents. -/ +@[expose] def nonpositiveSubring : Subring R⟦Γ⟧ where + carrier := {x | x.support ⊆ Set.Iic 0} + zero_mem' := by simp + one_mem' := by + intro g hg + have hg0 : g = 0 := support_single_subset hg + simp [hg0] + add_mem' := fun {x y} hx hy => by + intro g hg + rcases support_add_subset x y hg with hg | hg + · exact hx hg + · exact hy hg + neg_mem' := fun {x} hx => (support_neg_subset x).trans hx + mul_mem' := fun {x y} hx hy => by + intro g hg + obtain ⟨i, hi, j, hj, rfl⟩ := support_mul_subset hg + exact add_nonpos (hx hi) (hy hj) + +/-- Membership in `nonpositiveSubring` means that every support exponent is at most zero. -/ +@[simp] +theorem mem_nonpositiveSubring {x : R⟦Γ⟧} : + x ∈ nonpositiveSubring Γ R ↔ x.support ⊆ Set.Iic 0 := + (Iff.rfl) + +/-- The type of Hahn series supported in the nonpositive exponents. -/ +abbrev Nonpositive := ↥(nonpositiveSubring Γ R) + +namespace Nonpositive + +variable {Γ R} + +/-- The support of a nonpositive Hahn series is contained in `Set.Iic 0`. -/ +theorem support_subset (x : Nonpositive Γ R) : + (x : R⟦Γ⟧).support ⊆ Set.Iic 0 := + x.2 + +/-- A constant Hahn series, regarded as a nonpositive Hahn series. -/ +def C : R →+* Nonpositive Γ R := + (HahnSeries.C : R →+* R⟦Γ⟧).codRestrict (nonpositiveSubring Γ R) fun r g hg => by + have hg0 : g = 0 := support_single_subset hg + simp [hg0] + +@[simp] +theorem coe_C (r : R) : ((C : R →+* Nonpositive Γ R) r : R⟦Γ⟧) = HahnSeries.C r := + (rfl) + +/-- A single monomial with nonpositive exponent, regarded as a nonpositive Hahn series. -/ +def single (g : Γ) (r : R) (hg : g ≤ 0) : Nonpositive Γ R := + ⟨HahnSeries.single g r, fun i hi => by + rw [eq_of_mem_support_single hi] + exact hg⟩ + +@[simp] +theorem coe_single (g : Γ) (r : R) (hg : g ≤ 0) : + (single g r hg : R⟦Γ⟧) = HahnSeries.single g r := + (rfl) + +private theorem eq_zero_of_mem_addAntidiagonal_zero {x y : Nonpositive Γ R} {ij : Γ × Γ} + (hij : ij ∈ Finset.antidiagonal (x : R⟦Γ⟧).isPWO_support + (y : R⟦Γ⟧).isPWO_support 0) : + ij = (0, 0) := by + rcases Finset.mem_antidiagonal.mp hij with ⟨hi, hj, hij⟩ + have hi_zero := eq_zero_of_add_nonneg_left (support_subset x hi) (support_subset y hj) hij.ge + have hj_zero := eq_zero_of_add_nonneg_right (support_subset x hi) (support_subset y hj) hij.ge + exact Prod.ext hi_zero hj_zero + +/-- The coefficient at exponent zero of a product of nonpositive Hahn series is the product of +their coefficients at exponent zero. -/ +@[simp] +theorem coeff_zero_mul (x y : Nonpositive Γ R) : + ((x : R⟦Γ⟧) * (y : R⟦Γ⟧)).coeff 0 = + (x : R⟦Γ⟧).coeff 0 * (y : R⟦Γ⟧).coeff 0 := by + rw [HahnSeries.coeff_mul] + by_cases hx : (x : R⟦Γ⟧).coeff 0 = 0 + · rw [hx, zero_mul] + apply Finset.sum_eq_zero + intro ij hij + rw [eq_zero_of_mem_addAntidiagonal_zero hij] + simp [hx] + · by_cases hy : (y : R⟦Γ⟧).coeff 0 = 0 + · rw [hy, mul_zero] + apply Finset.sum_eq_zero + intro ij hij + rw [eq_zero_of_mem_addAntidiagonal_zero hij] + simp [hy] + · apply Finset.sum_eq_single (0, 0) + · intro ij hij hne + exact (hne (eq_zero_of_mem_addAntidiagonal_zero hij)).elim + · simp [Finset.mem_antidiagonal, HahnSeries.mem_support, hx, hy] + +/-- Evaluation at exponent zero as a ring homomorphism on nonpositive Hahn series. -/ +def constantCoeff : Nonpositive Γ R →+* R where + toFun x := (x : R⟦Γ⟧).coeff 0 + map_zero' := HahnSeries.coeff_zero + map_one' := by simp + map_add' x y := HahnSeries.coeff_add + map_mul' := coeff_zero_mul + +/-- Evaluating `constantCoeff` returns the coefficient at exponent zero. -/ +@[simp] +theorem constantCoeff_apply (x : Nonpositive Γ R) : + constantCoeff x = (x : R⟦Γ⟧).coeff 0 := + (rfl) + +end Nonpositive + +/-- The subring of nonpositive Hahn series whose coefficient at exponent zero lies in `Z`. -/ +def truncationIntegerPart (Γ : Type u) {R : Type v} [AddCommGroup Γ] [PartialOrder Γ] + [IsOrderedAddMonoid Γ] [Ring R] (Z : Subring R) : Subring (Nonpositive Γ R) := + Z.comap Nonpositive.constantCoeff + +/-- Membership in a truncation integer part is membership of the constant coefficient in `Z`. -/ +@[simp] +theorem mem_truncationIntegerPart {Z : Subring R} {x : Nonpositive Γ R} : + x ∈ truncationIntegerPart Γ Z ↔ (x : R⟦Γ⟧).coeff 0 ∈ Z := + (Iff.rfl) + +end HahnSeries diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/NonpositiveCoefficientMap.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/NonpositiveCoefficientMap.lean new file mode 100644 index 0000000000..e14c2e1fbe --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/NonpositiveCoefficientMap.lean @@ -0,0 +1,105 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Nonpositive +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.SupportSupremum + +/-! +# Coefficient extension of nonpositive Hahn series + +Applying a ring homomorphism to every coefficient of a Hahn series supported on the nonpositive +cone leaves the support inside that cone, so it induces a ring homomorphism between the +corresponding subrings. When the coefficient map is injective, in particular for an extension of +fields, the support is preserved exactly: a coefficient vanishes after the map precisely when it +vanished before. Constants are carried to constants. + +Two support computations used alongside the coefficient extension are recorded here as well. The +support supremum is monotone under inclusion of supports, across two coefficient rings, and +subtracting the constant term deletes exactly the exponent zero from the support. +-/ + +universe v w + +open scoped HahnSeries + +public noncomputable section + +namespace HahnSeries.Nonpositive + +/-- Support inclusion is monotone for the support supremum, across coefficient rings. -/ +theorem supportSup_mono {K₁ : Type v} {K₂ : Type w} [Field K₁] [Field K₂] + {u : HahnSeries.Nonpositive ℝ K₁} {v : HahnSeries.Nonpositive ℝ K₂} + (h : (u : K₁⟦ℝ⟧).support ⊆ (v : K₂⟦ℝ⟧).support) : supportSup u ≤ supportSup v := by + by_cases hu : u = 0 + · simp [hu] + · have hu' : (u : K₁⟦ℝ⟧) ≠ 0 := by simpa using hu + have hune := HahnSeries.support_nonempty_iff.mpr hu' + have hvne : ((v : K₂⟦ℝ⟧)).support.Nonempty := hune.mono h + have hv : v ≠ 0 := by intro hz; rw [hz] at hvne; simp at hvne + rw [supportSup_of_ne hu, supportSup_of_ne hv, WithBot.coe_le_coe] + exact csSup_le_csSup (bddAbove_support v) hune h + +/-- Removing the constant term deletes exactly the exponent zero from the support. -/ +theorem support_sub_C_constantCoeff {K₁ : Type v} [Field K₁] + (b : HahnSeries.Nonpositive ℝ K₁) : + ((b - HahnSeries.Nonpositive.C (HahnSeries.Nonpositive.constantCoeff b) : + HahnSeries.Nonpositive ℝ K₁) : K₁⟦ℝ⟧).support = (b : K₁⟦ℝ⟧).support \ {0} := by + ext x + simp only [Set.mem_sdiff, Set.mem_singleton_iff, HahnSeries.mem_support] + rcases eq_or_ne x 0 with rfl | hx + · simp [HahnSeries.Nonpositive.coe_C, HahnSeries.C_apply, + HahnSeries.Nonpositive.constantCoeff_apply] + · simp [HahnSeries.Nonpositive.coe_C, HahnSeries.C_apply, + HahnSeries.Nonpositive.constantCoeff_apply, hx] + +variable {K : Type v} {E : Type w} [Field K] [Field E] + +/-- Coefficientwise extension of a nonpositive Hahn series along a ring homomorphism. -/ +def nonpositiveCoefficientMap (f : K →+* E) : + HahnSeries.Nonpositive ℝ K →+* HahnSeries.Nonpositive ℝ E where + toFun u := ⟨(u : K⟦ℝ⟧).map (f : K →+* E), by + refine (HahnSeries.mem_nonpositiveSubring ℝ E).mpr fun x hx ↦ + HahnSeries.Nonpositive.support_subset u ?_ + rw [HahnSeries.mem_support] at hx ⊢ + intro hzero + exact hx (show f ((u : K⟦ℝ⟧).coeff x) = 0 by rw [hzero, map_zero])⟩ + map_one' := Subtype.ext (HahnSeries.map_one (f : K →+* E).toMonoidWithZeroHom) + map_mul' u v := Subtype.ext (HahnSeries.map_mul (f : K →+* E).toNonUnitalRingHom) + map_zero' := Subtype.ext (HahnSeries.map_zero (f : K →+* E).toMonoidWithZeroHom.toZeroHom) + map_add' u v := Subtype.ext (HahnSeries.map_add (f : K →+* E).toAddMonoidHom) + +/-- The coefficient extension acts coefficientwise. -/ +theorem coe_nonpositiveCoefficientMap (f : K →+* E) + (u : HahnSeries.Nonpositive ℝ K) (x : ℝ) : + ((nonpositiveCoefficientMap f u : HahnSeries.Nonpositive ℝ E) : E⟦ℝ⟧).coeff x = + f (((u : K⟦ℝ⟧)).coeff x) := + (rfl) + +/-- Coefficient extension along a field embedding preserves the support. -/ +theorem support_nonpositiveCoefficientMap (f : K →+* E) + (u : HahnSeries.Nonpositive ℝ K) : + ((nonpositiveCoefficientMap f u : HahnSeries.Nonpositive ℝ E) : E⟦ℝ⟧).support = + ((u : K⟦ℝ⟧)).support := by + ext x + simp only [HahnSeries.mem_support, coe_nonpositiveCoefficientMap] + exact ⟨fun h hz ↦ h (by rw [hz, map_zero]), fun h hz ↦ h (f.injective (by simpa using hz))⟩ + +/-- Coefficient extension carries a constant to the constant with extended value. -/ +theorem nonpositiveCoefficientMap_C (f : K →+* E) (k : K) : + nonpositiveCoefficientMap f (HahnSeries.Nonpositive.C k) = + HahnSeries.Nonpositive.C (f k) := by + apply Subtype.ext + ext x + rw [coe_nonpositiveCoefficientMap, HahnSeries.Nonpositive.coe_C, + HahnSeries.Nonpositive.coe_C, HahnSeries.C_apply, HahnSeries.C_apply] + rcases eq_or_ne x 0 with rfl | hx + · simp + · simp [hx] + +end HahnSeries.Nonpositive + +end diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/NonpositiveDomainEquiv.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/NonpositiveDomainEquiv.lean new file mode 100644 index 0000000000..70886845c4 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/NonpositiveDomainEquiv.lean @@ -0,0 +1,96 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.DomainEquiv +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Nonpositive +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrderType + +/-! +# Reindexing nonpositive Hahn series along an exponent equivalence + +An ordered additive equivalence of exponent groups induces a ring equivalence of their +nonpositive Hahn-series rings. Since the exponent types may live in different universes, support +order types are compared after lifting both ordinals to a common universe. + +This is the exponent-domain transport needed when LM24 assumption `(A1)_σ` identifies an +Archimedean stratum with the additive ordered group of real numbers. +-/ + +public noncomputable section + +namespace HahnSeries.Nonpositive + +universe u v w + +variable {G : Type u} {H : Type v} {K : Type w} +variable [LinearOrder G] [AddCommGroup G] [IsOrderedAddMonoid G] +variable [LinearOrder H] [AddCommGroup H] [IsOrderedAddMonoid H] +variable [CommRing K] + +/-- Reindex nonpositive Hahn series along an ordered additive equivalence of exponent groups. -/ +def embDomainRingEquiv (e : G ≃+o H) : Nonpositive G K ≃+* Nonpositive H K where + toFun x := ⟨HahnSeries.embDomainRingEquiv e x, by + rw [HahnSeries.mem_nonpositiveSubring] + intro h hh + rw [HahnSeries.support_embDomainRingEquiv] at hh + obtain ⟨g, hg, rfl⟩ := hh + change e g ≤ 0 + simpa only [map_zero] using e.strictMono.monotone (support_subset x hg)⟩ + invFun x := ⟨HahnSeries.embDomainRingEquiv e.symm x, by + rw [HahnSeries.mem_nonpositiveSubring] + intro g hg + rw [HahnSeries.support_embDomainRingEquiv] at hg + obtain ⟨h, hh, rfl⟩ := hg + change e.symm h ≤ 0 + simpa only [map_zero] using e.symm.strictMono.monotone (support_subset x hh)⟩ + left_inv x := by + apply Subtype.ext + ext g + have h := HahnSeries.embDomainRingEquiv_coeff e.symm + (HahnSeries.embDomainRingEquiv e (x : K⟦G⟧)) (e g) + rw [e.symm_apply_apply, HahnSeries.embDomainRingEquiv_coeff] at h + exact h + right_inv x := by + apply Subtype.ext + ext h + have hh := HahnSeries.embDomainRingEquiv_coeff e + (HahnSeries.embDomainRingEquiv e.symm (x : K⟦H⟧)) (e.symm h) + rw [e.apply_symm_apply, HahnSeries.embDomainRingEquiv_coeff] at hh + exact hh + map_mul' x y := by + apply Subtype.ext + exact map_mul (HahnSeries.embDomainRingEquiv e) (x : K⟦G⟧) y + map_add' x y := by + apply Subtype.ext + exact map_add (HahnSeries.embDomainRingEquiv e) (x : K⟦G⟧) y + +/-- The underlying Hahn series is the unrestricted exponent-domain equivalence. -/ +@[simp] +theorem coe_embDomainRingEquiv (e : G ≃+o H) (x : Nonpositive G K) : + (embDomainRingEquiv e x : K⟦H⟧) = HahnSeries.embDomainRingEquiv e x := + (rfl) + +/-- Reindexing identifies supports as ordered sets, so their order types agree after lifting. -/ +theorem lift_supportOrderType_embDomainRingEquiv (e : G ≃+o H) + (x : Nonpositive G K) : + Ordinal.lift.{u, v} + (HahnSeries.supportOrderType (embDomainRingEquiv e x : K⟦H⟧)) = + Ordinal.lift.{v, u} (HahnSeries.supportOrderType (x : K⟦G⟧)) := by + let : WellFoundedLT (x : K⟦G⟧).support := (x : K⟦G⟧).isWF_support + let : WellFoundedLT (embDomainRingEquiv e x : K⟦H⟧).support := + (embDomainRingEquiv e x : K⟦H⟧).isWF_support + let supportEquiv : (embDomainRingEquiv e x : K⟦H⟧).support ≃o + (x : K⟦G⟧).support := + (Set.orderIsoOfEq _ (e '' (x : K⟦G⟧).support) (by + rw [coe_embDomainRingEquiv, HahnSeries.support_embDomainRingEquiv])).trans + (StrictMonoOn.orderIso e (x : K⟦G⟧).support + (e.strictMono.strictMonoOn (x : K⟦G⟧).support)).symm + rw [HahnSeries.supportOrderType_eq_typeLT (OrderIso.refl _), + HahnSeries.supportOrderType_eq_typeLT (OrderIso.refl _)] + exact supportEquiv.toRelIsoLT.ordinal_lift_type_eq + +end HahnSeries.Nonpositive diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/NormalForm.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/NormalForm.lean new file mode 100644 index 0000000000..ab294a5e74 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/NormalForm.lean @@ -0,0 +1,501 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.SupportSupremum +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.WeakNormalForm + +/-! +# Principal series and normal forms of real Hahn series + +This module formalizes the principal-series clause of LM24, Definition 3.3.1, and the normal forms +of Definition 3.3.6 and Proposition 3.3.7. A principal series is a weakly principal series in the +nonpositive real Hahn ring whose support supremum is zero. + +A normal-form term stores a principal coefficient `b` and a real exponent `x`; its represented +series is the exponent translate `b t^x`. A normal form has nondecreasing exponents, nonincreasing +coefficient support order types, and strictly separated translated supports. The definition +stores pairwise support separation and proves its equivalence to the adjacent chain printed in +LM24. The zero series has the empty normal form. + +Repeated exponents are deliberately allowed. In particular, the uniqueness proof never infers a +strict inequality from the exponent ordering. It recovers a term's exponent as the real supremum +of the represented support and then recovers its coefficient by inverse translation. This is +compatible with LM24, Remark 3.3.10 and does not infer strict increase from a nondecreasing +sequence of exponents. + +The existence theorem starts with the already-proved weak normal form. Each weak block is still +supported in the nonpositive cone, so translating it by the negative of its support supremum gives +a principal coefficient. The proof is generalized from field coefficients to ring coefficients; +no multiplicative property of the coefficients is used. + +The construction reuses `List.pmap`, `List.Pairwise.pmap`, and the weak-normal-form API rather than +introducing a second decomposition algorithm. +-/ + +universe v + +public noncomputable section + +namespace HahnSeries + +variable {R : Type v} [Ring R] + +namespace Nonpositive + +/-- An LM24 principal series is weakly principal and has support supremum zero. -/ +def IsPrincipal (x : Nonpositive ℝ R) : Prop := + IsWeaklyPrincipal (x : R⟦ℝ⟧) ∧ supportSup x = 0 + +/-- Characterization of an LM24 principal series. -/ +theorem isPrincipal_iff {x : Nonpositive ℝ R} : + IsPrincipal x ↔ IsWeaklyPrincipal (x : R⟦ℝ⟧) ∧ supportSup x = 0 := + Iff.rfl + +theorem IsPrincipal.isWeaklyPrincipal {x : Nonpositive ℝ R} (hx : IsPrincipal x) : + IsWeaklyPrincipal (x : R⟦ℝ⟧) := + (isPrincipal_iff.mp hx).1 + +theorem IsPrincipal.supportSup_eq_zero {x : Nonpositive ℝ R} (hx : IsPrincipal x) : + supportSup x = 0 := + (isPrincipal_iff.mp hx).2 + +/-- A principal series is nonzero. -/ +theorem IsPrincipal.ne_zero {x : Nonpositive ℝ R} (hx : IsPrincipal x) : x ≠ 0 := by + have hx' := hx.isWeaklyPrincipal.ne_zero + simpa using hx' + +/-- Normalizing a weakly principal nonpositive series gives a principal series. -/ +theorem isPrincipal_normalize {x : Nonpositive ℝ R} + (hx : IsWeaklyPrincipal (x : R⟦ℝ⟧)) : IsPrincipal (normalize x) := by + rw [isPrincipal_iff] + constructor + · rw [isWeaklyPrincipal_iff, supportOrderType_normalize] + exact isWeaklyPrincipal_iff.mp hx + · apply supportSup_normalize + simpa using hx.ne_zero + +/-- A nonzero constant Hahn series is principal. -/ +theorem isPrincipal_C {r : R} (hr : r ≠ 0) : + IsPrincipal ((C : R →+* Nonpositive ℝ R) r) := by + have hsupport : + (((C : R →+* Nonpositive ℝ R) r : Nonpositive ℝ R) : + R⟦ℝ⟧).support = {0} := by + rw [coe_C, HahnSeries.C_apply, HahnSeries.support_single_of_ne hr] + have hne : (C : R →+* Nonpositive ℝ R) r ≠ 0 := by + intro hzero + have hcoeff := congrArg + (fun x : Nonpositive ℝ R ↦ (x : R⟦ℝ⟧).coeff 0) hzero + apply hr + simpa [coe_C] using hcoeff + rw [isPrincipal_iff] + constructor + · rw [HahnSeries.isWeaklyPrincipal_iff] + rw [coe_C, HahnSeries.C_apply, HahnSeries.supportOrderType_single hr] + simpa using Ordinal.isAdditivelyPrincipal_omega0_opow 0 + · apply supportSup_eq_coe_iff.mpr + refine ⟨hne, ?_⟩ + rw [hsupport] + exact isLUB_singleton + +/-- The multiplicative identity of a nontrivial nonpositive real Hahn-series ring is principal. -/ +theorem isPrincipal_one [Nontrivial R] : + IsPrincipal (1 : Nonpositive ℝ R) := by + rw [← map_one (C : R →+* Nonpositive ℝ R)] + exact isPrincipal_C one_ne_zero + +end Nonpositive + +namespace NormalForm + +/-- A coefficient-exponent pair occurring in a real Hahn-series normal form. Principality of the +coefficient is a clause of `HahnSeries.IsNormalForm`, not data stored in this structure. -/ +@[ext] +structure Term (R : Type v) [Ring R] where + /-- The nonpositive Hahn-series coefficient of the normal-form term. -/ + coefficient : Nonpositive ℝ R + /-- The real exponent translating the coefficient to form this term. -/ + exponent : ℝ + +namespace Term + +/-- The Hahn series represented by a normal-form term. -/ +def series (t : Term R) : R⟦ℝ⟧ := + translate t.exponent t.coefficient + +/-- A normal-form term represents the translate of its coefficient by its exponent. -/ +theorem series_eq_translate (t : Term R) : + t.series = translate t.exponent t.coefficient := + (rfl) + +@[simp] +theorem coeff_series (t : Term R) (g : ℝ) : + t.series.coeff g = (t.coefficient : R⟦ℝ⟧).coeff (g - t.exponent) := by + rw [series_eq_translate, coeff_translate] + +/-- Normalize a nonpositive Hahn series and record its original real support supremum. -/ +def ofNonpositive (x : Nonpositive ℝ R) : Term R where + coefficient := x.normalize + exponent := sSup (x : R⟦ℝ⟧).support + +@[simp] +theorem coefficient_ofNonpositive (x : Nonpositive ℝ R) : + (ofNonpositive x).coefficient = x.normalize := + (rfl) + +@[simp] +theorem exponent_ofNonpositive (x : Nonpositive ℝ R) : + (ofNonpositive x).exponent = sSup (x : R⟦ℝ⟧).support := + (rfl) + +/-- Normalizing a nonpositive series and translating it back recovers the original series. -/ +@[simp] +theorem series_ofNonpositive (x : Nonpositive ℝ R) : + (ofNonpositive x).series = x := + Nonpositive.translate_csSup_normalize x + +theorem coefficient_ofNonpositive_isPrincipal {x : Nonpositive ℝ R} + (hx : IsWeaklyPrincipal (x : R⟦ℝ⟧)) : + Nonpositive.IsPrincipal (ofNonpositive x).coefficient := + Nonpositive.isPrincipal_normalize hx + +/-- A term with principal coefficient represents a nonzero series. -/ +theorem series_ne_zero {t : Term R} (ht : Nonpositive.IsPrincipal t.coefficient) : + t.series ≠ 0 := by + intro hzero + apply ht.ne_zero + apply Subtype.ext + exact (translate t.exponent).injective (hzero.trans (map_zero _).symm) + +/-- The support of a normal-form term is bounded above by its exponent. -/ +theorem bddAbove_support (t : Term R) : BddAbove t.series.support := by + refine ⟨t.exponent, ?_⟩ + rw [series, support_translate] + rintro _ ⟨g, hg, rfl⟩ + simpa using add_le_add_left (Nonpositive.support_subset t.coefficient hg) t.exponent + +/-- For a principal coefficient, the exponent is the supremum of the represented support. -/ +theorem csSup_support_series (t : Term R) (ht : Nonpositive.IsPrincipal t.coefficient) : + sSup t.series.support = t.exponent := by + rw [series, csSup_support_translate] + · have hsup := ht.supportSup_eq_zero + rw [Nonpositive.supportSup_of_ne ht.ne_zero] at hsup + norm_cast at hsup + simp [hsup] + · simpa using ht.ne_zero + · exact Nonpositive.bddAbove_support t.coefficient + +/-- Principal normal-form terms representing the same Hahn series are equal. -/ +theorem eq_of_series_eq {s t : Term R} + (hs : Nonpositive.IsPrincipal s.coefficient) + (ht : Nonpositive.IsPrincipal t.coefficient) (hseries : s.series = t.series) : + s = t := by + have hexponent : s.exponent = t.exponent := by + calc + s.exponent = sSup s.series.support := (csSup_support_series s hs).symm + _ = sSup t.series.support := congrArg (fun x : R⟦ℝ⟧ ↦ sSup x.support) hseries + _ = t.exponent := csSup_support_series t ht + have hcoefficient : (s.coefficient : R⟦ℝ⟧) = t.coefficient := by + apply (translate s.exponent).injective + simpa only [series, hexponent] using hseries + apply Term.ext + · exact Subtype.ext hcoefficient + · exact hexponent + +end Term + +end NormalForm + +/-- Supremum is monotone across two nonzero, strictly separated real supports when the upper +support is bounded above. -/ +theorem csSup_support_le_of_supportBelow {x y : R⟦ℝ⟧} + (hx : x ≠ 0) (hy : y ≠ 0) (hybdd : BddAbove y.support) + (hxy : SupportBelow x y) : + sSup x.support ≤ sSup y.support := by + obtain ⟨j, hj⟩ := support_nonempty_iff.mpr hy + apply (csSup_le (support_nonempty_iff.mpr hx) fun i hi ↦ (hxy.lt hi hj).le).trans + exact le_csSup hybdd hj + +/-- The five clauses defining an LM24 real Hahn-series normal form. -/ +def IsNormalForm (x : R⟦ℝ⟧) (terms : List (NormalForm.Term R)) : Prop := + (terms.map NormalForm.Term.series).sum = x ∧ + (terms.map NormalForm.Term.exponent).SortedLE ∧ + (∀ t ∈ terms, Nonpositive.IsPrincipal t.coefficient) ∧ + (terms.map (fun t ↦ (t.coefficient : R⟦ℝ⟧).supportOrderType)).SortedGE ∧ + (terms.map NormalForm.Term.series).Pairwise SupportBelow + +/-- Characterization by represented sum, exponents, principal coefficients, order types, and +translated supports. -/ +theorem isNormalForm_iff {x : R⟦ℝ⟧} {terms : List (NormalForm.Term R)} : + IsNormalForm x terms ↔ + (terms.map NormalForm.Term.series).sum = x ∧ + (terms.map NormalForm.Term.exponent).SortedLE ∧ + (∀ t ∈ terms, Nonpositive.IsPrincipal t.coefficient) ∧ + (terms.map (fun t ↦ (t.coefficient : R⟦ℝ⟧).supportOrderType)).SortedGE ∧ + (terms.map NormalForm.Term.series).Pairwise SupportBelow := + Iff.rfl + +/-- Source-form characterization using the adjacent support chain printed in LM24, Definition +3.3.6. Principality makes every represented term nonzero, so the chain is pairwise separated. -/ +theorem isNormalForm_iff_isChain {x : R⟦ℝ⟧} {terms : List (NormalForm.Term R)} : + IsNormalForm x terms ↔ + (terms.map NormalForm.Term.series).sum = x ∧ + (terms.map NormalForm.Term.exponent).SortedLE ∧ + (∀ t ∈ terms, Nonpositive.IsPrincipal t.coefficient) ∧ + (terms.map (fun t ↦ (t.coefficient : R⟦ℝ⟧).supportOrderType)).SortedGE ∧ + (terms.map NormalForm.Term.series).IsChain SupportBelow := by + rw [isNormalForm_iff] + constructor + · rintro ⟨hsum, hexponents, hprincipal, htypes, hpair⟩ + exact ⟨hsum, hexponents, hprincipal, htypes, hpair.isChain⟩ + · rintro ⟨hsum, hexponents, hprincipal, htypes, hchain⟩ + refine ⟨hsum, hexponents, hprincipal, htypes, ?_⟩ + apply pairwise_supportBelow_of_isChain + · intro b hb + obtain ⟨t, ht, rfl⟩ := List.mem_map.mp hb + exact NormalForm.Term.series_ne_zero (hprincipal t ht) + · exact hchain + +/-- Forgetting coefficient normalization turns an LM24 normal form into its weak normal form. -/ +theorem IsNormalForm.isWeakNormalForm {x : R⟦ℝ⟧} {terms : List (NormalForm.Term R)} + (h : IsNormalForm x terms) : + IsWeakNormalForm x (terms.map NormalForm.Term.series) := by + obtain ⟨hsum, _, hprincipal, htypes, hpair⟩ := isNormalForm_iff.mp h + rw [isWeakNormalForm_iff] + refine ⟨hsum, ?_, ?_, hpair⟩ + · intro b hb + obtain ⟨t, ht, rfl⟩ := List.mem_map.mp hb + rw [isWeaklyPrincipal_iff, NormalForm.Term.series, supportOrderType_translate] + exact isWeaklyPrincipal_iff.mp (hprincipal t ht).isWeaklyPrincipal + · convert htypes using 1 + rw [List.map_map] + apply List.map_congr_left + intro t ht + simp [NormalForm.Term.series] + +private theorem bddAbove_support_normalTerm_sum (terms : List (NormalForm.Term R)) : + BddAbove (terms.map NormalForm.Term.series).sum.support := by + induction terms with + | nil => simp + | cons t terms ih => + simp only [List.map_cons, List.sum_cons] + obtain ⟨a, ha⟩ := NormalForm.Term.bddAbove_support t + obtain ⟨b, hb⟩ := ih + refine ⟨max a b, ?_⟩ + intro g hg + rcases support_add_subset t.series (terms.map NormalForm.Term.series).sum hg with hg | hg + · exact (ha hg).trans (le_max_left _ _) + · exact (hb hg).trans (le_max_right _ _) + +/-- Every series admitting a finite LM24 normal form has support bounded above. -/ +theorem IsNormalForm.bddAbove_support {x : R⟦ℝ⟧} {terms : List (NormalForm.Term R)} + (h : IsNormalForm x terms) : BddAbove x.support := by + have hbdd := bddAbove_support_normalTerm_sum terms + rw [(isNormalForm_iff.mp h).1] at hbdd + exact hbdd + +private theorem normalTerms_eq_of_series_eq {terms other : List (NormalForm.Term R)} + (hterms : ∀ t ∈ terms, Nonpositive.IsPrincipal t.coefficient) + (hother : ∀ t ∈ other, Nonpositive.IsPrincipal t.coefficient) + (hseries : terms.map NormalForm.Term.series = other.map NormalForm.Term.series) : + terms = other := by + induction terms generalizing other with + | nil => simpa using hseries + | cons t terms ih => + cases other with + | nil => simp at hseries + | cons s other => + simp only [List.map_cons, List.cons.injEq] at hseries + have hts : t = s := NormalForm.Term.eq_of_series_eq + (hterms t (by simp)) (hother s (by simp)) hseries.1 + subst s + rw [List.cons.injEq] + exact ⟨rfl, ih (fun t ht ↦ hterms t (by simp [ht])) + (fun s hs ↦ hother s (by simp [hs])) hseries.2⟩ + +/-- Two LM24 normal forms of the same real Hahn series are equal. -/ +theorem IsNormalForm.unique {x : R⟦ℝ⟧} {terms other : List (NormalForm.Term R)} + (hterms : IsNormalForm x terms) (hother : IsNormalForm x other) : + terms = other := by + obtain ⟨_, _, htermsPrincipal, _, _⟩ := isNormalForm_iff.mp hterms + obtain ⟨_, _, hotherPrincipal, _, _⟩ := isNormalForm_iff.mp hother + apply normalTerms_eq_of_series_eq htermsPrincipal hotherPrincipal + exact hterms.isWeakNormalForm.unique hother.isWeakNormalForm + +/-- Every nonpositive real Hahn series has an LM24 normal form. This is the existence part of +LM24, Proposition 3.3.7. -/ +theorem exists_isNormalForm (x : Nonpositive ℝ R) : + ∃ terms : List (NormalForm.Term R), IsNormalForm x terms := by + obtain ⟨blocks, hblocks⟩ := exists_isWeakNormalForm (x : R⟦ℝ⟧) + obtain ⟨hsum, hprincipal, htypes, hpair⟩ := isWeakNormalForm_iff.mp hblocks + have hnonpositive : ∀ b ∈ blocks, b.support ⊆ Set.Iic (0 : ℝ) := by + intro b hb + have hbsub := support_subset_list_sum_of_mem hpair hb + rw [hsum] at hbsub + exact hbsub.trans (Nonpositive.support_subset x) + have hblockData : ∀ b ∈ blocks, b ∈ blocks ∧ b.support ⊆ Set.Iic (0 : ℝ) := + fun b hb ↦ ⟨hb, hnonpositive b hb⟩ + let terms : List (NormalForm.Term R) := blocks.pmap + (fun b hb ↦ NormalForm.Term.ofNonpositive + ⟨b, (mem_nonpositiveSubring (x := b)).mpr hb.2⟩) hblockData + have hseries : terms.map NormalForm.Term.series = blocks := by + simp [terms, List.map_pmap] + refine ⟨terms, isNormalForm_iff.mpr ⟨?_, ?_, ?_, ?_, ?_⟩⟩ + · rw [hseries] + exact hsum + · rw [List.sortedLE_iff_pairwise] + simp only [terms, List.map_pmap] + apply hpair.pmap hblockData + intro b hb c hc hbc + apply csSup_support_le_of_supportBelow + · exact (hprincipal b hb.1).ne_zero + · exact (hprincipal c hc.1).ne_zero + · exact ⟨0, hc.2⟩ + · exact hbc + · intro t ht + simp only [terms, List.mem_pmap] at ht + obtain ⟨b, hb, rfl⟩ := ht + exact NormalForm.Term.coefficient_ofNonpositive_isPrincipal (hprincipal b hb) + · convert htypes using 1 + simp only [terms, List.map_pmap, NormalForm.Term.coefficient_ofNonpositive, + Nonpositive.supportOrderType_normalize] + apply List.pmap_eq_map + · rwa [hseries] + +/-- Every nonpositive real Hahn series has exactly one LM24 normal form. This is LM24, +Proposition 3.3.7. -/ +theorem existsUnique_isNormalForm (x : Nonpositive ℝ R) : + ∃! terms : List (NormalForm.Term R), IsNormalForm x terms := by + obtain ⟨terms, hterms⟩ := exists_isNormalForm x + exact ⟨terms, hterms, fun other hother ↦ (hterms.unique hother).symm⟩ + +private theorem degree_list_sum_le {l : List R⟦ℝ⟧} {d : WithBot NatOrdinal} + (h : ∀ x ∈ l, x.degree ≤ d) : l.sum.degree ≤ d := by + induction l with + | nil => simp + | cons x xs ih => + rw [List.sum_cons] + exact (degree_add_le x xs.sum).trans + (max_le (h x (by simp)) (ih fun y hy ↦ h y (by simp [hy]))) + +/-- A nonzero nonpositive real Hahn series has a principal leading term and a remainder supported +weakly above its exponent. The leading coefficient has the degree of the original series, and the +remainder has no larger degree. When that degree is zero, the remainder support is strictly above +the leading exponent. + +This is the head decomposition extracted from the normal form in LM24, Proposition 3.3.7. The +last clause uses only the source-valid strictness at degree zero and does not assume that all +normal-form exponents are distinct. -/ +theorem exists_principal_head_decomposition + {b : Nonpositive ℝ R} (hbne : b ≠ 0) : + ∃ b₁ : Nonpositive ℝ R, ∃ x : ℝ, ∃ b' : Nonpositive ℝ R, + Nonpositive.IsPrincipal b₁ ∧ + (b : R⟦ℝ⟧) = translate x (b₁ : R⟦ℝ⟧) + (b' : R⟦ℝ⟧) ∧ + (b' : R⟦ℝ⟧).support ⊆ Set.Ici x ∧ + (b₁ : R⟦ℝ⟧).degree = (b : R⟦ℝ⟧).degree ∧ + (b' : R⟦ℝ⟧).degree ≤ (b : R⟦ℝ⟧).degree ∧ + ((b : R⟦ℝ⟧).degree = 0 → + (b' : R⟦ℝ⟧).support ⊆ Set.Ioi x) := by + obtain ⟨terms, hterms⟩ := exists_isNormalForm b + obtain ⟨hsum, _, hprincipal, htypes, hpair⟩ := isNormalForm_iff.mp hterms + cases terms with + | nil => + simp only [List.map_nil, List.sum_nil] at hsum + exact (hbne (Subtype.ext hsum.symm)).elim + | cons t terms => + simp only [List.map_cons, List.sum_cons] at hsum + simp only [List.map_cons] at hpair htypes + rw [List.pairwise_cons] at hpair + have htPrincipal : Nonpositive.IsPrincipal t.coefficient := + hprincipal t (by simp) + have htBelow : + SupportBelow t.series (terms.map NormalForm.Term.series).sum := + supportBelow_list_sum hpair.1 + have hsupportSum : + (t.series + (terms.map NormalForm.Term.series).sum).support = + t.series.support ∪ (terms.map NormalForm.Term.series).sum.support := + support_add_eq_union_of_supportBelow _ _ htBelow + have htailSubset : + (terms.map NormalForm.Term.series).sum.support ⊆ + (b : R⟦ℝ⟧).support := by + rw [← hsum, hsupportSum] + exact Set.subset_union_right + let b' : Nonpositive ℝ R := + ⟨(terms.map NormalForm.Term.series).sum, + (mem_nonpositiveSubring + (x := (terms.map NormalForm.Term.series).sum)).mpr + (htailSubset.trans (Nonpositive.support_subset b))⟩ + have hb'Support : (b' : R⟦ℝ⟧).support ⊆ Set.Ici t.exponent := by + intro j hj + rw [← NormalForm.Term.csSup_support_series t htPrincipal] + apply csSup_le + (support_nonempty_iff.mpr (NormalForm.Term.series_ne_zero htPrincipal)) + intro i hi + exact (htBelow.lt hi hj).le + have htypesPair := List.sortedGE_iff_pairwise.mp htypes + rw [List.pairwise_cons] at htypesPair + have htailTermDegree : + ∀ s ∈ terms, + s.series.degree ≤ (t.coefficient : R⟦ℝ⟧).degree := by + intro s hs + rw [NormalForm.Term.series, degree_translate] + rw [degree_eq_cantorDegree, degree_eq_cantorDegree] + exact Ordinal.cantorDegree_mono (htypesPair.1 + (s.coefficient : R⟦ℝ⟧).supportOrderType + (List.mem_map.mpr ⟨s, hs, rfl⟩)) + have htailDegree : + (b' : R⟦ℝ⟧).degree ≤ (t.coefficient : R⟦ℝ⟧).degree := by + exact degree_list_sum_le (by + intro y hy + obtain ⟨s, hs, rfl⟩ := List.mem_map.mp hy + exact htailTermDegree s hs) + have hheadSupportSubset : + t.series.support ⊆ (b : R⟦ℝ⟧).support := by + rw [← hsum, hsupportSum] + exact Set.subset_union_left + have hheadDegree : + (t.coefficient : R⟦ℝ⟧).degree = (b : R⟦ℝ⟧).degree := by + apply le_antisymm + · calc + (t.coefficient : R⟦ℝ⟧).degree = t.series.degree := by + rw [NormalForm.Term.series, degree_translate] + _ ≤ (b : R⟦ℝ⟧).degree := degree_mono_support hheadSupportSubset + · calc + (b : R⟦ℝ⟧).degree = + (t.series + (b' : R⟦ℝ⟧)).degree := + congrArg degree hsum.symm + _ ≤ max t.series.degree (b' : R⟦ℝ⟧).degree := + degree_add_le _ _ + _ ≤ (t.coefficient : R⟦ℝ⟧).degree := max_le + (by rw [NormalForm.Term.series, degree_translate]) + htailDegree + have hb'Degree : + (b' : R⟦ℝ⟧).degree ≤ (b : R⟦ℝ⟧).degree := + htailDegree.trans hheadDegree.le + have hb'Strict : + (b : R⟦ℝ⟧).degree = 0 → + (b' : R⟦ℝ⟧).support ⊆ Set.Ioi t.exponent := by + intro hbDegree j hj + have htDegree : (t.coefficient : R⟦ℝ⟧).degree = 0 := + hheadDegree.trans hbDegree + have htFinite := (degree_eq_zero.mp htDegree).2 + have htNonempty : (t.coefficient : R⟦ℝ⟧).support.Nonempty := + support_nonempty_iff.mpr (by simpa using htPrincipal.ne_zero) + have htSup : sSup (t.coefficient : R⟦ℝ⟧).support = 0 := by + have hsup := htPrincipal.supportSup_eq_zero + rw [Nonpositive.supportSup_of_ne htPrincipal.ne_zero] at hsup + exact WithBot.coe_eq_coe.mp hsup + have hzero : 0 ∈ (t.coefficient : R⟦ℝ⟧).support := by + rw [← htSup] + exact htNonempty.csSup_mem htFinite + have hexponent : t.exponent ∈ t.series.support := by + rw [NormalForm.Term.series, support_translate] + exact ⟨0, hzero, by simp⟩ + exact htBelow.lt hexponent hj + exact ⟨t.coefficient, t.exponent, b', htPrincipal, + hsum.symm, hb'Support, hheadDegree, hb'Degree, hb'Strict⟩ + +end HahnSeries diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrderType.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrderType.lean new file mode 100644 index 0000000000..86bf39ec53 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrderType.lean @@ -0,0 +1,552 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.SeparatedSupport +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Truncation +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.Degree +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.SetOrderType +public import LeanPool.ConwayRefinement.ConwayRefinement.Order.Archimedean +public import Mathlib.RingTheory.HahnSeries.Multiplication + +import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.Sumset + +/-! +# Support order type and degree of a Hahn series + +LM24 orders the support of a generalized power series by increasing exponent. Accordingly, +`HahnSeries.supportOrderType` is the ordinal type of the strict order `<` on the support; no order +reversal occurs in this module. For a linearly ordered exponent type, Mathlib's `IsPWO` support +condition is equivalent to the well-foundedness needed for this ordinal type. + +If the exponent type belongs to `Type u`, the order type and degree belong to `Ordinal.{u}` and +`WithBot NatOrdinal.{u}`, independently of the universe of the coefficients. The degree uses +LM24's convention: a nonzero series has the leading Cantor exponent of its support order type, +whereas the zero series has degree `⊥`. + +These definitions formalize LM24, Sections 1.2, 1.5, 2.2, and 3.1. Multiplicativity is a later +theorem and is not built into the definitions. + +The support-decomposition theorems use the strict lower-to-upper relation +`HahnSeries.SupportBelow` and the generic support lemmas in +`ConwayRefinement.HahnSeries.SeparatedSupport`. +-/ + +universe u v + +public noncomputable section + +namespace HahnSeries + +open Ordinal + +variable {R : Type v} {G : Type u} [LinearOrder G] + +section ZeroCoefficients + +variable [Zero R] + +/-- The ordinary ordinal order type of a Hahn series support, ordered by increasing exponent. -/ +def supportOrderType (x : R⟦G⟧) : Ordinal.{u} := + x.isPWO_support.orderType + +/-- Support order type is the generic order type of the partially well-ordered support. -/ +theorem supportOrderType_eq_setOrderType (x : R⟦G⟧) : + supportOrderType x = x.isPWO_support.orderType := + (rfl) + +/-- Compute `supportOrderType` from an order isomorphism out of the support. -/ +theorem supportOrderType_eq_typeLT {x : R⟦G⟧} {A : Type u} [LinearOrder A] + [WellFoundedLT A] (e : x.support ≃o A) : + supportOrderType x = typeLT A := + x.isPWO_support.orderType_eq_typeLT_of_orderIso e + +/-- Compute `supportOrderType` from a relation isomorphism to an arbitrary well-order. -/ +theorem supportOrderType_eq_type_of_relIso {x : R⟦G⟧} {A : Type u} + {r : A → A → Prop} [IsWellOrder A r] + (e : Subrel (· < · : G → G → Prop) (· ∈ x.support) ≃r r) : + supportOrderType x = Ordinal.type r := + x.isPWO_support.orderType_eq_type_of_relIso e + +@[simp] +theorem supportOrderType_eq_zero {x : R⟦G⟧} : supportOrderType x = 0 ↔ x = 0 := by + rw [supportOrderType, Set.IsPWO.orderType_eq_zero] + exact support_eq_empty_iff + +@[simp] +theorem supportOrderType_zero : supportOrderType (0 : R⟦G⟧) = 0 := + supportOrderType_eq_zero.mpr rfl + +/-- A nonzero single-term Hahn series has ordinary support order type one. -/ +theorem supportOrderType_single {a : G} {r : R} (hr : r ≠ 0) : + (HahnSeries.single a r).supportOrderType = 1 := by + have hsupport : (HahnSeries.single a r).support = {a} := + HahnSeries.support_single_of_ne hr + let singletonOrderIso : ({a} : Set G) ≃o PUnit := + { toEquiv := Equiv.Set.singleton a + map_rel_iff' := by simp } + let e : (HahnSeries.single a r).support ≃o PUnit := + (Set.orderIsoOfEq _ {a} hsupport).trans singletonOrderIso + rw [supportOrderType_eq_typeLT e] + exact Ordinal.type_eq_one_of_unique _ + +/-- Inclusion of supports cannot decrease their ordinary ordinal order type. -/ +theorem supportOrderType_mono {x y : R⟦G⟧} (h : x.support ⊆ y.support) : + supportOrderType x ≤ supportOrderType y := + Set.IsPWO.orderType_mono x.isPWO_support y.isPWO_support h + +/-- A Hahn series has finite support exactly when its support order type is below `ω`. -/ +theorem support_finite_iff_supportOrderType_lt_omega {x : R⟦G⟧} : + x.support.Finite ↔ supportOrderType x < Ordinal.omega0 := + x.isPWO_support.finite_iff_orderType_lt_omega + +/-- The leading Cantor exponent of the support order type, with value `⊥` at zero. -/ +def degree (x : R⟦G⟧) : WithBot NatOrdinal.{u} := + Ordinal.cantorDegree x.supportOrderType + +/-- Degree is the leading Cantor exponent of the support order type. -/ +theorem degree_eq_cantorDegree (x : R⟦G⟧) : + degree x = Ordinal.cantorDegree x.supportOrderType := + (rfl) + +@[simp] +theorem degree_eq_bot {x : R⟦G⟧} : degree x = ⊥ ↔ x = 0 := by + rw [degree, Ordinal.cantorDegree_eq_bot, supportOrderType_eq_zero] + +@[simp] +theorem degree_zero : degree (0 : R⟦G⟧) = ⊥ := + degree_eq_bot.mpr rfl + +/-- Degree zero is equivalent to nonzero finite support. -/ +@[simp] +theorem degree_eq_zero {x : R⟦G⟧} : + degree x = (0 : WithBot NatOrdinal) ↔ x ≠ 0 ∧ x.support.Finite := by + rw [degree, Ordinal.cantorDegree_eq_zero] + constructor + · rintro ⟨hot, hlt⟩ + exact ⟨supportOrderType_eq_zero.not.mp hot, + support_finite_iff_supportOrderType_lt_omega.mpr hlt⟩ + · rintro ⟨hx, hfinite⟩ + exact ⟨supportOrderType_eq_zero.not.mpr hx, + support_finite_iff_supportOrderType_lt_omega.mp hfinite⟩ + +/-- The degree of a nonzero Hahn series is nonnegative. -/ +theorem zero_le_degree_of_ne_zero {x : R⟦G⟧} (hx : x ≠ 0) : + 0 ≤ x.degree := by + rw [degree_eq_cantorDegree, + Ordinal.cantorDegree_of_ne_zero (supportOrderType_eq_zero.not.mpr hx)] + exact WithBot.coe_le_coe.mpr bot_le + +/-- Degree is at most zero exactly for finite-support Hahn series, including the zero series. -/ +@[simp] +theorem degree_le_zero_iff {x : R⟦G⟧} : + degree x ≤ 0 ↔ x.support.Finite := by + constructor + · intro hdegree + by_cases hx : x = 0 + · simp [hx] + · have hzero : 0 ≤ degree x := zero_le_degree_of_ne_zero hx + have hxDegree : degree x = 0 := le_antisymm hdegree hzero + exact (degree_eq_zero.mp hxDegree).2 + · intro hfinite + by_cases hx : x = 0 + · simp [hx] + · rw [degree_eq_zero.mpr ⟨hx, hfinite⟩] + +/-- A Hahn series has positive degree exactly when its support is infinite. -/ +theorem degree_pos_iff_support_infinite {x : R⟦G⟧} : + 0 < degree x ↔ x.support.Infinite := by + rw [← not_le, degree_le_zero_iff] + exact Set.not_finite + +/-- Degree is strictly below zero exactly at the zero Hahn series. -/ +@[simp] +theorem degree_lt_zero_iff {x : R⟦G⟧} : + degree x < 0 ↔ x = 0 := by + constructor + · intro hdegree + by_contra hx + exact (not_lt_of_ge (zero_le_degree_of_ne_zero hx)) hdegree + · rintro rfl + simp + +/-- This is LM24's maximum characterization of the degree of a nonzero Hahn series. -/ +theorem coe_le_degree_iff {x : R⟦G⟧} {a : Ordinal.{u}} (hx : x ≠ 0) : + (NatOrdinal.of a : WithBot NatOrdinal) ≤ degree x ↔ + Ordinal.omega0 ^ a ≤ supportOrderType x := by + exact Ordinal.coe_le_cantorDegree_iff (supportOrderType_eq_zero.not.mpr hx) + +/-- A degree lies strictly below `α` exactly when the support order type lies strictly below +`ω^α`. -/ +theorem degree_lt_coe_iff_supportOrderType_lt_wpow (x : R⟦G⟧) + (α : NatOrdinal) : + degree x < (α : WithBot NatOrdinal) ↔ + supportOrderType x < (ω^ α).val := by + by_cases hx : x = 0 + · subst x + rw [degree_zero, supportOrderType_zero] + constructor + · intro _ + exact NatOrdinal.val.strictMono (NatOrdinal.wpow_pos α) + · intro _ + exact WithBot.bot_lt_coe α + · rw [← not_le, ← not_le] + apply not_congr + simpa only [NatOrdinal.of_val, NatOrdinal.val_wpow] using + coe_le_degree_iff (x := x) (a := α.val) hx + +/-- Inclusion of supports cannot decrease degree. -/ +theorem degree_mono_support {x y : R⟦G⟧} (h : x.support ⊆ y.support) : + degree x ≤ degree y := + Ordinal.cantorDegree_mono (supportOrderType_mono h) + +/-- Weak lower truncation cannot increase degree. This strengthens the final consequence following +LM24, Definition 3.2.2 by removing its unnecessary properness hypothesis. -/ +theorem degree_truncLE_le (c : G) (x : R⟦G⟧) : + (truncLE c x).degree ≤ x.degree := + degree_mono_support (support_truncLE_subset c x) + +end ZeroCoefficients + +section Addition + +variable [AddMonoid R] + +/-- A Hahn series has support order type `a + b` exactly when it is a sum whose first support lies +strictly below its second support and whose summands have support order types `a` and `b`. This is +LM24, Proposition 3.2.1, generalized from field coefficients and a fixed cardinal support bound to +additive-monoid coefficients and unrestricted Hahn series. The constructed summands have supports +contained in the original support, so the result restricts to the source's support regime. -/ +theorem supportOrderType_eq_add_iff (x : R⟦G⟧) (a b : Ordinal.{u}) : + x.supportOrderType = a + b ↔ + ∃ y z : R⟦G⟧, + SupportBelow y z ∧ + y.supportOrderType = a ∧ + z.supportOrderType = b ∧ + x = y + z := by + classical + constructor + · intro htype + rw [supportOrderType_eq_setOrderType] at htype + obtain ⟨s, t, hs, ht, hsx, htx, hst, hsa, htb, hunion⟩ := + (x.isPWO_support.orderType_eq_add_iff a b).mp htype + let y : R⟦G⟧ := filter (· ∈ s) x + let z : R⟦G⟧ := filter (· ∈ t) x + have hsy : y.support = s := by + change (filter (· ∈ s) x).support = s + rw [support_filter] + ext i + constructor + · exact fun hi ↦ hi.2 + · exact fun hi ↦ ⟨hsx hi, hi⟩ + have htz : z.support = t := by + change (filter (· ∈ t) x).support = t + rw [support_filter] + ext i + constructor + · exact fun hi ↦ hi.2 + · exact fun hi ↦ ⟨htx hi, hi⟩ + have hsum : x = y + z := by + ext i + by_cases hi : i ∈ x.support + · rw [hunion] at hi + rcases hi with his | hit + · have hit' : i ∉ t := by + intro hit + exact (hst i his i hit).false + change x.coeff i = + (filter (· ∈ s) x).coeff i + (filter (· ∈ t) x).coeff i + simp [his, hit'] + · have his' : i ∉ s := by + intro his + exact (hst i his i hit).false + change x.coeff i = + (filter (· ∈ s) x).coeff i + (filter (· ∈ t) x).coeff i + simp [his', hit] + · have hcoeff : x.coeff i = 0 := not_ne_iff.mp hi + have his : i ∉ s := fun his ↦ hi (hsx his) + have hit : i ∉ t := fun hit ↦ hi (htx hit) + change x.coeff i = + (filter (· ∈ s) x).coeff i + (filter (· ∈ t) x).coeff i + simp [his, hit, hcoeff] + refine ⟨y, z, ?_, ?_, ?_, hsum⟩ + · rw [supportBelow_iff] + simpa only [hsy, htz] using hst + · calc + y.supportOrderType = y.isPWO_support.orderType := + supportOrderType_eq_setOrderType y + _ = hs.orderType := Set.IsPWO.orderType_congr _ _ hsy + _ = a := hsa + · calc + z.supportOrderType = z.isPWO_support.orderType := + supportOrderType_eq_setOrderType z + _ = ht.orderType := Set.IsPWO.orderType_congr _ _ htz + _ = b := htb + · rintro ⟨y, z, hyz, hya, hzb, rfl⟩ + have hsupport : (y + z).support = y.support ∪ z.support := + support_add_eq_union_of_supportBelow y z hyz + rw [supportOrderType_eq_setOrderType] + apply ((y + z).isPWO_support.orderType_eq_add_iff a b).mpr + refine ⟨y.support, z.support, y.isPWO_support, z.isPWO_support, ?_, ?_, ?_, + ?_, ?_, hsupport⟩ + · rw [hsupport] + exact Set.subset_union_left + · rw [hsupport] + exact Set.subset_union_right + · intro i hi j hj + exact hyz.lt hi hj + · exact (supportOrderType_eq_setOrderType y).symm.trans hya + · exact (supportOrderType_eq_setOrderType z).symm.trans hzb + +/-- A decomposition from `supportOrderType_eq_add_iff` is uniquely determined by the order type of +its lower summand. This is the uniqueness used when LM24 iterates Proposition 3.2.1. -/ +theorem add_decomposition_unique {x₀ x₁ y₀ y₁ : R⟦G⟧} + (hx : SupportBelow x₀ x₁) + (hy : SupportBelow y₀ y₁) + (htype : x₀.supportOrderType = y₀.supportOrderType) + (hsum : x₀ + x₁ = y₀ + y₁) : + x₀ = y₀ ∧ x₁ = y₁ := by + have hxSupport : (x₀ + x₁).support = x₀.support ∪ x₁.support := + support_add_eq_union_of_supportBelow x₀ x₁ hx + have hySupport : (x₀ + x₁).support = y₀.support ∪ y₁.support := + (congrArg support hsum).trans (support_add_eq_union_of_supportBelow y₀ y₁ hy) + have htype' : x₀.isPWO_support.orderType = y₀.isPWO_support.orderType := by + rw [← supportOrderType_eq_setOrderType, ← supportOrderType_eq_setOrderType] + exact htype + obtain ⟨hlower, hupper⟩ := + Set.IsPWO.orderType_split_unique x₀.isPWO_support y₀.isPWO_support + (fun _ hi _ hj ↦ hx.lt hi hj) (fun _ hi _ hj ↦ hy.lt hi hj) + hxSupport hySupport htype' + constructor + · ext i + by_cases hi : i ∈ x₀.support + · have hi' : i ∈ y₀.support := hlower ▸ hi + have hx₁ : x₁.coeff i = 0 := by + rw [← not_ne_iff, ← mem_support] + intro hi₁ + exact (hx.lt hi hi₁).false + have hy₁ : y₁.coeff i = 0 := by + rw [← not_ne_iff, ← mem_support] + intro hi₁ + exact (hy.lt hi' hi₁).false + have hcoeff := congrArg (fun z : R⟦G⟧ => z.coeff i) hsum + simpa [hx₁, hy₁] using hcoeff + · have hi' : i ∉ y₀.support := by + rw [← hlower] + exact hi + exact (not_ne_iff.mp hi).trans (not_ne_iff.mp hi').symm + · ext i + by_cases hi : i ∈ x₁.support + · have hi' : i ∈ y₁.support := hupper ▸ hi + have hx₀ : x₀.coeff i = 0 := by + rw [← not_ne_iff, ← mem_support] + intro hi₀ + exact (hx.lt hi₀ hi).false + have hy₀ : y₀.coeff i = 0 := by + rw [← not_ne_iff, ← mem_support] + intro hi₀ + exact (hy.lt hi₀ hi').false + have hcoeff := congrArg (fun z : R⟦G⟧ => z.coeff i) hsum + simpa [hx₀, hy₀] using hcoeff + · have hi' : i ∉ y₁.support := by + rw [← hupper] + exact hi + exact (not_ne_iff.mp hi).trans (not_ne_iff.mp hi').symm + +/-- The support order type of a pairwise support-separated finite sum is the ordinary ordinal sum +of the support order types, in list order. -/ +theorem supportOrderType_list_sum {l : List R⟦G⟧} (hpair : l.Pairwise SupportBelow) : + l.sum.supportOrderType = (l.map supportOrderType).sum := by + induction l with + | nil => simp + | cons x xs ih => + rw [List.pairwise_cons] at hpair + have hbelow : SupportBelow x xs.sum := supportBelow_list_sum hpair.1 + have hadd := (supportOrderType_eq_add_iff (x + xs.sum) + x.supportOrderType xs.sum.supportOrderType).mpr + ⟨x, xs.sum, hbelow, rfl, rfl, rfl⟩ + simp only [List.sum_cons, List.map_cons, hadd, ih hpair.2] + +/-- The support order type splits at a strict lower and weak upper truncation. This is the first +order-type equality following LM24, Definition 3.2.2. -/ +theorem supportOrderType_eq_truncLT_add_truncGE (c : G) (x : R⟦G⟧) : + x.supportOrderType = + (truncLT c x).supportOrderType + (truncGE c x).supportOrderType := by + apply (supportOrderType_eq_add_iff x _ _).mpr + refine ⟨truncLT c x, truncGE c x, ?_, rfl, rfl, ?_⟩ + · rw [supportBelow_iff] + intro i hi j hj + rw [support_truncLT] at hi + rw [support_truncGE] at hj + exact hi.2.trans_le hj.2 + · exact (truncLT_add_truncGE c x).symm + +/-- The support order type splits at a weak lower and strict upper truncation. This is the second +order-type equality following LM24, Definition 3.2.2. -/ +theorem supportOrderType_eq_truncLE_add_truncGT (c : G) (x : R⟦G⟧) : + x.supportOrderType = + (truncLE c x).supportOrderType + (truncGT c x).supportOrderType := by + apply (supportOrderType_eq_add_iff x _ _).mpr + refine ⟨truncLE c x, truncGT c x, ?_, rfl, rfl, ?_⟩ + · rw [supportBelow_iff] + intro i hi j hj + rw [support_truncLE] at hi + rw [support_truncGT] at hj + exact hi.2.trans_lt hj.2 + · exact (truncLE_add_truncGT c x).symm + +/-- A proper weak lower truncation has strictly smaller support order type. This is the strict +inequality following LM24, Definition 3.2.2. -/ +theorem supportOrderType_truncLE_lt (c : G) {x : R⟦G⟧} (h : truncLE c x ≠ x) : + (truncLE c x).supportOrderType < x.supportOrderType := by + have hupper : truncGT c x ≠ 0 := by + intro hzero + apply h + calc + truncLE c x = truncLE c x + truncGT c x := by rw [hzero, add_zero] + _ = x := truncLE_add_truncGT c x + rw [supportOrderType_eq_truncLE_add_truncGT c x] + exact lt_add_of_pos_right _ + (pos_iff_ne_zero.mpr (supportOrderType_eq_zero.not.mpr hupper)) + +/-- The order type of the support of a sum is at most the Hessenberg sum of the two support order +types. This is LM24, Proposition 3.1.1(1), generalized from a field of coefficients. -/ +theorem supportOrderType_add_le_naturalAdd (x y : R⟦G⟧) : + supportOrderType (x + y) ≤ + (NatOrdinal.of x.supportOrderType + NatOrdinal.of y.supportOrderType).val := by + calc + supportOrderType (x + y) = (x + y).isPWO_support.orderType := + supportOrderType_eq_setOrderType (x + y) + _ ≤ (x.isPWO_support.union y.isPWO_support).orderType := + Set.IsPWO.orderType_mono (x + y).isPWO_support + (x.isPWO_support.union y.isPWO_support) (support_add_subset x y) + _ ≤ (NatOrdinal.of x.supportOrderType + + NatOrdinal.of y.supportOrderType).val := by + simpa only [← supportOrderType_eq_setOrderType] using + Set.IsPWO.orderType_union_le_naturalAdd x.isPWO_support y.isPWO_support + +/-- The degree of a sum is at most the maximum of the two degrees. This is LM24, +Corollary 3.1.2(1), generalized from a field of coefficients. -/ +theorem degree_add_le (x y : R⟦G⟧) : + degree (x + y) ≤ max (degree x) (degree y) := by + calc + degree (x + y) = Ordinal.cantorDegree (x + y).supportOrderType := + degree_eq_cantorDegree (x + y) + _ ≤ Ordinal.cantorDegree + (NatOrdinal.of x.supportOrderType + NatOrdinal.of y.supportOrderType).val := + Ordinal.cantorDegree_mono (supportOrderType_add_le_naturalAdd x y) + _ = NatOrdinal.cantorDegree + (NatOrdinal.of x.supportOrderType + NatOrdinal.of y.supportOrderType) := + (NatOrdinal.cantorDegree_eq_ordinalCantorDegree _).symm + _ = max (degree x) (degree y) := by + rw [NatOrdinal.cantorDegree_add, NatOrdinal.cantorDegree_of, + NatOrdinal.cantorDegree_of, degree_eq_cantorDegree, + degree_eq_cantorDegree] + +end Addition + +section AddGroup + +variable [AddGroup R] + +/-- Negation preserves ordinary support order type. -/ +@[simp] +theorem supportOrderType_neg (x : R⟦G⟧) : + (-x).supportOrderType = x.supportOrderType := by + calc + (-x).supportOrderType = (-x).isPWO_support.orderType := + supportOrderType_eq_setOrderType (-x) + _ = x.isPWO_support.orderType := + Set.IsPWO.orderType_congr _ _ support_neg + _ = x.supportOrderType := (supportOrderType_eq_setOrderType x).symm + +/-- Negation preserves degree. -/ +@[simp] +theorem degree_neg (x : R⟦G⟧) : (-x).degree = x.degree := by + rw [degree_eq_cantorDegree, degree_eq_cantorDegree, supportOrderType_neg] + +/-- Adding a series of strictly smaller degree does not change the larger degree. -/ +theorem degree_add_eq_left_of_lt {x y : R⟦G⟧} + (h : y.degree < x.degree) : (x + y).degree = x.degree := by + apply le_antisymm + · calc + (x + y).degree ≤ max x.degree y.degree := degree_add_le x y + _ = x.degree := max_eq_left h.le + · apply le_of_not_gt + intro hsum + have hreverse := degree_add_le (x + y) (-y) + rw [degree_neg, add_neg_cancel_right] at hreverse + exact (not_lt_of_ge hreverse) (max_lt hsum h) + +end AddGroup + +section Multiplication + +variable [AddCommMonoid G] [IsOrderedCancelAddMonoid G] +variable [NonUnitalNonAssocSemiring R] + +/-- The order type of the support of a product is at most the Hessenberg product of the two support +order types. This is LM24, Proposition 3.1.1(2), generalized from an ordered abelian exponent group +and a field of coefficients. -/ +theorem supportOrderType_mul_le_naturalMul (x y : R⟦G⟧) : + supportOrderType (x * y) ≤ + (NatOrdinal.of x.supportOrderType * NatOrdinal.of y.supportOrderType).val := by + calc + supportOrderType (x * y) = (x * y).isPWO_support.orderType := + supportOrderType_eq_setOrderType (x * y) + _ ≤ (x.isPWO_support.add y.isPWO_support).orderType := + Set.IsPWO.orderType_mono (x * y).isPWO_support + (x.isPWO_support.add y.isPWO_support) support_mul_subset + _ ≤ (NatOrdinal.of x.supportOrderType * + NatOrdinal.of y.supportOrderType).val := by + simpa only [← supportOrderType_eq_setOrderType] using + Set.IsPWO.orderType_add_le_naturalMul x.isPWO_support y.isPWO_support + +/-- The degree of a product is at most the Hessenberg sum of the two degrees. This is LM24, +Corollary 3.1.2(2), generalized from an ordered abelian exponent group and a field of +coefficients. -/ +theorem degree_mul_le (x y : R⟦G⟧) : + degree (x * y) ≤ degree x + degree y := by + calc + degree (x * y) = Ordinal.cantorDegree (x * y).supportOrderType := + degree_eq_cantorDegree (x * y) + _ ≤ Ordinal.cantorDegree + (NatOrdinal.of x.supportOrderType * NatOrdinal.of y.supportOrderType).val := + Ordinal.cantorDegree_mono (supportOrderType_mul_le_naturalMul x y) + _ = NatOrdinal.cantorDegree + (NatOrdinal.of x.supportOrderType * NatOrdinal.of y.supportOrderType) := + (NatOrdinal.cantorDegree_eq_ordinalCantorDegree _).symm + _ = degree x + degree y := by + rw [NatOrdinal.cantorDegree_mul, NatOrdinal.cantorDegree_of, + NatOrdinal.cantorDegree_of, degree_eq_cantorDegree, + degree_eq_cantorDegree] + +end Multiplication + + +section Archimedean + +variable [AddCommGroup G] [IsOrderedAddMonoid G] [Archimedean G] [Zero R] + +/-- Over an Archimedean exponent group every support is countable, so every support order type +is below `ω₁`. -/ +theorem supportOrderType_lt_omega_one (x : R⟦G⟧) : supportOrderType x < ω₁ := + x.isPWO_support.orderType_lt_omega_one_of_countable + x.isPWO_support.countable_of_archimedean + +/-- Over an Archimedean exponent group every degree is a countable ordinal. -/ +theorem degree_lt_omega_one (x : R⟦G⟧) : + degree x < (NatOrdinal.of ω₁ : WithBot NatOrdinal.{u}) := by + rw [degree_eq_cantorDegree] + by_cases h0 : supportOrderType x = 0 + · rw [h0, Ordinal.cantorDegree_zero] + exact WithBot.bot_lt_coe _ + · rw [Ordinal.cantorDegree_of_ne_zero h0, WithBot.coe_lt_coe, NatOrdinal.of_lt_iff] + exact (Ordinal.log_le_self _ _).trans_lt (supportOrderType_lt_omega_one x) + +end Archimedean + +end HahnSeries diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrderedIntervalSum.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrderedIntervalSum.lean new file mode 100644 index 0000000000..fc03a170a4 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrderedIntervalSum.lean @@ -0,0 +1,85 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.IncreasingSequenceUnion +public import Mathlib.RingTheory.HahnSeries.Summable + +/-! +# Hahn sums over ordered disjoint intervals + +A family of Hahn series supported in half-open intervals is summable when its index is partially +well ordered and every earlier interval lies below every later interval. The index may have +arbitrary cofinality. +-/ + +universe u v w + +open Set + +public noncomputable section + +namespace HahnSeries + +variable {Γ : Type u} {R : Type v} {ι : Type w} + [LinearOrder Γ] [AddCommMonoid R] [LinearOrder ι] + +/-- Hahn series supported in an ordered family of disjoint half-open intervals form a summable +family. -/ +def orderedIntervalSummableFamily (hι : (Set.univ : Set ι).IsPWO) + (f : ι → R⟦Γ⟧) (cut center : ι → Γ) + (hsupp : ∀ i, (f i).support ⊆ Ioc (cut i) (center i)) + (hord : ∀ i j, i < j → center i ≤ cut j) : SummableFamily Γ R ι where + toFun := f + isPWO_iUnion_support' := + Set.IsPWO.iUnion_of_ordered_index hι (fun i ↦ (f i).support) + (fun i ↦ (f i).isPWO_support) fun i j hij x hx y hy ↦ by + exact (hsupp i hx).2.trans_lt ((hord i j hij).trans_lt (hsupp j hy).1) + finite_co_support' x := by + refine Set.Subsingleton.finite fun i hi j hj ↦ ?_ + by_contra hne + have hix : x ∈ (f i).support := (mem_support _ _).mpr hi + have hjx : x ∈ (f j).support := (mem_support _ _).mpr hj + rcases lt_or_gt_of_ne hne with hij | hji + · exact (not_lt_of_ge (hsupp i hix).2) + ((hord i j hij).trans_lt (hsupp j hjx).1) + · exact (not_lt_of_ge (hsupp j hjx).2) + ((hord j i hji).trans_lt (hsupp i hix).1) + +/-- The ordered-interval family evaluates to the original series at each index. -/ +@[simp] +theorem orderedIntervalSummableFamily_apply (hι : (Set.univ : Set ι).IsPWO) + (f : ι → R⟦Γ⟧) (cut center : ι → Γ) + (hsupp : ∀ i, (f i).support ⊆ Ioc (cut i) (center i)) + (hord : ∀ i j, i < j → center i ≤ cut j) (i : ι) : + orderedIntervalSummableFamily hι f cut center hsupp hord i = f i := (rfl) + +/-- Ordered disjoint intervals prevent coefficient cancellation, so the support of the Hahn sum is +exactly the union of the component supports. -/ +theorem support_hsum_orderedIntervalSummableFamily (hι : (Set.univ : Set ι).IsPWO) + (f : ι → R⟦Γ⟧) (cut center : ι → Γ) + (hsupp : ∀ i, (f i).support ⊆ Ioc (cut i) (center i)) + (hord : ∀ i j, i < j → center i ≤ cut j) : + (orderedIntervalSummableFamily hι f cut center hsupp hord).hsum.support = + ⋃ i, (f i).support := by + apply Set.Subset.antisymm SummableFamily.support_hsum_subset + intro g hg + rw [Set.mem_iUnion] at hg + obtain ⟨i, hi⟩ := hg + rw [mem_support] at hi ⊢ + rw [SummableFamily.coeff_hsum, finsum_eq_single _ i] + · exact hi + · intro j hji + have hj : g ∉ (f j).support := by + intro hj + rcases lt_or_gt_of_ne hji with hji | hij + · exact (not_lt_of_ge (hsupp j hj).2) + ((hord j i hji).trans_lt (hsupp i hi).1) + · exact (not_lt_of_ge (hsupp i hi).2) + ((hord i j hij).trans_lt (hsupp j hj).1) + simpa only [orderedIntervalSummableFamily_apply, mem_support, not_not] using hj + +end HahnSeries diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue.lean new file mode 100644 index 0000000000..771e0c04e3 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue.lean @@ -0,0 +1,61 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.CoefficientMap +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.ComplexityDecrease +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Convolution +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.ConvolutionList +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.ConvolutionRemainder +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.CriticalPoint +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.CriticalPointExistence +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.FormalExpression +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Germ +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.GermDegree +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.GermValueCut +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Irreducibility +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.LeibnizRemainder +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.MainLemma +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OneRow +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrderTypeMultiplicativity +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValue +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValueConstantMul +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValueDegree +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValueFinalSegment +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValueImage +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValueSubmultiplicative +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValueSupport +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValueValuation +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PowerRemainder +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalComponent +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalComponentDegree +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalComponentTensor +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalSubring +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalSubringFiniteSupport +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalSubringFraction +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalSubringFractionAlgebraic +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalSubringLocalization +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalSubringMonoidAlgebra +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalSubringScalarRedistributionProof +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalSubringTensor +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalValue +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PurePowerRemainder +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.ResidualPoint +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.ResidualPointCofinality +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.ResidualPointOrderType +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.ResidualPointSupport +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.ResidualPointTail +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.ResidualPointValue +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.ResidualPointWellOrdered +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.StableInterval +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Statements +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Tests +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Truncation +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.TruncationDrop + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence.lean new file mode 100644 index 0000000000..bb1cf96c92 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence.lean @@ -0,0 +1,50 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.BaseChange +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.CantorBendixsonGrading +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.CantorBendixsonRank +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.CantorBendixsonRepresentatives +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.CombinedCofactors +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.DerivAt +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.DerivAtInjective +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.DerivationIdeal +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.IdealFromTruncations +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.InductionOverDegrees +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.LeadingCoefficient +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.Lifts +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.LimitOrdinalRelationAtCutoff +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.LinearMaximal +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.LowDegreeParts +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.LoweringDerivation +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.OmegaSupport +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.OrdinalValueCutoffs +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.PartialDerivativeIndices +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.Partials +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.Pieces +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.Polynomiality +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.PrincipalGraded +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.PrincipalIdealGE +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.PrincipalRepresentatives +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.ProductCondition +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.ProductTruncation +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.ProductValues +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.RealPartials +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.SeriesTruncations +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.Shift +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.SuccessorLeibniz +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.SuccessorSupportBound +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.SumAlongCutoffs +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.SupportLoweringPieces +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.Syzygy +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.TruncationExpansion +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.TruncationPolynomial +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.TruncationsIdeal +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.UnboundedTruncations + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/BaseChange.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/BaseChange.lean new file mode 100644 index 0000000000..a50195fdc2 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/BaseChange.lean @@ -0,0 +1,415 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.PrincipalGraded +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.CoefficientMap +public import Mathlib.LinearAlgebra.FiniteDimensional.Defs +public import Mathlib.RingTheory.TensorProduct.Basic +public import Mathlib.LinearAlgebra.Basis.Defs + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.StableInterval +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValueSupport +import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.DegreeAssociatedGradedMap +import Mathlib.LinearAlgebra.DirectSum.TensorProduct +import Mathlib.LinearAlgebra.TensorProduct.Basis +import Mathlib.LinearAlgebra.FreeModule.Basic +import Mathlib.Algebra.Ring.Hom.InjSurj +import Mathlib.Algebra.CharP.Algebra +import Mathlib.RingTheory.TensorProduct.Maps +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalSubringFraction + +/-! +# Coefficient base change for the spaces `P_α` + +The ordinal value of a nonpositive series is determined by its support, so it is monotone under +inclusion of supports even when the two series have different coefficient fields +(`Berarducci.ordinalValue_le_of_support_subset`). A `K`-linear map `λ : E → F` between extensions +of `K`, applied coefficientwise, can only shrink the support, and preserves it when `λ` is +injective; so it does not increase the ordinal value, and preserves it when `λ` is injective. +Coefficient extension along the structure map `K → E` is the injective case, and a coordinate +functional along a `K`-basis of `E` is the general case. + +Coefficient extension therefore preserves the ordinal-value degree and induces the graded ring +homomorphism `P̂ → P̂^(E)` of associated graded rings. For every field extension `E / K` the +induced map `E ⊗[K] P_α → P_α^(E)` is injective: a vanishing expansion along a `K`-basis of `E` has +vanishing coordinates, one by one. Assembling the homogeneous components gives an injective +`E`-algebra map +`E ⊗[K] P̂ → P̂^(E)`, multiplicative because the ring homomorphism `P̂ → P̂^(E)` is, so `E ⊗[K] P̂` +is a domain. This is the input to the geometric integrality of the quotient `P̂/I`. + +Degrees are `NatOrdinal`, so the degree of a product is the natural sum `⊕` of the degrees, and +the finite-degree part `P̂_{<ω}` is the part supported below `ω`. +-/ + +universe v w w' + +open scoped DirectSum HahnSeries NatOrdinal TensorProduct + +public noncomputable section + +namespace Berarducci + +open Berarducci + +open HahnSeries.Nonpositive + +variable {K : Type v} {E : Type w} [Field K] [Field E] + +/-! ### Coefficientwise linear maps and the ordinal value -/ + +section LinearCoefficientMap + +variable {F : Type w'} [Field F] [Algebra K E] [Algebra K F] + +/-- Coefficientwise application of a `K`-linear map `λ : E → F` between extensions of `K`. -/ +def nonpositiveLinearCoeffMap (lam : E →ₗ[K] F) : + HahnSeries.Nonpositive ℝ E →+ HahnSeries.Nonpositive ℝ F where + toFun u := ⟨(u : E⟦ℝ⟧).map (lam : E →+ F), by + refine (HahnSeries.mem_nonpositiveSubring ℝ F).mpr fun x hx ↦ + HahnSeries.Nonpositive.support_subset u ?_ + rw [HahnSeries.mem_support] at hx ⊢ + intro hzero + exact hx (show lam ((u : E⟦ℝ⟧).coeff x) = 0 by rw [hzero, map_zero])⟩ + map_zero' := Subtype.ext (HahnSeries.map_zero (lam : E →ₗ[K] F).toAddMonoidHom.toZeroHom) + map_add' u v := Subtype.ext (HahnSeries.map_add (lam : E →ₗ[K] F).toAddMonoidHom) + +@[simp] +theorem coe_nonpositiveLinearCoeffMap (lam : E →ₗ[K] F) (u : HahnSeries.Nonpositive ℝ E) + (x : ℝ) : + ((nonpositiveLinearCoeffMap lam u : HahnSeries.Nonpositive ℝ F) : F⟦ℝ⟧).coeff x = + lam ((u : E⟦ℝ⟧).coeff x) := + (rfl) + +/-- A coefficientwise linear map does not enlarge the support. -/ +theorem support_nonpositiveLinearCoeffMap_subset (lam : E →ₗ[K] F) + (u : HahnSeries.Nonpositive ℝ E) : + ((nonpositiveLinearCoeffMap lam u : HahnSeries.Nonpositive ℝ F) : F⟦ℝ⟧).support ⊆ + (u : E⟦ℝ⟧).support := by + intro x hx + rw [HahnSeries.mem_support] at hx ⊢ + intro hzero + exact hx (by rw [coe_nonpositiveLinearCoeffMap, hzero, map_zero]) + +/-- A coefficientwise injective linear map preserves the support. -/ +theorem support_nonpositiveLinearCoeffMap_of_injective (lam : E →ₗ[K] F) + (hlam : Function.Injective lam) (u : HahnSeries.Nonpositive ℝ E) : + ((nonpositiveLinearCoeffMap lam u : HahnSeries.Nonpositive ℝ F) : F⟦ℝ⟧).support = + (u : E⟦ℝ⟧).support := by + ext x + rw [HahnSeries.mem_support, HahnSeries.mem_support, coe_nonpositiveLinearCoeffMap] + exact (LinearMap.map_eq_zero_iff lam hlam).not + +/-- A coefficientwise `K`-linear map between extensions of `K` does not increase the ordinal +value. -/ +theorem ordinalValue_nonpositiveLinearCoeffMap_le (lam : E →ₗ[K] F) + (u : HahnSeries.Nonpositive ℝ E) : + ordinalValue (nonpositiveLinearCoeffMap lam u) ≤ ordinalValue u := + ordinalValue_le_of_support_subset _ _ (support_nonpositiveLinearCoeffMap_subset lam u) + +/-- A coefficientwise injective `K`-linear map between extensions of `K` preserves the ordinal +value. -/ +theorem ordinalValue_nonpositiveLinearCoeffMap_of_injective (lam : E →ₗ[K] F) + (hlam : Function.Injective lam) (u : HahnSeries.Nonpositive ℝ E) : + ordinalValue (nonpositiveLinearCoeffMap lam u) = ordinalValue u := + le_antisymm (ordinalValue_nonpositiveLinearCoeffMap_le lam u) + (ordinalValue_le_of_support_subset _ _ + (support_nonpositiveLinearCoeffMap_of_injective lam hlam u).superset) + +end LinearCoefficientMap + +/-- An extension field of a field of characteristic zero has characteristic zero. -/ +theorem charZero_of_algebra (L : Type v) [Field L] [CharZero L] (F : Type w) [Field F] + [Algebra L F] : CharZero F := + charZero_of_injective_algebraMap (algebraMap L F).injective + +/-! ### Base change of the spaces `P_α` and `P̂` + +The componentwise and ring base changes are defined for any fields `K ⊆ E`: they are the component +maps of the associated graded rings along coefficient extension, which rest only on the degree +structure of `ordinalValueDegreeValuation`. Characteristic zero of `E` enters for the domain +property of `P̂^(E)`, hence for injectivity of `ε` and for `E ⊗[K] P̂` being a domain. -/ + +section Layer + +/-- Coefficient extension preserves the ordinal-value degree exactly. -/ +private theorem ordinalValueDegreeValuation_nonpositiveCoefficientMap (f : K →+* E) + (x : HahnSeries.Nonpositive ℝ K) : + ordinalValueDegreeValuation E (nonpositiveCoefficientMap f x) = + ordinalValueDegreeValuation K x := by + rw [ordinalValueDegreeValuation_apply, ordinalValueDegreeValuation_apply] + have hov := ordinalValue_nonpositiveCoefficientMap f x + have key : ∀ α : NatOrdinal, + ordinalValueDegree (nonpositiveCoefficientMap f x) ≤ (α : WithBot NatOrdinal) ↔ + ordinalValueDegree x ≤ (α : WithBot NatOrdinal) := by + intro α + rw [ordinalValueDegree_le_coe_iff, ordinalValueDegree_le_coe_iff, hov] + have hbot : ordinalValueDegree (nonpositiveCoefficientMap f x) = ⊥ ↔ + ordinalValueDegree x = ⊥ := by + rw [ordinalValueDegree_eq_bot_iff, ordinalValueDegree_eq_bot_iff, ← ordinalValue_eq_zero_iff, + ← ordinalValue_eq_zero_iff, hov] + refine le_antisymm ?_ ?_ + · cases hxd : ordinalValueDegree x with + | bot => rw [hbot.mpr hxd] + | coe α => exact (key α).mpr (le_of_eq hxd) + · cases hyd : ordinalValueDegree (nonpositiveCoefficientMap f x) with + | bot => rw [hbot.mp hyd] + | coe β => exact (key β).mp (le_of_eq hyd) + +/-- The additive coefficient-extension map on `P_α`: the associated-graded +component map of the degree-preserving ring homomorphism `nonpositiveCoefficientMap f`. -/ +def principalComponentCoefficientExtendAddHom (f : K →+* E) (alpha : NatOrdinal) : + PrincipalComponent K alpha →+ PrincipalComponent E alpha := + (ordinalValueDegreeValuation K).componentMap (ordinalValueDegreeValuation E) + (nonpositiveCoefficientMap f) + (fun x ↦ (ordinalValueDegreeValuation_nonpositiveCoefficientMap f x).le) alpha + +/-- The additive component map sends the class of a representative to the class of its image. -/ +theorem principalComponentCoefficientExtendAddHom_principalComponentMk (f : K →+* E) + (alpha : NatOrdinal) (b : HahnSeries.Nonpositive ℝ K) + (hb : ordinalValue b < ω^ (alpha + 1)) : + principalComponentCoefficientExtendAddHom f alpha + (principalComponentMk alpha b hb) = + principalComponentMk alpha (nonpositiveCoefficientMap f b) + (by rw [ordinalValue_nonpositiveCoefficientMap]; exact hb) := by + rw [principalComponentCoefficientExtendAddHom, principalComponentMk_eq_componentMk, + MaxAddDegree.componentMap_componentMk, principalComponentMk_eq_componentMk] + congr 1 + apply Subtype.ext + rw [MaxAddDegree.coe_mapFiltrationLE] + +variable (K E) in +/-- Coefficient extension on `P_α`, semilinear along the algebra map: the +associated-graded component map of coefficient extension. -/ +def principalComponentCoefficientExtend [Algebra K E] (alpha : NatOrdinal) : + PrincipalComponent K alpha →ₛₗ[algebraMap K E] PrincipalComponent E alpha where + toFun := principalComponentCoefficientExtendAddHom (algebraMap K E) alpha + map_add' := map_add _ + map_smul' k x := by + obtain ⟨b, hb, rfl⟩ := exists_principalComponentMk alpha x + rw [smul_principalComponentMk, principalComponentCoefficientExtendAddHom_principalComponentMk, + principalComponentCoefficientExtendAddHom_principalComponentMk, smul_principalComponentMk] + congr 1 + rw [map_mul, nonpositiveCoefficientMap_C] + +variable (K E) in +/-- The scalar-extended component map `E ⊗[K] P_α →ₗ[E] P_α^(E)`. -/ +def principalComponentBaseChange [Algebra K E] (alpha : NatOrdinal) : + E ⊗[K] PrincipalComponent K alpha →ₗ[E] PrincipalComponent E alpha := by + letI : Module K (PrincipalComponent E alpha) := + Module.compHom (PrincipalComponent E alpha) (algebraMap K E) + haveI : IsScalarTower K E (PrincipalComponent E alpha) := + ⟨fun k e y ↦ by + change ((k • e : E)) • y = (algebraMap K E k) • (e • y) + rw [Algebra.smul_def, mul_smul]⟩ + exact LinearMap.liftBaseChange E + { toFun := principalComponentCoefficientExtend K E alpha + map_add' := fun x y ↦ map_add _ x y + map_smul' := fun k x ↦ + (principalComponentCoefficientExtend K E alpha).map_smul' k x } + +/-- A coefficientwise basis functional picks out one summand of a basis decomposition. -/ +private theorem nonpositiveLinearCoeffMap_C_mul [Algebra K E] {ι : Type*} [DecidableEq ι] + (bE : Module.Basis ι K E) (i j : ι) (v : HahnSeries.Nonpositive ℝ K) : + nonpositiveLinearCoeffMap (bE.coord j) + (HahnSeries.Nonpositive.C (bE i) * nonpositiveCoefficientMap (algebraMap K E) v) = + if i = j then v else 0 := by + apply Subtype.ext + ext x + rw [coe_nonpositiveLinearCoeffMap, Subring.coe_mul, HahnSeries.Nonpositive.coe_C, + HahnSeries.C_mul_eq_smul, HahnSeries.coeff_smul, coe_nonpositiveCoefficientMap, + smul_eq_mul, mul_comm, ← Algebra.smul_def, map_smul, Module.Basis.coord_apply, + Module.Basis.repr_self, + Finsupp.single_apply] + by_cases h : i = j <;> simp [h] + +/-- A finite sum stays inside a principal filtration level. -/ +private theorem ordinalValue_finsetSum_lt {ι : Type*} {K' : Type*} [Field K'] + (alpha : NatOrdinal) (g : ι → HahnSeries.Nonpositive ℝ K') + (hg : ∀ i, ordinalValue (g i) < ω^ (alpha + 1)) (t : Finset ι) : + ordinalValue (∑ i ∈ t, g i) < ω^ (alpha + 1) := by + classical + induction t using Finset.induction with + | empty => + rw [Finset.sum_empty, + ordinalValue_of_mem_negativeMonomialIdeal + (HahnSeries.Nonpositive.negativeMonomialIdeal K').zero_mem] + exact NatOrdinal.wpow_pos _ + | insert i t hi ih => + rw [Finset.sum_insert hi] + exact lt_of_le_of_lt (ordinalValue_add_le_max _ _) (max_lt (hg i) ih) + +/-- The class of a finite sum is the sum of the classes. -/ +private theorem principalComponentMk_sum {ι : Type*} + (alpha : NatOrdinal) (g : ι → HahnSeries.Nonpositive ℝ K) + (hg : ∀ i, ordinalValue (g i) < ω^ (alpha + 1)) (t : Finset ι) + (hsum : ordinalValue (∑ i ∈ t, g i) < ω^ (alpha + 1)) : + principalComponentMk alpha (∑ i ∈ t, g i) hsum = + ∑ i ∈ t, principalComponentMk alpha (g i) (hg i) := by + simp only [principalComponentMk_eq_componentMk] + rw [← map_sum] + congr 1 + apply Subtype.ext + rw [AddSubmonoidClass.coe_finsetSum] + +/-- The scalar-extended component map on a pure tensor. -/ +@[simp] +theorem principalComponentBaseChange_tmul [Algebra K E] + (alpha : NatOrdinal) (e : E) + (x : PrincipalComponent K alpha) : + principalComponentBaseChange K E alpha (e ⊗ₜ[K] x) = + e • principalComponentCoefficientExtend K E alpha x := + (rfl) + +variable (K E) in +/-- Base change on each homogeneous component is injective for every field extension `E / K`: the +coordinates of a +vanishing expansion along a `K`-basis of `E` vanish one by one. -/ +theorem principalComponentBaseChange_injective [Algebra K E] + (alpha : NatOrdinal) : + Function.Injective (principalComponentBaseChange K E alpha) := by + classical + rw [injective_iff_map_eq_zero] + intro z hz + let bE := Module.Free.chooseBasis K E + obtain ⟨c, rfl⟩ := TensorProduct.eq_repr_basis_left bE z + choose b hb hbx using fun i ↦ exists_principalComponentMk alpha (c i) + have hprod : ∀ i, ordinalValue (HahnSeries.Nonpositive.C (bE i) * + nonpositiveCoefficientMap (algebraMap K E) (b i)) < ω^ (alpha + 1) := fun i ↦ by + simpa only [zero_add] using ordinalValue_mul_lt_wpow_add_one + (ordinalValue_C_lt_wpow_one (bE i)) + (by rw [ordinalValue_nonpositiveCoefficientMap]; exact hb i) + have hsum := ordinalValue_finsetSum_lt alpha _ hprod c.support + have himg : principalComponentBaseChange K E alpha (c.sum fun i n ↦ bE i ⊗ₜ[K] n) = + principalComponentMk alpha + (∑ i ∈ c.support, HahnSeries.Nonpositive.C (bE i) * + nonpositiveCoefficientMap (algebraMap K E) (b i)) hsum := by + rw [Finsupp.sum, map_sum, principalComponentMk_sum alpha _ hprod _ hsum] + refine Finset.sum_congr rfl fun i _ ↦ ?_ + rw [← hbx i, principalComponentBaseChange_tmul] + change (bE i) • principalComponentCoefficientExtendAddHom + (algebraMap K E) alpha _ = _ + rw [principalComponentCoefficientExtendAddHom_principalComponentMk, smul_principalComponentMk] + rw [himg, principalComponentMk_eq_zero_iff] at hz + have hzero : ∀ j, c j = 0 := by + intro j + by_cases hj : j ∈ c.support + · rw [← hbx j, principalComponentMk_eq_zero_iff] + refine lt_of_le_of_lt (le_of_eq ?_) (lt_of_le_of_lt + (ordinalValue_nonpositiveLinearCoeffMap_le (bE.coord j) _) hz) + rw [map_sum] + rw [Finset.sum_congr rfl fun i (_ : i ∈ c.support) ↦ + nonpositiveLinearCoeffMap_C_mul bE i j (b i)] + rw [Finset.sum_ite_eq' c.support j b, ite_eq_left hj] + · exact Finsupp.notMem_support_iff.mp hj + have hc : c = 0 := Finsupp.ext hzero + rw [hc, Finsupp.sum_zero_index] + +/-! ### The graded base change `E ⊗[K] P̂ → P̂^(E)` -/ + +variable (E) in +/-- The semilinear component map on the class of a representative. -/ +theorem principalComponentCoefficientExtend_principalComponentMk [Algebra K E] + (alpha : NatOrdinal) + (b : HahnSeries.Nonpositive ℝ K) (hb : ordinalValue b < ω^ (alpha + 1)) : + principalComponentCoefficientExtend K E alpha (principalComponentMk alpha b hb) = + principalComponentMk alpha (nonpositiveCoefficientMap (algebraMap K E) b) + (by rw [ordinalValue_nonpositiveCoefficientMap]; exact hb) := + principalComponentCoefficientExtendAddHom_principalComponentMk (algebraMap K E) alpha b hb + +variable (K E) in +/-- The graded base change `E ⊗[K] P̂ → P̂^(E)`, as an `E`-linear map: the direct sum of the +componentwise base changes. -/ +def principalSubringBaseChangeLinear [Algebra K E] : + E ⊗[K] PrincipalSubring K →ₗ[E] PrincipalSubring E := + (DirectSum.lmap fun alpha ↦ principalComponentBaseChange K E alpha).comp + (TensorProduct.directSumRight K E E (PrincipalComponent K)).toLinearMap + +/-- The graded base change on a pure tensor of a homogeneous element. -/ +theorem principalSubringBaseChangeLinear_tmul_of [Algebra K E] + (e : E) (alpha : NatOrdinal) + (A : PrincipalComponent K alpha) : + principalSubringBaseChangeLinear K E + (e ⊗ₜ[K] DirectSum.of (PrincipalComponent K) alpha A) = + e • DirectSum.of (PrincipalComponent E) alpha + (principalComponentCoefficientExtend K E alpha A) := by + rw [principalSubringBaseChangeLinear, LinearMap.comp_apply, LinearEquiv.coe_coe, + ← DirectSum.lof_eq_of K, TensorProduct.directSumRight_tmul_lof, DirectSum.lmap_lof, + principalComponentBaseChange_tmul, LinearMap.map_smul, DirectSum.lof_eq_of] + +variable (K E) in +/-- The graded base change is injective, because base change on each homogeneous component is. -/ +theorem principalSubringBaseChangeLinear_injective [Algebra K E] : + Function.Injective (principalSubringBaseChangeLinear K E) := + ((DirectSum.lmap_injective _).mpr fun alpha ↦ + principalComponentBaseChange_injective K E alpha).comp + (TensorProduct.directSumRight K E E (PrincipalComponent K)).injective + +variable (K E) in +/-- Coefficient extension `P̂ → P̂^(E)` as a graded ring homomorphism: the associated-graded map +of the degree-preserving ring homomorphism `nonpositiveCoefficientMap (algebraMap K E)`. On the +homogeneous component `P_α` it is `principalComponentCoefficientExtend K E α`. -/ +def principalSubringCoefficientExtend [Algebra K E] : PrincipalSubring K →+* PrincipalSubring E := + (ordinalValueDegreeValuation K).associatedGradedMap (ordinalValueDegreeValuation E) + (nonpositiveCoefficientMap (algebraMap K E)) + fun x ↦ (ordinalValueDegreeValuation_nonpositiveCoefficientMap (algebraMap K E) x).le + +/-- Coefficient extension of `P̂` on a homogeneous element. -/ +theorem principalSubringCoefficientExtend_of [Algebra K E] + (alpha : NatOrdinal) + (A : PrincipalComponent K alpha) : + principalSubringCoefficientExtend K E (DirectSum.of (PrincipalComponent K) alpha A) = + DirectSum.of (PrincipalComponent E) alpha (principalComponentCoefficientExtend K E alpha A) := + MaxAddDegree.associatedGradedMap_of _ _ _ _ alpha A + +/-- The graded base change on a pure tensor: `e ⊗ A ↦ e • ε(A)`. -/ +theorem principalSubringBaseChangeLinear_tmul [Algebra K E] + (e : E) (A : PrincipalSubring K) : + principalSubringBaseChangeLinear K E (e ⊗ₜ[K] A) = + e • principalSubringCoefficientExtend K E A := by + induction A using DirectSum.induction_on with + | zero => rw [TensorProduct.tmul_zero, map_zero, map_zero, smul_zero] + | of alpha A => + rw [principalSubringBaseChangeLinear_tmul_of, + principalSubringCoefficientExtend_of] + | add x y hx hy => rw [TensorProduct.tmul_add, map_add, hx, hy, map_add, smul_add] + +variable (K E) in +/-- Coefficient extension as an `E`-algebra map `E ⊗[K] P̂ → P̂^(E)`, the paper's map `ε`; +it is injective when `E` has characteristic zero (`principalSubringBaseChange_injective`). -/ +def principalSubringBaseChange [Algebra K E] : + E ⊗[K] PrincipalSubring K →ₐ[E] PrincipalSubring E := + Algebra.TensorProduct.algHomOfLinearMapTensorProduct (principalSubringBaseChangeLinear K E) + (fun e f A B ↦ by + rw [principalSubringBaseChangeLinear_tmul, principalSubringBaseChangeLinear_tmul, + principalSubringBaseChangeLinear_tmul, map_mul, smul_mul_smul_comm]) + (by rw [principalSubringBaseChangeLinear_tmul, map_one, one_smul]) + +theorem principalSubringBaseChange_tmul_of [Algebra K E] + (e : E) (alpha : NatOrdinal) + (A : PrincipalComponent K alpha) : + principalSubringBaseChange K E + (e ⊗ₜ[K] DirectSum.of (PrincipalComponent K) alpha A) = + e • DirectSum.of (PrincipalComponent E) alpha + (principalComponentCoefficientExtend K E alpha A) := + principalSubringBaseChangeLinear_tmul_of e alpha A + +variable (K E) in +theorem principalSubringBaseChange_injective [Algebra K E] : + Function.Injective (principalSubringBaseChange K E) := + principalSubringBaseChangeLinear_injective K E + +variable (K E) in +/-- `E ⊗[K] P̂` is a domain, being a subring of the domain `P̂^(E)`. -/ +theorem isDomain_tensor_principalSubring [Algebra K E] [CharZero E] : + IsDomain (E ⊗[K] PrincipalSubring K) := + haveI : IsDomain (PrincipalSubring E) := principalSubringIsDomain + Function.Injective.isDomain (principalSubringBaseChange K E).toRingHom + (principalSubringBaseChange_injective K E) + +end Layer + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/CantorBendixsonGrading.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/CantorBendixsonGrading.lean new file mode 100644 index 0000000000..fb6af9ce95 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/CantorBendixsonGrading.lean @@ -0,0 +1,184 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.Scalar +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.PrincipalGraded +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.CantorBendixsonRank + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint + +/-! +# The subring $\widehat{\mathrm P}$ and Cantor–Bendixson degree + +For real exponents, Berarducci's ordinal value is `omega` raised to the Cantor–Bendixson rank of +zero in the closed support, so its Cantor degree is that rank. Consequently `P̂` +is canonically isomorphic to the associated graded algebra of the Cantor–Bendixson degree. The +isomorphism preserves every homogeneous component and therefore carries minimal homogeneous +generating systems to minimal generating systems. +-/ + +universe v w + +open scoped DirectSum HahnSeries NatOrdinal + +open Berarducci HahnSeries + +public noncomputable section + +namespace Berarducci + +variable {K : Type v} [Field K] [CharZero K] + +omit [CharZero K] in +private theorem principalSubring_algebraMap_eq_initialForm (k : K) : + algebraMap K (PrincipalSubring K) k = + (ordinalValueDegreeValuation K).initialForm (HahnSeries.Nonpositive.C k) := by + by_cases hk : k = 0 + · subst k + simp + · rw [principalSubring_algebraMap_apply, principalComponentScalarHom_apply, + principalComponentMk_eq_componentMk, ← MaxAddDegree.homogeneousMk_apply] + apply MaxAddDegree.homogeneousMk_eq_initialForm_of_degree_eq + rw [ordinalValueDegreeValuation_apply] + simpa only [WithBot.coe_zero] using ordinalValueDegree_C_of_ne (K := K) hk + +private theorem cantorBendixson_algebraMap_eq_initialForm (k : K) : + algebraMap K + (HahnSeries.Nonpositive.cantorBendixsonDegreeValuation + (G := ℝ) (R := K)).AssociatedGraded k = + (HahnSeries.Nonpositive.cantorBendixsonDegreeValuation + (G := ℝ) (R := K)).initialForm (HahnSeries.Nonpositive.C k) := by + by_cases hk : k = 0 + · subst k + simp + · rw [HahnSeries.Nonpositive.cantorBendixson_algebraMap_apply, + HahnSeries.Nonpositive.cantorBendixsonLayerScalarHom_apply, + ← MaxAddDegree.homogeneousMk_apply] + apply MaxAddDegree.homogeneousMk_eq_initialForm_of_degree_eq + exact HahnSeries.Nonpositive.degree_C_of_ne k hk + +/-- The subring `P̂` is canonically the associated graded algebra defined by the +Cantor–Bendixson degree. -/ +@[expose, blueprint "lem:principal-subring-cantor-bendixson" + (phase := "Principal RV-elements") + (title := "Cantor--Bendixson grading of $\\widehat{\\mathrm P}$") + (statement := /-- + Let $\widehat{\mathrm P}$ be the subring of principal elements of + $\widehat{\mathrm{RV}}$, equivalently the associated graded $K$-algebra + for $\deg_J$. Define + \[ + \delta_{\mathrm{CB}}(b)= + \begin{cases} + -\infty, & 0\notin\mathrm{cl}(\operatorname{supp}(b)),\\ + \operatorname{rk}_{\mathrm{CB},\mathrm{cl}(\operatorname{supp}(b))}(0), + & 0\in\mathrm{cl}(\operatorname{supp}(b)). + \end{cases} + \] + There is a canonical isomorphism of $K$-algebras + \[ + \widehat{\mathrm P}\simeq_K + \operatorname{gr}_{\delta_{\mathrm{CB}}}K((\mathbb R^{\le0})). + \] + -/) + (proof := /-- + The subring $\widehat{\mathrm P}$ is the associated graded algebra for $\deg_J$. + \ref{lem:ordinal-value-degree-is-cantor-bendixson-rank} identifies + $\deg_J$ with $\delta_{\mathrm{CB}}$, so the identity on series induces a + ring isomorphism between the associated graded algebras. Both scalar + embeddings send $k\in K$ to the initial form of the constant series $k$; + hence this is an isomorphism of $K$-algebras. + -/)] +def principalSubringCantorBendixsonAlgEquiv : PrincipalSubring K ≃ₐ[K] + (HahnSeries.Nonpositive.cantorBendixsonDegreeValuation + (G := ℝ) (R := K)).AssociatedGraded where + toRingEquiv := (ordinalValueDegreeValuation K).associatedGradedCongr + (ordinalValueDegreeValuation_eq_cantorBendixsonDegreeValuation (K := K)) + commutes' k := by + rw [principalSubring_algebraMap_eq_initialForm, cantorBendixson_algebraMap_eq_initialForm] + exact MaxAddDegree.associatedGradedCongr_initialForm _ _ + +/-- The underlying map is transport along equality of the two degree functions. -/ +theorem principalSubringCantorBendixsonAlgEquiv_apply (x : PrincipalSubring K) : + principalSubringCantorBendixsonAlgEquiv x = + (ordinalValueDegreeValuation K).associatedGradedCongr + (ordinalValueDegreeValuation_eq_cantorBendixsonDegreeValuation (K := K)) x := + rfl + +/-- The canonical equivalence preserves each homogeneous component. -/ +theorem principalSubringCantorBendixsonAlgEquiv_mem_grading + (n : NatOrdinal) (x : PrincipalSubring K) : + x ∈ principalGrading K n ↔ + principalSubringCantorBendixsonAlgEquiv x ∈ DirectSum.rangeLof K + (HahnSeries.Nonpositive.cantorBendixsonDegreeValuation + (G := ℝ) (R := K)).Component n := by + let ν := ordinalValueDegreeValuation K + let δ := HahnSeries.Nonpositive.cantorBendixsonDegreeValuation (G := ℝ) (R := K) + let hν : ν = δ := ordinalValueDegreeValuation_eq_cantorBendixsonDegreeValuation + constructor + · intro hx + obtain ⟨a, ha⟩ := (DirectSum.mem_rangeLof_iff K ν.Component n x).mp hx + rw [DirectSum.lof_eq_of] at ha + subst x + rw [show principalSubringCantorBendixsonAlgEquiv (DirectSum.of ν.Component n a) = + ν.associatedGradedCongr hν (DirectSum.of ν.Component n a) by rfl, + ν.associatedGradedCongr_of hν n a] + exact DirectSum.of_mem_rangeLof K δ.Component n (ν.componentCongr hν n a) + · intro hx + obtain ⟨a, ha⟩ := (DirectSum.mem_rangeLof_iff K δ.Component n + (principalSubringCantorBendixsonAlgEquiv x)).mp hx + rw [DirectSum.lof_eq_of] at ha + have hxa : x = DirectSum.of ν.Component n ((ν.componentCongr hν n).symm a) := by + apply (principalSubringCantorBendixsonAlgEquiv (K := K)).injective + rw [← ha] + change DirectSum.of δ.Component n a = + ν.associatedGradedCongr hν + (DirectSum.of ν.Component n ((ν.componentCongr hν n).symm a)) + rw [ν.associatedGradedCongr_of] + congr 2 + exact (ν.componentCongr hν n).apply_symm_apply a |>.symm + rw [hxa] + exact DirectSum.of_mem_rangeLof K ν.Component n _ + +variable {ι : Type w} {wt : ι → NatOrdinal} {x : ι → PrincipalSubring K} + +/-- Evaluation commutes with the canonical graded-algebra equivalence. -/ +theorem principalSubringCantorBendixsonAlgEquiv_aeval (F : MvPolynomial ι K) : + principalSubringCantorBendixsonAlgEquiv (MvPolynomial.aeval x F) = + MvPolynomial.aeval (fun i ↦ principalSubringCantorBendixsonAlgEquiv (x i)) F := by + change principalSubringCantorBendixsonAlgEquiv.toAlgHom (MvPolynomial.aeval x F) = _ + rw [← AlgHom.comp_apply, MvPolynomial.comp_aeval] + congr 1 + +/-- Degreewise injectivity is preserved by the canonical graded-algebra equivalence. -/ +theorem principalSubringCantorBendixson_injectiveAt_iff (n : NatOrdinal) : + OrdinalGraded.InjectiveAt K wt x n ↔ + OrdinalGraded.InjectiveAt K wt + (fun i ↦ principalSubringCantorBendixsonAlgEquiv (x i)) n := by + constructor + · intro h + rw [OrdinalGraded.injectiveAt_iff] at h ⊢ + intro F hF hzero + apply h F hF + apply principalSubringCantorBendixsonAlgEquiv.injective + rw [map_zero, principalSubringCantorBendixsonAlgEquiv_aeval, hzero] + · intro h + rw [OrdinalGraded.injectiveAt_iff] at h ⊢ + intro F hF hzero + apply h F hF + rw [← principalSubringCantorBendixsonAlgEquiv_aeval, hzero, map_zero] + +/-- A minimal system in `P̂` remains minimal in the equivalent graded algebra. -/ +theorem minimalSystem_cantorBendixson + (hx : OrdinalGraded.IsMinimalSystem (principalGrading K) wt x) : + OrdinalGraded.IsMinimalSystem + (DirectSum.rangeLof K (HahnSeries.Nonpositive.cantorBendixsonDegreeValuation + (G := ℝ) (R := K)).Component) + wt (fun i ↦ principalSubringCantorBendixsonAlgEquiv (x i)) := + hx.map_algEquiv principalSubringCantorBendixsonAlgEquiv + principalSubringCantorBendixsonAlgEquiv_mem_grading + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/CantorBendixsonRank.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/CantorBendixsonRank.lean new file mode 100644 index 0000000000..a65cdfa466 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/CantorBendixsonRank.lean @@ -0,0 +1,222 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.Graded +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValueValuation +public import Mathlib.Topology.Instances.Real.Lemmas + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.Additive +import LeanPool.ConwayRefinement.ConwayRefinement.Topology.Order.ClosedPWO +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValueDegree +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValueFinalSegment +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValueImage +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.StableInterval + +/-! +# A topological formula for Berarducci's ordinal value + +For a nonpositive real generalised power series, Berarducci's ordinal value is `omega` raised to +the Cantor–Bendixson rank of exponent zero in the closed support. A sufficiently short negative +support tail has order type equal to the ordinal value, and its strict supremum zero has the +corresponding point rank. The zero and one values are the bounded and constant germs. +-/ + +open Set +open scoped HahnSeries NatOrdinal + +universe v + +public noncomputable section + +namespace Berarducci + +open HahnSeries + +variable {K : Type v} [Field K] + +private theorem cantorBendixsonValue_eq_zero_of_mem_negativeMonomialIdeal + {b : Series K} (hb : b ∈ HahnSeries.Nonpositive.negativeMonomialIdeal K) : + (b : K⟦ℝ⟧).cantorBendixsonValue = 0 := by + rw [(b : K⟦ℝ⟧).cantorBendixsonValue_eq_zero_iff_support_bounded_lt + (HahnSeries.Nonpositive.support_subset b)] + have hsup := + HahnSeries.Nonpositive.mem_negativeMonomialIdeal_iff_supportSup_lt_zero.mp hb + by_cases hb0 : b = 0 + · subst b + exact ⟨-1, by norm_num, by simp⟩ + · rw [HahnSeries.Nonpositive.supportSup_of_ne hb0] at hsup + refine ⟨sSup (b : K⟦ℝ⟧).support, WithBot.coe_lt_coe.mp hsup, fun x hx ↦ ?_⟩ + exact le_csSup (HahnSeries.Nonpositive.bddAbove_support b) hx + +private theorem cantorBendixsonValue_eq_one_of_ordinalValue_eq_one + {b : Series K} (hb : ordinalValue b = 1) : + (b : K⟦ℝ⟧).cantorBendixsonValue = 1 := by + rw [HahnSeries.cantorBendixsonValue_eq_one_iff] + obtain ⟨hbNear, hbJ⟩ := ordinalValue_eq_one_iff.mp hb + have hcoeff : HahnSeries.Nonpositive.constantCoeff b ≠ 0 := by + intro hzero + apply hbJ + have h := mem_nearConstantSubgroup_iff_sub_C_constantCoeff_mem.mp hbNear + simpa [hzero] using h + refine ⟨by simpa [HahnSeries.Nonpositive.constantCoeff_apply] using hcoeff, ?_⟩ + have hJ := mem_nearConstantSubgroup_iff_sub_C_constantCoeff_mem.mp hbNear + have hcb := cantorBendixsonValue_eq_zero_of_mem_negativeMonomialIdeal hJ + have heq : + ((b - HahnSeries.Nonpositive.C (HahnSeries.Nonpositive.constantCoeff b) : Series K) : + K⟦ℝ⟧) = (b : K⟦ℝ⟧) - HahnSeries.single 0 ((b : K⟦ℝ⟧).coeff 0) := by + ext x + simp [HahnSeries.Nonpositive.coe_C, HahnSeries.Nonpositive.constantCoeff_apply] + rwa [heq] at hcb + +/-- Berarducci's ordinal value is zero off the closed support at zero and otherwise equals +`omega` raised to the Cantor–Bendixson rank there. -/ +@[blueprint "lem:ordinal-value-cantor-bendixson" + (phase := "Cantor–Bendixson ranks of supports") + (title := "Cantor--Bendixson formula for the ordinal value") + (statement := /-- + Let $b\in K((\mathbb R^{\le 0}))$. If zero does not belong to the closed + support of $b$, then $v_J(b)=0$; otherwise + \[ + v_J(b)= + \omega^{\operatorname{rk}_{\mathrm{CB},\mathrm{cl}(\operatorname{supp}(b))}(0)}. + \] + -/) + (proof := /-- + By \ref{def:cantor-bendixson-value}, the right-hand side is zero off the + closed support at $0$ and otherwise records its Cantor--Bendixson rank. + For $v_J(b)=0$ or $1$ the assertion is the definition of $J$ and of the + congruence class modulo $J+K$. If $v_J(b)=\omega^\alpha>1$, then + \ref{fact:ordinal-value-support-tail} gives $\eta<0$ for which + $\operatorname{supp}(b)\cap(\eta,0)$ has order type $\omega^\alpha$. Zero + is its strict supremum, so + \ref{lem:cantor-bendixson-rank-of-strict-supremum} gives rank $\alpha$ at + zero in the closure of this tail. The closed support of $b$ agrees with that + closure on a neighbourhood of zero. Cantor--Bendixson rank is local with + respect to closed sets, so it has the same value in the closed support. + -/)] +theorem ordinalValue_eq_cantorBendixsonValue (b : Series K) : + (ordinalValue b).val = (b : K⟦ℝ⟧).cantorBendixsonValue := by + rcases lt_trichotomy (ordinalValue b) 1 with hzero | hone | hlarge + · have hvalue : ordinalValue b = 0 := Order.lt_one_iff.mp hzero + have hbJ := ordinalValue_eq_zero_iff.mp hvalue + rw [hvalue, cantorBendixsonValue_eq_zero_of_mem_negativeMonomialIdeal hbJ] + simp + · rw [hone, cantorBendixsonValue_eq_one_of_ordinalValue_eq_one hone] + simp + · rcases ordinalValue_eq_zero_or_isAdditivelyPrincipal b with hzero | hprincipal + · exact absurd hzero (ne_of_gt (zero_lt_one.trans hlarge)) + obtain ⟨a, ha⟩ := Ordinal.isAdditivelyPrincipal_iff.mp hprincipal + let α : NatOrdinal := NatOrdinal.of a + have hvalue : ordinalValue b = ω^ α := by + apply NatOrdinal.val.injective + simpa only [α, NatOrdinal.val_wpow, NatOrdinal.val_of] using ha + obtain ⟨η, hη, htype⟩ := + exists_negativeSupportTail_orderType_eq_ordinalValue b hlarge + let T : Set ℝ := negativeSupportTail b η + let hT : T.IsPWO := + (b : K⟦ℝ⟧).isPWO_support.mono (negativeSupportTail_subset_support b η) + have hTLUB : IsLUB T 0 := + isLUB_negativeSupportTail_zero_of_one_lt_ordinalValue b hlarge hη + have hT0 : (0 : ℝ) ∉ T := fun h ↦ (mem_negativeSupportTail_iff.mp h).2.2.false + have hα0 : α.val ≠ 0 := by + intro hα + have hone' : ordinalValue b = 1 := by + rw [hvalue] + apply NatOrdinal.val.injective + simp [hα] + exact hlarge.ne' hone' + have hrankT : + TopologicalSpace.Closeds.cantorBendixsonRank + (⟨closure T, isClosed_closure⟩ : TopologicalSpace.Closeds ℝ) + hT.closure 0 = α.val := by + apply Set.IsPWO.cantorBendixsonRank_closure_eq_of_orderType_eq_opow + hT hTLUB hT0 hα0 + simpa only [T, hT, hvalue, NatOrdinal.val_wpow] using htype + have hlocal : + ((b : K⟦ℝ⟧).closedSupport : Set ℝ) ∩ Set.Ioi η = + closure T ∩ Set.Ioi η := by + apply Set.Subset.antisymm + · intro x hx + refine ⟨?_, hx.2⟩ + have hx' : x ∈ closure (b : K⟦ℝ⟧).support ∩ Set.Ioi η := by + simpa only [HahnSeries.coe_closedSupport] using hx + have hx'' := isOpen_Ioi.closure_inter hx' + apply closure_minimal (s := (b : K⟦ℝ⟧).support ∩ Set.Ioi η) + (t := closure T) ?_ isClosed_closure hx'' + rintro y ⟨hy, hηy⟩ + have hy0 : y ≤ 0 := HahnSeries.Nonpositive.support_subset b hy + rcases eq_or_lt_of_le hy0 with rfl | hyneg + · obtain ⟨z, hz, -, -⟩ := hTLUB.exists_between hη + exact hTLUB.mem_closure ⟨z, hz⟩ + · apply subset_closure + exact mem_negativeSupportTail_iff.mpr ⟨hy, hηy, hyneg⟩ + · intro x hx + refine ⟨?_, hx.2⟩ + exact (HahnSeries.mem_closedSupport _ _).mpr + (closure_mono (negativeSupportTail_subset_support b η) hx.1) + have hrank : (b : K⟦ℝ⟧).cantorBendixsonRank 0 = α.val := by + rw [HahnSeries.cantorBendixsonRank_eq] + exact ((b : K⟦ℝ⟧).closedSupport.cantorBendixsonRank_congr_on_open + ⟨closure T, isClosed_closure⟩ (b : K⟦ℝ⟧).closedSupport_isPWO hT.closure + isOpen_Ioi hlocal (by simpa using hη)).trans hrankT + have hbne : b ≠ 0 := by + intro hb0 + subst b + simp at hlarge + have hmem : 0 ∈ closure (b : K⟦ℝ⟧).support := + (isLUB_support_zero_of_ordinalValue_ne_zero (b := b) + (ne_of_gt (zero_lt_one.trans hlarge))).mem_closure + (HahnSeries.support_nonempty_iff.mpr fun hcoe ↦ hbne (Subtype.ext hcoe)) + rw [(b : K⟦ℝ⟧).cantorBendixsonValue_of_mem hmem, hrank, hvalue] + simp + +variable [CharZero K] + +/-- The Cantor degree of Berarducci's ordinal value is the Cantor–Bendixson rank at zero. -/ +@[blueprint "lem:ordinal-value-degree-is-cantor-bendixson-rank" + (phase := "Cantor–Bendixson ranks of supports") + (title := "Cantor--Bendixson formula for $\\deg_J$") + (statement := /-- + Let $b\in K((\mathbb R^{\le0}))$, and let $\deg_J(b)$ be the Cantor degree + of $v_J(b)$, with value $-\infty$ when $v_J(b)=0$. Then + \[ + \deg_J(b)= + \begin{cases} + -\infty, & 0\notin\mathrm{cl}(\operatorname{supp}(b)),\\ + \operatorname{rk}_{\mathrm{CB},\mathrm{cl}(\operatorname{supp}(b))}(0), + & 0\in\mathrm{cl}(\operatorname{supp}(b)). + \end{cases} + \] + -/) + (proof := /-- + By \ref{thm:cantor-bendixson-value-multiplicative}, taking Cantor degree of + $V_{\mathrm{CB}}$ gives the multiplicative degree on the right. Apply + Cantor degree to \ref{lem:ordinal-value-cantor-bendixson}. The Cantor degree + of $0$ is $-\infty$, and the Cantor degree of $\omega^\alpha$ is $\alpha$. + -/)] +theorem ordinalValueDegree_eq_cantorBendixsonDegree (b : Series K) : + ordinalValueDegree b = + HahnSeries.Nonpositive.cantorBendixsonDegreeValuation (G := ℝ) (R := K) b := by + rw [ordinalValueDegree_eq_cantorDegree, + HahnSeries.Nonpositive.cantorBendixsonDegreeValuation_apply, + HahnSeries.Nonpositive.cantorBendixsonValuation_apply, + NatOrdinal.cantorDegree_eq_ordinalCantorDegree, + NatOrdinal.cantorDegree_eq_ordinalCantorDegree] + exact congrArg Ordinal.cantorDegree (by + simpa only [NatOrdinal.val_of] using ordinalValue_eq_cantorBendixsonValue b) + +/-- The two max-additive degrees on nonpositive real generalised power series are equal. -/ +theorem ordinalValueDegreeValuation_eq_cantorBendixsonDegreeValuation : + ordinalValueDegreeValuation K = + HahnSeries.Nonpositive.cantorBendixsonDegreeValuation (G := ℝ) (R := K) := by + apply MaxAddDegree.ext + intro b + rw [ordinalValueDegreeValuation_apply] + exact ordinalValueDegree_eq_cantorBendixsonDegree (K := K) b + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/CantorBendixsonRepresentatives.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/CantorBendixsonRepresentatives.lean new file mode 100644 index 0000000000..280cfab2eb --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/CantorBendixsonRepresentatives.lean @@ -0,0 +1,120 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.LiftFamily +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.CantorBendixsonGrading +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.PrincipalRepresentatives + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint + +/-! +# Principal representatives for the Cantor–Bendixson degree + +The canonical identification of the two degree functions leaves the representing Hahn series +unchanged. Thus representatives for `P̂` give representatives for the associated graded ring +defined by the Cantor–Bendixson degree, and the series remain principal. +-/ + +universe v w + +open scoped HahnSeries NatOrdinal + +open Berarducci HahnSeries + +public noncomputable section + +namespace Berarducci + +variable {K : Type v} [Field K] [CharZero K] +variable {ι : Type w} {wt : ι → NatOrdinal} {x : ι → PrincipalSubring K} + +namespace Lifts + +/-- Reinterpret principal-subring lifts in the equivalent Cantor–Bendixson graded algebra. -/ +@[expose] def cantorBendixson (σ : Lifts wt x) : HahnSeries.Nonpositive.LiftFamily wt + (fun i ↦ principalSubringCantorBendixsonAlgEquiv (x i)) where + lift := σ.lift + represents i := by + simpa only [principalSubringCantorBendixsonAlgEquiv_apply] using + (σ.represents i).congr + (ordinalValueDegreeValuation_eq_cantorBendixsonDegreeValuation (K := K)) + +@[simp] +theorem cantorBendixson_lift (σ : Lifts wt x) (i : ι) : σ.cantorBendixson.lift i = σ.lift i := + rfl + +omit [CharZero K] in +/-- The generic and real translated truncations are the same Hahn series. -/ +theorem translatedTruncLE_eq_translatedTruncation (b : Series K) (y : ℝ) : + HahnSeries.Nonpositive.translatedTruncLE y b = + translatedTruncation ((b : Series K) : K⟦ℝ⟧) y := by + apply Subtype.ext + rw [HahnSeries.Nonpositive.coe_translatedTruncLE, + Berarducci.coe_translatedTruncation] + +/-- Principal real Hahn-series representatives remain principal under the graded-algebra +equivalence. -/ +@[blueprint "lem:principal-representatives-cantor-bendixson" + (phase := "Principal RV-elements") + (title := "Principal series representatives for the Cantor--Bendixson grading") + (statement := /-- + Let $K$ be a field of characteristic zero. For each $i\in I$, let + $x_i\in\mathrm P_{w_i}\subseteq\widehat{\mathrm P}$ and choose a principal + series $b_i$ of degree $w_i$ representing $x_i$. Let + $\delta_{\mathrm{CB}}$ be the Cantor--Bendixson degree identified with + $\deg_J$ by + \ref{lem:ordinal-value-degree-is-cantor-bendixson-rank}, and identify + $\widehat{\mathrm P}$ with + $\operatorname{gr}_{\delta_{\mathrm{CB}}} + K((\mathbb R^{\le0}))$ + by \ref{lem:principal-subring-cantor-bendixson}. + + The same series $b_i$ represent the images of the $x_i$ under this + isomorphism, and, for every $i\in I$, + \[ + \delta_{\mathrm{CB}}(b_i)=w_i,\qquad + \delta_{\mathrm{CB}}(b_i^{|\gamma})γ_k - γ_{k+1}} t^{γ_{k+1}}` (`combinedCofactor`). Then the support of the `j`-th +combined cofactor has order type at most `ω^{e j}`, its translated truncations at cutoffs `ζ < 0` +have ordinal value below `ω^{e j}` and vanish at cutoffs `ζ ≤ γ_0`, and — under the separation +condition (n) for `(e j, c j, τ)`, `e j ⊕ θ < τ` for every `θ < c j`, where the translated +truncations of `v j` at cutoffs `ζ < 0` have ordinal value below `ω^{c j}` — the series +`E - ∑_j (combined cofactor)_j * v j` has translated truncations of ordinal value below `ω^(τ+1)` +at every cutoff in `(γ_0, 0)`. + +For `ζ ∈ (γ_k, γ_{k+1}]` and `ξ := ζ - γ_{k+1}`: `E^{|ζ} ≡ (piece (γ k) (γ (k+1)) E)^{|ξ}` and +the translated truncation of the `j`-th combined cofactor at `ζ` is `(w k j)^{|ξ}`, both modulo +`J`; and the translated truncation of each product differs from the translated truncation of its +first factor times the second factor by a series of ordinal value below `ω^τ`. +-/ + +universe v w + +open scoped NatOrdinal HahnSeries +open Berarducci HahnSeries + +public noncomputable section + +namespace Berarducci + +variable {K : Type v} [Field K] + +/-- A point of `(γ 0, 0)` lies in an interval `(γ k, γ (k+1)]` of a strictly increasing sequence +with supremum `0`. -/ +theorem exists_lt_le_succ_of_strictMono {γ : ℕ → ℝ} (hcof : ∀ η < (0 : ℝ), ∃ k, η < γ k) {ζ : ℝ} + (h0 : γ 0 < ζ) (hζ : ζ < 0) : + ∃ k, γ k < ζ ∧ ζ ≤ γ (k + 1) := by + classical + have hex : ∃ n, ζ ≤ γ n := by + obtain ⟨n, hn⟩ := hcof ζ hζ + exact ⟨n, hn.le⟩ + have hpos : Nat.find hex ≠ 0 := by + intro h + have := Nat.find_spec hex + rw [h] at this + exact absurd this (not_le.mpr h0) + refine ⟨Nat.find hex - 1, ?_, ?_⟩ + · have := Nat.find_min hex (m := Nat.find hex - 1) (by omega) + exact not_le.mp this + · have := Nat.find_spec hex + rwa [Nat.sub_add_cancel (by omega : 1 ≤ Nat.find hex)] + +section CombinedCofactors + +variable {ι' : Type w} [Fintype ι'] (E : Series K) (γ : ℕ → ℝ) (hγ : StrictMono γ) + (hneg : ∀ k, γ k < 0) (hcof : ∀ η < (0 : ℝ), ∃ k, η < γ k) (w : ℕ → ι' → Series K) + +/-- The intervals `(γ k, γ (k+1)]` as the intervals `(γ_k + c_k, γ_k]` of the sum (m) of +`SumAlongCutoffs.lean`, with cutoffs `γ (k+1)` and `c_k := γ k - γ (k+1)`: the condition +`γ_k ≤ γ_{k+1} + c_{k+1}` of (m) holds. -/ +theorem pieces_le_add_sub (k : ℕ) : γ (k + 1) ≤ γ (k + 1 + 1) + (γ (k + 1) - γ (k + 1 + 1)) := by + linarith + +include hγ hneg in +/-- The `j`-th combined cofactor `∑_k (w_{kj})_{>γ_k - γ_{k+1}} t^{γ_{k+1}}`: the sum (m) along the +cutoffs `γ_{k+1}` with the cofactors `w k j` of the pieces as terms. -/ +def combinedCofactor (j : ι') : Series K := + sumAlongCutoffsSeries (fun k ↦ w k j) (fun k ↦ γ k - γ (k + 1)) (fun k ↦ γ (k + 1)) + (fun _ _ h ↦ hγ (by omega)) (pieces_le_add_sub γ) (fun k ↦ hneg (k + 1)) + +include hγ hneg + +omit [Fintype ι'] in +/-- At cutoffs `ζ ≤ γ 0`, the translated truncations of the combined cofactor vanish. -/ +theorem translatedTruncation_combinedCofactor_eq_zero (j : ι') {ζ : ℝ} (hζ : ζ ≤ γ 0) : + translatedTruncation ((combinedCofactor γ hγ hneg w j : Series K) : K⟦ℝ⟧) ζ = 0 := + translatedTruncation_sumAlongCutoffsSeries_eq_zero _ _ _ _ _ _ + (by linarith [hγ (Nat.lt_succ_self 0)]) + (by linarith) + +omit [Fintype ι'] in +/-- On the `k`-th interval, the translated truncations of the combined cofactor are those of +`w k j`, modulo `J`: at `γ (k+1) + ξ` for `γ k - γ (k+1) < ξ ≤ 0`, it is `(w k j)^{|ξ}`. -/ +theorem translatedTruncation_combinedCofactor_sub_mem (j : ι') (k : ℕ) {ξ : ℝ} + (hξ : γ k - γ (k + 1) < ξ) (hξ0 : ξ ≤ 0) : + translatedTruncation ((combinedCofactor γ hγ hneg w j : Series K) : K⟦ℝ⟧) (γ (k + 1) + ξ) - + translatedTruncation (w k j : K⟦ℝ⟧) ξ ∈ Nonpositive.negativeMonomialIdeal K := + translatedTruncation_sumAlongCutoffsSeries_sub_mem _ _ _ _ _ _ k hξ hξ0 + +variable {e : ι' → NatOrdinal} + (hw : ∀ k j, ((w k j : Series K) : K⟦ℝ⟧).supportOrderType < (ω^ (e j)).val) +include hw + +omit [Fintype ι'] in +/-- The support of the combined cofactor has order type at most `ω^{e j}`. -/ +theorem supportOrderType_combinedCofactor_le (j : ι') : + ((combinedCofactor γ hγ hneg w j : Series K) : K⟦ℝ⟧).supportOrderType ≤ (ω^ (e j)).val := + supportOrderType_sumAlongCutoffsSeries_le _ _ _ _ _ _ fun k ↦ hw k j + +omit [Fintype ι'] in +/-- Every translated truncation of the combined cofactor has ordinal value below `ω^(e j + 1)`. -/ +theorem ordinalValue_translatedTruncation_combinedCofactor_lt_add_one (j : ι') (ζ : ℝ) : + ordinalValue (translatedTruncation ((combinedCofactor γ hγ hneg w j : Series K) : K⟦ℝ⟧) ζ) < + ω^ (e j + 1) := by + refine (ordinalValue_translatedTruncation_le_of_supportOrderType _ ζ).trans_lt ?_ + rw [← NatOrdinal.of_val (ω^ (e j + 1)), NatOrdinal.of.lt_iff_lt] + exact (supportOrderType_combinedCofactor_le γ hγ hneg w hw j).trans_lt + (NatOrdinal.val.lt_iff_lt.mpr (NatOrdinal.wpow_lt_wpow.mpr (lt_add_one _))) + +include hcof + +omit [Fintype ι'] in +/-- **The translated truncations of the combined cofactor at cutoffs `ζ < 0` have ordinal value +below `ω^{e j}`.** -/ +theorem ordinalValue_translatedTruncation_combinedCofactor_lt (j : ι') {ζ : ℝ} (hζ : ζ < 0) : + ordinalValue (translatedTruncation ((combinedCofactor γ hγ hneg w j : Series K) : K⟦ℝ⟧) ζ) < + ω^ (e j) := by + rcases le_or_gt ζ (γ 0) with h0 | h0 + · rw [translatedTruncation_combinedCofactor_eq_zero γ hγ hneg w j h0, ordinalValue_zero] + exact NatOrdinal.wpow_pos _ + obtain ⟨k, hk1, hk2⟩ := exists_lt_le_succ_of_strictMono hcof h0 hζ + have hmem := translatedTruncation_combinedCofactor_sub_mem γ hγ hneg w j k + (ξ := ζ - γ (k + 1)) (by linarith) (by linarith) + rw [show γ (k + 1) + (ζ - γ (k + 1)) = ζ by ring] at hmem + rw [ordinalValue_eq_of_sub_mem_negativeMonomialIdeal hmem] + exact ordinalValue_translatedTruncation_lt_of_supportOrderType_lt (hw k j) _ + +variable {v : ι' → Series K} {c : ι' → NatOrdinal} {τ : NatOrdinal} + (hv : ∀ j, ∀ β : ℝ, β < 0 → ordinalValue (translatedTruncation (v j : K⟦ℝ⟧) β) < ω^ (c j)) + (hsep : ∀ j, ∀ θ, θ < c j → e j + θ < τ) + (hres : ∀ k, ∀ ξ : ℝ, γ k - γ (k + 1) < ξ → ξ ≤ 0 → + ordinalValue (translatedTruncation + ((piece (γ k) (γ (k + 1)) (E : K⟦ℝ⟧) - ∑ j, w k j * v j : Series K) : K⟦ℝ⟧) ξ) < + ω^ (τ + 1)) +include hv hsep hres + +/-- **Combining the cofactors of the pieces.** At every cutoff `ζ ∈ (γ 0, 0)`, the translated +truncation of `E - ∑_j (combined cofactor)_j * v j` has ordinal value below `ω^(τ+1)`. -/ +theorem ordinalValue_translatedTruncation_sub_sum_combinedCofactor_mul_lt {ζ : ℝ} (h0 : γ 0 < ζ) + (hζ : ζ < 0) : + ordinalValue (translatedTruncation + ((E - ∑ j, combinedCofactor γ hγ hneg w j * v j : Series K) : K⟦ℝ⟧) ζ) < ω^ (τ + 1) := by + classical + obtain ⟨k, hk1, hk2⟩ := exists_lt_le_succ_of_strictMono hcof h0 hζ + set ξ : ℝ := ζ - γ (k + 1) with hξdef + have hξ : γ k - γ (k + 1) < ξ := by rw [hξdef]; linarith + have hξ0 : ξ ≤ 0 := by rw [hξdef]; linarith + have hζξ : γ (k + 1) + ξ = ζ := by rw [hξdef]; ring + set C : ι' → Series K := combinedCofactor γ hγ hneg w with hCdef + set Dk : Series K := piece (γ k) (γ (k + 1)) (E : K⟦ℝ⟧) with hDkdef + -- the two translated truncations, expanded + have hX : translatedTruncation ((E - ∑ j, C j * v j : Series K) : K⟦ℝ⟧) ζ = + translatedTruncation (E : K⟦ℝ⟧) ζ - + ∑ j, translatedTruncation ((C j * v j : Series K) : K⟦ℝ⟧) ζ := by + rw [← translatedTruncationAddMonoidHom_apply, AddSubgroupClass.coe_sub, map_sub, + AddSubmonoidClass.coe_finsetSum, map_sum] + simp only [translatedTruncationAddMonoidHom_apply] + have hY : translatedTruncation ((Dk - ∑ j, w k j * v j : Series K) : K⟦ℝ⟧) ξ = + translatedTruncation (Dk : K⟦ℝ⟧) ξ - + ∑ j, translatedTruncation ((w k j * v j : Series K) : K⟦ℝ⟧) ξ := by + rw [← translatedTruncationAddMonoidHom_apply, AddSubgroupClass.coe_sub, map_sub, + AddSubmonoidClass.coe_finsetSum, map_sum] + simp only [translatedTruncationAddMonoidHom_apply] + have hYlt := hres k ξ hξ hξ0 + rw [hY] at hYlt + rw [hX] + -- the difference of the two expansions + set A := translatedTruncation (E : K⟦ℝ⟧) ζ + set A' := translatedTruncation (Dk : K⟦ℝ⟧) ξ + set P : ι' → Series K := fun j ↦ translatedTruncation ((C j * v j : Series K) : K⟦ℝ⟧) ζ + set Q : ι' → Series K := fun j ↦ translatedTruncation ((C j : Series K) : K⟦ℝ⟧) ζ * v j + set R : ι' → Series K := fun j ↦ translatedTruncation (w k j : K⟦ℝ⟧) ξ * v j + set P' : ι' → Series K := fun j ↦ translatedTruncation ((w k j * v j : Series K) : K⟦ℝ⟧) ξ + have hsplit : A - ∑ j, P j = (A' - ∑ j, P' j) + + ((A - A') - ∑ j, (P j - Q j) - ∑ j, (Q j - R j) + ∑ j, (P' j - R j)) := by + simp only [Finset.sum_sub_distrib] + abel + rw [hsplit] + refine (ordinalValue_add_le_max _ _).trans_lt (max_lt hYlt ?_) + refine lt_of_lt_of_le ?_ (NatOrdinal.wpow_le_wpow.mpr (lt_add_one τ).le) + -- each of the four differences has ordinal value below `ω^τ` + have hτpos : (0 : NatOrdinal) < ω^ τ := NatOrdinal.wpow_pos τ + have hAA' : ordinalValue (A - A') < ω^ τ := by + have := translatedTruncation_window_sub_mem (γ k) (γ (k + 1)) (E : K⟦ℝ⟧) hξ hξ0 + rw [hζξ] at this + rw [← ordinalValue_neg, neg_sub, ordinalValue_of_mem_negativeMonomialIdeal this] + exact hτpos + have hPQ : ∀ j, ordinalValue (P j - Q j) < ω^ τ := fun j ↦ + ordinalValue_translatedTruncation_mul_sub_mul_lt + (fun β _ ↦ ordinalValue_translatedTruncation_combinedCofactor_lt_add_one γ hγ hneg w hw j β) + (hv j) (hsep j) hζ + have hQR : ∀ j, ordinalValue (Q j - R j) < ω^ τ := fun j ↦ by + have hmem := translatedTruncation_combinedCofactor_sub_mem γ hγ hneg w j k hξ hξ0 + rw [hζξ] at hmem + have : Q j - R j ∈ Nonpositive.negativeMonomialIdeal K := by + rw [show Q j - R j = (translatedTruncation ((C j : Series K) : K⟦ℝ⟧) ζ - + translatedTruncation (w k j : K⟦ℝ⟧) ξ) * v j by simp only [Q, R]; ring] + exact Ideal.mul_mem_right _ _ hmem + rw [ordinalValue_of_mem_negativeMonomialIdeal this] + exact hτpos + have hP'R : ∀ j, ordinalValue (P' j - R j) < ω^ τ := fun j ↦ by + rcases lt_or_eq_of_le hξ0 with hξlt | hξ0' + · exact ordinalValue_translatedTruncation_mul_sub_mul_lt + (fun β _ ↦ (ordinalValue_translatedTruncation_lt_of_supportOrderType_lt (hw k j) β).trans + (NatOrdinal.wpow_lt_wpow.mpr (lt_add_one _))) + (hv j) (hsep j) hξlt + · simp only [P', R, hξ0', translatedTruncation_zero, sub_self, ordinalValue_zero] + exact hτpos + have hsum : ∀ (f : ι' → Series K), (∀ j, ordinalValue (f j) < ω^ τ) → + ordinalValue (∑ j, f j) < ω^ τ := fun f hf ↦ + ordinalValue_sum_lt _ _ hτpos fun j _ ↦ hf j + refine (ordinalValue_add_le_max _ _).trans_lt (max_lt ?_ (hsum _ hP'R)) + rw [sub_eq_add_neg] + refine (ordinalValue_add_le_max _ _).trans_lt + (max_lt ?_ (by rw [ordinalValue_neg]; exact hsum _ hQR)) + rw [sub_eq_add_neg] + exact (ordinalValue_add_le_max _ _).trans_lt + (max_lt hAA' (by rw [ordinalValue_neg]; exact hsum _ hPQ)) + +end CombinedCofactors + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/DerivAt.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/DerivAt.lean new file mode 100644 index 0000000000..a3582e0473 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/DerivAt.lean @@ -0,0 +1,293 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalComponent +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.TruncationDrop +public import LeanPool.ConwayRefinement.ConwayRefinement.Order.Filter.FunAtZeroMinus +public import LeanPool.ConwayRefinement.ConwayRefinement.Order.Filter.FunAtZeroMinus.Pointwise +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.FinitePart + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValueSubmultiplicative + +/-! +# The map `∂ : P_{α+1} → Fun_{0⁻}(P_α)` + +The paper's `∂ : P_{α+1} → Fun_{0⁻}(P_α)` (eq:derivation). Let `u ∈ J_{ω^(α+2)}`. By the +truncation drop, the translated truncations `u^{|γ}` lie in `J_{ω^(α+1)}` for all `γ < 0` +sufficiently close to `0`, so `γ ↦ u^{|γ} + J_{ω^α}` is a function at `0⁻` with values in `P_α`. +If `u ∈ J_{ω^(α+1)}`, the same lemma with `β = α` makes this function zero. Since translated +truncation is `K`-linear in `u`, this defines the `K`-linear map +`∂(u + J_{ω^(α+1)}) := (γ ↦ u^{|γ} + J_{ω^α})`. + +In Lean the component of successor degree is indexed by `α` itself (`0 < α.constantCoeff`) and the +component one degree below it by `α.removeNat 1`, written `α⁻` in these docstrings: +`principalComponentDerivAt K α hα` is +`∂` on `P_{α+1}` in the paper's indexing and `P_α → Fun_{0⁻}(P_{α⁻})` in Lean's. The value +`derivAt α u γ` is `∂(u)(γ)`, set to zero at the `γ` where `u^{|γ} ∉ J_{ω^α}`; the function at +`0⁻` does not depend on those values. +-/ + +open Filter Topology +open scoped HahnSeries NatOrdinal + +universe v + +public noncomputable section + +namespace Berarducci + +open Berarducci HahnSeries + +variable {K : Type v} [Field K] + +private theorem removeOne_add_one (alpha : NatOrdinal) + (halpha : 0 < alpha.constantCoeff) : + alpha.removeNat 1 + 1 = alpha := + by simpa using NatOrdinal.removeNat_add_natCast halpha + +/-- `∂(u)(γ)`, the class of the translated truncation `u^{|γ}` in `P_α` (paper eq:derivation); +in Lean's indexing it lies in `P_{α⁻}`, the component indexed by the predecessor of the successor +`α`. At the `γ` where +`u^{|γ} ∉ J_{ω^α}` the value is set to zero; the function at `0⁻` is independent of those +values. -/ +def derivAt (alpha : NatOrdinal) + (b : Series K) (gamma : ℝ) : + PrincipalComponent K (alpha.removeNat 1) := + if h : ordinalValue (translatedTruncation (b : K⟦ℝ⟧) gamma) < + ω^ (alpha.removeNat 1 + 1) then + principalComponentMk (alpha.removeNat 1) + (translatedTruncation (b : K⟦ℝ⟧) gamma) h + else + 0 + +/-- On its domain, `derivAt` is the class of the translated truncation. -/ +theorem derivAt_eq (alpha : NatOrdinal) + (b : Series K) (gamma : ℝ) + (h : ordinalValue (translatedTruncation (b : K⟦ℝ⟧) gamma) < + ω^ (alpha.removeNat 1 + 1)) : + derivAt alpha b gamma = + principalComponentMk (alpha.removeNat 1) + (translatedTruncation (b : K⟦ℝ⟧) gamma) h := by + simp only [derivAt, dite_eq_left h] + +/-- A series in `J_{ω^(α+1)}` has translated truncations in `J_{ω^α} = J_{ω^(α⁻+1)}` near zero +(truncation drop with `β = α`). -/ +theorem eventually_derivAt_bound (alpha : NatOrdinal) (halpha : 0 < alpha.constantCoeff) + (b : Series K) (hb : ordinalValue b < ω^ (alpha + 1)) : + ∀ᶠ gamma in 𝓝[<] (0 : ℝ), + ordinalValue (translatedTruncation (b : K⟦ℝ⟧) gamma) < + ω^ (alpha.removeNat 1 + 1) := by + have h := eventually_ordinalValue_translatedTruncation_lt_wpow_of_ordinalValue_lt_wpow_add_one + alpha b hb + simpa only [removeOne_add_one alpha halpha] using h + +/-- For all `γ < 0` sufficiently close to `0`, `∂(u)(γ)` is the class of the translated +truncation `u^{|γ}` in `P_{α⁻}`, the component indexed by the predecessor of `α`. -/ +theorem eventually_derivAt_eq_principalComponentMk + (alpha : NatOrdinal) (halpha : 0 < alpha.constantCoeff) + (b : Series K) (hb : ordinalValue b < ω^ (alpha + 1)) : + ∀ᶠ gamma in 𝓝[<] (0 : ℝ), + ∃ hgamma : ordinalValue (translatedTruncation (b : K⟦ℝ⟧) gamma) < + ω^ (alpha.removeNat 1 + 1), + derivAt alpha b gamma = + principalComponentMk (alpha.removeNat 1) + (translatedTruncation (b : K⟦ℝ⟧) gamma) hgamma := by + filter_upwards [eventually_derivAt_bound alpha halpha b hb] with + gamma hgamma + exact ⟨hgamma, derivAt_eq alpha b gamma hgamma⟩ + +/-- The quotient projection to `P_α` preserves addition. -/ +theorem principalComponentMk_add (alpha : NatOrdinal) + (b c : Series K) + (hb : ordinalValue b < ω^ (alpha + 1)) + (hc : ordinalValue c < ω^ (alpha + 1)) + (hbc : ordinalValue (b + c) < ω^ (alpha + 1)) : + principalComponentMk alpha (b + c) hbc = + principalComponentMk alpha b hb + + principalComponentMk alpha c hc := by + let w := ordinalValueDegreeValuation K + rw [principalComponentMk_eq_componentMk, principalComponentMk_eq_componentMk, + principalComponentMk_eq_componentMk] + change w.componentMk alpha ⟨b + c, _⟩ = + w.componentMk alpha ⟨b, _⟩ + w.componentMk alpha ⟨c, _⟩ + rw [← map_add] + apply congrArg (w.componentMk alpha) + rfl + +private theorem eventually_derivAt_add + (alpha : NatOrdinal) (halpha : 0 < alpha.constantCoeff) + (b c : Series K) + (hb : ordinalValue b < ω^ (alpha + 1)) + (hc : ordinalValue c < ω^ (alpha + 1)) : + ∀ᶠ gamma in 𝓝[<] (0 : ℝ), + derivAt alpha (b + c) gamma = + derivAt alpha b gamma + + derivAt alpha c gamma := by + have hbc : ordinalValue (b + c) < ω^ (alpha + 1) := + (ordinalValue_add_le_max b c).trans_lt (max_lt hb hc) + filter_upwards [eventually_derivAt_bound alpha halpha b hb, + eventually_derivAt_bound alpha halpha c hc, + eventually_derivAt_bound alpha halpha (b + c) hbc] with + gamma hbg hcg hbcg + rw [derivAt_eq alpha b gamma hbg, + derivAt_eq alpha c gamma hcg, + derivAt_eq alpha (b + c) gamma hbcg] + have hseries : translatedTruncation ((b + c : Series K) : K⟦ℝ⟧) gamma = + translatedTruncation (b : K⟦ℝ⟧) gamma + translatedTruncation (c : K⟦ℝ⟧) gamma := + translatedTruncation_add (b : K⟦ℝ⟧) (c : K⟦ℝ⟧) gamma + have hsum : ordinalValue + (translatedTruncation (b : K⟦ℝ⟧) gamma + translatedTruncation (c : K⟦ℝ⟧) gamma) < + ω^ (alpha.removeNat 1 + 1) := by + rwa [← hseries] + convert principalComponentMk_add (alpha.removeNat 1) + (translatedTruncation (b : K⟦ℝ⟧) gamma) + (translatedTruncation (c : K⟦ℝ⟧) gamma) hbg hcg hsum using 1 + simp only [hseries] + +variable (K) in +/-- `u ↦ ∂(u)` as an additive map on the ideal `J_{ω^(α+1)}`, valued in `Fun_{0⁻}(P_{α⁻})`. -/ +private def filtrationDerivAt (alpha : NatOrdinal) (halpha : 0 < alpha.constantCoeff) : + (ordinalValueDegreeValuation K).filtrationLE alpha →+ + FunAtZeroMinus (PrincipalComponent K (alpha.removeNat 1)) where + toFun b := (derivAt (K := K) alpha b : + FunAtZeroMinus (PrincipalComponent K (alpha.removeNat 1))) + map_zero' := (FunAtZeroMinus.coe_eq_zero_iff _).mpr <| + Filter.Eventually.of_forall fun gamma ↦ by + have hzero : ordinalValue (translatedTruncation (0 : K⟦ℝ⟧) gamma) < + ω^ (alpha.removeNat 1 + 1) := by + rw [translatedTruncation_zero_input, ordinalValue_zero] + exact NatOrdinal.wpow_pos _ + rw [ZeroMemClass.coe_zero, derivAt_eq alpha 0 gamma hzero] + exact (principalComponentMk_eq_zero_iff _ _ hzero).mpr (by + rw [translatedTruncation_zero_input, ordinalValue_zero] + exact NatOrdinal.wpow_pos _) + map_add' := by + intro b c + change (derivAt (K := K) alpha (b + c) : + FunAtZeroMinus (PrincipalComponent K (alpha.removeNat 1))) = + (derivAt (K := K) alpha b : + FunAtZeroMinus (PrincipalComponent K (alpha.removeNat 1))) + + (derivAt (K := K) alpha c : + FunAtZeroMinus (PrincipalComponent K (alpha.removeNat 1))) + rw [← Filter.Germ.coe_add, Filter.Germ.coe_eq] + exact eventually_derivAt_add alpha halpha (b : Series K) (c : Series K) + ((mem_ordinalValueDegreeValuation_filtrationLE_iff (b : Series K) alpha).mp b.2) + ((mem_ordinalValueDegreeValuation_filtrationLE_iff (c : Series K) alpha).mp c.2) + +variable (K) in +/-- A series `u ∈ J_{ω^α}` has `∂(u) = 0` (truncation drop with `β = α⁻`). -/ +private theorem lowerFiltration_le_filtrationDerivAt_ker + (alpha : NatOrdinal) (halpha : 0 < alpha.constantCoeff) : + (ordinalValueDegreeValuation K).lowerFiltration alpha ≤ + (filtrationDerivAt K alpha halpha).ker := by + let w := ordinalValueDegreeValuation K + intro b hb + refine (FunAtZeroMinus.coe_eq_zero_iff (derivAt (K := K) alpha b)).mpr ?_ + have hbValue : ordinalValue (b : Series K) < ω^ (alpha.removeNat 1 + 1) := by + rw [removeOne_add_one alpha halpha] + have hvalue := (w.mem_lowerFiltration_iff alpha b).mp hb + rw [ordinalValueDegreeValuation_apply] at hvalue + exact (ordinalValueDegree_lt_coe_iff _ alpha).mp hvalue + have hdrop := eventually_ordinalValue_translatedTruncation_lt_wpow_of_ordinalValue_lt_wpow_add_one + (alpha.removeNat 1) (b : Series K) hbValue + filter_upwards [hdrop] with gamma hgamma + have hupper : ordinalValue (translatedTruncation ((b : Series K) : K⟦ℝ⟧) gamma) < + ω^ (alpha.removeNat 1 + 1) := + hgamma.trans (NatOrdinal.wpow_lt_wpow.mpr (lt_add_one _)) + rw [derivAt_eq alpha (b : Series K) gamma hupper] + exact (principalComponentMk_eq_zero_iff _ _ hupper).mpr hgamma + +variable (K) in +private def principalComponentDerivAtAdd + (alpha : NatOrdinal) (halpha : 0 < alpha.constantCoeff) : + PrincipalComponent K alpha →+ FunAtZeroMinus (PrincipalComponent K (alpha.removeNat 1)) := + QuotientAddGroup.lift + ((ordinalValueDegreeValuation K).lowerFiltration alpha) + (filtrationDerivAt K alpha halpha) + (lowerFiltration_le_filtrationDerivAt_ker K alpha halpha) + +private theorem principalComponentDerivAtAdd_principalComponentMk + (alpha : NatOrdinal) (halpha : 0 < alpha.constantCoeff) + (b : Series K) (hb : ordinalValue b < ω^ (alpha + 1)) : + principalComponentDerivAtAdd K alpha halpha (principalComponentMk alpha b hb) = + (derivAt (K := K) alpha b : + FunAtZeroMinus (PrincipalComponent K (alpha.removeNat 1))) := by + let w := ordinalValueDegreeValuation K + rw [principalComponentMk_eq_componentMk, ← w.coe_component_eq_componentMk] + rfl + +private theorem eventually_derivAt_smul + (alpha : NatOrdinal) (halpha : 0 < alpha.constantCoeff) + (k : K) (b : Series K) (hb : ordinalValue b < ω^ (alpha + 1)) : + ∀ᶠ gamma in 𝓝[<] (0 : ℝ), + derivAt alpha + ((HahnSeries.Nonpositive.C : K →+* Series K) k * b) gamma = + k • derivAt alpha b gamma := by + let kb := (HahnSeries.Nonpositive.C : K →+* Series K) k * b + have hkb : ordinalValue kb < ω^ (alpha + 1) := by + rcases eq_or_ne k 0 with rfl | hk + · simp [kb] + · calc + ordinalValue kb ≤ ordinalValue ((HahnSeries.Nonpositive.C : K →+* Series K) k) * + ordinalValue b := ordinalValue_mul_le_naturalMul _ _ + _ = ordinalValue b := by rw [ordinalValue_C_of_ne hk, one_mul] + _ < ω^ (alpha + 1) := hb + filter_upwards [eventually_derivAt_bound alpha halpha b hb, + eventually_derivAt_bound alpha halpha kb hkb] with gamma hbg hkbg + rw [derivAt_eq alpha b gamma hbg, + derivAt_eq alpha kb gamma hkbg] + have hseries : translatedTruncation (kb : K⟦ℝ⟧) gamma = + (HahnSeries.Nonpositive.C : K →+* Series K) k * translatedTruncation (b : K⟦ℝ⟧) gamma := by + rw [show (kb : K⟦ℝ⟧) = HahnSeries.C k * (b : K⟦ℝ⟧) by + change ((((HahnSeries.Nonpositive.C : K →+* Series K) k) * b : Series K) : K⟦ℝ⟧) = _ + rw [Subring.coe_mul, HahnSeries.Nonpositive.coe_C]] + exact translatedTruncation_C_mul k (b : K⟦ℝ⟧) gamma + have hproduct : ordinalValue + ((HahnSeries.Nonpositive.C : K →+* Series K) k * translatedTruncation (b : K⟦ℝ⟧) gamma) < + ω^ (alpha.removeNat 1 + 1) := by + rwa [← hseries] + convert (smul_principalComponentMk (alpha.removeNat 1) k + (translatedTruncation (b : K⟦ℝ⟧) gamma) hbg).symm using 1 + simp only [hseries] + +private theorem principalComponentDerivAtAdd_map_smul + (alpha : NatOrdinal) (halpha : 0 < alpha.constantCoeff) + (k : K) (x : PrincipalComponent K alpha) : + principalComponentDerivAtAdd K alpha halpha (k • x) = + k • principalComponentDerivAtAdd K alpha halpha x := by + obtain ⟨b, hb, rfl⟩ := exists_principalComponentMk alpha x + rw [smul_principalComponentMk alpha k b hb, + principalComponentDerivAtAdd_principalComponentMk, + principalComponentDerivAtAdd_principalComponentMk] + change (derivAt alpha + ((HahnSeries.Nonpositive.C : K →+* Series K) k * b) : + FunAtZeroMinus (PrincipalComponent K (alpha.removeNat 1))) = + k • (derivAt (K := K) alpha b : + FunAtZeroMinus (PrincipalComponent K (alpha.removeNat 1))) + rw [← Filter.Germ.coe_smul, Filter.Germ.coe_eq] + exact eventually_derivAt_smul alpha halpha k b hb + +variable (K) in +/-- `∂` on `P_{α+1}` (paper eq:derivation): in Lean's indexing, the `K`-linear map +`P_α → Fun_{0⁻}(P_{α⁻})` for a successor `α`, where `α⁻ = α.removeNat 1` is the ordinal one below +`α`. -/ +def principalComponentDerivAt (alpha : NatOrdinal) (halpha : 0 < alpha.constantCoeff) : + PrincipalComponent K alpha →ₗ[K] FunAtZeroMinus (PrincipalComponent K (alpha.removeNat 1)) := + { principalComponentDerivAtAdd K alpha halpha with + map_smul' := principalComponentDerivAtAdd_map_smul alpha halpha } + +/-- On any representative `u ∈ J_{ω^(α+1)}`, `∂(u + J_{ω^α})` is the function at `0⁻` +`γ ↦ ∂(u)(γ)`, the class of the translated truncation `u^{|γ}` in `P_{α⁻}`. -/ +theorem principalComponentDerivAt_principalComponentMk + (alpha : NatOrdinal) (halpha : 0 < alpha.constantCoeff) + (b : Series K) (hb : ordinalValue b < ω^ (alpha + 1)) : + principalComponentDerivAt K alpha halpha (principalComponentMk alpha b hb) = + (derivAt (K := K) alpha b : + FunAtZeroMinus (PrincipalComponent K (alpha.removeNat 1))) := + principalComponentDerivAtAdd_principalComponentMk alpha halpha b hb + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/DerivAtInjective.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/DerivAtInjective.lean new file mode 100644 index 0000000000..059465ce67 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/DerivAtInjective.lean @@ -0,0 +1,170 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.DerivAt +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.UnboundedTruncations + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.StableInterval +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValueFinalSegment +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValueImage +import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.SetOrderType +import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.AdditivelyPrincipal +import Mathlib.Topology.Instances.Real.Lemmas + +/-! +# Injectivity of translated truncation on `P_α` for successor `α` + +For every `α`, `∂` is injective on `P_{α+1}` (Berarducci's Lem. 6.8 in the present language). +Let `α = β + 1` be a successor ordinal and `u` a series with `v_J(u) = ω^α = ω^β · ω`. A +sufficiently short support tail `B` of `u` is order isomorphic to `ω` copies of `ω^β`. Let `S` +be its first block, the set of points of `B` of index below `ω^β`, and let `γ = sup S`. Then +`v_J(u^{|γ}) = ω^β`: + +* if `β = 0`, then `S` is a single support point `γ`, so `u^{|γ}` has nonzero constant term and + support otherwise bounded away from zero; +* if `β ≥ 1`, then `ω^β` is a limit, `S` has no largest element, the exponents of `u^{|γ}` + immediately below zero are the translates of final segments of `S`, and every nonempty final + segment of `S` has order type `ω^β` because `ω^β` is additively indecomposable. + +Applying this to the tail above any `θ < 0` produces cutoffs `γ ∈ (θ, 0)` at which +`∂(u)(γ) = u^{|γ} + J_{ω^β}` is nonzero, so `∂(B) ≠ 0` for every nonzero `B ∈ P_α`. +-/ + +open Filter Topology Ordinal +open scoped HahnSeries NatOrdinal + +universe v + +public noncomputable section + +namespace Berarducci + +open Berarducci HahnSeries + +variable {K : Type v} [Field K] + +/-- If `v_J(u) = ω^(β+1)` and `θ < 0`, there is a cutoff `θ < γ < 0` with +`v_J(u^{|γ}) = ω^β`. -/ +@[blueprint "lem:successor-truncation-value" + (phase := "Translated truncations") + (title := "Translated truncations of successor ordinal value") + (statement := /-- + Let $\beta<\omega_1$ and $b\in K((\mathbb R^{\le0}))$. If + $v_J(b)=\omega^{\beta+1}$, then for every $\theta<0$ there is + $\gamma\in(\theta,0)$ such that $v_J(b^{|\gamma})=\omega^\beta$. + -/) + (proof := /-- + By \ref{fact:ordinal-value-support-tail}, choose above $\theta$ a support + tail $B$ of order type + $\omega^{\beta+1}=\omega^\beta\cdot\omega$. Let $S$ be its initial block + of order type $\omega^\beta$, and put $\gamma=\sup S$. + + If $\beta=0$, then $S=\{\gamma\}$. The translated truncation has a non-zero + constant coefficient and a gap immediately below zero, so its ordinal value + is $1$. + + If $\beta>0$, then $\omega^\beta$ is an additively principal limit ordinal. + The set $S$ is a final segment of the support below $\gamma$, giving + $v_J(b^{|\gamma})\le\omega^\beta$. Every interval immediately below + $\gamma$ contains a final segment of $S$, still of order type + $\omega^\beta$, giving the reverse inequality. Thus + $v_J(b^{|\gamma})=\omega^\beta$, and the choice of $B$ gives + $\theta<\gamma<0$. + -/)] +theorem exists_ordinalValue_translatedTruncation_eq_wpow_of_ordinalValue_eq_wpow_add_one + (beta : NatOrdinal) (u : Series K) (hu : ordinalValue u = ω^ (beta + 1)) + {θ : ℝ} (hθ : θ < 0) : + ∃ γ : ℝ, θ < γ ∧ γ < 0 ∧ ordinalValue (translatedTruncation (u : K⟦ℝ⟧) γ) = ω^ beta := by + exact exists_ordinalValue_translatedTruncation_eq_wpow_of_lt (lt_add_one beta) u hu hθ + +/-- A nonzero class in `P_α`, for successor `α`, has a representative of ordinal value exactly +`ω^α`. -/ +theorem ordinalValue_eq_wpow_of_principalComponentMk_ne_zero (alpha : NatOrdinal) + (u : Series K) (hu : ordinalValue u < ω^ (alpha + 1)) + (hne : principalComponentMk alpha u hu ≠ 0) : + ordinalValue u = ω^ alpha := by + have hnot : ¬ ordinalValue u < ω^ alpha := fun h ↦ + hne ((principalComponentMk_eq_zero_iff alpha u hu).mpr h) + rcases ordinalValue_eq_zero_or_isAdditivelyPrincipal u with hzero | hprincipal + · exact absurd (hzero ▸ NatOrdinal.wpow_pos alpha) hnot + · have hxi := Ordinal.natOrdinal_of_eq_wpow_log hprincipal + rw [NatOrdinal.of_val] at hxi + rw [hxi] at hu hnot ⊢ + rw [NatOrdinal.wpow_inj] + exact le_antisymm (Order.lt_add_one_iff.mp (NatOrdinal.wpow_lt_wpow.mp hu)) + (not_lt.mp fun h ↦ hnot (NatOrdinal.wpow_lt_wpow.mpr h)) + +/-- If `α` is a successor, translated truncation sends every nonzero class in `P_α` to a nonzero +function at `0⁻`. -/ +theorem principalComponentDerivAt_ne_zero + (alpha : NatOrdinal) (halpha : 0 < alpha.constantCoeff) + {x : PrincipalComponent K alpha} (hx : x ≠ 0) : + principalComponentDerivAt K alpha halpha x ≠ 0 := by + obtain ⟨u, hu, rfl⟩ := exists_principalComponentMk alpha x + have hvalue := ordinalValue_eq_wpow_of_principalComponentMk_ne_zero alpha u hu hx + have halpha' : alpha.removeNat 1 + 1 = alpha := by + simpa using NatOrdinal.removeNat_add_natCast halpha + rw [principalComponentDerivAt_principalComponentMk] + intro hzero + obtain ⟨θ, hθ, hθzero⟩ := (FunAtZeroMinus.coe_eq_zero_iff_exists _).mp hzero + obtain ⟨γ, hθγ, hγ0, hγvalue⟩ := + exists_ordinalValue_translatedTruncation_eq_wpow_of_ordinalValue_eq_wpow_add_one + (alpha.removeNat 1) u + (by rw [hvalue, halpha']) hθ + have hbound : ordinalValue (translatedTruncation (u : K⟦ℝ⟧) γ) < ω^ (alpha.removeNat 1 + 1) := by + rw [hγvalue] + exact NatOrdinal.wpow_lt_wpow.mpr (lt_add_one _) + have hcut := hθzero γ hθγ hγ0 + rw [derivAt_eq alpha u γ hbound, principalComponentMk_eq_zero_iff, hγvalue] at hcut + exact lt_irrefl _ hcut + +variable (K) in +/-- Translated truncation is injective on `P_α` for every successor ordinal `α`. -/ +@[blueprint "prop:successor-principal-rv-injective" + (phase := "Translated truncations") + (title := "Injectivity of the translated-truncation map on $\\mathrm P_\\alpha$") + (statement := /-- + Let $K$ be a field, let $\alpha<\omega_1$ be a successor ordinal, and write + $\alpha=\beta+1$. Put + \[ + \mathrm P_\delta:=J_{\omega^{\delta+1}}/J_{\omega^\delta}. + \] + Let $\operatorname{Fun}_{0^-}(V)$ be the space of $V$-valued functions on + intervals $(\eta,0)$, identified when they agree sufficiently close to $0$. + Then the $K$-linear map + \[ + \partial_\alpha:\mathrm P_\alpha\longrightarrow + \operatorname{Fun}_{0^-}(\mathrm P_\beta),\qquad + \partial_\alpha([b])=[\gamma\mapsto[b^{|\gamma}]], + \] + is injective. The inner class is taken modulo $J_{\omega^\beta}$. + -/) + (proof := /-- + By \ref{lem:truncation-drop}, every series of ordinal value below + $\omega^\alpha$ has translated truncations of ordinal value below $\omega^\beta$ + sufficiently close to $0$. Thus translated truncation induces the displayed map on the + quotient. + + A nonzero class $[b]\in\mathrm P_\alpha$ has a representative with + $v_J(b)=\omega^\alpha$. By + \ref{lem:successor-truncation-value}, every interval $(\theta,0)$ contains + a cutoff $\gamma$ with $v_J(b^{|\gamma})=\omega^\beta$. Hence + $[b^{|\gamma}]\ne0$ in $\mathrm P_\beta$, so + $\partial_\alpha([b])\ne0$. The kernel of the linear map + $\partial_\alpha$ is therefore zero, and the map is injective. + -/)] +theorem principalComponentDerivAt_injective + (alpha : NatOrdinal) (halpha : 0 < alpha.constantCoeff) : + Function.Injective (principalComponentDerivAt K alpha halpha) := by + rw [← LinearMap.ker_eq_bot, LinearMap.ker_eq_bot'] + intro x hx + by_contra hne + exact principalComponentDerivAt_ne_zero alpha halpha hne hx + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/DerivationIdeal.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/DerivationIdeal.lean new file mode 100644 index 0000000000..6ba1b57496 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/DerivationIdeal.lean @@ -0,0 +1,256 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.LoweringDerivation +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.GradedRing.HomogeneousSpan +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.SumAlongCutoffs +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.OmegaSupport +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.DerivAtInjective + +/-! +# Ideal membership of a class from ideal membership of its derivative + +Let `α` be a successor ordinal and `(q_1, …, q_m) ⊆ P̂` the ideal generated by finitely many +homogeneous elements `q j` of degrees `c j` that are zero or limits (so `∂ q_j = 0`). For +`x ∈ P_α`, if `∂(x)` is the class of a function at `0⁻` with values in `(q_1, …, q_m)`, then +`x ∈ (q_1, …, q_m)`; indeed `x = ∑_j q_j w_j` with `w_j ∈ P_{μ_j + 1}` and `μ_j + c_j = α ⊖ 1`. + +The proof uses that every function at `0⁻` vanishing outside a sequence `γ_k ↑ 0` is a derivative, +and that `∂` is injective on `P_α`. Take a principal representative `p` of `x`; its derivative +`γ ↦ ∂(p)(γ)` vanishes outside a strictly increasing sequence of cutoffs `γ_k` with supremum `0` +(`exists_principal_representative_derivAt`). Decompose the value at `γ_k`, an element of +`(q_1, …, q_m) ∩ P_{α ⊖ 1}`, as `∑_j q_j a_{jk}` with `a_{jk} ∈ P_{μ_j}`, without any coherence in +`k` (`exists_decompose_eq_sum_mul_of_mem_span`). Each `k ↦ a_{jk}` is the derivative of the class +`w_j ∈ P_{μ_j + 1}` of a sum along the cutoffs `γ_k` (`exists_sumAlongCutoffs`). +Since `∂` is a derivation and `∂ q_j = 0`, `∂(∑_j q_j w_j) = ∑_j q_j ∂(w_j) = ∂(x)`, and `∂` is +injective on `P_α`. +-/ + +universe v w + +open scoped NatOrdinal HahnSeries +open Berarducci HahnSeries LoweringDerivation DirectSum + +public noncomputable section + +namespace Berarducci + +variable {K : Type v} [Field K] + +/-- The class of a series in `P̂`, through an equality of indices. -/ +theorem of_principalComponentMk_congr {β β' : NatOrdinal} (h : β = β') (t : Series K) + (hβ : ordinalValue t < ω^ (β + 1)) (hβ' : ordinalValue t < ω^ (β' + 1)) : + DirectSum.of (PrincipalComponent K) β (principalComponentMk β t hβ) = + DirectSum.of (PrincipalComponent K) β' (principalComponentMk β' t hβ') := by + subst h + rfl + +/-- The class of a function at `0⁻` of a finite sum is the sum of the classes. -/ +theorem funAtZeroMinus_coe_sum {ι : Type w} (s : Finset ι) (g : ι → ℝ → PrincipalSubring K) : + ((fun ξ ↦ ∑ j ∈ s, g j ξ : ℝ → PrincipalSubring K) : FunAtZeroMinus (PrincipalSubring K)) = + ∑ j ∈ s, ((g j : ℝ → PrincipalSubring K) : FunAtZeroMinus (PrincipalSubring K)) := by + have : (fun ξ ↦ ∑ j ∈ s, g j ξ : ℝ → PrincipalSubring K) = ∑ j ∈ s, g j := by + ext ξ + simp [Finset.sum_apply] + rw [this] + exact map_sum (Filter.Germ.coeRingHom _) g s + +/-- `∂` vanishes on homogeneous elements of degree zero or a limit. -/ +theorem principalSubringDerivation_eq_zero_of_constantCoeff_eq_zero {c : NatOrdinal} + (hc : c.constantCoeff = 0) {q : PrincipalSubring K} (hq : q ∈ principalGrading K c) : + principalSubringDerivation K q = 0 := by + obtain ⟨b, rfl⟩ := (DirectSum.mem_rangeLof_iff K _ c q).mp hq + rw [DirectSum.lof_eq_of, principalSubringDerivation_of, + principalComponentDerivation_of_eq_zero hc] + +/-- **A sequence of values at the cutoffs `γ_k` is the derivative of a class.** Given cutoffs +`γ_k ↑ 0` and, for each `k`, an element `u k ∈ P_β` (`β + c = δ`), there is `w ∈ P̂` with +`q * w ∈ P_{δ+1}` for `q ∈ P_c`, whose derivative is the class of a function equal to `u k` at +`γ_k` and to `0` at every other cutoff in `(γ_0, 0)`. When no `β` with `β + c = δ` exists (and +then every `u k = 0`), `w = 0`. -/ +theorem exists_principalSubringDerivation_eq_of_forall {δ c : NatOrdinal} {q : PrincipalSubring K} + (hq : q ∈ principalGrading K c) (γ : ℕ → ℝ) (hγ : StrictMono γ) (hneg : ∀ k, γ k < 0) + (hcof : ∀ η < (0 : ℝ), ∃ k, η < γ k) (u : ℕ → PrincipalSubring K) + (hu : ∀ k, ∀ β, β + c = δ → u k ∈ principalGrading K β) + (hu0 : ∀ k, (¬ ∃ β, β + c = δ) → u k = 0) : + ∃ w : PrincipalSubring K, q * w ∈ principalGrading K (δ + 1) ∧ + ∃ g : ℝ → PrincipalSubring K, principalSubringDerivation K w = (g : FunAtZeroMinus _) ∧ + (∀ k, g (γ k) = u k) ∧ ∀ ξ, γ 0 < ξ → ξ < 0 → (∀ k, ξ ≠ γ k) → g ξ = 0 := by + classical + by_cases h : ∃ β, β + c = δ + · obtain ⟨μ, hμ⟩ := h + -- the values, as elements of the homogeneous component `P_μ` + have ha : ∀ k, ∃ a : PrincipalComponent K μ, + DirectSum.of (PrincipalComponent K) μ a = u k := fun k ↦ by + obtain ⟨a, ha⟩ := (DirectSum.mem_rangeLof_iff K _ μ (u k)).mp (hu k μ hμ) + exact ⟨a, by rw [← DirectSum.lof_eq_of K]; exact ha⟩ + choose a ha using ha + -- the sum (m) along the cutoffs `γ_k` whose derivative takes these values + obtain ⟨s, hs, hsk, hsoff⟩ := exists_sumAlongCutoffs μ γ hγ hneg hcof a + have hidx : (μ + 1).removeNat 1 = μ := by + have h1 : 1 ≤ (μ + 1).constantCoeff := by + have := NatOrdinal.constantCoeff_add_natCast μ 1 + rw [Nat.cast_one] at this + omega + have := NatOrdinal.removeNat_add_natCast (a := μ + 1) (n := 1) h1 + rw [Nat.cast_one] at this + exact add_right_cancel this + have hpos : 0 < (μ + 1).constantCoeff := by + have := NatOrdinal.constantCoeff_add_natCast μ 1 + rw [Nat.cast_one] at this + omega + refine ⟨DirectSum.of (PrincipalComponent K) (μ + 1) (principalComponentMk (μ + 1) s hs), ?_, + fun ξ ↦ DirectSum.of (PrincipalComponent K) ((μ + 1).removeNat 1) (derivAt (μ + 1) s ξ), ?_, + fun k ↦ ?_, fun ξ hξ0 hξ hξk ↦ ?_⟩ + · -- the degree of `q * w` + have hmem := SetLike.mul_mem_graded hq (of_mem_principalGrading (μ + 1) + (principalComponentMk (μ + 1) s hs)) + have heq : c + (μ + 1) = δ + 1 := by rw [← add_assoc, add_comm c μ, hμ] + rwa [heq] at hmem + · rw [principalSubringDerivation_of, principalComponentDerivation_principalComponentMk hpos] + · -- the value at `γ k` + obtain ⟨hk, hak⟩ := hsk k + have hk' : ordinalValue (translatedTruncation (s : K⟦ℝ⟧) (γ k)) < + ω^ ((μ + 1).removeNat 1 + 1) := by rwa [hidx] + beta_reduce + rw [derivAt_eq (μ + 1) s (γ k) hk', of_principalComponentMk_congr hidx _ hk' hk, hak, ha] + · -- the value at a cutoff that is not a `γ k` + have hlt := hsoff ξ hξ0 hξ hξk + have hk' : ordinalValue (translatedTruncation (s : K⟦ℝ⟧) ξ) < + ω^ ((μ + 1).removeNat 1 + 1) := by + rw [hidx] + exact hlt.trans (NatOrdinal.wpow_lt_wpow.mpr (lt_add_one μ)) + beta_reduce + rw [derivAt_eq (μ + 1) s ξ hk', of_principalComponentMk_congr hidx _ hk' (by + exact hlt.trans (NatOrdinal.wpow_lt_wpow.mpr (lt_add_one μ))), + (principalComponentMk_eq_zero_iff μ _ _).mpr hlt, map_zero] + · refine ⟨0, by rw [mul_zero]; exact zero_mem _, fun _ ↦ 0, by rw [map_zero]; rfl, + fun k ↦ (hu0 k h).symm, fun _ _ _ _ ↦ rfl⟩ + +/-- **Ideal membership of a class from ideal membership of its derivative.** Let `α` be a +successor ordinal, let `q j ∈ P_{c j}` be finitely many homogeneous elements of degrees `c j` that +are zero or limits, and let `x ∈ P_α`. If `∂(x)` is the class of a function at `0⁻` with values in +the ideal `(q_1, …, q_m)`, then `x` lies in that ideal. -/ +@[blueprint "prop:ideal-from-derivative" + (phase := "Translated truncations") + (title := "Derivative criterion for homogeneous ideal membership") + (statement := /-- + Let $K$ be a field and let $(q_j)_{j\in I}$ be a finite family in + $\widehat{\mathrm P}$. Suppose that $q_j$ is homogeneous of degree $c_j$ + and that the coefficient of $\omega^0$ in the Cantor normal form of $c_j$ + is zero for every $j$. Let $\alpha$ be an ordinal whose coefficient of + $\omega^0$ is positive, and let $x\in\mathrm P_\alpha$. If + $f\colon\mathbb R\to\widehat{\mathrm P}$ satisfies + \[ + f(\xi)\in(q_j:j\in I)\quad\text{for every }\xi\in\mathbb R + \] + and the lowering derivative $\partial x$ is the class of $f$ at $0^-$, + then + \[ + x\in(q_j:j\in I)\subseteq\widehat{\mathrm P}. + \] + -/) + (proof := /-- + By \ref{lem:successor-principal-rv-countable-support}, choose a principal series + representing $x$ whose derivative is supported on a strictly increasing + sequence of cutoffs cofinal below $0$. At each cutoff, decompose the value of + $f$ separately as a homogeneous linear combination of the $q_j$. For each + $j$, apply \ref{prop:realise-derivative} to the resulting sequence of + coefficients, obtaining a homogeneous element $w_j$ whose derivative has + exactly those values at the chosen cutoffs and vanishes between them. + + The coefficient condition on $c_j$ gives $\partial q_j=0$. Hence + \ref{thm:leibniz-rule-lowering-derivation} shows that + \[ + \partial\!\left(x-\sum_j q_jw_j\right)=0: + \] + at a chosen cutoff this is the selected homogeneous decomposition of + $f(\xi)$, and between the cutoffs both representative functions vanish near + $0$. The expression in parentheses is homogeneous of degree $\alpha$. + The same injectivity of the lowering derivative used in the representative + theorem applies because the coefficient of $\omega^0$ in $\alpha$ is + positive. Therefore $x=\sum_jq_jw_j$ and $x\in(q_j:j\in I)$. + -/)] +theorem mem_span_of_principalSubringDerivation_eq_coe {ι : Type w} [Finite ι] + {q : ι → PrincipalSubring K} {c : ι → NatOrdinal} (hq : ∀ j, q j ∈ principalGrading K (c j)) + (hc : ∀ j, (c j).constantCoeff = 0) {α : NatOrdinal} (hα : 0 < α.constantCoeff) + {x : PrincipalSubring K} (hx : x ∈ principalGrading K α) {f : ℝ → PrincipalSubring K} + (hf : ∀ ξ, f ξ ∈ Ideal.span (Set.range q)) + (hΔ : principalSubringDerivation K x = (f : FunAtZeroMinus (PrincipalSubring K))) : + x ∈ Ideal.span (Set.range q) := by + classical + cases nonempty_fintype ι + set δ := α.removeNat 1 with hδdef + have hδ : δ + 1 = α := by + have := NatOrdinal.removeNat_add_natCast (a := α) (n := 1) hα + rwa [Nat.cast_one] at this + have hinj := (principalSubringDerivation_isLoweringDerivation K).injective hα hx + -- `x` is the class of a principal series `p` + obtain ⟨a, hax⟩ := (DirectSum.mem_rangeLof_iff K _ α x).mp hx + rw [DirectSum.lof_eq_of] at hax + by_cases ha : a = 0 + · rw [← hax, ha, map_zero] + exact Ideal.zero_mem _ + obtain ⟨p, hp, -, -, hpa, γ, hγ, hneg, hcof, hsupp⟩ := + exists_principal_representative_derivAt α hα ha + have hΔx : principalSubringDerivation K x = + ((fun ξ ↦ DirectSum.of (PrincipalComponent K) δ (derivAt α p ξ) : ℝ → PrincipalSubring K) : + FunAtZeroMinus (PrincipalSubring K)) := by + rw [← hax, ← hpa, principalSubringDerivation_of, + principalComponentDerivation_principalComponentMk hα] + -- `f` agrees with `ξ ↦ ∂(p)(ξ)` on `(-ε, 0)` + rw [hΔx] at hΔ + obtain ⟨ε, hε, hfε⟩ := (funAtZeroMinus_coe_eq_iff_exists _ _).mp hΔ + -- decompose the values at the cutoffs along the generators + have hdec := fun k ↦ OrdinalGraded.exists_decompose_eq_sum_mul_of_mem_span + (𝒜 := principalGrading K) hq + (hf (γ k)) δ + choose u hu hu0 hsum using hdec + -- each sequence of coefficients `k ↦ u k j` is the derivative of a class `w j` + have hreal := fun j ↦ exists_principalSubringDerivation_eq_of_forall (hq j) γ hγ hneg hcof + (fun k ↦ u k j) (fun k β hβ ↦ hu k j β hβ) (fun k h ↦ hu0 k j h) + choose w hw g hg hgk hgoff using hreal + -- the difference `x - ∑ q_j w_j` has zero derivative + have hy : x - ∑ j, q j * w j ∈ principalGrading K α := + sub_mem hx (hδ ▸ sum_mem fun j _ ↦ hw j) + have hΔy : principalSubringDerivation K (x - ∑ j, q j * w j) = 0 := by + have hΔw : principalSubringDerivation K (∑ j, q j * w j) = + ((fun ξ ↦ ∑ j, q j * g j ξ : ℝ → PrincipalSubring K) : + FunAtZeroMinus (PrincipalSubring K)) := by + rw [map_sum, funAtZeroMinus_coe_sum] + refine Finset.sum_congr rfl fun j _ ↦ ?_ + rw [principalSubringDerivation_mul, + principalSubringDerivation_eq_zero_of_constantCoeff_eq_zero + (hc j) (hq j), zero_mul, zero_add, hg j, FunAtZeroMinus.const_mul_coe] + rw [map_sub, hΔx, hΔw, ← Filter.Germ.coe_sub, FunAtZeroMinus.coe_eq_zero_iff_exists] + refine ⟨max (-ε) (γ 0), max_lt (by linarith) (hneg 0), fun ξ hξ1 hξ2 ↦ ?_⟩ + rw [max_lt_iff] at hξ1 + simp only [Pi.sub_apply] + by_cases hξk : ∃ k, γ k = ξ + · obtain ⟨k, rfl⟩ := hξk + -- at a cutoff: `f (γ k) ∈ P_δ` equals its decomposition + have hfk : f (γ k) = DirectSum.of (PrincipalComponent K) δ (derivAt α p (γ k)) := + (hfε (γ k) hξ1.1 hξ2).symm + have hfδ : f (γ k) ∈ principalGrading K δ := hfk ▸ of_mem_principalGrading δ _ + rw [← hfk, sub_eq_zero, ← decompose_of_mem_same (principalGrading K) hfδ, hsum k] + exact Finset.sum_congr rfl fun j _ ↦ by rw [hgk j k] + · -- off the cutoffs both sides vanish + push Not at hξk + have h0 : derivAt α p ξ = 0 := by + by_contra hne + obtain ⟨k, hk⟩ := hsupp ξ hξ2 hne + exact hξk k hk + rw [h0, map_zero, Finset.sum_eq_zero fun j _ ↦ by + rw [hgoff j ξ hξ1.2 hξ2 fun k ↦ (hξk k).symm, mul_zero], sub_zero] + have hx' := (principalSubringDerivation_isLoweringDerivation K).injective hα hy hΔy + rw [sub_eq_zero] at hx' + rw [hx'] + exact Ideal.sum_mem _ fun j _ ↦ Ideal.mul_mem_right _ _ (Ideal.subset_span ⟨j, rfl⟩) + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/IdealFromTruncations.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/IdealFromTruncations.lean new file mode 100644 index 0000000000..b77770777b --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/IdealFromTruncations.lean @@ -0,0 +1,280 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.InductionOverDegrees +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.StableInterval + +/-! +# Ideal membership of a class from the condition (p) on its translated truncations + +Let the polynomials `q j ∈ K[X]` be finitely many homogeneous polynomials of non-zero limit +degrees `c j` (the degrees `σ_j` of the generators), let `h = b j ⊕ c j < α` (`h` the degree `μ` +of the series being reduced, `b j` the cofactor degrees `ρ_j`) and assume evaluation injective +below `α`; let the degree `τ` satisfy `τ + 1 < h` and the separation condition (n) for every +`(b j, c j, τ)`: `b j ⊕ θ < τ` for every `θ < c j`. Let `u` be a series with `v_J(u) = ω^h` whose +translated truncations `u^{|γ}` at the cutoffs `γ` of some interval `(η, 0)` satisfy (p) for +`(q_1, …, q_m; τ)`: above the degree `τ`, the polynomial of every such translated truncation lies +in the ideal `(q_1, …, q_m) ⊆ K[X]`. Then the class of `u` in `P_h` lies in the ideal +`(q_1(𝓑), …, q_m(𝓑)) ⊆ P̂`. + +*Proof.* On an interval `(η, 0)` on which `ot(supp u ∩ (γ, 0)) = v_J(u)` for all `γ ∈ [η, 0)` +(Berarducci's remark after [Ber00, Def. 5.2]; +`exists_forall_later_negativeSupportTail_orderType_eq_ordinalValue`), every piece of `u` on +`(γ_k, γ_{k+1}]`, translated to `0`, with `γ_k ↑ 0`, has support of order type below `ω^h` and +translated truncations satisfying (p); the induction over degrees (`InductionOverDegrees.lean`) +yields for each piece cofactors such that every translated truncation of the difference has +ordinal value below `ω^(τ+1)`; the combined cofactors (`CombinedCofactors.lean`) are series `C_j` +of ordinal value below `ω^(b j + 1)` with `u - ∑_j C_j · q_j(b_𝓑)` of translated truncations of +ordinal value below `ω^(τ+1)` at every cutoff in `(η, 0)`, whence +`v_J(u - ∑_j C_j · q_j(b_𝓑)) < ω^(τ+2) ≤ ω^h` +(`ordinalValue_lt_wpow_add_one_of_forall_translatedTruncation_lt`): in `P_h`, the class of `u` is +the sum over `j` of the class of `C_j` in `P_{b j}` times `q_j(𝓑)`. +-/ + +universe v w + +open scoped NatOrdinal HahnSeries +open Berarducci HahnSeries MvPolynomial DirectSum OrdinalGraded + +public noncomputable section + +namespace Berarducci + +variable {K : Type v} [Field K] {ι : Type w} {wt : ι → NatOrdinal} {x : ι → PrincipalSubring K} + +namespace Lifts + +variable (σ : Lifts wt x) (hx : IsMinimalSystem (principalGrading K) wt x) {α : NatOrdinal} + (hinj : ∀ β < α, InjectiveAt K wt x β) (hσ : σ.IsPrincipal) +include hinj hσ + +/-- **Ideal membership from translated truncations.** If the high-degree components of the +polynomial representatives of the translated truncations of `u` lie in the indicated polynomial +ideal sufficiently close to zero, then the degree-`h` class of `u` lies in the evaluated ideal. -/ +@[blueprint "prop:ideal-from-truncations" + (phase := "Limit ordinals in the degree induction") + (title := "Ideal membership from translated truncations") + (statement := /-- + Let $K$ be a field and let $\mathcal B$ be a minimal homogeneous generating + system of $\widehat{\mathrm P}$ with principal representatives $b_B$. + Assume evaluation is injective below $\alpha$. Let $I$ be a finite index + set, and let $Q_j\in K[X_B:B\in\mathcal B]$ be weighted homogeneous of + nonzero degree $\sigma_j$ that is a limit ordinal. Suppose + \[ + \rho_j\oplus\sigma_j=\mu<\alpha,\qquad + \tau+1<\mu,\qquad + \rho_j\oplus\theta<\tau\quad(\theta<\sigma_j) + \] + for every $j$. + + Let $u\in K((\mathbb R^{\le0}))$ have ordinal value + $v_J(u)=\omega^\mu$. Suppose there is $\eta<0$ such that + \[ + \operatorname{pol}_{<\alpha}(u^{|\gamma})_{\ge\tau} + \in (Q_j:j\in I) + \] + for every $\eta<\gamma<0$. Then the degree-$\mu$ class + $u+J_{\omega^\mu}\in\mathrm P_\mu$, embedded in + $\widehat{\mathrm P}$, lies in + \[ + (Q_j(\mathcal B):j\in I)\subseteq\widehat{\mathrm P}. + \] + -/) + (proof := /-- + Choose a negative interval on which every support tail of $u$ has order type + $v_J(u)=\omega^\mu$, and cut that tail along a sequence $\gamma_k\uparrow0$. + Each interval piece has support order strictly below $\omega^\mu$ and + inherits the high-degree ideal condition. For a piece whose support degree is + at most $\tau$, take zero cofactors; otherwise apply + \ref{lem:induction-over-degrees} at that degree. + + Combine the piecewise cofactors into series $C_j$. Their support bounds give + $v_J(C_j)<\omega^{\rho_j+1}$, while every translated truncation sufficiently + close to zero of $u-\sum_jC_jQ_j(b_B)$ has ordinal value below + $\omega^{\tau+1}$. Consequently the residual series has ordinal value below + $\omega^{\tau+2}$. Since $\tau+1<\mu$, one has $\tau+2\le\mu$, and hence + this value is at most $\omega^\mu$. Thus $u$ and + $\sum_jC_jQ_j(b_B)$ define the same degree-$\mu$ class. Multiplicativity of + representatives then places this class in $(Q_j(\mathcal B):j\in I)$. + -/)] +theorem IsPrincipal.of_principalComponentMk_mem_span_of_forall_componentsGE_mem + {ι' : Type*} [Finite ι'] {q : ι' → MvPolynomial ι K} {c : ι' → NatOrdinal} + (hq : ∀ j, IsWeightedHomogeneous wt (q j) (c j)) (hc : ∀ j, (c j).constantCoeff = 0) + (hc0 : ∀ j, c j ≠ 0) {τ h : NatOrdinal} {b : ι' → NatOrdinal} (hb : ∀ j, b j + c j = h) + (hsep : ∀ j, ∀ θ, θ < c j → b j + θ < τ) (hτh : τ + 1 < h) (hhα : h < α) {u : Series K} + (hu : ordinalValue u = ω^ h) (hu' : ordinalValue u < ω^ (h + 1)) {η : ℝ} (hη : η < 0) + (htrunc : ∀ γ : ℝ, η < γ → γ < 0 → + componentsGE wt τ (σ.pol hx α (translatedTruncation (u : K⟦ℝ⟧) γ)) ∈ + Ideal.span (Set.range q)) : + DirectSum.of (PrincipalComponent K) h (principalComponentMk h u hu') ∈ + Ideal.span (Set.range fun j ↦ aeval x (q j)) := by + classical + cases nonempty_fintype ι' + have hwt : ∀ i, wt i ≠ 0 := hx.ne_zero + have h0 : 0 < h := lt_of_le_of_lt zero_le hτh + have hτ2 : τ + 1 + 1 ≤ h := Order.add_one_le_of_lt hτh + have hhα' : h ≤ α := hhα.le + have hqcut : ∀ j, ∀ β : ℝ, β < 0 → + ordinalValue (translatedTruncation (aeval σ.lift (q j) : K⟦ℝ⟧) β) < ω^ (c j) := fun j β hβ ↦ + hσ.ordinalValue_translatedTruncation_aeval_lt hwt (hq j) hβ + -- an interval `(η₀, 0)` on which `ot(supp u ∩ (ξ, 0)) = v_J(u) = ω^h` for all `ξ ∈ (η₀, 0)` + have hone : 1 < ordinalValue u := by + rw [hu, ← NatOrdinal.wpow_zero] + exact NatOrdinal.wpow_lt_wpow.mpr h0 + obtain ⟨η₀, hη₀, hstable⟩ := + exists_forall_later_negativeSupportTail_orderType_eq_ordinalValue u hone + set η₁ : ℝ := max η η₀ with hη₁def + have hη₁ : η₁ < 0 := max_lt hη hη₀ + set ε : ℝ := -η₁ / 2 with hεdef + have hε : 0 < ε := by rw [hεdef]; linarith + -- the pieces on `(γ k, γ (k+1)]` + set γ : ℕ → ℝ := fun k ↦ -ε / ((k : ℝ) + 1) with hγdef + have hγ : StrictMono γ := strictMono_neg_div_succ hε + have hneg : ∀ k, γ k < 0 := neg_div_succ_neg hε + have hcof : ∀ η' < (0 : ℝ), ∃ k, η' < γ k := fun η' hη' ↦ exists_lt_neg_div_succ ε hη' + have hγ0 : γ 0 = -ε := by simp [hγdef] + have hγ0gt : η₁ < γ 0 := by rw [hγ0, hεdef]; linarith + have hγle : ∀ k, γ 0 ≤ γ k := fun k ↦ hγ.monotone (Nat.zero_le k) + have hηγ : ∀ k, η < γ k := fun k ↦ (le_max_left η η₀).trans_lt (hγ0gt.trans_le (hγle k)) + have hη₀γ : ∀ k, η₀ < γ k := fun k ↦ (le_max_right η η₀).trans_lt (hγ0gt.trans_le (hγle k)) + -- every piece has support of order type below `ω^h` + have hwinot : ∀ k, ((piece (γ k) (γ (k + 1)) (u : K⟦ℝ⟧) : Series K) : K⟦ℝ⟧).supportOrderType < + (ω^ h).val := by + intro k + -- `T`, the part of `u` on `(γ k, 0)`, has support of order type `ω^h` + set T : K⟦ℝ⟧ := truncGT (γ k) (truncLT 0 (u : K⟦ℝ⟧)) with hTdef + have hTsupp : T.support = negativeSupportTail u (γ k) := by + ext y + rw [hTdef, support_truncGT, support_truncLT, mem_negativeSupportTail_iff] + simp only [Set.mem_ofPred_eq] + tauto + have hTot : T.supportOrderType = (ω^ h).val := by + rw [supportOrderType_eq_setOrderType, ← hu] + rw [← hstable (γ k) (hη₀γ k) (hneg k)] + exact Set.IsPWO.orderType_congr _ _ hTsupp + -- split `T` at `γ (k+1)`; the part above is nonempty + have hsplit := supportOrderType_eq_truncLE_add_truncGT (γ (k + 1)) T + have hhigh : (truncGT (γ (k + 1)) T).supportOrderType ≠ 0 := by + rw [supportOrderType_eq_setOrderType, Ne, Set.IsPWO.orderType_eq_zero] + have hne : (negativeSupportTail u (γ (k + 1))).Nonempty := by + rw [Set.nonempty_iff_ne_empty] + intro hemp + have := hstable (γ (k + 1)) (hη₀γ (k + 1)) (hneg (k + 1)) + rw [Set.IsPWO.orderType_congr _ Set.isPWO_empty hemp, + (Set.isPWO_empty (α := ℝ)).orderType_eq_zero.mpr rfl, hu] at this + exact absurd this.symm (ne_of_gt (Ordinal.opow_pos _ Ordinal.omega0_pos)) + obtain ⟨y, hy⟩ := hne + rw [mem_negativeSupportTail_iff] at hy + refine Set.nonempty_iff_ne_empty.mp ⟨y, ?_⟩ + rw [support_truncGT, hTdef, support_truncGT, support_truncLT] + exact ⟨⟨⟨hy.1, hy.2.2⟩, by linarith [hγ (Nat.lt_succ_self k), hy.2.1]⟩, hy.2.1⟩ + have hlow : (truncLE (γ (k + 1)) T).supportOrderType < (ω^ h).val := by + by_contra hge + rw [not_lt] at hge + have : (ω^ h).val < (truncLE (γ (k + 1)) T).supportOrderType + + (truncGT (γ (k + 1)) T).supportOrderType := + lt_of_lt_of_le (lt_add_of_pos_right _ (pos_iff_ne_zero.mpr hhigh)) (add_le_add hge le_rfl) + rw [← hsplit, hTot] at this + exact lt_irrefl _ this + -- the piece is the part of `T` below `γ (k+1)`, translated + have hset : (truncGT (γ k) (truncLE (γ (k + 1)) (u : K⟦ℝ⟧))).support = + (truncLE (γ (k + 1)) T).support := by + ext y + rw [support_truncGT, support_truncLE, support_truncLE, hTdef, support_truncGT, + support_truncLT] + simp only [Set.mem_ofPred_eq] + constructor + · rintro ⟨⟨h1, h2⟩, h3⟩ + exact ⟨⟨⟨h1, by linarith [hneg (k + 1)]⟩, h3⟩, h2⟩ + · rintro ⟨⟨⟨h1, -⟩, h3⟩, h2⟩ + exact ⟨⟨h1, h2⟩, h3⟩ + rw [coe_piece, supportOrderType_translate, supportOrderType_eq_setOrderType, + Set.IsPWO.orderType_congr _ (truncLE (γ (k + 1)) T).isPWO_support hset, + ← supportOrderType_eq_setOrderType] + exact hlow + -- the translated truncations of every piece satisfy (p) + have hwinctrl : ∀ k, ∀ θ : ℝ, θ ≤ 0 → + componentsGE wt τ (σ.pol hx α (translatedTruncation + ((piece (γ k) (γ (k + 1)) (u : K⟦ℝ⟧) : Series K) : K⟦ℝ⟧) θ)) ∈ + Ideal.span (Set.range q) := by + intro k θ hθ + rcases le_or_gt θ (γ k - γ (k + 1)) with h | h + · rw [translatedTruncation_eq_zero_of_forall_lt fun y hy ↦ + lt_of_le_of_lt h (lt_of_mem_support_piece hy), σ.pol_zero hx hinj, componentsGE_zero] + exact Ideal.zero_mem _ + · have hmem := translatedTruncation_window_sub_mem (γ k) (γ (k + 1)) (u : K⟦ℝ⟧) h hθ + have hval : ordinalValue (translatedTruncation + ((piece (γ k) (γ (k + 1)) (u : K⟦ℝ⟧) : Series K) : K⟦ℝ⟧) θ) < ω^ α := + (ordinalValue_translatedTruncation_lt_of_supportOrderType_lt (hwinot k) θ).trans_le + (NatOrdinal.wpow_le_wpow.mpr hhα') + rw [σ.pol_congr hx hinj hval (toGerm_eq_toGerm_iff.mpr hmem)] + exact htrunc _ (by linarith [hηγ k]) (by linarith [hneg (k + 1)]) + -- the induction over degrees in every piece + have hwin : ∀ k, ∃ w : ι' → Series K, + (∀ j, ((w j : Series K) : K⟦ℝ⟧).supportOrderType < (ω^ (b j)).val) ∧ + ∀ θ : ℝ, θ ≤ 0 → ordinalValue (translatedTruncation + ((piece (γ k) (γ (k + 1)) (u : K⟦ℝ⟧) - ∑ j, w j * aeval σ.lift (q j) : Series K) : K⟦ℝ⟧) + θ) < ω^ (τ + 1) := by + intro k + obtain ⟨hk, hhk1, hDk⟩ := exists_supportOrderType_lt_wpow_add_one h0.ne' (hwinot k) + have hhkh : hk < h := Order.add_one_le_iff.mp hhk1 + rcases le_or_gt hk τ with hτk | hτk + · refine ⟨fun _ ↦ 0, fun j ↦ ?_, fun θ _ ↦ ?_⟩ + · rw [Subring.coe_zero, supportOrderType_eq_setOrderType] + simp only [HahnSeries.support_zero] + rw [(Set.isPWO_empty.orderType_eq_zero).mpr rfl] + exact Ordinal.opow_pos _ Ordinal.omega0_pos + · simp only [zero_mul, Finset.sum_const_zero, sub_zero] + exact (ordinalValue_translatedTruncation_lt_of_supportOrderType_lt hDk θ).trans_le + (NatOrdinal.wpow_le_wpow.mpr (add_le_add_left hτk 1)) + · have he : ∀ j, ∃ e, e + c j = hk := fun j ↦ by + obtain ⟨b', -, hb'⟩ := NatOrdinal.exists_le_add_eq_of_forall_add_lt (hc0 j) (hsep j) hτk + (hhkh.le.trans_eq (hb j).symm) + exact ⟨b', hb'⟩ + choose e he using he + obtain ⟨w, hw1, hw2⟩ := + IsPrincipal.exists_forall_ordinalValue_translatedTruncation_sub_sum_mul_aeval_lt + σ hx hinj hσ hq hc hc0 hb hsep hhα hk hτk hhkh.le e he _ hDk (hwinctrl k) + refine ⟨w, fun j ↦ (hw1 j).trans_le (NatOrdinal.val.le_iff_le.mpr + (NatOrdinal.wpow_le_wpow.mpr ?_)), hw2⟩ + have : e j < b j := lt_of_add_lt_add_right ((he j).trans_lt (hhkh.trans_eq (hb j).symm)) + exact Order.add_one_le_of_lt this + choose w hw1 hw2 using hwin + -- the combined cofactors + set C : ι' → Series K := fun j ↦ combinedCofactor γ hγ hneg w j with hCdef + have hCot : ∀ j, ((C j : Series K) : K⟦ℝ⟧).supportOrderType ≤ (ω^ (b j)).val := + fun j ↦ supportOrderType_combinedCofactor_le γ hγ hneg w hw1 j + have hCv : ∀ j, ordinalValue (C j) < ω^ (b j + 1) := fun j ↦ + (ordinalValue_le_supportOrderType _).trans_lt (by + rw [← NatOrdinal.of_val (ω^ (b j + 1)), NatOrdinal.of.lt_iff_lt] + exact (hCot j).trans_lt (NatOrdinal.val.lt_iff_lt.mpr + (NatOrdinal.wpow_lt_wpow.mpr (lt_add_one _)))) + have hres : ∀ ζ, γ 0 < ζ → ζ < 0 → ordinalValue (translatedTruncation + ((u - ∑ j, C j * aeval σ.lift (q j) : Series K) : K⟦ℝ⟧) ζ) < ω^ (τ + 1) := + fun ζ h1 h2 ↦ + ordinalValue_translatedTruncation_sub_sum_combinedCofactor_mul_lt u γ hγ hneg hcof w + hw1 hqcut hsep (fun k θ _ h2 ↦ hw2 k θ h2) h1 h2 + have hsmall : ordinalValue (u - ∑ j, C j * aeval σ.lift (q j)) < ω^ h := + (ordinalValue_lt_wpow_add_one_of_forall_translatedTruncation_lt (hneg 0) hres).trans_le + (NatOrdinal.wpow_le_wpow.mpr hτ2) + -- the classes + have hrepS : Represents (∑ j, C j * aeval σ.lift (q j)) h + (∑ j, DirectSum.of (PrincipalComponent K) (b j) (principalComponentMk (b j) (C j) (hCv j)) * + aeval x (q j)) := + represents_sum _ _ _ _ fun j _ ↦ + ((represents_iff.mpr ⟨hCv j, rfl⟩).mul (σ.aeval_represents (hq j))).of_eq (hb j) + have hmk : principalComponentMk h u hu' = + principalComponentMk h (∑ j, C j * aeval σ.lift (q j)) hrepS.ordinalValue_lt := + (principalComponentMk_eq_iff h _ _ hu' hrepS.ordinalValue_lt).mpr hsmall + rw [hmk, hrepS.of_principalComponentMk] + exact Ideal.sum_mem _ fun j _ ↦ Ideal.mul_mem_left _ _ (Ideal.subset_span ⟨j, rfl⟩) + +end Lifts + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/InductionOverDegrees.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/InductionOverDegrees.lean new file mode 100644 index 0000000000..fd55c987d0 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/InductionOverDegrees.lean @@ -0,0 +1,228 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.SupportLoweringPieces +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.Separation + +/-! +# The induction over degrees + +Let the polynomials `q j ∈ K[X]` be homogeneous of nonzero degrees `c j` that are limit ordinals +(the degrees +`σ_j` of the generators), let `h = b j ⊕ c j` (`h` the degree `μ` of the series being reduced, +`b j` the cofactor degrees `ρ_j`), and let the degree `τ` satisfy the separation condition (n) for +every `(b j, c j, τ)`: `b j ⊕ θ < τ` for every `θ < c j`. Let `h < α` and assume evaluation +injective below `α`. For every degree `h'` with `τ < h' ≤ h` — then `h' = e j ⊕ c j` with +`e j ≤ b j` (`Separation.lean`) — and every series `D` whose support has order type below +`ω^(h'+1)` and whose translated truncations satisfy (p) for `(q_1, …, q_m; τ)`, there are +cofactors `u j` with supports of order type below `ω^(e j + 1)` such that every translated +truncation of `D - ∑_j u_j · q_j(b_𝓑)` has ordinal value below `ω^(τ+1)`. + +The proof is a well-founded induction on `h'`: the order type of the support of `D` is lowered +below `ω^{h'}` in one step when `h' = τ + 1` (the successor-degree bound) and by cutting into +pieces when `h' ≥ τ + 2` (`SupportLoweringPieces`, with the induction hypothesis at the degrees +of the pieces); the result has support of order type below `ω^{h'}`, hence below `ω^(h''+1)` for +some `h'' < h'`, and the induction hypothesis at `h''` finishes (or the bound is already below +`ω^(τ+1)`). +-/ + +universe v w + +open scoped NatOrdinal HahnSeries +open Berarducci HahnSeries MvPolynomial OrdinalGraded + +public noncomputable section + +namespace Berarducci + +variable {K : Type v} [Field K] + +/-- The order type of the support of a nonpositive series, as a natural ordinal below `ω^g`, lies +below `ω^(h''+1)` for some `h''` with `h'' + 1 ≤ g`. -/ +theorem exists_supportOrderType_lt_wpow_add_one {D : Series K} {g : NatOrdinal} (hg : g ≠ 0) + (hD : (D : K⟦ℝ⟧).supportOrderType < (ω^ g).val) : + ∃ h'', h'' + 1 ≤ g ∧ (D : K⟦ℝ⟧).supportOrderType < (ω^ (h'' + 1)).val := by + have h : NatOrdinal.of (D : K⟦ℝ⟧).supportOrderType < ω^ g := by + rw [← NatOrdinal.of_val (ω^ g)] + exact NatOrdinal.of.lt_iff_lt.mpr hD + obtain ⟨h'', h1, h2⟩ := exists_lt_wpow_add_one_of_lt_wpow hg h + refine ⟨h'', h1, ?_⟩ + rw [← NatOrdinal.of_val (ω^ (h'' + 1)), NatOrdinal.of.lt_iff_lt] at h2 + exact h2 + +/-- A series whose support has order type below `ω^(τ+1)` has all translated truncations of value +below `ω^(τ+1)`. -/ +theorem ordinalValue_translatedTruncation_lt_of_supportOrderType_lt' {D : Series K} + {τ : NatOrdinal} (hD : (D : K⟦ℝ⟧).supportOrderType < (ω^ (τ + 1)).val) (ξ : ℝ) : + ordinalValue (translatedTruncation (D : K⟦ℝ⟧) ξ) < ω^ (τ + 1) := + ordinalValue_translatedTruncation_lt_of_supportOrderType_lt hD ξ + +variable {ι : Type w} {wt : ι → NatOrdinal} {x : ι → PrincipalSubring K} + +namespace Lifts + +variable (σ : Lifts wt x) (hx : IsMinimalSystem (principalGrading K) wt x) {α : NatOrdinal} + (hinj : ∀ β < α, InjectiveAt K wt x β) (hσ : σ.IsPrincipal) +include hinj hσ + +/-- **Cofactor reduction at intermediate degrees.** For every intermediate degree and compatible +cofactor degrees, the stated translated-truncation ideal condition yields cofactors whose +remainder has translated truncations of ordinal value below `ω^(τ+1)`. -/ +@[blueprint "lem:induction-over-degrees" + (phase := "Limit ordinals in the degree induction") + (title := "Translated-truncation approximation at intermediate degrees") + (statement := /-- + Let $K$ be a field and let $\mathcal B$ be a minimal homogeneous generating + system of $\widehat{\mathrm P}$ with principal representatives $b_B$. + Assume evaluation is injective below $\alpha$. Let $I$ be a finite index + set, and let $Q_j\in K[X_B:B\in\mathcal B]$ be weighted homogeneous of + nonzero degree $\sigma_j$ that is a limit ordinal. Let $\mu<\alpha$, and suppose + \[ + \rho_j\oplus\sigma_j=\mu,\qquad + \rho_j\oplus\theta<\tau\quad(\theta<\sigma_j) + \] + for every $j$. + + For every $\mu'$ with $\tau<\mu'\le\mu$, every family $(\rho'_j)_{j\in I}$ + satisfying $\rho'_j\oplus\sigma_j=\mu'$, and every series + $u\in K((\mathbb R^{\le0}))$ such that + \[ + \operatorname{ot}(\operatorname{supp}(u))<\omega^{\mu'+1} + \] + and + \[ + \operatorname{pol}_{<\alpha}(u^{|\xi})_{\ge\tau} + \in (Q_j:j\in I)\quad(\xi\le0), + \] + there are series $u_j$ with + \[ + \operatorname{ot}(\operatorname{supp}(u_j))<\omega^{\rho'_j+1} + \] + and + \[ + v_J\!\left((u-\sum_ju_jQ_j(b_B))^{|\xi}\right) + <\omega^{\tau+1}\quad(\xi\le0). + \] + -/) + (proof := /-- + Use well-founded induction on $\mu'$. By + \ref{lem:intermediate-ordinal-hessenberg-decomposition}, each + $\rho'_j\le\rho_j$, so the separation inequalities remain valid; the same + result supplies cofactor degrees at every smaller degree used below. + + For a series with support order below $\omega^{\mu'}$, choose $\mu''<\mu'$ + such that its support order is below $\omega^{\mu''+1}$. If + $\mu''\le\tau$, zero cofactors suffice. Otherwise apply the induction + hypothesis at $\mu''$. + + If $\mu'=\tau+1$, apply \ref{lem:successor-support-lowering}, then convert + its support bound into the required translated-truncation bound. If + $\tau+1<\mu'$, apply \ref{lem:lower-by-pieces} to obtain first cofactors + whose remainder has support order below $\omega^{\mu'}$ and retains the + high-degree ideal condition. Apply the auxiliary induction hypothesis to + this remainder and add the two cofactor families. The natural-sum support + estimate gives the required bounds. + -/)] +theorem IsPrincipal.exists_forall_ordinalValue_translatedTruncation_sub_sum_mul_aeval_lt + {ι' : Type*} [Fintype ι'] {q : ι' → MvPolynomial ι K} {c : ι' → NatOrdinal} + (hq : ∀ j, IsWeightedHomogeneous wt (q j) (c j)) (hc : ∀ j, (c j).constantCoeff = 0) + (hc0 : ∀ j, c j ≠ 0) {τ h : NatOrdinal} {b : ι' → NatOrdinal} (hb : ∀ j, b j + c j = h) + (hsep : ∀ j, ∀ θ, θ < c j → b j + θ < τ) (hhα : h < α) : + ∀ h' : NatOrdinal, τ < h' → h' ≤ h → ∀ e : ι' → NatOrdinal, (∀ j, e j + c j = h') → + ∀ D : Series K, (D : K⟦ℝ⟧).supportOrderType < (ω^ (h' + 1)).val → + (∀ ξ : ℝ, ξ ≤ 0 → + componentsGE wt τ (σ.pol hx α (translatedTruncation (D : K⟦ℝ⟧) ξ)) ∈ + Ideal.span (Set.range q)) → + ∃ u : ι' → Series K, (∀ j, ((u j : Series K) : K⟦ℝ⟧).supportOrderType < (ω^ (e j + 1)).val) ∧ + ∀ ξ : ℝ, ξ ≤ 0 → ordinalValue (translatedTruncation + ((D - ∑ j, u j * aeval σ.lift (q j) : Series K) : K⟦ℝ⟧) ξ) < ω^ (τ + 1) := by + classical + intro h' + induction h' using WellFoundedLT.induction with + | _ h' ih => + intro hτh' hh'h e he D hD htrunc + have hh'α : h' < α := hh'h.trans_lt hhα + -- the cofactor degrees at `h'` are at most those at `h` + have heb : ∀ j, e j ≤ b j := fun j ↦ by + obtain ⟨b', hb'b, hb'⟩ := NatOrdinal.exists_le_add_eq_of_forall_add_lt (hc0 j) (hsep j) hτh' + (hh'h.trans_eq (hb j).symm) + have : e j = b' := add_right_cancel ((he j).trans hb'.symm) + rw [this] + exact hb'b + have hsep' : ∀ j, ∀ θ, θ < c j → e j + θ < τ := fun j θ hθ ↦ + (add_le_add_left (heb j) θ).trans_lt (hsep j θ hθ) + -- the induction hypothesis, in the form used when cutting into pieces + have hIH : ∀ E : Series K, (E : K⟦ℝ⟧).supportOrderType < (ω^ h').val → + (∀ ξ : ℝ, ξ ≤ 0 → + componentsGE wt τ (σ.pol hx α (translatedTruncation (E : K⟦ℝ⟧) ξ)) ∈ + Ideal.span (Set.range q)) → + ∃ w : ι' → Series K, (∀ j, ((w j : Series K) : K⟦ℝ⟧).supportOrderType < (ω^ (e j)).val) ∧ + ∀ ξ : ℝ, ξ ≤ 0 → ordinalValue (translatedTruncation + ((E - ∑ j, w j * aeval σ.lift (q j) : Series K) : K⟦ℝ⟧) ξ) < ω^ (τ + 1) := by + intro E hE hEctrl + obtain ⟨h'', hh''1, hE''⟩ := exists_supportOrderType_lt_wpow_add_one + (lt_of_le_of_lt zero_le hτh').ne' hE + have hh''h' : h'' < h' := Order.add_one_le_iff.mp hh''1 + rcases le_or_gt h'' τ with hτ'' | hτ'' + · -- the support of `E` is already small + refine ⟨fun _ ↦ 0, fun j ↦ ?_, fun ξ _ ↦ ?_⟩ + · rw [Subring.coe_zero, supportOrderType_eq_setOrderType] + simp only [HahnSeries.support_zero] + rw [(Set.isPWO_empty.orderType_eq_zero).mpr rfl] + exact Ordinal.opow_pos _ Ordinal.omega0_pos + · simp only [zero_mul, Finset.sum_const_zero, sub_zero] + exact (ordinalValue_translatedTruncation_lt_of_supportOrderType_lt hE'' ξ).trans_le + (NatOrdinal.wpow_le_wpow.mpr (add_le_add_left hτ'' 1)) + · -- the induction hypothesis at `h''` + have he'' : ∀ j, ∃ e'', e'' + c j = h'' := fun j ↦ by + obtain ⟨b', -, hb'⟩ := NatOrdinal.exists_le_add_eq_of_forall_add_lt (hc0 j) (hsep j) hτ'' + ((hh''h'.le.trans hh'h).trans_eq (hb j).symm) + exact ⟨b', hb'⟩ + choose e'' he'' using he'' + obtain ⟨w, hw1, hw2⟩ := ih h'' hh''h' hτ'' (hh''h'.le.trans hh'h) e'' he'' E hE'' hEctrl + refine ⟨w, fun j ↦ (hw1 j).trans_le (NatOrdinal.val.le_iff_le.mpr + (NatOrdinal.wpow_le_wpow.mpr ?_)), hw2⟩ + -- `e'' j < e j` since `e'' j ⊕ c j = h'' < h' = e j ⊕ c j` + have : e'' j < e j := by + have := (he'' j).trans_lt (hh''h'.trans_eq (he j).symm) + exact lt_of_add_lt_add_right this + exact Order.add_one_le_of_lt this + -- lower the order type of the support below `ω^{h'}` + rcases eq_or_lt_of_le (Order.add_one_le_of_lt hτh') with hsucc | hlt + · -- `h' = τ + 1`: one step; the result has support of order type below `ω^(τ+1)` + subst hsucc + obtain ⟨u₀, hu₀, hD'⟩ := IsPrincipal.exists_supportOrderType_sub_sum_mul_aeval_lt σ hx hinj + hσ hq hc hh'α he hsep' hD htrunc + exact ⟨u₀, hu₀, fun ξ _ ↦ ordinalValue_translatedTruncation_lt_of_supportOrderType_lt hD' ξ⟩ + · -- `h' ≥ τ + 2`: cutting into pieces, then the induction hypothesis on the result + obtain ⟨u₀, hu₀, hD', hD'ctrl⟩ := + IsPrincipal.exists_supportOrderType_sub_sum_mul_aeval_lt_of_pieces σ hx hinj hσ hq hlt + hh'α he hsep' hD htrunc hIH + obtain ⟨w, hw1, hw2⟩ := hIH _ hD' hD'ctrl + refine ⟨fun j ↦ u₀ j + w j, fun j ↦ ?_, fun ξ hξ ↦ ?_⟩ + · rw [Subring.coe_add] + refine (supportOrderType_add_le_naturalAdd _ _).trans_lt ?_ + have h1 : NatOrdinal.of ((u₀ j : Series K) : K⟦ℝ⟧).supportOrderType < ω^ (e j + 1) := by + rw [← NatOrdinal.of_val (ω^ (e j + 1))] + exact NatOrdinal.of.lt_iff_lt.mpr (hu₀ j) + have h2 : NatOrdinal.of ((w j : Series K) : K⟦ℝ⟧).supportOrderType < ω^ (e j + 1) := by + rw [← NatOrdinal.of_val (ω^ (e j + 1))] + exact NatOrdinal.of.lt_iff_lt.mpr ((hw1 j).trans (NatOrdinal.val.lt_iff_lt.mpr + (NatOrdinal.wpow_lt_wpow.mpr (lt_add_one _)))) + exact NatOrdinal.val.lt_iff_lt.mpr (NatOrdinal.add_lt_wpow h1 h2) + · have heq : (D - ∑ j, (u₀ j + w j) * aeval σ.lift (q j) : Series K) = + (D - ∑ j, u₀ j * aeval σ.lift (q j)) - ∑ j, w j * aeval σ.lift (q j) := by + simp only [add_mul, Finset.sum_add_distrib] + ring + rw [heq] + exact hw2 ξ hξ + +end Lifts + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/LeadingCoefficient.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/LeadingCoefficient.lean new file mode 100644 index 0000000000..2aec98f787 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/LeadingCoefficient.lean @@ -0,0 +1,646 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.TruncationPolynomial + +/-! +# The coefficient of `X_{B₀}^e` in the polynomial of a translated truncation + +Fix a variable `B₀` of degree `deg B₀ < α` and assume evaluation injective below `α`. A series `u` +with `v_J(u) < ω^{β+1}`, `β < α`, is *free of `X_{B₀}`* (`FreeOfVariable`) if neither `pol(u)` nor +`pol(u^{|γ})`, for all `γ < 0` sufficiently close to `0`, involves `X_{B₀}`. Constants are free of +`X_{B₀}`; so are the lifts `b_B` of the variables `B ≠ B₀` of degree at most `deg B₀`, since a +polynomial of degree below `deg B₀` cannot involve `X_{B₀}`; and sums, scalar multiples, products +and powers of series free of `X_{B₀}` are free of `X_{B₀}` (degrees permitting), by the +convolution formula read in polynomials [Ber00, Lem. 7.5], because in every term each factor is +either free of `X_{B₀}` or untruncated. + +For `u` free of `X_{B₀}` and the lift `b_{B₀}`, the polynomial of `(b_{B₀}^e u)^{|γ}`, expanded in +powers of `X_{B₀}`, has no coefficient above `e`, and its coefficient of `X_{B₀}^e` is +`pol(u^{|γ})`: by induction on `e` through the convolution formula with the factors `b_{B₀}` and +`b_{B₀}^{e-1} u`, the only term reaching `X_{B₀}^e` is the boundary term +`X_{B₀} · pol((b_{B₀}^{e-1} u)^{|γ})`, every translated truncation of `b_{B₀}` at a cutoff `ζ < 0` +being free of `X_{B₀}`. For `u = 1` the coefficient of `X_{B₀}^{e-1}` is `e · pol(b_{B₀}^{|γ})`, by +the same induction. These are the two leading-coefficient identities used in the limit step. +-/ + +universe v w + +open scoped NatOrdinal HahnSeries +open Berarducci MvPolynomial OrdinalGraded + +public noncomputable section + +namespace Berarducci + +variable {K : Type v} [Field K] {ι : Type w} [DecidableEq ι] {wt : ι → NatOrdinal} + {x : ι → PrincipalSubring K} + +namespace Lifts + +variable (σ : Lifts wt x) (hx : IsMinimalSystem (Berarducci.principalGrading K) wt x) + {α : NatOrdinal} (hinj : ∀ β < α, InjectiveAt K wt x β) (B₀ : ι) + +/-! ### Series free of `X_{B₀}` -/ + +variable (α) in +/-- A series `u` with `v_J(u) < ω^{β+1}`, `β < α`, is free of `X_{B₀}` if `pol u` and the +polynomials `pol(u^{|γ})` of its translated truncations, for all `γ < 0` sufficiently close to `0`, +do not involve `X_{B₀}`. -/ +structure FreeOfVariable (u : Series K) (β : NatOrdinal) : Prop where + /-- `u ∈ J_{ω^(β+1)}`. -/ + lt : ordinalValue u < ω^ (β + 1) + /-- `β < α`. -/ + beta_lt : β < α + /-- `pol u` does not involve `X_{B₀}`. -/ + pol_mem : σ.pol hx α u ∈ supported K {B₀}ᶜ + /-- The polynomials of the translated truncations, for all `γ < 0` sufficiently close to `0`, do + not involve `X_{B₀}`. -/ + exists_forall : ∃ ε > 0, ∀ γ : ℝ, -ε < γ → γ < 0 → + σ.pol hx α (translatedTruncation (u : K⟦ℝ⟧) γ) ∈ supported K {B₀}ᶜ + +include hinj + +omit [DecidableEq ι] in +/-- Constants are free of `X_{B₀}` (in degree `0`, when `0 < α`). -/ +theorem freeOfVariable_C (hα : 0 < α) (k : K) : + σ.FreeOfVariable hx α B₀ ((HahnSeries.Nonpositive.C : K →+* Series K) k) 0 where + lt := ordinalValue_C_lt_wpow_one k + beta_lt := hα + pol_mem := by + have h1 : (HahnSeries.Nonpositive.C : K →+* Series K) k = + aeval σ.lift (C k : MvPolynomial ι K) := by + rw [aeval_C, HahnSeries.Nonpositive.algebraMap_apply] + have hC : DegreeLT wt (C k : MvPolynomial ι K) α := degreeLT_iff.mpr fun d hd ↦ by + classical + rw [support_C] at hd + split_ifs at hd with hk + · exact absurd hd (Finset.notMem_empty d) + · rw [Finset.mem_singleton] at hd + rw [hd, map_zero] + exact hα + rw [h1, σ.pol_aeval hx hinj hC] + exact Subalgebra.algebraMap_mem _ k + exists_forall := ⟨1, one_pos, fun γ _ hγ ↦ by + rw [σ.pol_translatedTruncation_C hx hinj k hγ] + exact Subalgebra.zero_mem _⟩ + +omit [DecidableEq ι] in +/-- `1` is free of `X_{B₀}`. -/ +theorem freeOfVariable_one (hα : 0 < α) : σ.FreeOfVariable hx α B₀ 1 0 := by + have := σ.freeOfVariable_C hx hinj B₀ hα 1 + rwa [map_one] at this + +omit [DecidableEq ι] in +/-- The lift of a variable `i ≠ B₀` of degree at most `wt B₀ < α` is free of `X_{B₀}`. -/ +theorem freeOfVariable_lift (hg : wt B₀ < α) {i : ι} (hi : i ≠ B₀) (hwt : wt i ≤ wt B₀) : + σ.FreeOfVariable hx α B₀ (σ.lift i) (wt i) where + lt := Berarducci.Represents.ordinalValue_lt (σ.represents i) + beta_lt := hwt.trans_lt hg + pol_mem := by + have h1 : σ.lift i = aeval σ.lift (X i : MvPolynomial ι K) := (aeval_X _ i).symm + have hX : DegreeLT wt (X i : MvPolynomial ι K) α := degreeLT_iff.mpr fun d hd ↦ by + rw [support_X, Finset.mem_singleton] at hd + rw [hd, Finsupp.weight_single, one_smul] + exact hwt.trans_lt hg + rw [h1, σ.pol_aeval hx hinj hX, X_mem_supported] + exact hi + exists_forall := by + obtain ⟨ε, hε, h⟩ := + exists_forall_ordinalValue_translatedTruncation_lt + (Berarducci.Represents.ordinalValue_lt (σ.represents i)) + refine ⟨ε, hε, fun γ hγε hγ0 ↦ ?_⟩ + have hlt := σ.pol_degreeLT_of_lt hx hinj (hwt.trans_lt hg).le (h γ hγε hγ0) + exact mem_supported_of_forall_weight_lt B₀ wt fun d hd ↦ + (degreeLT_iff.mp hlt d hd).trans_le hwt + +omit [DecidableEq ι] in +variable {σ hx B₀} in +/-- The product of two series free of `X_{B₀}` is free of `X_{B₀}`, when the sum of their degrees +stays below `α`. -/ +theorem FreeOfVariable.mul {u u' : Series K} {β β' : NatOrdinal} (hu : σ.FreeOfVariable hx α B₀ u β) + (hu' : σ.FreeOfVariable hx α B₀ u' β') (h : β + β' < α) : + σ.FreeOfVariable hx α B₀ (u * u') (β + β') where + lt := ordinalValue_mul_lt_wpow_add_one hu.lt hu'.lt + beta_lt := h + pol_mem := by + have hβα : β + 1 ≤ α := Order.add_one_le_of_lt hu.beta_lt + have hβ'α : β' + 1 ≤ α := Order.add_one_le_of_lt hu'.beta_lt + have hmul := σ.pol_mul hx hinj (hu.lt.trans_le (NatOrdinal.wpow_le_wpow.mpr hβα)) + (hu'.lt.trans_le (NatOrdinal.wpow_le_wpow.mpr hβ'α)) + (((σ.pol_degreeLE hx hinj hu.beta_lt hu.lt).mul + (σ.pol_degreeLE hx hinj hu'.beta_lt hu'.lt)).degreeLT h) + rw [hmul.2] + exact Subalgebra.mul_mem _ hu.pol_mem hu'.pol_mem + exists_forall := by + obtain ⟨ε₁, hε₁, h₁⟩ := hu.exists_forall + obtain ⟨ε₂, hε₂, h₂⟩ := hu'.exists_forall + obtain ⟨ε₃, hε₃, h₃⟩ := σ.exists_forall_pol_translatedTruncation_mul hx hinj hu.lt hu'.lt + hu.beta_lt hu'.beta_lt h.le + refine ⟨min ε₁ (min ε₂ ε₃), lt_min hε₁ (lt_min hε₂ hε₃), fun γ hγε hγ0 ↦ ?_⟩ + have hγ₁ : -ε₁ < γ := by have := min_le_left ε₁ (min ε₂ ε₃); linarith + have hγ₂ : -ε₂ < γ := by + have := (min_le_right ε₁ (min ε₂ ε₃)).trans (min_le_left ε₂ ε₃); linarith + have hγ₃ : -ε₃ < γ := by + have := (min_le_right ε₁ (min ε₂ ε₃)).trans (min_le_right ε₂ ε₃); linarith + rw [h₃ γ hγ₃ hγ0 _ subset_rfl fun β hβ ↦ mem_Icc_of_mem_convolutionIndex hβ] + refine Subalgebra.sum_mem _ fun β hβ ↦ Subalgebra.mul_mem _ ?_ ?_ + · obtain ⟨hγβ, hβ0⟩ := mem_Icc_of_mem_convolutionIndex hβ + rcases eq_or_lt_of_le hβ0 with rfl | hβneg + · rw [translatedTruncation_zero]; exact hu.pol_mem + · exact h₁ β (by linarith) hβneg + · obtain ⟨hγβ, hβ0⟩ := mem_Icc_of_mem_convolutionIndex hβ + rcases eq_or_lt_of_le (sub_nonpos.mpr hγβ) with h0 | hneg + · rw [h0, translatedTruncation_zero]; exact hu'.pol_mem + · exact h₂ (γ - β) (by linarith) hneg + +omit [DecidableEq ι] in +variable {σ hx B₀} in +/-- Powers of a series free of `X_{B₀}` are free of `X_{B₀}`, degrees permitting. -/ +theorem FreeOfVariable.pow {u : Series K} {β : NatOrdinal} (hu : σ.FreeOfVariable hx α B₀ u β) + (n : ℕ) + (h : n • β < α) : σ.FreeOfVariable hx α B₀ (u ^ n) (n • β) := by + induction n with + | zero => + rw [pow_zero, zero_smul] + exact σ.freeOfVariable_one hx hinj B₀ (zero_smul ℕ β ▸ h) + | succ n ih => + rw [pow_succ, succ_nsmul] + have hn : n • β < α := NatOrdinal.le_add_right.trans_lt (succ_nsmul β n ▸ h) + exact (ih hn).mul hinj hu (succ_nsmul β n ▸ h) + +omit [DecidableEq ι] in +/-- Finite products of series free of `X_{B₀}` are free of `X_{B₀}`, degrees permitting. -/ +theorem freeOfVariable_prod {ι' : Type*} (hα : 0 < α) (s : Finset ι') (f : ι' → Series K) + (g : ι' → NatOrdinal) (h : ∀ i ∈ s, σ.FreeOfVariable hx α B₀ (f i) (g i)) + (hsum : ∑ i ∈ s, g i < α) : + σ.FreeOfVariable hx α B₀ (∏ i ∈ s, f i) (∑ i ∈ s, g i) := by + classical + induction s using Finset.induction_on with + | empty => simpa using σ.freeOfVariable_one hx hinj B₀ hα + | insert a s ha ih => + rw [Finset.sum_insert ha] at hsum + rw [Finset.prod_insert ha, Finset.sum_insert ha] + have hs : ∑ i ∈ s, g i < α := NatOrdinal.le_add_left.trans_lt hsum + exact (h a (Finset.mem_insert_self a s)).mul hinj + (ih (fun i hi ↦ h i (Finset.mem_insert_of_mem hi)) hs) hsum + +omit [DecidableEq ι] in +/-- The evaluation at the lifts of a monomial not involving `X_{B₀}`, in variables of degree at +most `wt B₀`, of degree below `α`, is free of `X_{B₀}`. -/ +theorem freeOfVariable_aeval_monomial (hg : wt B₀ < α) (d : ι →₀ ℕ) (hd : d B₀ = 0) + (hwt : ∀ i ∈ d.support, wt i ≤ wt B₀) (hdegree : Finsupp.weight wt d < α) : + σ.FreeOfVariable hx α B₀ (∏ i ∈ d.support, σ.lift i ^ d i) (Finsupp.weight wt d) := by + have hα : 0 < α := (bot_le : (0 : NatOrdinal) ≤ wt B₀).trans_lt hg + rw [Finsupp.weight_apply, Finsupp.sum] + rw [Finsupp.weight_apply, Finsupp.sum] at hdegree + refine σ.freeOfVariable_prod hx hinj B₀ hα d.support (fun i ↦ σ.lift i ^ d i) + (fun i ↦ d i • wt i) ?_ hdegree + intro i hi + have hi0 : i ≠ B₀ := fun h ↦ (Finsupp.mem_support_iff.mp hi) (h ▸ hd) + have hlt : d i • wt i < α := (Finset.single_le_sum (f := fun i ↦ d i • wt i) + (fun _ _ ↦ bot_le) hi).trans_lt hdegree + exact (σ.freeOfVariable_lift hx hinj B₀ hg hi0 (hwt i hi)).pow hinj (d i) hlt + +omit [DecidableEq ι] in +/-- `0` is free of `X_{B₀}` in every degree below `α`. -/ +theorem freeOfVariable_zero {β : NatOrdinal} (hβ : β < α) : σ.FreeOfVariable hx α B₀ 0 β where + lt := by rw [ordinalValue_zero]; exact NatOrdinal.wpow_pos _ + beta_lt := hβ + pol_mem := by rw [σ.pol_zero hx hinj]; exact Subalgebra.zero_mem _ + exists_forall := ⟨1, one_pos, fun γ _ _ ↦ by + rw [Subring.coe_zero, translatedTruncation_zero_input, σ.pol_zero hx hinj] + exact Subalgebra.zero_mem _⟩ + +omit [DecidableEq ι] in +variable {σ hx B₀} in +/-- The sum of two series free of `X_{B₀}` of the same degree is free of `X_{B₀}`. -/ +theorem FreeOfVariable.add {u u' : Series K} {β : NatOrdinal} (hu : σ.FreeOfVariable hx α B₀ u β) + (hu' : σ.FreeOfVariable hx α B₀ u' β) : σ.FreeOfVariable hx α B₀ (u + u') β where + lt := (ordinalValue_add_le_max u u').trans_lt (max_lt hu.lt hu'.lt) + beta_lt := hu.beta_lt + pol_mem := by + have hβα : β + 1 ≤ α := Order.add_one_le_of_lt hu.beta_lt + rw [σ.pol_add hx hinj (hu.lt.trans_le (NatOrdinal.wpow_le_wpow.mpr hβα)) + (hu'.lt.trans_le (NatOrdinal.wpow_le_wpow.mpr hβα))] + exact Subalgebra.add_mem _ hu.pol_mem hu'.pol_mem + exists_forall := by + obtain ⟨ε₁, hε₁, h₁⟩ := hu.exists_forall + obtain ⟨ε₂, hε₂, h₂⟩ := hu'.exists_forall + obtain ⟨ε₃, hε₃, h₃⟩ := exists_forall_ordinalValue_translatedTruncation_lt hu.lt + obtain ⟨ε₄, hε₄, h₄⟩ := exists_forall_ordinalValue_translatedTruncation_lt hu'.lt + refine ⟨min (min ε₁ ε₂) (min ε₃ ε₄), lt_min (lt_min hε₁ hε₂) (lt_min hε₃ hε₄), + fun γ hγε hγ0 ↦ ?_⟩ + have hγ₁ : -ε₁ < γ := by + have := (min_le_left (min ε₁ ε₂) (min ε₃ ε₄)).trans (min_le_left ε₁ ε₂); linarith + have hγ₂ : -ε₂ < γ := by + have := (min_le_left (min ε₁ ε₂) (min ε₃ ε₄)).trans (min_le_right ε₁ ε₂); linarith + have hγ₃ : -ε₃ < γ := by + have := (min_le_right (min ε₁ ε₂) (min ε₃ ε₄)).trans (min_le_left ε₃ ε₄); linarith + have hγ₄ : -ε₄ < γ := by + have := (min_le_right (min ε₁ ε₂) (min ε₃ ε₄)).trans (min_le_right ε₃ ε₄); linarith + rw [Subring.coe_add, translatedTruncation_add, + σ.pol_add hx hinj ((h₃ γ hγ₃ hγ0).trans_le (NatOrdinal.wpow_le_wpow.mpr hu.beta_lt.le)) + ((h₄ γ hγ₄ hγ0).trans_le (NatOrdinal.wpow_le_wpow.mpr hu.beta_lt.le))] + exact Subalgebra.add_mem _ (h₁ γ hγ₁ hγ0) (h₂ γ hγ₂ hγ0) + +omit [DecidableEq ι] in +variable {σ hx B₀} in +/-- Scalar multiples of a series free of `X_{B₀}` are free of `X_{B₀}`. -/ +theorem FreeOfVariable.C_mul (k : K) {u : Series K} {β : NatOrdinal} + (hu : σ.FreeOfVariable hx α B₀ u β) : + σ.FreeOfVariable hx α B₀ ((HahnSeries.Nonpositive.C : K →+* Series K) k * u) β := by + rcases eq_or_ne k 0 with rfl | hk + · rw [map_zero, zero_mul]; exact σ.freeOfVariable_zero hx hinj B₀ hu.beta_lt + have hβα : β + 1 ≤ α := Order.add_one_le_of_lt hu.beta_lt + refine ⟨by rw [ordinalValue_C_mul hk]; exact hu.lt, hu.beta_lt, ?_, ?_⟩ + · rw [σ.pol_C_mul hx hinj k (hu.lt.trans_le (NatOrdinal.wpow_le_wpow.mpr hβα))] + exact Subalgebra.mul_mem _ (Subalgebra.algebraMap_mem _ k) hu.pol_mem + · obtain ⟨ε₁, hε₁, h₁⟩ := hu.exists_forall + obtain ⟨ε₂, hε₂, h₂⟩ := exists_forall_ordinalValue_translatedTruncation_lt hu.lt + refine ⟨min ε₁ ε₂, lt_min hε₁ hε₂, fun γ hγε hγ0 ↦ ?_⟩ + have hγ₁ : -ε₁ < γ := by have := min_le_left ε₁ ε₂; linarith + have hγ₂ : -ε₂ < γ := by have := min_le_right ε₁ ε₂; linarith + rw [Subring.coe_mul, HahnSeries.Nonpositive.coe_C, translatedTruncation_C_mul, + σ.pol_C_mul hx hinj k ((h₂ γ hγ₂ hγ0).trans_le + (NatOrdinal.wpow_le_wpow.mpr hu.beta_lt.le))] + exact Subalgebra.mul_mem _ (Subalgebra.algebraMap_mem _ k) (h₁ γ hγ₁ hγ0) + +omit [DecidableEq ι] in +/-- Finite sums of series free of `X_{B₀}`, all of one degree, are free of `X_{B₀}`. -/ +theorem freeOfVariable_sum {ι' : Type*} {β : NatOrdinal} (hβ : β < α) (s : Finset ι') + (f : ι' → Series K) (h : ∀ i ∈ s, σ.FreeOfVariable hx α B₀ (f i) β) : + σ.FreeOfVariable hx α B₀ (∑ i ∈ s, f i) β := by + classical + induction s using Finset.induction_on with + | empty => rw [Finset.sum_empty]; exact σ.freeOfVariable_zero hx hinj B₀ hβ + | insert a s ha ih => + rw [Finset.sum_insert ha] + exact (h a (Finset.mem_insert_self a s)).add hinj + (ih fun i hi ↦ h i (Finset.mem_insert_of_mem hi)) + +omit [DecidableEq ι] in +/-- The evaluation at the lifts of a polynomial not involving `X_{B₀}`, homogeneous of degree +`β < α`, in variables of degree at most `wt B₀`, is free of `X_{B₀}`. -/ +theorem freeOfVariable_aeval (hg : wt B₀ < α) {F : MvPolynomial ι K} {β : NatOrdinal} + (hF : IsWeightedHomogeneous wt F β) (hβ : β < α) (hmem : F ∈ supported K {B₀}ᶜ) + (hvars : ∀ i ∈ F.vars, wt i ≤ wt B₀) : σ.FreeOfVariable hx α B₀ (aeval σ.lift F) β := by + classical + conv => rw [F.as_sum] + rw [map_sum] + refine σ.freeOfVariable_sum hx hinj B₀ hβ _ _ fun d hd ↦ ?_ + have hdw : Finsupp.weight wt d = β := hF (mem_support_iff.mp hd) + have hmono : (monomial d (F.coeff d) : MvPolynomial ι K) = C (F.coeff d) * monomial d 1 := by + rw [C_mul_monomial, mul_one] + rw [hmono, map_mul, aeval_C, HahnSeries.Nonpositive.algebraMap_apply, aeval_monomial, map_one, + one_mul, Finsupp.prod] + refine FreeOfVariable.C_mul hinj _ ?_ + have hd0 : d B₀ = 0 := by + by_contra h0 + have hv : B₀ ∈ F.vars := + (mem_vars_iff_mem_support B₀).mpr ⟨d, hd, Finsupp.mem_support_iff.mpr h0⟩ + exact (mem_supported.mp hmem) hv rfl + have hwt' : ∀ i ∈ d.support, wt i ≤ wt B₀ := fun i hi ↦ + hvars i ((mem_vars_iff_mem_support i).mpr ⟨d, hd, hi⟩) + rw [← hdw] + exact σ.freeOfVariable_aeval_monomial hx hinj B₀ hg d hd0 hwt' (hdw ▸ hβ) + +/-! ### The coefficient of `X_{B₀}^e` -/ + +omit [DecidableEq ι] in +/-- The polynomial of `b_{B₀}^e` is `X_{B₀}^e` when `e • wt B₀ < α`. -/ +theorem pol_lift_pow (e : ℕ) (he : e • wt B₀ < α) : + σ.pol hx α (σ.lift B₀ ^ e) = X B₀ ^ e := by + have h1 : σ.lift B₀ ^ e = aeval σ.lift (X B₀ ^ e : MvPolynomial ι K) := by + rw [map_pow, aeval_X] + have hX : DegreeLT wt (X B₀ ^ e : MvPolynomial ι K) α := degreeLT_iff.mpr fun d hd ↦ by + classical + rw [X_pow_eq_monomial, support_monomial, ite_eq_right one_ne_zero, Finset.mem_singleton] at hd + rw [hd, Finsupp.weight_single] + exact he + rw [h1, σ.pol_aeval hx hinj hX] + +omit [DecidableEq ι] in +/-- The polynomials of the translated truncations `b_{B₀}^{|γ}`, for all `γ < 0` sufficiently close +to `0`, do not involve `X_{B₀}`. -/ +@[blueprint "lem:proper-truncation-omits-variable" + (phase := "Translated truncations") + (title := "Omission of a maximal-weight variable from proper truncation representatives") + (statement := /-- + Let $K$ be a field, let $(x_i)_{i\in I}$ be a minimal homogeneous + generating system of $\widehat{\mathrm P}$ with + $x_i\in\mathrm P_{w_i}$, and choose representatives + $b_i\in K((\mathbb R^{\le0}))$. Fix $\alpha<\omega_1$, and suppose that + evaluation at $(x_i)$ is injective on weighted-homogeneous polynomials of + every degree below $\alpha$. For $v_J(u)<\omega^\alpha$, denote by $P_u$ + the unique polynomial whose monomials have weight below $\alpha$ and for + which $P_u(b_i)\equiv u\pmod J$. + + If $B_0\in I$ and $w_{B_0}<\alpha$, then there is $\varepsilon>0$ such + that + \[ + X_{B_0}\notin\operatorname{vars}(P_{b_{B_0}^{|\gamma}}) + \qquad(-\varepsilon<\gamma<0). + \] + -/) + (proof := /-- + Since $b_{B_0}$ represents $x_{B_0}\in\mathrm P_{w_{B_0}}$, its ordinal + value is below $\omega^{w_{B_0}+1}$. By + \ref{lem:truncation-drop}, for every $\gamma<0$ sufficiently close to $0$, + \[ + v_J(b_{B_0}^{|\gamma})<\omega^{w_{B_0}}. + \] + Apply \ref{prop:polynomial-representative-exists} at $w_{B_0}$. Its + polynomial has every monomial of weight below $w_{B_0}$, and uniqueness from + \ref{prop:polynomial-evaluation-ordinal-value} identifies it with the + representative $P_{b_{B_0}^{|\gamma}}$ chosen below $\alpha$. A monomial + involving $X_{B_0}$ has weight at least $w_{B_0}$, so no such monomial can + occur. + -/)] +theorem exists_forall_pol_translatedTruncation_lift_mem (hg : wt B₀ < α) : + ∃ ε > 0, ∀ γ : ℝ, -ε < γ → γ < 0 → + σ.pol hx α (translatedTruncation (σ.lift B₀ : K⟦ℝ⟧) γ) ∈ supported K {B₀}ᶜ := by + obtain ⟨ε, hε, h⟩ := + exists_forall_ordinalValue_translatedTruncation_lt + (Berarducci.Represents.ordinalValue_lt (σ.represents B₀)) + refine ⟨ε, hε, fun γ hγε hγ0 ↦ ?_⟩ + exact mem_supported_of_forall_weight_lt B₀ wt + (degreeLT_iff.mp (σ.pol_degreeLT_of_lt hx hinj hg.le (h γ hγε hγ0))) + +omit [DecidableEq ι] hinj in +/-- The sum over a finite set containing `0` and `γ ≠ 0`, split at these two points. -/ +theorem sum_eq_add_add_sum_erase {S : Finset ℝ} {γ : ℝ} (h0 : (0 : ℝ) ∈ S) (hγ : γ ∈ S) + (hne : γ ≠ 0) (f : ℝ → MvPolynomial ι K) : + ∑ β ∈ S, f β = f 0 + f γ + ∑ β ∈ (S.erase 0).erase γ, f β := by + rw [add_assoc, Finset.add_sum_erase _ _ (Finset.mem_erase.mpr ⟨hne, hγ⟩), + Finset.add_sum_erase _ _ h0] + +/-- **The coefficient of `X_{B₀}^e`.** For `u` free of `X_{B₀}`, of degree `β` with +`e • wt B₀ ⊕ β ≤ α`, and all `γ < 0` sufficiently close to `0`: the polynomial of +`(b_{B₀}^e · u)^{|γ}` has no coefficient of `X_{B₀}^k` for `k > e`, and its coefficient of +`X_{B₀}^e` is `pol(u^{|γ})`. -/ +@[blueprint "lem:leading-coefficient-of-truncated-product" + (phase := "Translated truncations") + (title := "Leading coefficient after translated truncation") + (statement := /-- + Let $(x_i)_{i\in I}$ be a minimal homogeneous generating system of + $\widehat{\mathrm P}$, with $x_i\in\mathrm P_{w_i}$, and choose series + $b_i$ representing the $x_i$. Assume that evaluation at $(x_i)$ is + injective in every weighted degree below $\alpha<\omega_1$, and write + $P_a$ for the resulting polynomial representative of a series $a$ of + ordinal value below $\omega^\alpha$. + + Fix $B_0\in I$ with $w_{B_0}<\alpha$. Let $\beta<\alpha$ and let + $u\in K((\mathbb R^{\le0}))$ satisfy $v_J(u)<\omega^{\beta+1}$. Suppose + that $P_u$ does not involve $X_{B_0}$ and that the same holds for + $P_{u^{|\gamma}}$ for every $\gamma<0$ sufficiently close to $0$. + + If $(e\odot w_{B_0})\oplus\beta\le\alpha$, then, for every + $\gamma<0$ sufficiently close to $0$, the polynomial + $P_{(b_{B_0}^eu)^{|\gamma}}$ has degree at most $e$ in $X_{B_0}$ and + \[ + [X_{B_0}^e]\,P_{(b_{B_0}^eu)^{|\gamma}}=P_{u^{|\gamma}}. + \] + -/) + (proof := /-- + Induct on $e$. The case $e=0$ is the hypothesis on $u$. For the successor + step, apply \ref{lem:polynomial-convolution-formula} to + $b_{B_0}(b_{B_0}^eu)$. The summand at cutoff $0$ is + $X_{B_0}P_{(b_{B_0}^eu)^{|\gamma}}$, whose coefficients are controlled by + the induction hypothesis. + + In every other summand the first factor is a proper translated truncation + of $b_{B_0}$, so its polynomial omits $X_{B_0}$ by + \ref{lem:proper-truncation-omits-variable}. At cutoff $\gamma$, the second + translated truncation is $b_{B_0}^eu$, whose unique polynomial + representative with monomial weights below $\alpha$ is $P_uX_{B_0}^e$; + at the interior cutoffs the induction hypothesis bounds its + $X_{B_0}$-degree by $e$. Thus only the cutoff-$0$ summand can contribute in + degree $e+1$, and its coefficient there is $P_{u^{|\gamma}}$. + -/)] +theorem exists_forall_xCoeff_pol_translatedTruncation_pow_mul (hg : wt B₀ < α) {u : Series K} + {β : NatOrdinal} (hu : σ.FreeOfVariable hx α B₀ u β) (e : ℕ) (he : e • wt B₀ + β ≤ α) : + ∃ ε > 0, ∀ γ : ℝ, -ε < γ → γ < 0 → + (∀ k, e < k → + xCoeff B₀ k (σ.pol hx α (translatedTruncation ((σ.lift B₀ ^ e * u : Series K) : K⟦ℝ⟧) γ)) + = 0) ∧ + xCoeff B₀ e (σ.pol hx α (translatedTruncation ((σ.lift B₀ ^ e * u : Series K) : K⟦ℝ⟧) γ)) = + σ.pol hx α (translatedTruncation (u : K⟦ℝ⟧) γ) := by + have hg0 : wt B₀ ≠ 0 := hx.ne_zero B₀ + induction e with + | zero => + obtain ⟨ε, hε, h⟩ := hu.exists_forall + refine ⟨ε, hε, fun γ hγε hγ0 ↦ ?_⟩ + rw [pow_zero, one_mul] + refine ⟨fun k hk ↦ ?_, ?_⟩ + · rw [xCoeff_of_mem_supported B₀ (h γ hγε hγ0), ite_eq_right (Nat.pos_iff_ne_zero.mp hk)] + · rw [xCoeff_of_mem_supported B₀ (h γ hγε hγ0), ite_eq_left rfl] + | succ e ih => + -- degrees + have hstep : e • wt B₀ + β < (e + 1) • wt B₀ + β := by + rw [succ_nsmul, add_right_comm] + exact lt_add_of_pos_right _ (pos_iff_ne_zero.mpr hg0) + have he' : e • wt B₀ + β < α := hstep.trans_le he + obtain ⟨ε₁, hε₁, h₁⟩ := ih he'.le + -- the factor `b_{B₀}^e · u` + have hw : ordinalValue (σ.lift B₀ ^ e * u) < ω^ (e • wt B₀ + β + 1) := + ordinalValue_mul_lt_wpow_add_one + (Berarducci.Represents.ordinalValue_lt ((σ.represents B₀).pow e)) hu.lt + have hsum : wt B₀ + (e • wt B₀ + β) ≤ α := by + rw [← add_assoc, add_comm (wt B₀), ← succ_nsmul] + exact he + obtain ⟨ε₂, hε₂, h₂⟩ := σ.exists_forall_pol_translatedTruncation_mul hx hinj + (Berarducci.Represents.ordinalValue_lt (σ.represents B₀)) hw hg he' hsum + obtain ⟨ε₃, hε₃, h₃⟩ := σ.exists_forall_pol_translatedTruncation_lift_mem hx hinj B₀ hg + refine ⟨min ε₁ (min ε₂ ε₃), lt_min hε₁ (lt_min hε₂ hε₃), fun γ hγε hγ0 ↦ ?_⟩ + have hγ₁ : -ε₁ < γ := by have := min_le_left ε₁ (min ε₂ ε₃); linarith + have hγ₂ : -ε₂ < γ := by + have := (min_le_right ε₁ (min ε₂ ε₃)).trans (min_le_left ε₂ ε₃); linarith + have hγ₃ : -ε₃ < γ := by + have := (min_le_right ε₁ (min ε₂ ε₃)).trans (min_le_right ε₂ ε₃); linarith + -- the convolution sum over `S = {0, γ} ∪ index` + set S : Finset ℝ := insert 0 (insert γ + (convolutionIndex (σ.lift B₀ : K⟦ℝ⟧) ((σ.lift B₀ ^ e * u : Series K) : K⟦ℝ⟧) γ)) with hS + have hSsub : convolutionIndex (σ.lift B₀ : K⟦ℝ⟧) ((σ.lift B₀ ^ e * u : Series K) : K⟦ℝ⟧) γ ⊆ + S := (Finset.subset_insert _ _).trans (Finset.subset_insert _ _) + have hSIcc : (S : Set ℝ) ⊆ Set.Icc γ 0 := by + intro β hβ + rw [hS, Finset.coe_insert, Finset.coe_insert] at hβ + rcases hβ with rfl | rfl | hβ + · exact ⟨hγ0.le, le_rfl⟩ + · exact ⟨le_rfl, hγ0.le⟩ + · exact mem_Icc_of_mem_convolutionIndex hβ + have h0S : (0 : ℝ) ∈ S := Finset.mem_insert_self _ _ + have hγS : γ ∈ S := Finset.mem_insert_of_mem (Finset.mem_insert_self _ _) + have hexp : σ.lift B₀ ^ (e + 1) * u = σ.lift B₀ * (σ.lift B₀ ^ e * u) := by ring + set f : ℝ → MvPolynomial ι K := fun β ↦ + σ.pol hx α (translatedTruncation (σ.lift B₀ : K⟦ℝ⟧) β) * + σ.pol hx α (translatedTruncation ((σ.lift B₀ ^ e * u : Series K) : K⟦ℝ⟧) (γ - β)) + with hf + have hconv : σ.pol hx α (translatedTruncation ((σ.lift B₀ ^ (e + 1) * u : Series K) : K⟦ℝ⟧) γ) + = f 0 + f γ + ∑ β ∈ (S.erase 0).erase γ, f β := by + rw [hexp, h₂ γ hγ₂ hγ0 S hSsub hSIcc, ← sum_eq_add_add_sum_erase h0S hγS hγ0.ne] + -- the three kinds of terms + have hf0 : f 0 = X B₀ * σ.pol hx α + (translatedTruncation ((σ.lift B₀ ^ e * u : Series K) : K⟦ℝ⟧) γ) := by + rw [hf] + simp only + rw [translatedTruncation_zero, sub_zero] + congr 1 + have := σ.pol_lift_pow hx hinj B₀ 1 (by rw [one_smul]; exact hg) + rwa [pow_one, pow_one] at this + have hfγ : f γ = σ.pol hx α (translatedTruncation (σ.lift B₀ : K⟦ℝ⟧) γ) * + (σ.pol hx α u * X B₀ ^ e) := by + rw [hf] + simp only + rw [sub_self, translatedTruncation_zero] + congr 1 + have hβα : β + 1 ≤ α := Order.add_one_le_of_lt hu.beta_lt + have hmul := σ.pol_mul hx hinj + ((Berarducci.Represents.ordinalValue_lt ((σ.represents B₀).pow e)).trans_le + (NatOrdinal.wpow_le_wpow.mpr + (Order.add_one_le_of_lt (NatOrdinal.le_add_right.trans_lt he')))) + (hu.lt.trans_le (NatOrdinal.wpow_le_wpow.mpr hβα)) + (by + rw [σ.pol_lift_pow hx hinj B₀ e (NatOrdinal.le_add_right.trans_lt he')] + exact (((isWeightedHomogeneous_X K wt B₀).pow e).degreeLE.mul + (σ.pol_degreeLE hx hinj hu.beta_lt hu.lt)).degreeLT he') + rw [hmul.2, σ.pol_lift_pow hx hinj B₀ e (NatOrdinal.le_add_right.trans_lt he'), mul_comm] + have hfβ : ∀ β ∈ (S.erase 0).erase γ, ∀ k, e < k → xCoeff B₀ k (f β) = 0 := by + intro β hβ k hk + have hβne : β ≠ γ := (Finset.mem_erase.mp hβ).1 + have hβ0 : β ≠ 0 := (Finset.mem_erase.mp (Finset.mem_erase.mp hβ).2).1 + obtain ⟨hγβ, hβle⟩ := hSIcc (Finset.mem_erase.mp (Finset.mem_erase.mp hβ).2).2 + have hβneg : β < 0 := lt_of_le_of_ne hβle hβ0 + have hγβneg : γ - β < 0 := by + rcases lt_or_eq_of_le hγβ with h | h + · linarith + · exact absurd h.symm hβne + rw [hf] + simp only + rw [xCoeff_mul_of_mem_supported B₀ (h₃ β (by linarith) hβneg), + (h₁ (γ - β) (by linarith) hγβneg).1 k hk, mul_zero] + refine ⟨fun k hk ↦ ?_, ?_⟩ + · -- no coefficient above `e + 1` + rw [hconv, map_add, map_add, hf0, hfγ, map_sum, + Finset.sum_eq_zero fun β hβ ↦ hfβ β hβ k (by omega)] + obtain ⟨k', rfl⟩ : ∃ k', k = k' + 1 := ⟨k - 1, by omega⟩ + rw [xCoeff_succ_X_mul, (h₁ γ hγ₁ hγ0).1 k' (by omega), ← mul_assoc, + xCoeff_mul_X_pow B₀ (Subalgebra.mul_mem _ (h₃ γ hγ₃ hγ0) hu.pol_mem), ite_eq_right (by + omega), + add_zero, add_zero] + · -- the coefficient of `X_{B₀}^(e+1)` + rw [hconv, map_add, map_add, hf0, hfγ, map_sum, + Finset.sum_eq_zero fun β hβ ↦ hfβ β hβ (e + 1) (Nat.lt_succ_self e), + xCoeff_succ_X_mul, (h₁ γ hγ₁ hγ0).2, ← mul_assoc, + xCoeff_mul_X_pow B₀ (Subalgebra.mul_mem _ (h₃ γ hγ₃ hγ0) hu.pol_mem), + ite_eq_right (Nat.succ_ne_self e), add_zero, add_zero] + +/-- **The coefficient of `X_{B₀}^e` for the pure power `b_{B₀}^{e+1}`.** For `(e + 1) • wt B₀ ≤ α` +and all `γ < 0` sufficiently close to `0`, the coefficient of `X_{B₀}^e` in the polynomial of +`(b_{B₀}^{e+1})^{|γ}` is `(e + 1) · pol(b_{B₀}^{|γ})`. -/ +theorem exists_forall_xCoeff_pol_translatedTruncation_pow (hg : wt B₀ < α) (e : ℕ) + (he : (e + 1) • wt B₀ ≤ α) : + ∃ ε > 0, ∀ γ : ℝ, -ε < γ → γ < 0 → + xCoeff B₀ e (σ.pol hx α (translatedTruncation ((σ.lift B₀ ^ (e + 1) : Series K) : K⟦ℝ⟧) γ)) + = (e + 1 : ℕ) • σ.pol hx α (translatedTruncation (σ.lift B₀ : K⟦ℝ⟧) γ) := by + have hg0 : wt B₀ ≠ 0 := hx.ne_zero B₀ + have hα : 0 < α := (bot_le : (0 : NatOrdinal) ≤ wt B₀).trans_lt hg + induction e with + | zero => + obtain ⟨ε, hε, h⟩ := σ.exists_forall_pol_translatedTruncation_lift_mem hx hinj B₀ hg + refine ⟨ε, hε, fun γ hγε hγ0 ↦ ?_⟩ + rw [zero_add, pow_one, xCoeff_of_mem_supported B₀ (h γ hγε hγ0), ite_eq_left rfl, one_smul] + | succ e ih => + have hstep : (e + 1) • wt B₀ < (e + 1 + 1) • wt B₀ := by + rw [succ_nsmul (wt B₀) (e + 1)] + exact lt_add_of_pos_right _ (pos_iff_ne_zero.mpr hg0) + have he' : (e + 1) • wt B₀ < α := hstep.trans_le he + obtain ⟨ε₁, hε₁, h₁⟩ := ih he'.le + -- the coefficient of `X_{B₀}^{e+1}` for `b_{B₀}^{e+1} · 1` + obtain ⟨ε₀, hε₀, h₀⟩ := σ.exists_forall_xCoeff_pol_translatedTruncation_pow_mul hx hinj B₀ hg + (σ.freeOfVariable_one hx hinj B₀ hα) (e + 1) (by rw [add_zero]; exact he'.le) + have hw : ordinalValue (σ.lift B₀ ^ (e + 1)) < ω^ ((e + 1) • wt B₀ + 1) := + (Berarducci.Represents.ordinalValue_lt ((σ.represents B₀).pow (e + 1))) + have hsum : wt B₀ + (e + 1) • wt B₀ ≤ α := by + rw [add_comm, ← succ_nsmul] + exact he + obtain ⟨ε₂, hε₂, h₂⟩ := σ.exists_forall_pol_translatedTruncation_mul hx hinj + (Berarducci.Represents.ordinalValue_lt (σ.represents B₀)) hw hg he' hsum + obtain ⟨ε₃, hε₃, h₃⟩ := σ.exists_forall_pol_translatedTruncation_lift_mem hx hinj B₀ hg + refine ⟨min (min ε₀ ε₁) (min ε₂ ε₃), lt_min (lt_min hε₀ hε₁) (lt_min hε₂ hε₃), + fun γ hγε hγ0 ↦ ?_⟩ + have hγ₀ : -ε₀ < γ := by + have := (min_le_left (min ε₀ ε₁) (min ε₂ ε₃)).trans (min_le_left ε₀ ε₁); linarith + have hγ₁ : -ε₁ < γ := by + have := (min_le_left (min ε₀ ε₁) (min ε₂ ε₃)).trans (min_le_right ε₀ ε₁); linarith + have hγ₂ : -ε₂ < γ := by + have := (min_le_right (min ε₀ ε₁) (min ε₂ ε₃)).trans (min_le_left ε₂ ε₃); linarith + have hγ₃ : -ε₃ < γ := by + have := (min_le_right (min ε₀ ε₁) (min ε₂ ε₃)).trans (min_le_right ε₂ ε₃); linarith + set S : Finset ℝ := insert 0 (insert γ + (convolutionIndex (σ.lift B₀ : K⟦ℝ⟧) ((σ.lift B₀ ^ (e + 1) : Series K) : K⟦ℝ⟧) γ)) with hS + have hSsub : convolutionIndex (σ.lift B₀ : K⟦ℝ⟧) ((σ.lift B₀ ^ (e + 1) : Series K) : K⟦ℝ⟧) γ ⊆ + S := (Finset.subset_insert _ _).trans (Finset.subset_insert _ _) + have hSIcc : (S : Set ℝ) ⊆ Set.Icc γ 0 := by + intro β hβ + rw [hS, Finset.coe_insert, Finset.coe_insert] at hβ + rcases hβ with rfl | rfl | hβ + · exact ⟨hγ0.le, le_rfl⟩ + · exact ⟨le_rfl, hγ0.le⟩ + · exact mem_Icc_of_mem_convolutionIndex hβ + have h0S : (0 : ℝ) ∈ S := Finset.mem_insert_self _ _ + have hγS : γ ∈ S := Finset.mem_insert_of_mem (Finset.mem_insert_self _ _) + have hexp : σ.lift B₀ ^ (e + 1 + 1) = σ.lift B₀ * σ.lift B₀ ^ (e + 1) := by ring + set f : ℝ → MvPolynomial ι K := fun β ↦ + σ.pol hx α (translatedTruncation (σ.lift B₀ : K⟦ℝ⟧) β) * + σ.pol hx α (translatedTruncation ((σ.lift B₀ ^ (e + 1) : Series K) : K⟦ℝ⟧) (γ - β)) + with hf + have hconv : σ.pol hx α (translatedTruncation ((σ.lift B₀ ^ (e + 1 + 1) : Series K) : K⟦ℝ⟧) γ) + = f 0 + f γ + ∑ β ∈ (S.erase 0).erase γ, f β := by + rw [hexp, h₂ γ hγ₂ hγ0 S hSsub hSIcc, ← sum_eq_add_add_sum_erase h0S hγS hγ0.ne] + have hf0 : f 0 = X B₀ * σ.pol hx α + (translatedTruncation ((σ.lift B₀ ^ (e + 1) : Series K) : K⟦ℝ⟧) γ) := by + rw [hf] + simp only + rw [translatedTruncation_zero, sub_zero] + congr 1 + have := σ.pol_lift_pow hx hinj B₀ 1 (by rw [one_smul]; exact hg) + rwa [pow_one, pow_one] at this + have hfγ : f γ = σ.pol hx α (translatedTruncation (σ.lift B₀ : K⟦ℝ⟧) γ) * X B₀ ^ (e + 1) := by + rw [hf] + simp only + rw [sub_self, translatedTruncation_zero, σ.pol_lift_pow hx hinj B₀ (e + 1) he'] + -- the interior terms have no coefficient of `X_{B₀}^(e+1)`: the coefficient of `X_{B₀}^{e+1}` + -- in the polynomial of a translated truncation of the pure power is the polynomial of a + -- translated truncation of `1`, which is `0` + have hfβ : ∀ β ∈ (S.erase 0).erase γ, xCoeff B₀ (e + 1) (f β) = 0 := by + intro β hβ + have hβne : β ≠ γ := (Finset.mem_erase.mp hβ).1 + have hβ0 : β ≠ 0 := (Finset.mem_erase.mp (Finset.mem_erase.mp hβ).2).1 + obtain ⟨hγβ, hβle⟩ := hSIcc (Finset.mem_erase.mp (Finset.mem_erase.mp hβ).2).2 + have hβneg : β < 0 := lt_of_le_of_ne hβle hβ0 + have hγβneg : γ - β < 0 := by + rcases lt_or_eq_of_le hγβ with h | h + · linarith + · exact absurd h.symm hβne + have h0' := (h₀ (γ - β) (by linarith) hγβneg).2 + rw [mul_one] at h0' + have hC := σ.pol_translatedTruncation_C hx hinj (1 : K) hγβneg + rw [map_one] at hC + rw [hf] + simp only + rw [xCoeff_mul_of_mem_supported B₀ (h₃ β (by linarith) hβneg), h0', hC, mul_zero] + rw [hconv, map_add, map_add, hf0, hfγ, map_sum, Finset.sum_eq_zero hfβ, add_zero, + xCoeff_succ_X_mul, h₁ γ hγ₁ hγ0, xCoeff_mul_X_pow B₀ (h₃ γ hγ₃ hγ0), ite_eq_left rfl] + exact (succ_nsmul _ (e + 1)).symm + +end Lifts + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/Lifts.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/Lifts.lean new file mode 100644 index 0000000000..9acb007b24 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/Lifts.lean @@ -0,0 +1,615 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.GradedRing.OrdinalGenerators +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.DegreeRepresentatives +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.PrincipalGraded +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.SuccessorLeibniz +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.DerivAt +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Germ +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValueImage +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValueDegree +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.TruncationIntegerPartPrimal +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.AdditivelyPrincipal +public import Mathlib.Algebra.MvPolynomial.CommRing + +/-! +# Lifts of a minimal system of homogeneous generators of `P̂` and the polynomial of a series +modulo `J` + +Fix a minimal system of homogeneous generators `𝓑` of `P̂` (Lean `x : ι → P̂`, the generator `x i` +of degree `wt i`; `OrdinalGraded.IsMinimalSystem`) and lifts: series `lift i ∈ J_{ω^(wt i + 1)}` +representing `x i`, i.e. with class `x i` in `P_{wt i}`. Evaluation at the lifts is graded modulo +`J_{ω^β}`: a polynomial `F` homogeneous of degree `β` evaluates to a series `F(b_𝓑) ∈ J_{ω^(β+1)}` +representing `F(𝓑)`. + +Read modulo Berarducci's ideal `J` [Ber00, Def. 5.1], this gives the *polynomial of a series +modulo `J`*. Without any hypothesis, every series of ordinal value below `ω^α` is congruent +modulo `J` to a value `F(b_𝓑)` with every monomial of `F` of degree below `α`, by well-founded +induction on the ordinal value. If moreover evaluation `K[X] → P̂` is injective in every degree +below `α`, the polynomial is unique, and `v_J(F(b_𝓑)) = ω^(deg F)` for `F ≠ 0`. The function +`pol` records the polynomial of a series modulo `J`. +-/ + +universe v w + +open scoped NatOrdinal DirectSum +open Berarducci MvPolynomial OrdinalGraded + +public noncomputable section + +namespace Berarducci + +variable {K : Type v} [Field K] + +local notation "ν" => (ordinalValueDegreeValuation K) + +/-! ### Series representing homogeneous elements of `P̂` -/ + +/-- A series representing a homogeneous element of `P̂` in a specified degree. -/ +abbrev Represents (u : Series K) (β : NatOrdinal) (e : PrincipalSubring K) : Prop := + (ν).Represents u β e + +theorem represents_iff {u : Series K} {β : NatOrdinal} {e : PrincipalSubring K} : + Represents u β e ↔ ∃ h : ordinalValue u < ω^ (β + 1), + DirectSum.of (PrincipalComponent K) β (principalComponentMk β u h) = e := by + change (ν).Represents u β e ↔ _ + rw [MaxAddDegree.represents_iff] + constructor + · rintro ⟨hdegree, hclass⟩ + have hvalue : ordinalValue u < ω^ (β + 1) := + (mem_ordinalValueDegreeValuation_filtrationLE_iff u β).mp + ((ν).mem_filtrationLE_iff β u |>.mpr hdegree) + refine ⟨hvalue, ?_⟩ + simpa only [MaxAddDegree.homogeneousMk_apply, principalComponentMk_eq_componentMk] using hclass + · rintro ⟨hvalue, hclass⟩ + have hdegree : ν u ≤ β := + ((ν).mem_filtrationLE_iff β u).mp + ((mem_ordinalValueDegreeValuation_filtrationLE_iff u β).mpr hvalue) + refine ⟨hdegree, ?_⟩ + simpa only [MaxAddDegree.homogeneousMk_apply, principalComponentMk_eq_componentMk] using hclass + +theorem Represents.ordinalValue_lt {u : Series K} {β : NatOrdinal} {e : PrincipalSubring K} + (h : Represents u β e) : ordinalValue u < ω^ (β + 1) := + (ordinalValueDegree_le_coe_iff u β).mp (by + simpa only [ordinalValueDegreeValuation_apply] using h.degree_le) + +theorem Represents.of_principalComponentMk {u : Series K} {β : NatOrdinal} {e : PrincipalSubring K} + (h : Represents u β e) : + DirectSum.of (PrincipalComponent K) β (principalComponentMk β u h.ordinalValue_lt) = e := + (represents_iff.mp h).2 + +theorem represents_zero (β : NatOrdinal) : Represents (0 : Series K) β 0 := + (ν).represents_zero β + +theorem represents_C (k : K) : + Represents ((HahnSeries.Nonpositive.C : K →+* Series K) k) 0 + (algebraMap K (PrincipalSubring K) k) := + represents_iff.mpr ⟨ordinalValue_C_lt_wpow_one k, by + rw [principalSubring_algebraMap_apply, principalComponentScalarHom_apply]⟩ + +theorem represents_one : Represents (1 : Series K) 0 1 := by + have := represents_C (K := K) 1 + rwa [map_one, map_one] at this + +theorem Represents.add {u u' : Series K} {β : NatOrdinal} {e e' : PrincipalSubring K} + (h : Represents u β e) (h' : Represents u' β e') : Represents (u + u') β (e + e') := + MaxAddDegree.Represents.add h h' + +theorem Represents.mul {u u' : Series K} {β β' : NatOrdinal} {e e' : PrincipalSubring K} + (h : Represents u β e) (h' : Represents u' β' e') : + Represents (u * u') (β + β') (e * e') := + MaxAddDegree.Represents.mul rfl h h' + +theorem Represents.pow {u : Series K} {β : NatOrdinal} {e : PrincipalSubring K} + (h : Represents u β e) (n : ℕ) : Represents (u ^ n) (n • β) (e ^ n) := + MaxAddDegree.Represents.pow h n + +theorem represents_prod {ι : Type w} (s : Finset ι) (f : ι → Series K) (g : ι → NatOrdinal) + (e : ι → PrincipalSubring K) (h : ∀ i ∈ s, Represents (f i) (g i) (e i)) : + Represents (∏ i ∈ s, f i) (∑ i ∈ s, g i) (∏ i ∈ s, e i) := + (ν).represents_prod h + +/-- The ordinal value of a series representing a nonzero element of `P̂` in degree `β` is +exactly `ω^β`. -/ +theorem Represents.ordinalValue_eq {u : Series K} {β : NatOrdinal} {e : PrincipalSubring K} + (h : Represents u β e) (he : e ≠ 0) : ordinalValue u = ω^ β := by + apply (ordinalValueDegree_eq_coe_iff u β).mp + simpa only [ordinalValueDegreeValuation_apply] using + MaxAddDegree.Represents.degree_eq h he + +/-- A series representing `0` in degree `β` has ordinal value below `ω^β`. -/ +theorem Represents.ordinalValue_lt_of_eq_zero {u : Series K} {β : NatOrdinal} + (h : Represents u β 0) : ordinalValue u < ω^ β := by + apply (ordinalValueDegree_lt_coe_iff u β).mp + simpa only [ordinalValueDegreeValuation_apply] using + MaxAddDegree.Represents.degree_lt_of_eq_zero h + +/-! ### Lifts of a minimal system of homogeneous generators -/ + +variable {ι : Type w} (wt : ι → NatOrdinal) (x : ι → PrincipalSubring K) + +/-- Representatives of a family of homogeneous elements of `P̂`, in their specified degrees. -/ +abbrev Lifts := MaxAddDegree.LiftFamily (ordinalValueDegreeValuation K) wt x + +variable {wt x} + +/-- Lifts exist for every family of homogeneous elements. -/ +theorem exists_lifts (hmem : ∀ i, x i ∈ Berarducci.principalGrading K (wt i)) : + Nonempty (Lifts wt x) := by + have h : ∀ i, ∃ u : Series K, Represents u (wt i) (x i) := fun i ↦ by + obtain ⟨a, ha⟩ := (DirectSum.mem_rangeLof_iff K _ _ _).mp (hmem i) + obtain ⟨u, hu, rfl⟩ := exists_principalComponentMk (wt i) a + exact ⟨u, represents_iff.mpr ⟨hu, by rw [← ha, DirectSum.lof_eq_of]⟩⟩ + choose u hu using h + exact ⟨⟨u, hu⟩⟩ + +namespace Lifts + +variable (σ : Lifts wt x) + +/-- Evaluation at the lifts is graded: `F(b_𝓑) ∈ J_{ω^(β+1)}` represents `F(𝓑)` in degree `β` for +`F` homogeneous of degree `β`. -/ +@[blueprint "lem:homogeneous-evaluation-represents" + (phase := "Translated truncations") + (title := "Initial form of a weighted-homogeneous evaluation") + (statement := /-- + Let $K$ be a field. For each $i\in I$, let + $x_i\in\mathrm P_{\alpha_i}\subseteq\widehat{\mathrm P}$ and choose + $b_i\in K((\mathbb R^{\le0}))$ representing $x_i$, so that + \[ + v_J(b_i)<\omega^{\alpha_i+1},\qquad + b_i+J_{\omega^{\alpha_i}}=x_i. + \] + If $F\in K[X_i:i\in I]$ is weighted-homogeneous of degree $\beta$ for the + weights $\alpha_i$, then + \[ + v_J(F(b_i))<\omega^{\beta+1},\qquad + F(b_i)+J_{\omega^\beta}=F(x_i)\in\mathrm P_\beta. + \] + -/) + (proof := /-- + Constants represent their images in degree $0$, and representatives are + preserved by addition, multiplication, and powers. Hence every monomial in + $F(b_i)$ represents the corresponding monomial in $F(x_i)$ in its weighted + degree. Since every monomial of $F$ has weighted degree $\beta$, summing gives + the two asserted properties in degree $\beta$. + -/)] +theorem aeval_represents {F : MvPolynomial ι K} {β : NatOrdinal} + (hF : IsWeightedHomogeneous wt F β) : Represents (aeval σ.lift F) β (aeval x F) := + (ν).represents_aeval represents_C σ.represents hF + +/-- `v_J(F(b_𝓑)) < ω^(β+1)` for `F` homogeneous of degree `β`. -/ +theorem ordinalValue_aeval_lt_of_isWeightedHomogeneous {F : MvPolynomial ι K} {β : NatOrdinal} + (hF : IsWeightedHomogeneous wt F β) : ordinalValue (aeval σ.lift F) < ω^ (β + 1) := + (σ.aeval_represents hF).ordinalValue_lt + +/-- `v_J(F(b_𝓑)) = ω^β` for `F` homogeneous of degree `β` with `F(𝓑) ≠ 0`. -/ +theorem ordinalValue_aeval_eq_of_aeval_ne_zero {F : MvPolynomial ι K} {β : NatOrdinal} + (hF : IsWeightedHomogeneous wt F β) (h : aeval x F ≠ 0) : + ordinalValue (aeval σ.lift F) = ω^ β := + (σ.aeval_represents hF).ordinalValue_eq h + +/-- `v_J(F(b_𝓑)) < ω^β` for `F` homogeneous of degree `β` with `F(𝓑) = 0`. -/ +theorem ordinalValue_aeval_lt_of_aeval_eq_zero {F : MvPolynomial ι K} {β : NatOrdinal} + (hF : IsWeightedHomogeneous wt F β) (h : aeval x F = 0) : + ordinalValue (aeval σ.lift F) < ω^ β := + (h ▸ σ.aeval_represents hF).ordinalValue_lt_of_eq_zero + +end Lifts + +/-! ### Polynomials of degree below `α` -/ + +variable (wt) in +/-- Every monomial of `F` has degree below `α`. -/ +def DegreeLT (F : MvPolynomial ι K) (α : NatOrdinal) : Prop := + ∀ d ∈ F.support, Finsupp.weight wt d < α + +theorem degreeLT_iff {F : MvPolynomial ι K} {α : NatOrdinal} : + DegreeLT wt F α ↔ ∀ d ∈ F.support, Finsupp.weight wt d < α := + Iff.rfl + +theorem degreeLT_zero (α : NatOrdinal) : DegreeLT wt (0 : MvPolynomial ι K) α := fun d hd ↦ by + simp at hd + +theorem DegreeLT.add {F G : MvPolynomial ι K} {α : NatOrdinal} (hF : DegreeLT wt F α) + (hG : DegreeLT wt G α) : DegreeLT wt (F + G) α := fun d hd ↦ by + classical + rcases Finset.mem_union.mp (MvPolynomial.support_add hd) with h | h + · exact hF d h + · exact hG d h + +theorem DegreeLT.neg {F : MvPolynomial ι K} {α : NatOrdinal} (hF : DegreeLT wt F α) : + DegreeLT wt (-F) α := fun d hd ↦ hF d (by rwa [MvPolynomial.support_neg] at hd) + +theorem DegreeLT.sub {F G : MvPolynomial ι K} {α : NatOrdinal} (hF : DegreeLT wt F α) + (hG : DegreeLT wt G α) : DegreeLT wt (F - G) α := by + rw [sub_eq_add_neg]; exact hF.add hG.neg + +theorem DegreeLT.mono {F : MvPolynomial ι K} {α α' : NatOrdinal} (hF : DegreeLT wt F α) + (h : α ≤ α') : DegreeLT wt F α' := fun d hd ↦ (hF d hd).trans_le h + +theorem _root_.MvPolynomial.IsWeightedHomogeneous.degreeLT {F : MvPolynomial ι K} + {β α : NatOrdinal} (hF : IsWeightedHomogeneous wt F β) (h : β < α) : DegreeLT wt F α := + fun _ hd ↦ (hF (mem_support_iff.mp hd)).symm ▸ h + +/-- The homogeneous components of `F` of degree at least `α` vanish when `F` has degree below `α`. +-/ +theorem DegreeLT.weightedHomogeneousComponent_eq_zero {F : MvPolynomial ι K} {α β : NatOrdinal} + (hF : DegreeLT wt F α) (h : α ≤ β) : weightedHomogeneousComponent wt β F = 0 := + weightedHomogeneousComponent_eq_zero' β F fun d hd (hw : Finsupp.weight wt d = β) ↦ + (hF d hd).not_ge (hw.symm ▸ h) + +/-- The component of `F` in degree `β` has degree below `α` whenever `F` does. -/ +theorem DegreeLT.weightedHomogeneousComponent {F : MvPolynomial ι K} {α : NatOrdinal} + (hF : DegreeLT wt F α) (β : NatOrdinal) : + DegreeLT wt (weightedHomogeneousComponent wt β F) α := by + classical + intro d hd + rw [mem_support_iff, coeff_weightedHomogeneousComponent] at hd + split_ifs at hd with hw + · exact hF d (mem_support_iff.mpr hd) + · exact absurd rfl hd + +/-- A nonzero polynomial of degree below `α` has total degree below `α`. -/ +theorem DegreeLT.weightedTotalDegree_lt {F : MvPolynomial ι K} {α : NatOrdinal} + (hF : DegreeLT wt F α) (hF0 : F ≠ 0) : weightedTotalDegree wt F < α := by + obtain ⟨d, hd, hsup⟩ := Finset.exists_mem_eq_sup _ (support_nonempty.mpr hF0) + (Finsupp.weight wt) + rw [weightedTotalDegree, hsup] + exact hF d hd + +/-- The top homogeneous component of a nonzero polynomial is nonzero. -/ +theorem weightedHomogeneousComponent_weightedTotalDegree_ne_zero {F : MvPolynomial ι K} + (hF0 : F ≠ 0) : weightedHomogeneousComponent wt (weightedTotalDegree wt F) F ≠ 0 := by + classical + obtain ⟨d, hd, hsup⟩ := Finset.exists_mem_eq_sup _ (support_nonempty.mpr hF0) + (Finsupp.weight wt) + intro h + have := congrArg (fun p : MvPolynomial ι K ↦ p.coeff d) h + rw [coeff_weightedHomogeneousComponent, ite_eq_left (by rw [weightedTotalDegree, hsup]), + AddMonoidAlgebra.coeff_zero, Finsupp.zero_apply] at this + exact mem_support_iff.mp hd this + +/-- Removing the top homogeneous component leaves a polynomial of degree below the top degree. -/ +theorem degreeLT_sub_weightedHomogeneousComponent_weightedTotalDegree (F : MvPolynomial ι K) : + DegreeLT wt (F - weightedHomogeneousComponent wt (weightedTotalDegree wt F) F) + (weightedTotalDegree wt F) := by + classical + intro d hd + rw [mem_support_iff, coeff_sub, coeff_weightedHomogeneousComponent] at hd + split_ifs at hd with hw + · exact absurd (sub_self _) hd + · exact lt_of_le_of_ne (le_weightedTotalDegree wt (mem_support_iff.mpr fun h ↦ hd + (by rw [h, sub_zero]))) hw + +/-- A polynomial of degree below `α` is the sum of its homogeneous components of degree below `α`, +over the finite set of degrees occurring. -/ +theorem sum_weightedHomogeneousComponent_eq (F : MvPolynomial ι K) : + ∑ β ∈ (weightedHomogeneousComponent_finsupp (w := wt) F).toFinset, + weightedHomogeneousComponent wt β F = F := by + rw [← finsum_eq_sum _ (weightedHomogeneousComponent_finsupp F), sum_weightedHomogeneousComponent] + +/-! ### Ordinal value of a finite sum -/ + +/-- The ordinal value of a finite sum of series of ordinal value below `c > 0` is below `c`. -/ +theorem ordinalValue_sum_lt {ι' : Type*} (s : Finset ι') (f : ι' → Series K) {c : NatOrdinal} + (hc : 0 < c) (h : ∀ i ∈ s, ordinalValue (f i) < c) : ordinalValue (∑ i ∈ s, f i) < c := by + classical + induction s using Finset.induction_on with + | empty => rw [Finset.sum_empty, ordinalValue_zero]; exact hc + | insert a s ha ih => + rw [Finset.sum_insert ha] + exact (ordinalValue_add_le_max _ _).trans_lt (max_lt (h a (Finset.mem_insert_self a s)) + (ih fun i hi ↦ h i (Finset.mem_insert_of_mem hi))) + +/-- The ordinal value of `a + b` is that of `a` when `v_J(b) < v_J(a)`. -/ +theorem ordinalValue_add_eq_of_lt {a b : Series K} (h : ordinalValue b < ordinalValue a) : + ordinalValue (a + b) = ordinalValue a := by + refine le_antisymm ((ordinalValue_add_le_max a b).trans (max_le le_rfl h.le)) ?_ + have h1 : a = a + b + -b := by abel + calc ordinalValue a = ordinalValue (a + b + -b) := by rw [← h1] + _ ≤ max (ordinalValue (a + b)) (ordinalValue (-b)) := ordinalValue_add_le_max _ _ + _ ≤ ordinalValue (a + b) := by + rw [ordinalValue_neg] + refine max_le le_rfl ?_ + by_contra hlt + rw [not_le] at hlt + have h2 : ordinalValue (a + b) ≤ max (ordinalValue a) (ordinalValue b) := + ordinalValue_add_le_max a b + rw [max_eq_left h.le] at h2 + have h3 : ordinalValue a ≤ max (ordinalValue (a + b)) (ordinalValue b) := by + calc ordinalValue a = ordinalValue (a + b + -b) := by rw [← h1] + _ ≤ max (ordinalValue (a + b)) (ordinalValue (-b)) := ordinalValue_add_le_max _ _ + _ = _ := by rw [ordinalValue_neg] + rw [max_eq_right hlt.le] at h3 + exact h.not_ge h3 + +namespace Lifts + +variable (σ : Lifts wt x) + +/-- `v_J(F(b_𝓑)) < ω^α` when every monomial of `F` has degree below `α`. -/ +theorem ordinalValue_aeval_lt_of_degreeLT {F : MvPolynomial ι K} {α : NatOrdinal} + (hF : DegreeLT wt F α) : ordinalValue (aeval σ.lift F) < ω^ α := + (ordinalValueDegree_lt_coe_iff _ _).mp (by + simpa only [ordinalValueDegreeValuation_apply] using + (ν).degree_aeval_lt_of_forall_weight_lt represents_C σ.represents hF) + +/-! ### Every series of ordinal value below `ω^α` is congruent modulo `J` to a value `F(b_𝓑)` -/ + +variable (hx : IsMinimalSystem (Berarducci.principalGrading K) wt x) +include hx + +/-- Every series of ordinal value below `ω^α` is congruent modulo `J` to a value `F(b_𝓑)` with +every monomial of `F` of degree below `α`. -/ +@[blueprint "prop:polynomial-representative-exists" + (phase := "Translated truncations") + (title := "Existence of polynomial representatives modulo $J$") + (statement := /-- + Let $K$ be a field, let $(x_i)_{i\in I}$ be a minimal homogeneous + generating system of + $\widehat{\mathrm P}=\bigoplus_{\beta<\omega_1}\mathrm P_\beta$, with + $x_i\in\mathrm P_{w_i}$, and choose representatives $b_i$ satisfying + \[ + v_J(b_i)<\omega^{w_i+1},\qquad + b_i+J_{\omega^{w_i}}=x_i. + \] + If $\alpha<\omega_1$ and + $u\in K((\mathbb R^{\le0}))$ satisfies $v_J(u)<\omega^\alpha$, then there + is a polynomial $F\in K[X_i:i\in I]$ such that every monomial of $F$ has + weighted degree less than $\alpha$ and + \[ + u\equiv F(b_i)\pmod J. + \] + -/) + (proof := /-- + Use well-founded induction on $v_J(u)$. The case $u\in J$ is represented by + $0$. Otherwise $v_J(u)=\omega^\beta$ for some $\beta<\alpha$. Since the + chosen $b_i$ are available by + \ref{fact:principal-series-representatives}, and since the $x_i$ generate + $\widehat{\mathrm P}$, \ref{lem:generate} gives a weighted-homogeneous polynomial $F_0$ of + degree $\beta$ whose value $F_0(x_i)$ is the class of $u$ in $\mathrm P_\beta$. + By \ref{lem:homogeneous-evaluation-represents}, $F_0(b_i)$ represents the + same class, so + \[ + v_J\bigl(u-F_0(b_i)\bigr) + intro u huo hu + rcases ordinalValue_eq_zero_or_isAdditivelyPrincipal u with h0 | hprin + · -- `u ∈ J` + refine ⟨0, degreeLT_zero α, ?_⟩ + rw [map_zero, map_zero, eq_comm, toGerm_apply, Ideal.Quotient.eq_zero_iff_mem] + exact ordinalValue_eq_zero_iff.mp h0 + · obtain ⟨γ, hγ⟩ := Ordinal.isAdditivelyPrincipal_iff.mp hprin + set β : NatOrdinal := NatOrdinal.of γ with hβdef + have hval : ordinalValue u = ω^ β := by + rw [hβdef, NatOrdinal.wpow_def, NatOrdinal.val_of, ← hγ, NatOrdinal.of_val] + have hβα : β < α := by rwa [hval, NatOrdinal.wpow_lt_wpow] at hu + have hu1 : ordinalValue u < ω^ (β + 1) := by + rw [hval, NatOrdinal.wpow_lt_wpow]; exact Order.lt_add_one_iff.mpr le_rfl + -- the class of `u` in `P_β` is the evaluation of a homogeneous polynomial + obtain ⟨G, hG, hGu⟩ := hx.exists_aeval_eq + (Berarducci.principalGrading_gradeZeroScalars K) β + (DirectSum.of (PrincipalComponent K) β (principalComponentMk β u hu1)) + (Berarducci.of_mem_principalGrading β _) + have hrep := σ.aeval_represents hG + rw [hGu] at hrep + obtain ⟨hGlt, hGmk⟩ := represents_iff.mp hrep + have hmk : principalComponentMk β (aeval σ.lift G) hGlt = principalComponentMk β u hu1 := + DirectSum.of_injective β hGmk + rw [principalComponentMk_eq_iff] at hmk + -- the difference `u - G(b_𝓑)` has smaller ordinal value + have hrem : ordinalValue (u - aeval σ.lift G) < o := by + rw [← huo, hval] + have := hmk + rwa [← ordinalValue_neg, neg_sub] at this + obtain ⟨F', hF', hF'u⟩ := ih _ hrem (u - aeval σ.lift G) rfl + (hrem.trans (huo ▸ hu)) + refine ⟨G + F', (hG.degreeLT hβα).add hF', ?_⟩ + rw [map_add, map_add, hF'u, map_sub, add_sub_cancel] + +end Lifts + +/-! ### Uniqueness of the polynomial when evaluation is injective below `α` -/ + +namespace Lifts + +variable (σ : Lifts wt x) + +/-- When evaluation is injective in degree `β`, `v_J(F(b_𝓑)) = ω^β` for every nonzero `F` +homogeneous of degree `β`. -/ +theorem ordinalValue_aeval_eq_of_injectiveAt {β : NatOrdinal} (hβ : InjectiveAt K wt x β) + {F : MvPolynomial ι K} (hF : IsWeightedHomogeneous wt F β) (hF0 : F ≠ 0) : + ordinalValue (aeval σ.lift F) = ω^ β := + σ.ordinalValue_aeval_eq_of_aeval_ne_zero hF fun h ↦ hF0 ((injectiveAt_iff β).mp hβ F hF h) + +/-- When evaluation is injective in the top degree of `F ≠ 0`, `v_J(F(b_𝓑)) = ω^(deg F)`. -/ +@[blueprint "prop:polynomial-evaluation-ordinal-value" + (phase := "Translated truncations") + (title := "Ordinal value of a polynomial evaluation") + (statement := /-- + Let $K$ be a field. For each $i\in I$, let + $x_i\in\mathrm P_{w_i}\subseteq\widehat{\mathrm P}$ and choose a + representative $b_i\in K((\mathbb R^{\le0}))$. Let + $F\in K[X_i:i\in I]$ be nonzero, and let $\deg_w(F)$ be the largest weighted + degree of a monomial of $F$. If evaluation at $(x_i)$ is injective on the + weighted-homogeneous polynomials of degree $\deg_w(F)$, then + \[ + v_J(F(b_i))=\omega^{\deg_w(F)}. + \] + -/) + (proof := /-- + Let $F_d$ be the weighted-homogeneous component of $F$ of top degree + $d=\deg_w(F)$. It is nonzero, and injectivity in degree $d$ gives + $F_d(x_i)\ne0$. By \ref{lem:homogeneous-evaluation-represents}, + $F_d(b_i)$ represents this nonzero class in $\mathrm P_d$, so + $v_J(F_d(b_i))=\omega^d$. Every monomial of $F-F_d$ has weighted degree less + than $d$, whence $v_J((F-F_d)(b_i))<\omega^d$. Since + $F(b_i)=F_d(b_i)+(F-F_d)(b_i)$, the strict inequality and the ultrametric + property give $v_J(F(b_i))=\omega^d$. + -/)] +theorem ordinalValue_aeval_eq_wpow_weightedTotalDegree {F : MvPolynomial ι K} + (hβ : InjectiveAt K wt x (weightedTotalDegree wt F)) (hF0 : F ≠ 0) : + ordinalValue (aeval σ.lift F) = ω^ (weightedTotalDegree wt F) := by + set β := weightedTotalDegree wt F + set T := weightedHomogeneousComponent wt β F + have hT : ordinalValue (aeval σ.lift T) = ω^ β := + σ.ordinalValue_aeval_eq_of_injectiveAt hβ + (weightedHomogeneousComponent_isWeightedHomogeneous (w := wt) (n := β) (φ := F)) + (weightedHomogeneousComponent_weightedTotalDegree_ne_zero hF0) + have hR : ordinalValue (aeval σ.lift (F - T)) < ω^ β := + σ.ordinalValue_aeval_lt_of_degreeLT + (degreeLT_sub_weightedHomogeneousComponent_weightedTotalDegree F) + have hsplit : aeval σ.lift F = aeval σ.lift T + aeval σ.lift (F - T) := by + rw [← map_add, add_sub_cancel] + rw [hsplit, ordinalValue_add_eq_of_lt (hT ▸ hR), hT] + +/-- When evaluation is injective in every degree below `α`, a polynomial of degree below `α` +whose value at the lifts lies in `J` is zero. -/ +theorem eq_zero_of_degreeLT_of_toGerm_aeval_eq_zero {α : NatOrdinal} + (hinj : ∀ β < α, InjectiveAt K wt x β) {F : MvPolynomial ι K} (hF : DegreeLT wt F α) + (h : toGerm (aeval σ.lift F) = 0) : F = 0 := by + by_contra hF0 + have hval := σ.ordinalValue_aeval_eq_wpow_weightedTotalDegree + (hinj _ (hF.weightedTotalDegree_lt hF0)) hF0 + rw [toGerm_apply, Ideal.Quotient.eq_zero_iff_mem, ← ordinalValue_eq_zero_iff, hval] at h + exact NatOrdinal.wpow_ne_zero _ h + +/-- Uniqueness of the polynomial: two polynomials of degree below `α` whose values at the lifts +are congruent modulo `J` agree, when evaluation is injective in every degree below `α`. -/ +theorem eq_of_degreeLT_of_toGerm_aeval_eq {α : NatOrdinal} (hinj : ∀ β < α, InjectiveAt K wt x β) + {F G : MvPolynomial ι K} (hF : DegreeLT wt F α) (hG : DegreeLT wt G α) + (h : toGerm (aeval σ.lift F) = toGerm (aeval σ.lift G)) : F = G := by + rw [← sub_eq_zero] + exact σ.eq_zero_of_degreeLT_of_toGerm_aeval_eq_zero hinj (hF.sub hG) + (by rw [map_sub, map_sub, h, sub_self]) + +end Lifts + +/-! ### The polynomial of a series modulo `J` -/ + +namespace Lifts + +variable (σ : Lifts wt x) (hx : IsMinimalSystem (Berarducci.principalGrading K) wt x) + +/-- The polynomial `pol(u)` of a series `u` of ordinal value below `ω^α` modulo `J`: a polynomial +`F` with every monomial of degree below `α` and `F(b_𝓑) ≡ u (mod J)`, chosen by +`exists_degreeLT_toGerm_aeval_eq`; `0` when `v_J(u) ≥ ω^α`. -/ +def pol (α : NatOrdinal) (u : Series K) : MvPolynomial ι K := by + classical + exact if hu : ordinalValue u < ω^ α then + Classical.choose (σ.exists_degreeLT_toGerm_aeval_eq hx α u hu) else 0 + +theorem pol_degreeLT (α : NatOrdinal) (u : Series K) : DegreeLT wt (σ.pol hx α u) α := by + classical + unfold pol + split_ifs with hu + · exact (Classical.choose_spec (σ.exists_degreeLT_toGerm_aeval_eq hx α u hu)).1 + · exact degreeLT_zero α + +theorem toGerm_aeval_pol {α : NatOrdinal} {u : Series K} (hu : ordinalValue u < ω^ α) : + toGerm (aeval σ.lift (σ.pol hx α u)) = toGerm u := by + classical + unfold pol + rw [dite_eq_left hu] + exact (Classical.choose_spec (σ.exists_degreeLT_toGerm_aeval_eq hx α u hu)).2 + +/-- When evaluation is injective below `α`, the polynomial of `u` modulo `J` is the unique +polynomial of degree below `α` whose value at the lifts is congruent to `u` modulo `J`. -/ +theorem pol_eq_of_toGerm_aeval_eq {α : NatOrdinal} (hinj : ∀ β < α, InjectiveAt K wt x β) + {u : Series K} (hu : ordinalValue u < ω^ α) {F : MvPolynomial ι K} (hF : DegreeLT wt F α) + (h : toGerm (aeval σ.lift F) = toGerm u) : σ.pol hx α u = F := + σ.eq_of_degreeLT_of_toGerm_aeval_eq hinj (σ.pol_degreeLT hx α u) hF + (by rw [σ.toGerm_aeval_pol hx hu, h]) + +/-- The polynomial of a value `F(b_𝓑)`, `F` of degree below `α`, is `F`. -/ +theorem pol_aeval {α : NatOrdinal} (hinj : ∀ β < α, InjectiveAt K wt x β) + {F : MvPolynomial ι K} (hF : DegreeLT wt F α) : + σ.pol hx α (aeval σ.lift F) = F := + σ.pol_eq_of_toGerm_aeval_eq hx hinj (σ.ordinalValue_aeval_lt_of_degreeLT hF) hF rfl + +/-- `pol` is additive. -/ +theorem pol_add {α : NatOrdinal} (hinj : ∀ β < α, InjectiveAt K wt x β) {u u' : Series K} + (hu : ordinalValue u < ω^ α) (hu' : ordinalValue u' < ω^ α) : + σ.pol hx α (u + u') = σ.pol hx α u + σ.pol hx α u' := + σ.pol_eq_of_toGerm_aeval_eq hx hinj + ((ordinalValue_add_le_max u u').trans_lt (max_lt hu hu')) + ((σ.pol_degreeLT hx α u).add (σ.pol_degreeLT hx α u')) + (by rw [map_add, map_add, σ.toGerm_aeval_pol hx hu, σ.toGerm_aeval_pol hx hu', map_add]) + +/-- The polynomial of a series in `J` is zero. -/ +theorem pol_eq_zero_of_mem {α : NatOrdinal} (hinj : ∀ β < α, InjectiveAt K wt x β) + {u : Series K} (hu : u ∈ HahnSeries.Nonpositive.negativeMonomialIdeal K) : + σ.pol hx α u = 0 := + σ.pol_eq_of_toGerm_aeval_eq hx hinj + (by rw [ordinalValue_eq_zero_iff.mpr hu]; exact NatOrdinal.wpow_pos α) (degreeLT_zero α) + (by rw [map_zero, map_zero, toGerm_apply, eq_comm, Ideal.Quotient.eq_zero_iff_mem]; exact hu) + +/-- `v_J(u) = ω^(deg pol(u))` for `u ∉ J` of ordinal value below `ω^α`, when evaluation is +injective below `α`. -/ +@[blueprint "prop:ordinal-value-of-polynomial-representative" + (phase := "Translated truncations") + (title := "Ordinal value of a polynomial representative") + (statement := /-- + Let $K$ be a field, let $(x_i)_{i\in I}$ be a minimal homogeneous + generating system of $\widehat{\mathrm P}$ with + $x_i\in\mathrm P_{w_i}$, and choose representatives $b_i$. Fix + $\alpha<\omega_1$ and assume that evaluation at $(x_i)$ is injective on + weighted-homogeneous polynomials of every degree less than $\alpha$. + + For $u\in K((\mathbb R^{\le0}))$ with $v_J(u)<\omega^\alpha$, let $P_u$ be + the unique polynomial whose monomials have weight less than $\alpha$ and + which satisfies $P_u(b_i)\equiv u\pmod J$. If $u\notin J$, then + \[ + v_J(u)=\omega^{\deg_w(P_u)}, + \] + where $\deg_w(P_u)$ is the largest weighted degree of a monomial of $P_u$. + -/) + (proof := /-- + Existence and congruence of $P_u$ come from + \ref{prop:polynomial-representative-exists}. The polynomial is nonzero, + since otherwise its congruence would put $u$ in $J$. Its largest weighted + degree is less than $\alpha$, so the injectivity hypothesis applies there. + By \ref{prop:polynomial-evaluation-ordinal-value}, + \[ + v_J(P_u(b_i))=\omega^{\deg_w(P_u)}. + \] + Congruence modulo $J$ preserves every nonzero ordinal value, giving the + asserted equality for $u$. + -/)] +theorem ordinalValue_eq_wpow_weightedTotalDegree_pol {α : NatOrdinal} + (hinj : ∀ β < α, InjectiveAt K wt x β) {u : Series K} (hu : ordinalValue u < ω^ α) + (hu0 : u ∉ HahnSeries.Nonpositive.negativeMonomialIdeal K) : + ordinalValue u = ω^ (weightedTotalDegree wt (σ.pol hx α u)) := by + have hp0 : σ.pol hx α u ≠ 0 := by + intro h + have := σ.toGerm_aeval_pol hx hu + rw [h, map_zero, map_zero, toGerm_apply, eq_comm, Ideal.Quotient.eq_zero_iff_mem] at this + exact hu0 this + rw [← ordinalValue_eq_of_sub_mem_negativeMonomialIdeal + (toGerm_eq_toGerm_iff.mp (σ.toGerm_aeval_pol hx hu))] + exact σ.ordinalValue_aeval_eq_wpow_weightedTotalDegree + (hinj _ ((σ.pol_degreeLT hx α u).weightedTotalDegree_lt hp0)) hp0 + +end Lifts + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/LimitOrdinalRelationAtCutoff.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/LimitOrdinalRelationAtCutoff.lean new file mode 100644 index 0000000000..5b1b6bdfde --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/LimitOrdinalRelationAtCutoff.lean @@ -0,0 +1,390 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.LinearMaximal +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MvPolynomial.LimitOrdinalContradiction +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.AlgebraicOrder + +/-! +# Relations of limit-ordinal degree split at a Cantor cutoff + +Let `α` be a limit ordinal, assume evaluation is injective below `α`, and let `F ≠ 0` be +homogeneous of degree `α` with `F(𝓑) = 0`. Let `B₀` be a variable of `F` of maximal degree +`δ := deg B₀`, +`D` the degree of `F` in `X_{B₀}`, `H_D` the coefficient of `X_{B₀}^D` in `F`, homogeneous of +degree `α ⊖ (δ ⊙ D)`, and `ω^β` the last term of the Cantor normal form of `deg H_D`. +The leading-coefficient argument excludes a constant `H_D` and excludes the situation in which +every term of `δ` is at least `ω^β`. Thus `δ` has a term below `ω^β`. Write every degree as +`λ = λ_{≥β} ⊕ λ_{<β}`, its parts at or above and below `β`; for a variable `B` of `F` the +part `(deg B)_{<β}` is `S.degLT B`; `α_{≥β}`, `α_{<β}` are `S.αGE`, `S.αLT`. The bound on +remainder of the Leibniz rule (`RemainderBound`) and the ordinal values of the translated +truncations of `F(b_𝓑)` provide `λ₀ < α_{<β}` such that every term of the expansion of a +monomial of `F` by the convolution formula with at least two truncated factors has degree below +`α' := α_{≥β} ⊕ λ₀`, together with `α₁ ≤ α'` and `ε₁ > 0` such that +`v_J(F(b_𝓑)^{|γ}) < ω^{α₁}` for all `γ ∈ (-ε₁, 0)`. + +`LimitOrdinalRelationAtCutoff` bundles this relation, cutoff, and the required bounds. +`LimitOrdinalRelationAtCutoff.HasCanonicalBounds` records the canonical choice obtained from the +last term of `deg H_D`. The first consequences are: `β ≠ 0`; every `(deg B)_{<β}` is a limit +ordinal or `0`; +`D = 1`; `(deg B₀)_{<β} = α_{<β}`; `H := ∂F/∂X_{B₀}` is nonzero and homogeneous of degree +`α ⊖ δ`; every variable of `H` has zero part below `β`; in every monomial of `F` the parts +below `β` add up to `α_{<β}`; and two factors with nonzero parts below `β` obey `pair_bound`. +-/ + +universe v w + +open scoped NatOrdinal HahnSeries +open Berarducci HahnSeries MvPolynomial OrdinalGraded + +public noncomputable section + +namespace Berarducci + +variable {K : Type v} [Field K] {ι : Type w} {wt : ι → NatOrdinal} +variable {x : ι → PrincipalSubring K} + +namespace Lifts + +variable (σ : Lifts wt x) {α : NatOrdinal} + +/-- A homogeneous relation whose degree is a limit ordinal, a maximal variable, a Cantor cutoff, +and uniform bounds for translated truncations and the Leibniz remainder. -/ +structure LimitOrdinalRelationAtCutoff (α : NatOrdinal) where + /-- The relation. -/ + F : MvPolynomial ι K + hom : IsWeightedHomogeneous wt F α + eval_zero : aeval x F = 0 + ne_zero : F ≠ 0 + vars_lt : ∀ i ∈ F.vars, wt i < α + vars_limit : ∀ i ∈ F.vars, (wt i).constantCoeff = 0 + /-- A variable of maximal degree. -/ + B₀ : ι + mem : B₀ ∈ F.vars + max : ∀ i ∈ F.vars, wt i ≤ wt B₀ + /-- A cutoff exponent `β` such that every term of `deg H_D` is at least `ω^β`. -/ + β : NatOrdinal + /-- The degree `α ⊖ (δ ⊙ D)` of `H_D`, the coefficient of `X_{B₀}^D` in `F`. -/ + degHD : NatOrdinal + hdegHD : degHD + degreeOf B₀ F • wt B₀ = α + degHD_terms : ∀ t ∈ degHD.val.additivePrincipalTerms, (ω^ β).val ≤ t + degHD_ne_zero : degHD ≠ 0 + /-- The degree `δ = deg B₀` has a term below `ω^β`. -/ + term_lt : NatOrdinal.leastTerm (wt B₀) < ω^ β + /-- The bound `λ₀`: the terms of the remainder of the Leibniz rule have degree below + `α_{≥β} ⊕ λ₀`, and the translated truncations of `F(b_𝓑)` have ordinal value below + `ω^{α₁}` with `α₁ ≤ α_{≥β} ⊕ λ₀`. -/ + lam₀ : NatOrdinal + lam₀_lt : lam₀ < NatOrdinal.partLT β α + /-- The exponent bounding the ordinal values of sufficiently late translated truncations of + the relation. -/ + α₁ : NatOrdinal + α₁_le : α₁ ≤ NatOrdinal.partGE β α + lam₀ + α₁_le_α : α₁ ≤ α + /-- A positive radius on which translated truncations satisfy the designated ordinal-value + bound. -/ + ε₁ : ℝ + ε₁_pos : 0 < ε₁ + truncation_lt : ∀ γ : ℝ, -ε₁ < γ → γ < 0 → + ordinalValue (translatedTruncation ((aeval σ.lift F : Series K) : K⟦ℝ⟧) γ) < ω^ α₁ + remainder_lt : ∀ d ∈ F.support, ∀ (k : ℕ) (ρ : NatOrdinal), 2 ≤ k → + TermDegree wt d k ρ → ρ < NatOrdinal.partGE β α + lam₀ + +namespace LimitOrdinalRelationAtCutoff + +variable {σ} (S : σ.LimitOrdinalRelationAtCutoff α) + +/-- The part `α_{≥β}` of `α` at or above `β`. -/ +def αGE : NatOrdinal := NatOrdinal.partGE S.β α + +/-- The part `α_{<β}` of `α` below `β`. -/ +def αLT : NatOrdinal := NatOrdinal.partLT S.β α + +/-- The part `(deg B)_{<β}` of the degree of a variable `B` below `β`. -/ +def degLT (i : ι) : NatOrdinal := NatOrdinal.partLT S.β (wt i) + +/-- `H := ∂F/∂X_{B₀}`, the partial derivative of `F` at its variable of maximal degree. -/ +def H : MvPolynomial ι K := pderiv S.B₀ S.F + +/-- The part of `deg B` below `β` is zero. -/ +def LowDegreePartEqZero (i : ι) : Prop := S.degLT i = 0 + +/-- The part of `deg B` below `β` equals the part of `α` below `β`. -/ +def LowDegreePartEq (i : ι) : Prop := S.degLT i = S.αLT + +/-- The part of `deg B` below `β` precedes `λ₀` in the algebraic order. -/ +def LowDegreePartAlgebraicLE (i : ι) : Prop := NatOrdinal.AlgebraicLE (S.degLT i) S.lam₀ + +theorem αGE_def : S.αGE = NatOrdinal.partGE S.β α := (rfl) +theorem αLT_def : S.αLT = NatOrdinal.partLT S.β α := (rfl) +theorem degLT_def (i : ι) : S.degLT i = NatOrdinal.partLT S.β (wt i) := (rfl) +theorem H_def : S.H = pderiv S.B₀ S.F := (rfl) +theorem lowDegreePartEqZero_iff (i : ι) : S.LowDegreePartEqZero i ↔ S.degLT i = 0 := (Iff.rfl) +theorem lowDegreePartEq_iff (i : ι) : S.LowDegreePartEq i ↔ S.degLT i = S.αLT := (Iff.rfl) +theorem lowDegreePartAlgebraicLE_iff (i : ι) : + S.LowDegreePartAlgebraicLE i ↔ NatOrdinal.AlgebraicLE (S.degLT i) S.lam₀ := (Iff.rfl) + +/-- The canonical cutoff and bounds obtained from the last term of `deg H_D` and the truncation +and remainder estimates. -/ +structure HasCanonicalBounds : Prop where + /-- The degree `α` is nonzero. -/ + α_ne_zero : α ≠ 0 + /-- The degree `α` is a limit ordinal. -/ + α_constantCoeff : α.constantCoeff = 0 + /-- The last-term exponent `β` is nonzero. -/ + β_ne_zero : S.β ≠ 0 + /-- `ω^β` is the last term of the Cantor normal form of `deg H_D`. -/ + leastTerm_degHD : NatOrdinal.leastTerm S.degHD = ω^ S.β + /-- The translated-truncation exponent satisfies `α₁ < α`. -/ + α₁_lt : S.α₁ < α + /-- A remainder bound `λ` and the resulting definition of `λ₀`. -/ + lambda_choice : ∃ lam : NatOrdinal, + lam < S.αLT ∧ + (∀ d ∈ S.F.support, ∀ (k : ℕ) (ρ : NatOrdinal), 2 ≤ k → TermDegree wt d k ρ → + NatOrdinal.partGE S.β ρ = S.αGE → NatOrdinal.partLT S.β ρ ≤ lam) ∧ + S.lam₀ = Max.max (lam + 1) + (if NatOrdinal.partGE S.β S.α₁ = S.αGE then NatOrdinal.partLT S.β S.α₁ else 0) + +theorem αGE_add_αLT : S.αGE + S.αLT = α := NatOrdinal.partGE_add_partLT _ _ + +theorem partGE_add_degLT (i : ι) : NatOrdinal.partGE S.β (wt i) + S.degLT i = wt i := + NatOrdinal.partGE_add_partLT _ _ + +theorem degLT_lt_wpow (i : ι) : S.degLT i < ω^ S.β := NatOrdinal.partLT_lt _ _ + +theorem αLT_lt_wpow : S.αLT < ω^ S.β := NatOrdinal.partLT_lt _ _ + +theorem lam₀_lt_wpow : S.lam₀ < ω^ S.β := S.lam₀_lt.trans S.αLT_lt_wpow + +theorem partGE_αGE_add_lam₀ : + NatOrdinal.partGE S.β (NatOrdinal.partGE S.β α + S.lam₀) = + NatOrdinal.partGE S.β α := by + rw [NatOrdinal.partGE_add, NatOrdinal.partGE_partGE, + NatOrdinal.partGE_eq_zero_of_lt S.lam₀_lt_wpow, add_zero] + +theorem partLT_αGE_add_lam₀ : + NatOrdinal.partLT S.β (NatOrdinal.partGE S.β α + S.lam₀) = S.lam₀ := by + have := NatOrdinal.partGE_add_partLT S.β (NatOrdinal.partGE S.β α + S.lam₀) + rw [S.partGE_αGE_add_lam₀] at this + exact add_left_cancel this + +theorem partLT_degHD : NatOrdinal.partLT S.β S.degHD = 0 := + NatOrdinal.partLT_eq_zero_of_forall_le S.degHD_terms + +theorem αLT_eq_nsmul_degLT : S.αLT = degreeOf S.B₀ S.F • S.degLT S.B₀ := by + have h : NatOrdinal.partLT S.β α = + NatOrdinal.partLT S.β (S.degHD + degreeOf S.B₀ S.F • wt S.B₀) := + congrArg _ S.hdegHD.symm + rw [αLT, h, NatOrdinal.partLT_add, S.partLT_degHD, zero_add, NatOrdinal.partLT_nsmul] + rfl + +/-- In every monomial of `F` the parts below `β` add up to `α_{<β}`. -/ +theorem sum_degLT_eq_αLT {d : ι →₀ ℕ} (hd : d ∈ S.F.support) : + ∑ i ∈ d.support, d i • S.degLT i = S.αLT := by + simpa [degLT, αLT, Finsupp.weight_apply, Finsupp.sum] using + (S.hom.map_weight (NatOrdinal.partLTAddMonoidHom S.β) (mem_support_iff.mp hd)) + +/-- In every monomial of `F` the parts at or above `β` add up to `α_{≥β}`. -/ +theorem sum_partGE_eq_αGE {d : ι →₀ ℕ} (hd : d ∈ S.F.support) : + ∑ i ∈ d.support, d i • NatOrdinal.partGE S.β (wt i) = S.αGE := by + simpa [αGE, Finsupp.weight_apply, Finsupp.sum] using + (S.hom.map_weight (NatOrdinal.partGEAddMonoidHom S.β) (mem_support_iff.mp hd)) + +variable (hx : IsMinimalSystem (Berarducci.principalGrading K) wt x) +include hx + +theorem β_ne_zero : S.β ≠ 0 := by + intro h + have hbad := S.term_lt + rw [h, NatOrdinal.wpow_zero] at hbad + exact absurd (NatOrdinal.one_le_leastTerm (hx.ne_zero S.B₀)) (not_le.mpr hbad) + +/-- For every variable `B` of `F`, `(deg B)_{<β}` has finite part `0`. -/ +theorem degLT_constantCoeff {i : ι} (hi : i ∈ S.F.vars) : (S.degLT i).constantCoeff = 0 := by + rw [degLT, NatOrdinal.constantCoeff_partLT (S.β_ne_zero hx)] + exact S.vars_limit i hi + +/-- If `(deg B)_{<β} ≠ 0`, the last term of its Cantor normal form is `ω^e` with `e ≠ 0`. -/ +theorem exists_leastTerm_degLT {i : ι} (hi : i ∈ S.F.vars) (h : S.degLT i ≠ 0) : + ∃ e, e ≠ 0 ∧ NatOrdinal.leastTerm (S.degLT i) = ω^ e := by + obtain ⟨e, he⟩ := NatOrdinal.exists_leastTerm_eq_wpow h + refine ⟨e, fun he0 ↦ ?_, he⟩ + rw [he0, NatOrdinal.wpow_zero, ← NatOrdinal.removeLeastTerm_add_one_eq_self_iff] at he + have := S.degLT_constantCoeff hx hi + rw [← he, show (1 : NatOrdinal) = ((1 : ℕ) : NatOrdinal) by rw [Nat.cast_one], + NatOrdinal.constantCoeff_add_natCast] at this + omega + +/-- `(deg B₀)_{<β} ≠ 0`: the variable of maximal degree has a term below `ω^β`. -/ +theorem degLT_B₀_ne_zero : S.degLT S.B₀ ≠ 0 := by + obtain ⟨e, he⟩ := NatOrdinal.exists_leastTerm_eq_wpow (hx.ne_zero S.B₀) + have hlt : e < S.β := by + have := S.term_lt + rwa [he, NatOrdinal.wpow_lt_wpow] at this + exact NatOrdinal.partLT_ne_zero_of_leastTerm_lt (hx.ne_zero S.B₀) he hlt + +theorem αLT_ne_zero : S.αLT ≠ 0 := by + rw [S.αLT_eq_nsmul_degLT] + exact NatOrdinal.nsmul_ne_zero_of_ne_zero (S.degLT_B₀_ne_zero hx) + (Nat.one_le_iff_ne_zero.mpr (mem_vars_iff_degreeOf_ne_zero.mp S.mem)) + +theorem αLT_constantCoeff : S.αLT.constantCoeff = 0 := by + rw [S.αLT_eq_nsmul_degLT, NatOrdinal.constantCoeff_nsmul, S.degLT_constantCoeff hx S.mem, + mul_zero] + +/-! ### `X_{B₀}` occurs linearly in `F` -/ + +variable (hinj : ∀ β < α, InjectiveAt K wt x β) (hσ : σ.IsPrincipal) +include hinj hσ + +/-- **`D = 1`: `X_{B₀}` occurs linearly in `F`.** -/ +@[blueprint "lem:relation-at-limit-ordinal-maximal-variable-linear" + (phase := "Limit ordinals in the degree induction") + (title := "Maximal-variable linearity for the ordinal-value degree") + (statement := /-- + Let $K$ be a field of characteristic zero. Let $(x_i)_{i\in I}$ be a + minimal homogeneous generating system of $\widehat{\mathrm P}$, with + $x_i\in\mathrm P_{w_i}$, and choose principal series $b_i$ of degree + $w_i$ representing $x_i$. Assume evaluation at $(x_i)$ is injective on + every homogeneous degree below $\alpha$. + + Let $0\ne F\in K[X_i:i\in I]$ be weighted homogeneous of degree $\alpha$ + with $F(x)=0$. Suppose every variable of $F$ has weight below $\alpha$ + and zero constant Cantor coefficient. Choose $X_{B_0}$ of maximal weight + among the variables of $F$, and put $D=\deg_{X_{B_0}}F$. Suppose there are + ordinals $\beta,\Delta,\lambda_0,\alpha_1$ such that + \[ + \Delta\ne0,\qquad + \Delta\oplus D w_{B_0}=\alpha,\qquad + \lambda_0<\alpha_{<\beta}, + \] + every Cantor term of $\Delta$ is at least $\omega^\beta$, and the last + Cantor term of $w_{B_0}$ is below $\omega^\beta$. Assume also + \[ + \alpha_1\le\alpha_{\ge\beta}\oplus\lambda_0, + \qquad \alpha_1\le\alpha, + \] + that for some $\varepsilon_1>0$ every $\gamma\in(-\varepsilon_1,0)$ + satisfies + \[ + v_J\bigl(F(b)^{\vert\gamma}\bigr)<\omega^{\alpha_1}, + \] + and that in the convolution expansion of any monomial of $F$, every term + $\rho$ using at least two translated truncations satisfies + $\rho<\alpha_{\ge\beta}\oplus\lambda_0$. + + Then $D=1$. + -/) + (proof := /-- + Suppose $D\ge2$, put $t=(w_{B_0})_{<\beta}$, and set + $\Theta=\partial_{B_0}F$. The hypotheses give + $\alpha_{<\beta}=Dt$, while $t$ is a nonzero limit ordinal. The polynomial + $\Theta$ is nonzero and homogeneous of degree + \[ + h=\Delta\oplus(D-1)w_{B_0}<\alpha. + \] + Since evaluation is injective in degree $h$, the homogeneous evaluation + $\Theta(b)$ has ordinal value $\omega^h$. + + Since $\lambda_0\oplus1<(D-1)t\oplus t$, + \ref{lem:natural-sum-approach} gives $s<(D-1)t$ with + $\lambda_0\oplus1\le s\oplus t$. Put + $\tau=h_{\ge\beta}\oplus s$. Then $\tauw_{B_0}$. Maximality of $B_0$ makes + this ideal zero. On the other hand, \ref{lem:truncation-values} supplies + such a translated truncation with ordinal value exactly $\omega^\tau$. + This ordinal value is nonzero, and $\tau δ` (`exists_forall_componentsGE_pol_translatedTruncation_aeval_pderiv_mem`); there +are no such variables, so these components vanish, for any degree `τ` with `α′ ≤ τ ⊕ δ`. Here +`∂F/∂X_{B₀} ≠ 0` (characteristic `0`) is homogeneous of degree `h := deg H_D ⊕ (δ ⊙ (D−1))`, so +`v_J((∂F/∂X_{B₀})(b_𝓑)) = ω^h` by injectivity below `α`, and the cofinality clause of +[Ber00, Lem. 6.8] gives translated truncations of ordinal value `ω^τ` for every `τ < h` — whose +polynomials have a nonzero component of degree `τ`. It remains to find `τ < h` with `α′ ≤ τ ⊕ δ`: +the part of `h` below `β` is `(D−1) ⊙ δ_{<β}`, and some `σ < (D−1) ⊙ δ_{<β}` has +`σ ⊕ δ_{<β} > λ₀`; take `τ := h_{≥β} ⊕ σ`. +-/ + +universe v w + +open scoped NatOrdinal HahnSeries +open Berarducci HahnSeries MvPolynomial OrdinalGraded + +public noncomputable section + +namespace NatOrdinal + +/-- A natural ordinal whose Cantor normal form has last term `ω^e` with `e ≠ 0` is a limit. -/ +theorem constantCoeff_eq_zero_of_leastTerm_eq_wpow {a e : NatOrdinal} (he : e ≠ 0) + (ha : leastTerm a = ω^ e) : a.constantCoeff = 0 := by + by_contra h + have := leastTerm_eq_one_of_constantCoeff_pos (pos_iff_ne_zero.mpr h) + rw [ha, ← wpow_zero, wpow_inj] at this + exact he this + +theorem ne_zero_of_leastTerm_eq_wpow {a e : NatOrdinal} (ha : leastTerm a = ω^ e) : a ≠ 0 := by + rintro rfl + rw [leastTerm_zero] at ha + exact (wpow_pos e).ne ha + +end NatOrdinal + +namespace Berarducci + +variable {K : Type v} [Field K] {ι : Type w} {wt : ι → NatOrdinal} + +variable {x : ι → PrincipalSubring K} + +namespace Lifts + +variable (σ : Lifts wt x) (hx : IsMinimalSystem (Berarducci.principalGrading K) wt x) + {α : NatOrdinal} (hinj : ∀ β < α, InjectiveAt K wt x β) (hσ : σ.IsPrincipal) +include hx hinj hσ + +/-- **A maximal variable occurs linearly.** Let `F` be a relation of degree `α` in +variables of degree `< α`, `B₀` a variable of `F` of maximal degree, `degHD ⊕ (D • wt B₀) = α` with +`D` the degree of `F` in `X_{B₀}`, every term of `degHD` at least `ω^β`, the part of `wt B₀` below +`β` with last term `ω^e`, `e ≠ 0`, and `lam₀ < α_{<β}`. If the translated truncations of `F(b_𝓑)` +have ordinal value below `ω^{α₁}` for all `γ < 0` sufficiently close to `0`, with +`α₁ ≤ α_{≥β} ⊕ lam₀` and `α₁ ≤ α`, and every term of the expansion of a monomial of `F` with at +least two translated truncations has degree below `α_{≥β} ⊕ lam₀`, then `D = 1` (characteristic +`0`). -/ +theorem degreeOf_eq_one_of_forall_termDegree_lt [CharZero K] {F : MvPolynomial ι K} + (hF : IsWeightedHomogeneous wt F α) (hvars : ∀ i ∈ F.vars, wt i < α) + {B₀ : ι} (hB₀ : B₀ ∈ F.vars) (hmax : ∀ i ∈ F.vars, wt i ≤ wt B₀) + {degHD : NatOrdinal} (hdegHD : degHD + degreeOf B₀ F • wt B₀ = α) + {β : NatOrdinal} (hdegHDβ : ∀ t ∈ degHD.val.additivePrincipalTerms, (ω^ β).val ≤ t) + {e : NatOrdinal} (he : e ≠ 0) + (ht : NatOrdinal.leastTerm (NatOrdinal.partLT β (wt B₀)) = ω^ e) + {lam₀ : NatOrdinal} (hlam₀ : lam₀ < NatOrdinal.partLT β α) + {α₁ : NatOrdinal} (hα₁ : α₁ ≤ NatOrdinal.partGE β α + lam₀) (hα₁α : α₁ ≤ α) + {ε₁ : ℝ} (hε₁ : 0 < ε₁) + (hG : ∀ γ : ℝ, -ε₁ < γ → γ < 0 → + ordinalValue (translatedTruncation ((aeval σ.lift F : Series K) : K⟦ℝ⟧) γ) < ω^ α₁) + (hwin : ∀ d ∈ F.support, ∀ (k : ℕ) (ρ : NatOrdinal), 2 ≤ k → TermDegree wt d k ρ → + ρ < NatOrdinal.partGE β α + lam₀) : + degreeOf B₀ F = 1 := by + classical + set D := degreeOf B₀ F with hDdef + have hD1 : 1 ≤ D := Nat.one_le_iff_ne_zero.mpr (mem_vars_iff_degreeOf_ne_zero.mp hB₀) + by_contra hne + have hD2 : 2 ≤ D := by omega + set g := wt B₀ with hgdef + set t := NatOrdinal.partLT β g with htdef + have ht0 : t ≠ 0 := NatOrdinal.ne_zero_of_leastTerm_eq_wpow ht + have hg0 : g ≠ 0 := hx.ne_zero B₀ + -- the part of `α` below `β` is `D • t`, a limit + have hμ : NatOrdinal.partLT β α = D • t := by + rw [← hdegHD, NatOrdinal.partLT_add, NatOrdinal.partLT_eq_zero_of_forall_le hdegHDβ, + zero_add, NatOrdinal.partLT_nsmul] + have hμcc : (NatOrdinal.partLT β α).constantCoeff = 0 := by + rw [hμ, NatOrdinal.constantCoeff_nsmul, + NatOrdinal.constantCoeff_eq_zero_of_leastTerm_eq_wpow he ht, mul_zero] + -- the degree `h = degHD ⊕ (D-1) • g` of `∂F/∂X_{B₀}` + set h : NatOrdinal := degHD + (D - 1) • g with hhdef + have hhg : h + g = α := by + rw [hhdef, add_assoc, ← succ_nsmul, Nat.sub_add_cancel hD1, hdegHD] + have hhα : h < α := by + rw [← hhg]; exact lt_add_of_pos_right _ (pos_iff_ne_zero.mpr hg0) + have hhLT : NatOrdinal.partLT β h = (D - 1) • t := by + rw [hhdef, NatOrdinal.partLT_add, NatOrdinal.partLT_eq_zero_of_forall_le hdegHDβ, + zero_add, NatOrdinal.partLT_nsmul] + set Θ := pderiv B₀ F with hΘdef + have hΘ : IsWeightedHomogeneous wt Θ h := isWeightedHomogeneous_pderiv wt hF B₀ hhg + have hΘ0 : Θ ≠ 0 := pderiv_ne_zero_of_mem_vars hB₀ + have hvΘ : ordinalValue (aeval σ.lift Θ) = ω^ h := + σ.ordinalValue_aeval_eq_of_injectiveAt (hinj h hhα) hΘ hΘ0 + -- the degree `τ = h_{≥β} ⊕ σ'` with `σ' < (D-1) • t` and `λ₀ + 1 ≤ σ' ⊕ t` + have hlam : (D - 1) • t ≠ 0 := NatOrdinal.nsmul_ne_zero_of_ne_zero ht0 (by omega) + have hsig : t = 0 ∨ NatOrdinal.leastTerm ((D - 1) • t) ≤ NatOrdinal.leastTerm t := + Or.inr (le_of_eq (NatOrdinal.leastTerm_nsmul ht0 (by omega))) + have htau : lam₀ + 1 < (D - 1) • t + t := by + rw [← succ_nsmul, Nat.sub_add_cancel hD1, ← hμ] + refine lt_of_le_of_ne (Order.add_one_le_of_lt hlam₀) fun heq ↦ ?_ + have := congrArg NatOrdinal.constantCoeff heq + rw [hμcc, show lam₀ + 1 = lam₀ + ((1 : ℕ) : NatOrdinal) by rw [Nat.cast_one], + NatOrdinal.constantCoeff_add_natCast] at this + omega + obtain ⟨σ', hσ'lt, hσ'⟩ := NatOrdinal.exists_lt_le_add_of_lastCantorTerm_le hlam hsig htau + set τ : NatOrdinal := NatOrdinal.partGE β h + σ' with hτdef + have hτh : τ < h := by + conv_rhs => rw [← NatOrdinal.partGE_add_partLT β h] + rw [hhLT] + exact add_lt_add_right hσ'lt _ + have hτα'' : NatOrdinal.partGE β α + lam₀ ≤ τ + g := by + have h1 : τ + g = NatOrdinal.partGE β α + (σ' + t) := by + rw [← hhg, NatOrdinal.partGE_add, hτdef, htdef] + conv_lhs => rw [show g = NatOrdinal.partGE β g + NatOrdinal.partLT β g from + (NatOrdinal.partGE_add_partLT β g).symm] + abel + rw [h1] + exact add_le_add_right ((lt_add_one lam₀).le.trans hσ') _ + -- no variable of `F` has degree above `wt B₀`: the components of degree at least `τ` vanish + obtain ⟨ε, hε, h2⟩ := σ.exists_forall_componentsGE_pol_translatedTruncation_aeval_pderiv_mem hx + hinj hσ hF hvars hα₁ hα₁α hε₁ hG hwin B₀ hτα'' + have hempty : IsEmpty {j : ι // j ∈ F.vars ∧ wt B₀ < wt j} := + ⟨fun j ↦ absurd j.2.2 (not_lt.mpr (hmax j.1 j.2.1))⟩ + have hzero : ∀ γ : ℝ, -ε < γ → γ < 0 → componentsGE wt τ (σ.pol hx α + (translatedTruncation ((aeval σ.lift Θ : Series K) : K⟦ℝ⟧) γ)) = 0 := by + intro γ hγε hγ0 + have := h2 γ hγε hγ0 + rwa [Set.range_eq_empty, Ideal.span_empty, Ideal.mem_bot] at this + -- a translated truncation of ordinal value exactly `ω^τ` (cofinality clause of [Ber00, Lem. 6.8]) + obtain ⟨γ, hγε, hγ0, hγ⟩ := exists_ordinalValue_translatedTruncation_eq_wpow_of_lt hτh + (aeval σ.lift Θ) hvΘ (neg_neg_of_pos hε) + have hlt : ordinalValue (translatedTruncation ((aeval σ.lift Θ : Series K) : K⟦ℝ⟧) γ) < ω^ α := by + rw [hγ]; exact NatOrdinal.wpow_lt_wpow.mpr (hτh.trans hhα) + have hnotJ : translatedTruncation ((aeval σ.lift Θ : Series K) : K⟦ℝ⟧) γ ∉ + HahnSeries.Nonpositive.negativeMonomialIdeal K := + fun h ↦ NatOrdinal.wpow_ne_zero τ (hγ ▸ ordinalValue_eq_zero_iff.mpr h) + have hdeg := σ.ordinalValue_eq_wpow_weightedTotalDegree_pol hx hinj hlt hnotJ + rw [hγ, NatOrdinal.wpow_inj] at hdeg + have hp0 : σ.pol hx α (translatedTruncation ((aeval σ.lift Θ : Series K) : K⟦ℝ⟧) γ) ≠ 0 := by + intro h + have := σ.toGerm_aeval_pol hx hlt + rw [h, map_zero, map_zero, toGerm_apply, eq_comm, Ideal.Quotient.eq_zero_iff_mem] at this + exact hnotJ this + have hcomp := weightedHomogeneousComponent_weightedTotalDegree_ne_zero (wt := wt) hp0 + rw [← hdeg, ← weightedHomogeneousComponent_componentsGE_of_le wt le_rfl, hzero γ hγε hγ0, + map_zero] at hcomp + exact hcomp rfl + +end Lifts + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/LowDegreeParts.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/LowDegreeParts.lean new file mode 100644 index 0000000000..9985e16024 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/LowDegreeParts.lean @@ -0,0 +1,408 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MvPolynomial.LimitOrdinalContradiction +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.LimitOrdinalRelationAtCutoff + +/-! +# Low-degree parts and algebraic order + +For a relation of limit-ordinal degree `α` and a cutoff `β`, distinguish variables whose part of +the degree below `β` is zero, equals `α_{<β}`, precedes `λ₀` in the algebraic order, or is nonzero +and does not precede `λ₀` in that order. The bound `pair_bound` on a remainder term with two +truncated factors, through `PairBounds`, describes the last class: such a variable `B` occurs with +exponent `1` in every monomial of `F`; +every other variable `B'` with `(deg B')_{<β} ≠ 0` in such a monomial has the exponent `e_{B'}` +of the last term of `(deg B')_{<β}` above the exponent `e_B` of the last term of `(deg B)_{<β}`, +and `(λ₀)_{≥e_{B'}} = (α_{<β})_{≥e_{B'}}`; and with `ω^ε` the last term of the Cantor normal form +of `α_{<β} ⊖ (deg B)_{<β}`, `(λ₀)_{≥ε} = (α_{<β})_{≥ε}`. +-/ + +universe v w + +open scoped NatOrdinal HahnSeries +open Berarducci HahnSeries MvPolynomial OrdinalGraded + +public noncomputable section + +namespace NatOrdinal + +/-- The last term of the Cantor normal form of a sum of nonzero natural ordinals is the last term +of one of them. -/ +theorem exists_leastTerm_sum_eq {ι' : Type*} {s : Finset ι'} (hs : s.Nonempty) + (f : ι' → NatOrdinal) (hf : ∀ i ∈ s, f i ≠ 0) : + ∃ i ∈ s, leastTerm (∑ j ∈ s, f j) = leastTerm (f i) := by + classical + induction hs using Finset.Nonempty.cons_induction with + | singleton a => exact ⟨a, Finset.mem_singleton_self a, by rw [Finset.sum_singleton]⟩ + | cons a s ha hs ih => + obtain ⟨i, hi, hi'⟩ := ih fun j hj ↦ hf j (Finset.mem_cons_of_mem hj) + have hsum : ∑ j ∈ s, f j ≠ 0 := by + have : f i ≤ ∑ j ∈ s, f j := Finset.single_le_sum (fun j _ ↦ zero_le) hi + exact (lt_of_lt_of_le (pos_iff_ne_zero.mpr (hf i (Finset.mem_cons_of_mem hi))) this).ne' + rw [Finset.sum_cons, leastTerm_add (hf a (Finset.mem_cons_self a s)) hsum] + rcases min_choice (leastTerm (f a)) (leastTerm (∑ j ∈ s, f j)) with h | h + · exact ⟨a, Finset.mem_cons_self a s, h⟩ + · exact ⟨i, Finset.mem_cons_of_mem hi, h.trans hi'⟩ + +end NatOrdinal + +namespace Berarducci + +/-! ### Splitting off factors of a monomial -/ + +variable {ι : Type w} + +/-- A monomial containing `X_i` twice is `d' · X_i · X_i`. -/ +theorem exists_eq_add_single_add_single_self {d : ι →₀ ℕ} {i : ι} (h : 2 ≤ d i) : + ∃ d' : ι →₀ ℕ, d = d' + Finsupp.single i 1 + Finsupp.single i 1 := by + classical + refine ⟨d - Finsupp.single i 1 - Finsupp.single i 1, ?_⟩ + have h1 : Finsupp.single i 1 ≤ d - Finsupp.single i 1 := by + rw [Finsupp.single_le_iff, Finsupp.tsub_apply, Finsupp.single_eq_same] + omega + have h2 : Finsupp.single i 1 ≤ d := Finsupp.single_le_iff.mpr (by omega) + rw [tsub_add_cancel_of_le h1, tsub_add_cancel_of_le h2] + +/-- A monomial containing `X_i` and `X_u`, `u ≠ i`, is `d' · X_i · X_u`. -/ +theorem exists_eq_add_single_add_single {d : ι →₀ ℕ} {i u : ι} (hi : i ∈ d.support) + (hu : u ∈ d.support) (hui : u ≠ i) : + ∃ d' : ι →₀ ℕ, d = d' + Finsupp.single i 1 + Finsupp.single u 1 := by + classical + refine ⟨d - Finsupp.single i 1 - Finsupp.single u 1, ?_⟩ + have hdi : 1 ≤ d i := Nat.one_le_iff_ne_zero.mpr (Finsupp.mem_support_iff.mp hi) + have hdu : 1 ≤ d u := Nat.one_le_iff_ne_zero.mpr (Finsupp.mem_support_iff.mp hu) + have h1 : Finsupp.single u 1 ≤ d - Finsupp.single i 1 := by + rw [Finsupp.single_le_iff, Finsupp.tsub_apply, Finsupp.single_apply, ite_eq_right (Ne.symm hui)] + omega + have h2 : Finsupp.single i 1 ≤ d := Finsupp.single_le_iff.mpr hdi + rw [add_right_comm, tsub_add_cancel_of_le h1, tsub_add_cancel_of_le h2] + +variable {K : Type v} [Field K] {wt : ι → NatOrdinal} {x : ι → PrincipalSubring K} + +namespace Lifts.LimitOrdinalRelationAtCutoff + +variable {σ : Lifts wt x} {α : NatOrdinal} (S : σ.LimitOrdinalRelationAtCutoff α) + +/-- A variable of `F` has a proper low-degree part outside the algebraic bound when its part below +`β` is nonzero, is not all of `α_{<β}`, and does not precede `λ₀` in the algebraic order. -/ +def HasProperLowDegreePartNotAlgebraicLE (i : ι) : Prop := + i ∈ S.F.vars ∧ S.degLT i ≠ 0 ∧ ¬ S.LowDegreePartEq i ∧ ¬ S.LowDegreePartAlgebraicLE i + +theorem hasProperLowDegreePartNotAlgebraicLE_iff (i : ι) : + S.HasProperLowDegreePartNotAlgebraicLE i ↔ + i ∈ S.F.vars ∧ S.degLT i ≠ 0 ∧ ¬ S.LowDegreePartEq i ∧ + ¬ S.LowDegreePartAlgebraicLE i := (Iff.rfl) + +/-- For every variable `B` of `F`, `(deg B)_{<β} ≼ α_{<β}` in the algebraic order. -/ +theorem degLT_algebraicLE_αLT {i : ι} (hi : i ∈ S.F.vars) : + NatOrdinal.AlgebraicLE (S.degLT i) S.αLT := by + classical + obtain ⟨d, hd, hid⟩ := (mem_vars_iff_mem_support i).mp hi + have hsum := S.sum_degLT_eq_αLT hd + rw [← Finset.add_sum_erase _ _ hid] at hsum + have h1 : d i • S.degLT i = S.degLT i + (d i - 1) • S.degLT i := by + conv_lhs => rw [show d i = d i - 1 + 1 from + (Nat.sub_add_cancel (Nat.one_le_iff_ne_zero.mpr (Finsupp.mem_support_iff.mp hid))).symm] + rw [succ_nsmul'] + rw [h1, add_assoc] at hsum + rw [← hsum] + exact NatOrdinal.algebraicLE_add_right _ _ + +/-- For a monomial `d' · X_i · X_u` of `F`: `(deg d')_{<β} ⊕ S.degLT i ⊕ S.degLT u = α_{<β}`. -/ +theorem partLT_weight_add_degLT_add_degLT {d' : ι →₀ ℕ} {i u : ι} + (hd : d' + Finsupp.single i 1 + Finsupp.single u 1 ∈ S.F.support) : + NatOrdinal.partLT S.β (Finsupp.weight wt d') + S.degLT i + S.degLT u = S.αLT := by + rw [S.αLT_def, S.degLT_def, S.degLT_def] + exact MvPolynomial.partLT_weight_add_partLT_add_partLT S.hom hd + +variable (hx : IsMinimalSystem (Berarducci.principalGrading K) wt x) +include hx + +/-- **A variable whose proper low-degree part does not precede `λ₀` occurs once in each monomial +that contains it.** -/ +@[blueprint "lem:low-degree-part-outside-algebraic-bound-occurs-linearly" + (phase := "Limit ordinals in the degree induction") + (title := "Linearity when $(w_B)_{<\\beta}\\oplus\\nu\\ne\\lambda_0$ for every $\\nu$") + (statement := /-- + Let $K$ be a field. Let $(x_i)_{i\in I}$ be a minimal homogeneous + generating system of $\widehat{\mathrm P}$, with + $x_i\in\mathrm P_{w_i}$, and choose series $b_i$ representing $x_i$. + + Let $0\ne F\in K[X_i:i\in I]$ be weighted homogeneous of degree $\alpha$ + with $F(x)=0$. Suppose every variable of $F$ has weight below $\alpha$ + and zero constant Cantor coefficient. Choose $X_{B_0}$ of maximal weight + among the variables of $F$, and put $D=\deg_{X_{B_0}}F$. Suppose there are + ordinals $\beta,\Delta,\lambda_0,\alpha_1$ such that + \[ + \Delta\ne0,\qquad + \Delta\oplus D w_{B_0}=\alpha,\qquad + \lambda_0<\alpha_{<\beta}, + \] + every Cantor term of $\Delta$ is at least $\omega^\beta$, and the last + Cantor term of $w_{B_0}$ is below $\omega^\beta$. Assume also + \[ + \alpha_1\le\alpha_{\ge\beta}\oplus\lambda_0, + \qquad \alpha_1\le\alpha, + \] + that for some $\varepsilon_1>0$ every $\gamma\in(-\varepsilon_1,0)$ + satisfies + \[ + v_J\bigl(F(b)^{\vert\gamma}\bigr)<\omega^{\alpha_1}, + \] + and that in the convolution expansion of any monomial of $F$, every term + $\rho$ using at least two translated truncations satisfies + $\rho<\alpha_{\ge\beta}\oplus\lambda_0$. + + Let $X_B$ occur in $F$, and suppose + \[ + 0<(w_B)_{<\beta}\ne\alpha_{<\beta}, + \qquad + (w_B)_{<\beta}\not\preccurlyeq\lambda_0. + \] + Then $X_B$ has exponent $1$ in every monomial of $F$ in which it occurs. + -/) + (proof := /-- + Put $t=(w_B)_{<\beta}$. If some monomial contains $X_B$ at least twice, + write it as $M'X_B^2$. The finite part of $t$ is zero, so its last Cantor + term is $\omega^e$ for some $e\ne0$. Weighted homogeneity gives + \[ + (\deg M')_{<\beta}\oplus t\oplus t=\alpha_{<\beta}. + \] + The two-truncation bound says that for all $\rho_1,\rho_20$ every $\gamma\in(-\varepsilon_1,0)$ + satisfies + \[ + v_J\bigl(F(b)^{\vert\gamma}\bigr)<\omega^{\alpha_1}, + \] + and that in the convolution expansion of any monomial of $F$, every term + $\rho$ using at least two translated truncations satisfies + $\rho<\alpha_{\ge\beta}\oplus\lambda_0$. + + Let distinct variables $X_B,X_C$ occur in the same monomial of $F$. + Suppose + \[ + 0<(w_B)_{<\beta}\ne\alpha_{<\beta},\qquad + (w_B)_{<\beta}\oplus\nu\ne\lambda_0 + \quad\text{for every ordinal }\nu, + \] + and $(w_C)_{<\beta}\ne0$. If the last Cantor terms of + $(w_B)_{<\beta}$ and $(w_C)_{<\beta}$ are respectively + $\omega^{e_B}$ and $\omega^{e_C}$, then + \[ + e_B0$ every $\gamma\in(-\varepsilon_1,0)$ + satisfies + \[ + v_J\bigl(F(b)^{\vert\gamma}\bigr)<\omega^{\alpha_1}, + \] + and that in the convolution expansion of any monomial of $F$, every term + $\rho$ using at least two translated truncations satisfies + $\rho<\alpha_{\ge\beta}\oplus\lambda_0$. + + Let $X_B$ occur in $F$, and suppose + \[ + 0<(w_B)_{<\beta}\ne\alpha_{<\beta},\qquad + (w_B)_{<\beta}\oplus\nu\ne\lambda_0 + \quad\text{for every ordinal }\nu. + \] + If + \[ + c\oplus(w_B)_{<\beta}=\alpha_{<\beta} + \] + and the last Cantor term of $c$ is $\omega^e$, then + \[ + (\lambda_0)_{\ge e}=(\alpha_{<\beta})_{\ge e}. + \] + -/) + (proof := /-- + Choose a monomial containing $X_B$. By + \ref{lem:low-degree-part-outside-algebraic-bound-occurs-linearly}, $X_B$ has exponent one in this + monomial. After deleting it, the natural sum of the remaining nonzero parts + below $\beta$ is $c$. This family is nonempty because otherwise + $(w_B)_{<\beta}=\alpha_{<\beta}$. + + The last Cantor term of a finite natural sum of nonzero ordinals is the last + Cantor term of one of its summands. Choose a remaining variable $X_C$ that + supplies $\omega^e$. Then + \ref{lem:later-cantor-terms-outside-algebraic-bound} applied to $X_B$ and + $X_C$ gives + $(\lambda_0)_{\ge e}=(\alpha_{<\beta})_{\ge e}$. + -/)] +theorem partGE_lam₀_eq_of_hasProperLowDegreePartNotAlgebraicLE {i : ι} + (hi : S.HasProperLowDegreePartNotAlgebraicLE i) {c ε : NatOrdinal} + (hc : c + S.degLT i = S.αLT) (hε : NatOrdinal.leastTerm c = ω^ ε) : + NatOrdinal.partGE ε S.lam₀ = NatOrdinal.partGE ε S.αLT := by + classical + obtain ⟨hiv, hti, htop, -⟩ := id hi + obtain ⟨d, hd, hid⟩ := (mem_vars_iff_mem_support i).mp hiv + have hd1 := S.apply_eq_one_of_hasProperLowDegreePartNotAlgebraicLE hx hi hd hid + -- the parts below `β` of the other factors add up to `c` + have hsum := S.sum_degLT_eq_αLT hd + rw [← Finset.add_sum_erase _ _ hid, hd1, one_smul, add_comm] at hsum + have hc' : ∑ j ∈ d.support.erase i, d j • S.degLT j = c := + add_right_cancel (hsum.trans hc.symm) + -- restrict to the factors with nonzero part below `β` + set s := (d.support.erase i).filter fun j ↦ S.degLT j ≠ 0 with hsdef + have hcs : ∑ j ∈ s, d j • S.degLT j = c := by + rw [← hc', hsdef, Finset.sum_filter] + refine Finset.sum_congr rfl fun j _ ↦ ?_ + split_ifs with h + · rfl + · rw [not_not.mp h, smul_zero] + have hc0 : c ≠ 0 := by + rintro rfl + rw [zero_add] at hc + exact htop ((S.lowDegreePartEq_iff i).mpr hc) + have hs : s.Nonempty := by + rw [Finset.nonempty_iff_ne_empty] + intro h + rw [h, Finset.sum_empty] at hcs + exact hc0 hcs.symm + have hsne : ∀ j ∈ s, d j • S.degLT j ≠ 0 := fun j hj ↦ by + obtain ⟨hj, htj⟩ := Finset.mem_filter.mp hj + exact NatOrdinal.nsmul_ne_zero_of_ne_zero htj + (Nat.one_le_iff_ne_zero.mpr (Finsupp.mem_support_iff.mp (Finset.mem_erase.mp hj).2)) + obtain ⟨u, hus, hu⟩ := NatOrdinal.exists_leastTerm_sum_eq hs _ hsne + obtain ⟨hu', htu⟩ := Finset.mem_filter.mp hus + obtain ⟨hui, hud⟩ := Finset.mem_erase.mp hu' + rw [hcs, hε, NatOrdinal.leastTerm_nsmul htu + (Nat.one_le_iff_ne_zero.mpr (Finsupp.mem_support_iff.mp hud))] at hu + obtain ⟨eᵢ, -, heᵢ⟩ := S.exists_leastTerm_degLT hx hiv hti + exact + (S.lt_and_partGE_eq_of_hasProperLowDegreePartNotAlgebraicLE + hx hi hd hid hud hui htu heᵢ hu.symm).2 + +end Lifts.LimitOrdinalRelationAtCutoff + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/LoweringDerivation.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/LoweringDerivation.lean new file mode 100644 index 0000000000..3de8b68a55 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/LoweringDerivation.lean @@ -0,0 +1,306 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.LoweringDerivation.BaseChange +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.DirectSum.InternalGrading +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.GeometricIntegrality +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.SuccessorLeibniz +public import LeanPool.ConwayRefinement.ConwayRefinement.Order.Filter.FunAtZeroMinus.Pointwise +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.PrincipalIdealGE +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.BaseChange + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.DerivAtInjective +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalSubringFraction +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Degree.Statements.Degree +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Statements.ProductValue + +/-! +# `(P̂, ∂)` is a graded domain over `K` with a lowering derivation + +The ring `P̂ = ⨁ P_α` is internally graded by its components `P_α`, with `P_0 = K`, and the +maps `∂ : P_{α+1} → Fun_{0⁻}(P_α)` assemble into a single `K`-linear derivation +`∂ : P̂ → Fun_{0⁻}(P̂)`: the Leibniz identity on components of successor degree is the Leibniz +rule (D1) for `∂`, `∂` lowers the degree by one by construction (D2), and `∂` is injective on every +component of successor degree (D3). Hence `(P̂, ∂)` is a graded domain over `K` with a lowering +derivation (prop:P-lowering); the ideals `I_{≥j}` and the quotient `P̂/I` of the abstract theory are +those of `P̂`. + +The grading and `∂` exist over every coefficient field. In characteristic zero the abstract +structure theorem gives that `P̂/I` is a domain, and, applied to the base change `E ⊗[K] P̂` (a +domain, being a subring of the domain `P̂_E`), that `E ⊗[K] P̂/I` is a domain for every field +extension `E / K`: `P̂/I` is geometrically integral over `K`. +-/ + +universe v + +open Filter Topology +open scoped DirectSum HahnSeries NatOrdinal TensorProduct + +public noncomputable section + +namespace Berarducci + +open Berarducci LoweringDerivation + +variable {K : Type v} [Field K] + +/-! ### The derivation `∂` of `P̂` -/ + +variable (K) in +/-- `∂` on a single homogeneous component `P_α`, valued in `Fun_{0⁻}(P̂)`: for `α` a successor, +`∂` on `P_α` followed by the inclusion of the component `P_{α⁻}` indexed by its predecessor +into `P̂`; zero for `α` zero or a +limit (D2). -/ +def principalComponentDerivation (α : NatOrdinal) : + PrincipalComponent K α →ₗ[K] FunAtZeroMinus (PrincipalSubring K) := + if hα : 0 < α.constantCoeff then + (Filter.Germ.mapLinear (DirectSum.lof K NatOrdinal (PrincipalComponent K) (α.removeNat 1))).comp + (principalComponentDerivAt K α hα) + else 0 + +theorem principalComponentDerivation_of_pos {α : NatOrdinal} (hα : 0 < α.constantCoeff) + (a : PrincipalComponent K α) : + principalComponentDerivation K α a = + Filter.Germ.mapLinear (DirectSum.lof K NatOrdinal (PrincipalComponent K) (α.removeNat 1)) + (principalComponentDerivAt K α hα a) := by + rw [principalComponentDerivation, dite_eq_left hα, LinearMap.comp_apply] + +theorem principalComponentDerivation_of_eq_zero {α : NatOrdinal} (hα : α.constantCoeff = 0) + (a : PrincipalComponent K α) : principalComponentDerivation K α a = 0 := by + rw [principalComponentDerivation, dite_eq_right (by omega), LinearMap.zero_apply] + +/-- For `α` a successor, `∂` of the class of `u` is the function at `0⁻` `γ ↦ ∂(u)(γ)`, the class +of the translated truncation `u^{|γ}` in `P_{α⁻}` included into `P̂`. -/ +theorem principalComponentDerivation_principalComponentMk + {α : NatOrdinal} (hα : 0 < α.constantCoeff) + (u : Series K) (hu : ordinalValue u < ω^ (α + 1)) : + principalComponentDerivation K α (principalComponentMk α u hu) = + ((fun γ ↦ DirectSum.of (PrincipalComponent K) (α.removeNat 1) (derivAt α u γ) : + ℝ → PrincipalSubring K) : FunAtZeroMinus (PrincipalSubring K)) := by + rw [principalComponentDerivation_of_pos hα, principalComponentDerivAt_principalComponentMk, + Filter.Germ.mapLinear_coe] + rfl + +variable (K) in +/-- The derivation `∂ : P̂ → Fun_{0⁻}(P̂)`: `∂ : P_{α+1} → Fun_{0⁻}(P_α) ⊆ Fun_{0⁻}(P̂)` on each +component of successor degree, extended `K`-linearly, vanishing on components indexed by limit +ordinals +and of degree `0`. -/ +def principalSubringDerivation : PrincipalSubring K →ₗ[K] FunAtZeroMinus (PrincipalSubring K) := + DirectSum.toModule K NatOrdinal _ (principalComponentDerivation K) + +theorem principalSubringDerivation_of (α : NatOrdinal) (a : PrincipalComponent K α) : + principalSubringDerivation K (DirectSum.of (PrincipalComponent K) α a) = + principalComponentDerivation K α a := by + rw [principalSubringDerivation, ← DirectSum.lof_eq_of K, DirectSum.toModule_lof] + +/-- `∂` vanishes on scalars. -/ +theorem principalSubringDerivation_algebraMap (k : K) : + principalSubringDerivation K (algebraMap K (PrincipalSubring K) k) = 0 := by + rw [principalSubring_algebraMap_apply, principalSubringDerivation_of, + principalComponentDerivation_of_eq_zero NatOrdinal.constantCoeff_zero] + +/-- The Leibniz rule for `∂` on homogeneous elements, in the main case: `α` a successor and +`β > 0`. The translated-truncation identity in `P_{(α+β)⁻}` is pushed into `Fun_{0⁻}(P̂)`. -/ +private theorem principalSubringDerivation_of_mul_of_of_pos {α β : NatOrdinal} + (hα : 0 < α.constantCoeff) + (a : PrincipalComponent K α) (b : PrincipalComponent K β) : + principalSubringDerivation K + (DirectSum.of (PrincipalComponent K) α a * DirectSum.of (PrincipalComponent K) β b) = + principalSubringDerivation K (DirectSum.of (PrincipalComponent K) α a) * + ((DirectSum.of (PrincipalComponent K) β b : PrincipalSubring K) : FunAtZeroMinus _) + + ((DirectSum.of (PrincipalComponent K) α a : PrincipalSubring K) : FunAtZeroMinus _) * + principalSubringDerivation K (DirectSum.of (PrincipalComponent K) β b) := by + obtain ⟨u, hu, rfl⟩ := exists_principalComponentMk α a + obtain ⟨v, hv, rfl⟩ := exists_principalComponentMk β b + have hsum : 0 < (α + β).constantCoeff := by + rw [NatOrdinal.constantCoeff_add]; omega + rw [← of_principalComponentMul, principalComponentMul_mk, principalSubringDerivation_of, + principalSubringDerivation_of, principalSubringDerivation_of, + principalComponentDerivation_principalComponentMk hsum, + principalComponentDerivation_principalComponentMk hα] + by_cases hβc : 0 < β.constantCoeff + · rw [principalComponentDerivation_principalComponentMk hβc] + change _ = ((fun γ ↦ _ : ℝ → PrincipalSubring K) : FunAtZeroMinus (PrincipalSubring K)) + rw [Filter.Germ.coe_eq] + exact eventually_of_derivAt_mul_of_pos hα hβc u v hu hv + · rw [principalComponentDerivation_of_eq_zero (by omega), mul_zero, add_zero] + change _ = ((fun γ ↦ _ : ℝ → PrincipalSubring K) : FunAtZeroMinus (PrincipalSubring K)) + rw [Filter.Germ.coe_eq] + exact eventually_of_derivAt_mul_of_eq_zero hα (by omega) u v hu hv + +/-- The Leibniz rule for `∂` on homogeneous elements. -/ +theorem principalSubringDerivation_of_mul_of (α β : NatOrdinal) (a : PrincipalComponent K α) + (b : PrincipalComponent K β) : + principalSubringDerivation K + (DirectSum.of (PrincipalComponent K) α a * DirectSum.of (PrincipalComponent K) β b) = + principalSubringDerivation K (DirectSum.of (PrincipalComponent K) α a) * + ((DirectSum.of (PrincipalComponent K) β b : PrincipalSubring K) : FunAtZeroMinus _) + + ((DirectSum.of (PrincipalComponent K) α a : PrincipalSubring K) : FunAtZeroMinus _) * + principalSubringDerivation K (DirectSum.of (PrincipalComponent K) β b) := by + -- Scalars: a degree-zero factor is a constant `k`, and `k v` represents `k • B`. + rcases eq_or_ne α 0 with rfl | hα0 + · obtain ⟨k, rfl⟩ := principalComponentScalarHom_surjective K a + rw [← principalSubring_algebraMap_apply, ← Algebra.smul_def, map_smul, + principalSubringDerivation_algebraMap, zero_mul, zero_add, + FunAtZeroMinus.const_algebraMap_mul] + rcases eq_or_ne β 0 with rfl | hβ0 + · obtain ⟨k, rfl⟩ := principalComponentScalarHom_surjective K b + rw [← principalSubring_algebraMap_apply, ← Algebra.commutes, ← Algebra.smul_def, map_smul, + principalSubringDerivation_algebraMap, mul_zero, add_zero, + FunAtZeroMinus.mul_const_algebraMap] + by_cases hαc : 0 < α.constantCoeff + · exact principalSubringDerivation_of_mul_of_of_pos hαc a b + by_cases hβc : 0 < β.constantCoeff + · -- Symmetric case: apply the main case to `b * a`. + have h := principalSubringDerivation_of_mul_of_of_pos hβc b a + rw [mul_comm] at h + rw [h, add_comm] + simp only [mul_comm] + · -- Neither grade is a successor: both sides vanish. + have hsum : (α + β).constantCoeff = 0 := by + rw [NatOrdinal.constantCoeff_add]; omega + rw [← of_principalComponentMul, principalSubringDerivation_of, principalSubringDerivation_of, + principalSubringDerivation_of, principalComponentDerivation_of_eq_zero hsum, + principalComponentDerivation_of_eq_zero (by omega), + principalComponentDerivation_of_eq_zero (by omega), zero_mul, mul_zero, add_zero] + +/-- The Leibniz rule (D1) for `∂`. -/ +@[blueprint "thm:leibniz-rule-lowering-derivation" + (phase := "Translated truncations") + (title := "Leibniz rule for the lowering derivation") + (statement := /-- + Let $K$ be a field. On each successor component + $\mathrm P_{\alpha+1}\subseteq\widehat{\mathrm P}$, let $\partial$ send a + class represented by $b$ to the germ at $0^-$ of + \[ + \gamma\longmapsto + b^{\vert\gamma}+J_{\omega^\alpha}\in\mathrm P_\alpha, + \] + and let $\partial$ vanish on $\mathrm P_0$ and on components of limit + degree. Extend this map $K$-linearly to + \[ + \partial:\widehat{\mathrm P}\longrightarrow + \operatorname{Fun}_{0^-}(\widehat{\mathrm P}). + \] + Then, for all $B,C\in\widehat{\mathrm P}$, + \[ + \partial(BC)=\partial(B)C+B\partial(C) + \] + in $\operatorname{Fun}_{0^-}(\widehat{\mathrm P})$. + -/) + (proof := /-- + First suppose $B$ and $C$ are homogeneous. Degree-zero components are + scalars, so the identity follows from $K$-linearity. For positive degrees, + use \ref{fact:principal-series-representatives} to choose representatives. + If the degree of $B$ is a + successor, apply \ref{lem:convolution-formula} to $(BC)^{\vert\gamma}$. The two + boundary terms give $\partial(B)C+B\partial(C)$; by + \ref{lem:truncation-drop}, every interior term has smaller ordinal value and + vanishes in the target component. The case where only the degree of $C$ is a + successor follows by commutativity. If both positive degrees are limits, + their natural sum is a limit and all three derivatives vanish. + + Finally decompose arbitrary $B$ and $C$ into their finite sums of homogeneous + components. $K$-linearity of $\partial$ and distributivity extend the + homogeneous identity to all of $\widehat{\mathrm P}$. + -/)] +theorem principalSubringDerivation_mul (x y : PrincipalSubring K) : + principalSubringDerivation K (x * y) = + principalSubringDerivation K x * (y : FunAtZeroMinus _) + + (x : FunAtZeroMinus _) * principalSubringDerivation K y := by + induction x using DirectSum.induction_on with + | zero => rw [zero_mul, map_zero, zero_mul, FunAtZeroMinus.const_zero, zero_mul, add_zero] + | of α a => + induction y using DirectSum.induction_on with + | zero => rw [mul_zero, map_zero, mul_zero, FunAtZeroMinus.const_zero, mul_zero, add_zero] + | of β b => exact principalSubringDerivation_of_mul_of α β a b + | add y z hy hz => + rw [mul_add, map_add, hy, hz, map_add, FunAtZeroMinus.const_add, mul_add, mul_add] + abel + | add x z hx hz => + rw [add_mul, map_add, hx, hz, map_add, FunAtZeroMinus.const_add, add_mul, add_mul] + abel + +variable (K) in +/-- `∂` is a lowering derivation of `P̂` for its grading by the homogeneous components `P_α`: (D1) +the Leibniz +rule, (D2) `∂(P_{α+1}) ⊆ Fun_{0⁻}(P_α)` and `∂(P_α) = 0` for `α` zero or a limit, (D3) injectivity +on every `P_{α+1}`. With `P̂` a domain and `P_0 = K` this is prop:P-lowering: `(P̂, ∂)` is a +graded domain over `K` with a lowering derivation. -/ +theorem principalSubringDerivation_isLoweringDerivation : + IsLoweringDerivation (principalGrading K) (principalSubringDerivation K) where + map_mul := principalSubringDerivation_mul + mem_lower := by + intro α hα x hx + obtain ⟨a, rfl⟩ := (DirectSum.mem_rangeLof_iff K _ _ x).mp hx + rw [DirectSum.lof_eq_of, principalSubringDerivation_of, + principalComponentDerivation_of_pos hα, principalGrading, + DirectSum.rangeLof_eq_range] + exact mapLinear_mem_funAtZeroMinusSubmodule_range + (DirectSum.lof K NatOrdinal (PrincipalComponent K) (α.removeNat 1)) _ + eq_zero := by + intro α hα x hx + obtain ⟨a, rfl⟩ := (DirectSum.mem_rangeLof_iff K _ _ x).mp hx + rw [DirectSum.lof_eq_of, principalSubringDerivation_of, + principalComponentDerivation_of_eq_zero hα] + injective := by + intro α hα x hx h + obtain ⟨a, rfl⟩ := (DirectSum.mem_rangeLof_iff K _ _ x).mp hx + rw [DirectSum.lof_eq_of, principalSubringDerivation_of, + principalComponentDerivation_of_pos hα] at h + have h1 := Filter.Germ.mapLinear_injective _ (DirectSum.of_injective _) (by rw [h, map_zero] : + Filter.Germ.mapLinear (DirectSum.lof K NatOrdinal (PrincipalComponent K) (α.removeNat 1)) + (principalComponentDerivAt K α hα a) = Filter.Germ.mapLinear _ 0) + have h2 := principalComponentDerivAt_injective K α hα (by rw [h1, map_zero] : + principalComponentDerivAt K α hα a = principalComponentDerivAt _ α hα 0) + rw [h2, map_zero] + +/-! ### The quotient `P̂/I` is a domain -/ + +variable [CharZero K] + +variable (K) in +/-- The quotient `P̂/I` (Lean `PrincipalFibre K`) is an integral domain. -/ +theorem principalFibre_isDomain : + IsDomain (PrincipalFibre K) := + haveI : IsDomain (PrincipalSubring K) := principalSubringIsDomain + (principalSubringDerivation_isLoweringDerivation K).fibre_isDomain + (principalGrading_gradeZeroScalars K) + +variable (K) in +/-- `E ⊗[K] P̂/I` is a domain for every field extension `E / K`, in every universe: the base +change `E ⊗[K] P̂` is a graded domain over `E` with a lowering derivation, its quotient is +`E ⊗[K] P̂/I`, and the quotient `A/I` of every such ring is a domain. -/ +theorem isDomain_tensor_principalFibre (E : Type*) [Field E] [Algebra K E] : + IsDomain (E ⊗[K] PrincipalFibre K) := by + have := charZero_of_algebra K E + have : IsDomain (E ⊗[K] PrincipalSubring K) := isDomain_tensor_principalSubring K E + exact isDomain_tensor_fibre E (principalGrading K) (principalGrading_gradeZeroScalars K) + (principalSubringDerivation_isLoweringDerivation K) + +variable (K) in +/-- The quotient `P̂/I` is geometrically integral over `K`. -/ +theorem principalFibre_isGeometricallyIntegral : + Algebra.IsGeometricallyIntegral K (PrincipalFibre K) := by + rw [Algebra.isGeometricallyIntegral_iff] + intro E _ _ + have := isDomain_tensor_principalFibre K E + exact (Algebra.TensorProduct.comm K _ _).toMulEquiv.isDomain _ + +variable (K) in +/-- `P̂/I ⊗[K] D` is a domain for every domain `D` over `K`, in every universe. -/ +theorem isDomain_principalFibre_tensor (D : Type*) [CommRing D] [IsDomain D] [Algebra K D] : + IsDomain (PrincipalFibre K ⊗[K] D) := + Algebra.isDomain_tensor_of_isDomain_of_forall_field + (fun L _ _ ↦ + haveI := isDomain_tensor_principalFibre K L + (Algebra.TensorProduct.comm K (PrincipalFibre K) L).toMulEquiv.isDomain _) D + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/OmegaSupport.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/OmegaSupport.lean new file mode 100644 index 0000000000..e1d3ed19c9 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/OmegaSupport.lean @@ -0,0 +1,424 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.DerivAt +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.SetOrderType +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Germ +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValueDegree +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.PrincipalAddition +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrderType +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.DerivAtInjective + +/-! +# The support of a derivative has order type at most `ω` + +Let `α` be a successor ordinal, `δ := α ⊖ 1`, and `p` a principal series of degree `α`: +`v_J(p) = ω^α` and the support of `p` has order type `ω^α`. The set of cutoffs `ξ < 0` at which +the ordinal value of `p` is at least `ω^δ`, that is `ω^δ ≤ v_J(p^{|ξ})` (`cutoffsGE δ p`), is well +ordered with finite initial segments, hence of order type at most `ω`. Indeed, for a cutoff `ξ` of +this set, every interval `(θ, ξ]` with `θ < ξ` carries support of order type at least `ω^δ`; a +strictly increasing sequence of such cutoffs bounded by `ξ₀ < 0` would therefore force support of +order type at least `ω^δ · ω = ω^α` below `ξ₀`, while `v_J(p) = ω^α` already needs support of +order type `ω^α` above `ξ₀`, more than the order type `ω^α` of the whole support. + +Consequently the derivative `∂(x)` of a nonzero `x ∈ P_α` is the class of a function at `0⁻` +vanishing outside a strictly increasing sequence of cutoffs with supremum `0`: `∂(x)` vanishes +outside the cutoffs at which the ordinal value of a principal representative is at least `ω^δ`. +This is the form used by `mem_span_of_principalSubringDerivation_eq_coe`. +-/ + +universe v + +open scoped NatOrdinal HahnSeries +open Berarducci HahnSeries + +public noncomputable section + +namespace Berarducci + +variable {K : Type v} [Field K] + +/-! ### Support between two cutoffs -/ + +/-- If `p^{|γ}` has ordinal value at least `ω^δ`, the support of `p` in any interval `(θ, γ]` +has order type at least `ω^δ`. -/ +theorem wpow_le_supportOrderType_truncGT_truncLE {δ : NatOrdinal} (p : Series K) {γ θ : ℝ} + (hθγ : θ < γ) (hγ : ω^ δ ≤ ordinalValue (translatedTruncation (p : K⟦ℝ⟧) γ)) : + ω^ δ ≤ NatOrdinal.of (truncGT θ (truncLE γ (p : K⟦ℝ⟧))).supportOrderType := by + -- the part of `p^{|γ}` beyond `θ - γ`, as a nonpositive series + let r : Series K := ⟨translate (-γ) (truncGT θ (truncLE γ (p : K⟦ℝ⟧))), by + rw [mem_nonpositiveSubring] + intro x hx + rw [support_translate] at hx + obtain ⟨y, hy, rfl⟩ := hx + have hy' : y ≤ γ := by + have := support_truncGT_subset θ _ hy + rw [support_truncLE] at this + exact this.2 + change -γ + y ≤ 0 + linarith⟩ + have hgerm : toGerm (translatedTruncation (p : K⟦ℝ⟧) γ) = toGerm r := by + rw [toGerm_eq_toGerm_iff_exists_coeff_eq] + refine ⟨θ - γ, by linarith, fun η hη1 hη2 ↦ ?_⟩ + rw [coeff_translatedTruncation, ite_eq_left hη2] + change _ = (translate (-γ) (truncGT θ (truncLE γ (p : K⟦ℝ⟧)))).coeff η + rw [coeff_translate, sub_neg_eq_add, coeff_truncGT_of_lt (by linarith), + HahnSeries.coeff_truncLE, ite_eq_left (by linarith), add_comm] + calc ω^ δ ≤ ordinalValue (translatedTruncation (p : K⟦ℝ⟧) γ) := hγ + _ = ordinalValue r := + ordinalValue_eq_of_sub_mem_negativeMonomialIdeal (toGerm_eq_toGerm_iff.mp hgerm) + _ ≤ NatOrdinal.of (r : K⟦ℝ⟧).supportOrderType := ordinalValue_le_supportOrderType r + _ = NatOrdinal.of (truncGT θ (truncLE γ (p : K⟦ℝ⟧))).supportOrderType := by + change NatOrdinal.of + (translate (-γ) (truncGT θ (truncLE γ (p : K⟦ℝ⟧)))).supportOrderType = _ + rw [supportOrderType_translate] + +/-- The support of `p` in `(θ, γ]` is nonempty when `p^{|γ}` has ordinal value at least `ω^δ`. -/ +theorem exists_mem_support_Ioc_of_wpow_le {δ : NatOrdinal} (p : Series K) {γ θ : ℝ} + (hθγ : θ < γ) (hγ : ω^ δ ≤ ordinalValue (translatedTruncation (p : K⟦ℝ⟧) γ)) : + ∃ x ∈ (p : K⟦ℝ⟧).support, θ < x ∧ x ≤ γ := by + have h := wpow_le_supportOrderType_truncGT_truncLE p hθγ hγ + have hne : (truncGT θ (truncLE γ (p : K⟦ℝ⟧))).support.Nonempty := by + rw [Set.nonempty_iff_ne_empty] + intro hempty + have h0 : (truncGT θ (truncLE γ (p : K⟦ℝ⟧))).supportOrderType = 0 := by + rw [supportOrderType_eq_setOrderType] + exact (Set.IsPWO.orderType_eq_zero _).mpr hempty + rw [h0] at h + exact absurd h (not_le.mpr (NatOrdinal.wpow_pos δ)) + obtain ⟨x, hx⟩ := hne + rw [support_truncGT, support_truncLE] at hx + exact ⟨x, hx.1.1, hx.2, hx.1.2⟩ + +/-! ### The cutoffs at which the ordinal value is at least `ω^δ` -/ + +/-- The set of cutoffs `ξ < 0` at which the ordinal value of `p` is at least `ω^δ`: +`ω^δ ≤ v_J(p^{|ξ})`. For `p` principal of degree `δ + 1` this is the set of cutoffs at which +`∂(p + J_{ω^{δ+1}})` does not vanish and, `v_J^r(p)` being `ω^δ`, it is the set `Res(p) = X(p)` of +residual points of [FLLM, Def. 2.7], [Ber00, Def. 6.6]; for arbitrary `p` and `δ` it is the set +`Big^δ(p)` of [FLLM, Def. 2.7] *without* FLLM's clause `ξ > crit_J(p)`, which is not imposed +here. -/ +def cutoffsGE (δ : NatOrdinal) (p : Series K) : Set ℝ := + {ξ | ξ < 0 ∧ ω^ δ ≤ ordinalValue (translatedTruncation (p : K⟦ℝ⟧) ξ)} + +theorem mem_cutoffsGE_iff {δ : NatOrdinal} {p : Series K} {ξ : ℝ} : + ξ ∈ cutoffsGE δ p ↔ ξ < 0 ∧ ω^ δ ≤ ordinalValue (translatedTruncation (p : K⟦ℝ⟧) ξ) := + (Iff.rfl) + +/-- The cutoffs at which the ordinal value of `p` is at least `ω^δ` form a well-ordered set. -/ +theorem cutoffsGE_isPWO (δ : NatOrdinal) (p : Series K) : (cutoffsGE δ p).IsPWO := by + rw [Set.isPWO_iff_isWF, Set.isWF_iff_no_descending_seq] + intro f hf hmem + have hpick : ∀ k, ∃ x ∈ (p : K⟦ℝ⟧).support, f (k + 1) < x ∧ x ≤ f k := fun k ↦ + exists_mem_support_Ioc_of_wpow_le p (hf (Nat.lt_succ_self k)) (hmem k).2 + choose x hx hx1 hx2 using hpick + refine (Set.isWF_iff_no_descending_seq.mp (p : K⟦ℝ⟧).isPWO_support.isWF) x ?_ hx + exact strictAnti_nat_of_succ_lt fun k ↦ (hx2 (k + 1)).trans_lt (hx1 k) + +/-- Truncating below `c` and then below `c'` with `c ≤ c'` truncates below `c`. -/ +theorem truncLE_truncLE_of_le {c c' : ℝ} (h : c ≤ c') (x : K⟦ℝ⟧) : + truncLE c (truncLE c' x) = truncLE c x := by + ext g + simp only [HahnSeries.coeff_truncLE] + split_ifs with h1 h2 <;> first | rfl | exact absurd (h1.trans h) h2 + +/-- A strictly increasing sequence of cutoffs at which the ordinal value of `p` is at least `ω^δ` +forces support of order type at least `ω^δ · n` below its `n`-th member. -/ +theorem wpow_mul_le_supportOrderType_truncLE {δ : NatOrdinal} (p : Series K) (γ : ℕ → ℝ) + (hγ : StrictMono γ) (hmem : ∀ k, γ k ∈ cutoffsGE δ p) (n : ℕ) : + Ordinal.omega0 ^ δ.val * n ≤ (truncLE (γ n) (p : K⟦ℝ⟧)).supportOrderType := by + induction n with + | zero => simp + | succ n ih => + have hsplit := supportOrderType_eq_truncLE_add_truncGT (γ n) (truncLE (γ (n + 1)) (p : K⟦ℝ⟧)) + rw [truncLE_truncLE_of_le (hγ.monotone (Nat.le_succ n))] at hsplit + have hblock : Ordinal.omega0 ^ δ.val ≤ + (truncGT (γ n) (truncLE (γ (n + 1)) (p : K⟦ℝ⟧))).supportOrderType := by + have := wpow_le_supportOrderType_truncGT_truncLE (δ := δ) p (hγ (Nat.lt_succ_self n)) + (hmem (n + 1)).2 + rw [← NatOrdinal.val_wpow] + exact NatOrdinal.val.monotone this + rw [hsplit, Nat.cast_add_one, ← Order.succ_eq_add_one, Ordinal.mul_succ] + exact add_le_add ih hblock + +/-- A strictly increasing sequence of cutoffs at which the ordinal value of `p` is at least `ω^δ`, +bounded by `ξ₀`, forces support of order type at least `ω^(δ+1)` below `ξ₀`. -/ +theorem wpow_add_one_le_supportOrderType_truncLE {δ : NatOrdinal} (p : Series K) (γ : ℕ → ℝ) + (hγ : StrictMono γ) (hmem : ∀ k, γ k ∈ cutoffsGE δ p) {ξ₀ : ℝ} (hξ₀ : ∀ k, γ k ≤ ξ₀) : + ω^ (δ + 1) ≤ NatOrdinal.of (truncLE ξ₀ (p : K⟦ℝ⟧)).supportOrderType := by + rw [NatOrdinal.wpow_add_one_le_iff] + intro n + rw [NatOrdinal.wpow_mul_natCast] + refine NatOrdinal.of.monotone ?_ + refine (wpow_mul_le_supportOrderType_truncLE p γ hγ hmem n).trans ?_ + rw [supportOrderType_eq_setOrderType, supportOrderType_eq_setOrderType] + refine Set.IsPWO.orderType_mono _ _ ?_ + rw [support_truncLE, support_truncLE] + exact Set.inter_subset_inter_right _ (Set.Iic_subset_Iic.mpr (hξ₀ n)) + +/-- For `p` with ordinal value and support order type `ω^(δ+1)`, only finitely many translated +truncations at or below a fixed negative exponent have ordinal value at least `ω^δ`. -/ +@[blueprint "lem:finite-successor-value-cutoffs" + (phase := "Translated truncations") + (title := "Local finiteness of translated truncations at successor ordinal value") + (statement := /-- + Let $K$ be a field, let $\delta<\omega_1$, and let + $p\in K((\mathbb R^{\le0}))$ satisfy + \[ + v_J(p)=\operatorname{ot}(p)=\omega^{\delta+1}. + \] + For every $\xi_0<0$, the set + \[ + \{\xi\le\xi_0:v_J(p^{|\xi})\ge\omega^\delta\} + \] + is finite. + -/) + (proof := /-- + Otherwise choose a strictly increasing sequence $(\gamma_n)$ in this set. + The support between consecutive $\gamma_n$ has order type at least + $\omega^\delta$, so the support at or below $\xi_0$ has order type at least + $\omega^\delta\cdot\omega=\omega^{\delta+1}$. Removing that part does not + change the series modulo $J$, hence the remaining support above $\xi_0$ also + has order type at least $\omega^{\delta+1}$. Splitting the support at + $\xi_0$ would therefore give + \[ + \operatorname{ot}(p)\ge + \omega^{\delta+1}+\omega^{\delta+1}>\omega^{\delta+1}, + \] + a contradiction. + -/)] +theorem cutoffsGE_inter_Iic_finite_of_neg {δ : NatOrdinal} (p : Series K) + (hv : ordinalValue p = ω^ (δ + 1)) (hot : (p : K⟦ℝ⟧).supportOrderType = (ω^ (δ + 1)).val) + {ξ₀ : ℝ} (hξ₀ : ξ₀ < 0) : (cutoffsGE δ p ∩ Set.Iic ξ₀).Finite := by + by_contra hinf + rw [Set.not_finite] at hinf + -- a strictly increasing sequence in `cutoffsGE δ p` bounded by `ξ₀` + let f := hinf.natEmbedding + obtain ⟨g, hg⟩ := (cutoffsGE_isPWO δ p).exists_monotone_subseq + (f := fun n ↦ ((f n : ↥(cutoffsGE δ p ∩ Set.Iic ξ₀)) : ℝ)) fun n ↦ (f n).2.1 + set γ : ℕ → ℝ := fun k ↦ ((f (g k) : ↥(cutoffsGE δ p ∩ Set.Iic ξ₀)) : ℝ) with hγdef + have hmono : StrictMono γ := by + refine Monotone.strictMono_of_injective (fun ⦃_ _⦄ hmn ↦ hg hmn) ?_ + intro m n hmn + exact g.injective (f.injective (Subtype.val_injective hmn)) + have hmem : ∀ k, γ k ∈ cutoffsGE δ p := fun k ↦ (f (g k)).2.1 + have hle : ∀ k, γ k ≤ ξ₀ := fun k ↦ (f (g k)).2.2 + -- support of order type `ω^(δ+1)` below `ξ₀` … + have hbelow : (ω^ (δ + 1)).val ≤ (truncLE ξ₀ (p : K⟦ℝ⟧)).supportOrderType := + NatOrdinal.val.monotone (wpow_add_one_le_supportOrderType_truncLE p γ hmono hmem hle) + -- … and above `ξ₀` + have habove : (ω^ (δ + 1)).val ≤ (truncGT ξ₀ (p : K⟦ℝ⟧)).supportOrderType := by + let r : Series K := ⟨truncGT ξ₀ (p : K⟦ℝ⟧), by + rw [mem_nonpositiveSubring] + exact (support_truncGT_subset ξ₀ _).trans (HahnSeries.Nonpositive.support_subset p)⟩ + have hgerm : toGerm p = toGerm r := by + rw [toGerm_eq_toGerm_iff_exists_coeff_eq] + refine ⟨ξ₀, hξ₀, fun η hη1 _ ↦ ?_⟩ + change _ = (truncGT ξ₀ (p : K⟦ℝ⟧)).coeff η + rw [coeff_truncGT_of_lt hη1] + have := ordinalValue_le_supportOrderType r + rw [← ordinalValue_eq_of_sub_mem_negativeMonomialIdeal (toGerm_eq_toGerm_iff.mp hgerm), + hv] at this + exact NatOrdinal.val.monotone this + have hsplit := supportOrderType_eq_truncLE_add_truncGT ξ₀ (p : K⟦ℝ⟧) + rw [hot] at hsplit + have hpos : 0 < (ω^ (δ + 1)).val := Ordinal.opow_pos _ Ordinal.omega0_pos + exact absurd hsplit (ne_of_lt ((lt_add_of_pos_right _ hpos).trans_le (add_le_add hbelow habove))) + +/-- **Finite initial segments.** For `p` with `v_J(p) = ω^(δ+1)` and support of order type +`ω^(δ+1)` (a principal series of degree `δ + 1`), the cutoffs of `cutoffsGE δ p` below any +`ξ₀ ∈ cutoffsGE δ p` are finitely many. -/ +theorem cutoffsGE_inter_Iic_finite {δ : NatOrdinal} (p : Series K) + (hv : ordinalValue p = ω^ (δ + 1)) (hot : (p : K⟦ℝ⟧).supportOrderType = (ω^ (δ + 1)).val) + {ξ₀ : ℝ} (hξ₀ : ξ₀ ∈ cutoffsGE δ p) : (cutoffsGE δ p ∩ Set.Iic ξ₀).Finite := + cutoffsGE_inter_Iic_finite_of_neg p hv hot hξ₀.1 + +/-- **Finitely many cutoffs of ordinal value at least `ω^δ`.** A series `p` whose support has +order type below `ω^(δ+1)` has only finitely many cutoffs `ξ < 0` with `ω^δ ≤ v_J(p^{|ξ})`. -/ +theorem cutoffsGE_finite_of_supportOrderType_lt {δ : NatOrdinal} (p : Series K) + (hot : (p : K⟦ℝ⟧).supportOrderType < (ω^ (δ + 1)).val) : (cutoffsGE δ p).Finite := by + by_contra hinf + rw [Set.not_finite] at hinf + let f := hinf.natEmbedding + obtain ⟨g, hg⟩ := (cutoffsGE_isPWO δ p).exists_monotone_subseq + (f := fun n ↦ ((f n : ↥(cutoffsGE δ p)) : ℝ)) fun n ↦ (f n).2 + set γ : ℕ → ℝ := fun k ↦ ((f (g k) : ↥(cutoffsGE δ p)) : ℝ) with hγdef + have hmono : StrictMono γ := by + refine Monotone.strictMono_of_injective (fun ⦃_ _⦄ hmn ↦ hg hmn) ?_ + intro m n hmn + exact g.injective (f.injective (Subtype.val_injective hmn)) + have hmem : ∀ k, γ k ∈ cutoffsGE δ p := fun k ↦ (f (g k)).2 + have hle : ∀ k, γ k ≤ 0 := fun k ↦ (mem_cutoffsGE_iff.mp (hmem k)).1.le + have h := wpow_add_one_le_supportOrderType_truncLE p γ hmono hmem hle + have htrunc : truncLE (0 : ℝ) (p : K⟦ℝ⟧) = p := by + ext i + rw [HahnSeries.coeff_truncLE] + split_ifs with hi + · rfl + · by_contra h + exact hi (HahnSeries.Nonpositive.support_subset p + ((HahnSeries.mem_support _ _).mpr fun h0 ↦ h h0.symm)) + rw [htrunc] at h + exact absurd (NatOrdinal.val.monotone h) (not_le.mpr hot) + +/-! ### Enumerating a well-ordered set with finite initial segments -/ + +/-- An infinite well-ordered set of reals with finite initial segments is the range of a strictly +increasing sequence. -/ +theorem exists_strictMono_range_eq {Z : Set ℝ} (hZ : Z.IsPWO) + (hfin : ∀ z ∈ Z, (Z ∩ Set.Iic z).Finite) (hinf : Z.Infinite) : + ∃ γ : ℕ → ℝ, StrictMono γ ∧ Set.range γ = Z := by + classical + have hne : Z.Nonempty := hinf.nonempty + -- the least element of `Z` above a point + let next : ℝ → ℝ := fun x ↦ + if h : (Z ∩ Set.Ioi x).Nonempty then (hZ.isWF.mono Set.inter_subset_left).min h else x + have hnext_mem : ∀ x, (Z ∩ Set.Ioi x).Nonempty → next x ∈ Z ∧ x < next x := fun x h ↦ by + simp only [next, dite_eq_left h] + exact Set.IsWF.min_mem _ h + have hnext_le : ∀ x, ∀ z ∈ Z, x < z → next x ≤ z := fun x z hz hxz ↦ by + have h : (Z ∩ Set.Ioi x).Nonempty := ⟨z, hz, hxz⟩ + simp only [next, dite_eq_left h] + exact Set.IsWF.min_le _ h ⟨hz, hxz⟩ + -- every point of `Z` has a point of `Z` above it + have hZne : ∀ x ∈ Z, (Z ∩ Set.Ioi x).Nonempty := fun x hx ↦ by + by_contra hcon + rw [Set.not_nonempty_iff_eq_empty] at hcon + refine hinf ((hfin x hx).subset fun z hz ↦ ⟨hz, ?_⟩) + by_contra hlt + rw [Set.mem_Iic, not_le] at hlt + exact Set.eq_empty_iff_forall_notMem.mp hcon z ⟨hz, hlt⟩ + let γ : ℕ → ℝ := fun k ↦ next^[k] (hZ.isWF.min hne) + have hγsucc : ∀ k, γ (k + 1) = next (γ k) := fun k ↦ Function.iterate_succ_apply' next k _ + have hγmem : ∀ k, γ k ∈ Z := by + intro k + induction k with + | zero => exact Set.IsWF.min_mem _ _ + | succ k ih => + rw [hγsucc] + exact (hnext_mem _ (hZne _ ih)).1 + have hmono : StrictMono γ := strictMono_nat_of_lt_succ fun k ↦ by + rw [hγsucc] + exact (hnext_mem _ (hZne _ (hγmem k))).2 + refine ⟨γ, hmono, Set.Subset.antisymm ?_ fun z hz ↦ ?_⟩ + · rintro _ ⟨k, rfl⟩ + exact hγmem k + · by_contra hz' + -- a point of `Z` missed by the enumeration lies above every term + have hlt : ∀ k, γ k < z := by + intro k + induction k with + | zero => exact lt_of_le_of_ne (Set.IsWF.min_le _ _ hz) fun h ↦ hz' ⟨0, h⟩ + | succ k ih => + rw [hγsucc] + exact lt_of_le_of_ne (hnext_le _ z hz ih) fun h ↦ hz' ⟨k + 1, by rw [hγsucc]; exact h⟩ + exact (hfin z hz).not_infinite ((Set.infinite_range_of_injective hmono.injective).mono + (Set.range_subset_iff.mpr fun k ↦ ⟨hγmem k, (hlt k).le⟩)) + +/-! ### The derivative of a nonzero class vanishes outside a sequence `γ_k ↑ 0` -/ + +/-- A nonzero class in `P_α`, for successor `α`, has a principal representative whose +translated-truncation function is supported on a sequence increasing to zero. -/ +@[blueprint "lem:successor-principal-rv-countable-support" + (phase := "Translated truncations") + (title := "Countable-support representatives of $\\mathrm P_\\alpha$") + (statement := /-- + Let $K$ be a field, let $\alpha=\beta+1<\omega_1$, and let + $0\ne x\in\mathrm P_\alpha$. Then $x$ has a principal representative $p$ + of degree $\alpha$. Let $D_p:\mathbb R\to\mathrm P_\beta$ be the function + used to represent $\partial_\alpha(x)$: whenever + $v_J(p^{|\xi})<\omega^{\beta+1}$, put $D_p(\xi)=[p^{|\xi}]$, and put + $D_p(\xi)=0$ otherwise. There is a strictly increasing sequence of negative + reals $(\gamma_k)_{k\in\mathbb N}$, cofinal in $0$, such that + \[ + \{\xi<0:D_p(\xi)\ne0\}\subseteq + \{\gamma_k:k\in\mathbb N\}. + \] + -/) + (proof := /-- + By \ref{fact:principal-series-representatives}, choose a principal + representative $p$ of $x$ of degree $\alpha$. The set + \[ + Z:=\{\xi<0:D_p(\xi)\ne0\} + \] + is well ordered because a decreasing sequence in $Z$ would induce a + decreasing sequence in $\operatorname{supp}(p)$. By + \ref{lem:finite-successor-value-cutoffs}, each initial segment of $Z$ is + finite. By + \ref{prop:successor-principal-rv-injective}, $D_p$ cannot vanish throughout + any interval $(\eta,0)$, since that would give + $\partial_\alpha(x)=0$ and hence $x=0$. Thus $Z$ is infinite and cofinal in + $0$. Enumerating $Z$ in increasing order gives the required sequence. + -/)] +theorem exists_principal_representative_derivAt (α : NatOrdinal) (hα : 0 < α.constantCoeff) + {x : PrincipalComponent K α} (hx : x ≠ 0) : + ∃ (p : Series K) (hp : ordinalValue p < ω^ (α + 1)), + HahnSeries.Nonpositive.IsPrincipal p ∧ + (p : K⟦ℝ⟧).degree = (α : WithBot NatOrdinal) ∧ + principalComponentMk α p hp = x ∧ + ∃ γ : ℕ → ℝ, StrictMono γ ∧ (∀ k, γ k < 0) ∧ + (∀ η < (0 : ℝ), ∃ k, η < γ k) ∧ + ∀ ξ, ξ < 0 → derivAt α p ξ ≠ 0 → ∃ k, γ k = ξ := by + classical + obtain ⟨p, hp, hprin, hdeg, hpx⟩ := exists_principal_representative_of_ne_zero α x hx + refine ⟨p, hp, hprin, hdeg, hpx, ?_⟩ + set δ := α.removeNat 1 with hδdef + have hδ : δ + 1 = α := by + have := NatOrdinal.removeNat_add_natCast (a := α) (n := 1) hα + rwa [Nat.cast_one] at this + have hv : ordinalValue p = ω^ (δ + 1) := by + rw [hδ] + exact ordinalValue_eq_wpow_of_principalComponentMk_ne_zero α p hp (hpx ▸ hx) + have hot : (p : K⟦ℝ⟧).supportOrderType = (ω^ (δ + 1)).val := by + rw [hδ] + exact hprin.supportOrderType_eq_wpow_of_degree_eq hdeg + -- the cutoffs where the derivative is nonzero + set Z : Set ℝ := {ξ | ξ < 0 ∧ derivAt α p ξ ≠ 0} with hZdef + have hZsub : Z ⊆ cutoffsGE δ p := by + rintro ξ ⟨hξ0, hξ⟩ + refine ⟨hξ0, ?_⟩ + by_cases h : ordinalValue (translatedTruncation (p : K⟦ℝ⟧) ξ) < ω^ (δ + 1) + · rw [derivAt_eq α p ξ h] at hξ + exact (ordinalValue_eq_wpow_of_principalComponentMk_ne_zero δ _ h hξ).ge + · exact (NatOrdinal.wpow_lt_wpow.mpr (lt_add_one δ)).le.trans (not_lt.mp h) + have hZpwo : Z.IsPWO := (cutoffsGE_isPWO δ p).mono hZsub + have hZfin : ∀ z ∈ Z, (Z ∩ Set.Iic z).Finite := fun z hz ↦ + (cutoffsGE_inter_Iic_finite p hv hot (hZsub hz)).subset + (Set.inter_subset_inter_left _ hZsub) + have hcof : ∀ η < (0 : ℝ), ∃ ξ, η < ξ ∧ ξ < 0 ∧ derivAt α p ξ ≠ 0 := by + intro η hη + by_contra h + push Not at h + have hzero : principalComponentDerivAt K α hα x = 0 := by + rw [← hpx, principalComponentDerivAt_principalComponentMk, + FunAtZeroMinus.coe_eq_zero_iff_exists] + exact ⟨η, hη, h⟩ + apply hx + apply principalComponentDerivAt_injective K α hα + simpa using hzero + have hinf : Z.Infinite := by + intro hfin + rcases Z.eq_empty_or_nonempty with hempty | hne + · obtain ⟨ξ, -, hξ2, hξ3⟩ := hcof (-1) (by norm_num) + exact Set.eq_empty_iff_forall_notMem.mp hempty ξ ⟨hξ2, hξ3⟩ + · obtain ⟨m, hm, hmax⟩ := Set.exists_max_image Z id hfin hne + obtain ⟨ξ, hξ1, hξ2, hξ3⟩ := hcof m hm.1 + exact absurd (hmax ξ ⟨hξ2, hξ3⟩) (not_le.mpr hξ1) + obtain ⟨γ, hmono, hrange⟩ := exists_strictMono_range_eq hZpwo hZfin hinf + have hγZ : ∀ k, γ k ∈ Z := fun k ↦ hrange ▸ Set.mem_range_self k + refine ⟨γ, hmono, fun k ↦ (hγZ k).1, fun η hη ↦ ?_, fun ξ hξ0 hξ ↦ ?_⟩ + · obtain ⟨ξ, hξ1, hξ2, hξ3⟩ := hcof η hη + have hξZ : ξ ∈ Z := ⟨hξ2, hξ3⟩ + rw [← hrange] at hξZ + obtain ⟨k, hk⟩ := hξZ + exact ⟨k, hk ▸ hξ1⟩ + · have hξZ : ξ ∈ Z := ⟨hξ0, hξ⟩ + rwa [← hrange] at hξZ + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/OrdinalValueCutoffs.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/OrdinalValueCutoffs.lean new file mode 100644 index 0000000000..9d9268e263 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/OrdinalValueCutoffs.lean @@ -0,0 +1,379 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.OmegaSupport +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.TruncationPolynomial +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MvPolynomial.Components +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValueFinalSegment +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.PrincipalAddition +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.SupportSupremum +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Germ + +/-! +# Ordinal-value bounds at translated-truncation cutoffs + +For a series `D` and an ordinal `ρ`, consider the cutoffs `ξ < 0` at which the translated +truncation `D^{|ξ}` has ordinal value at least `ω^ρ`. Two +facts drive the induction over degrees by cutting into pieces: a series whose support has order +type below `ω^(ρ+1)` has finitely many cutoffs with `ω^ρ ≤ v_J(D^{|ξ})` +(`cutoffsGE_finite_of_supportOrderType_lt`), and, conversely, a series supported in `(c, 0]` whose +support has order type at least `ω^ρ` has a cutoff `ξ ∈ (c, 0]` with `ω^ρ ≤ v_J(D^{|ξ})`: the +supremum of an initial segment of the support of order type `ω^ρ`. + +We also record how the class of a series `u ∈ J_{ω^(β+1)}` in `P_β` is read off its polynomial +when evaluation is injective below `α`: it is `pol(u)_β(𝓑)`, the evaluation of the degree-`β` +component of `pol(u)`. +-/ + +universe v w + +open scoped NatOrdinal HahnSeries +open Berarducci HahnSeries MvPolynomial OrdinalGraded + +public noncomputable section + +namespace Berarducci + +variable {K : Type v} [Field K] + +/-- If the support of `D` has order type at least `ω^ρ` with `ρ ≠ 0`, then at some cutoff `ξ ≤ 0`, +at or above some support point, the ordinal value of `D` is at least `ω^ρ`: +`ω^ρ ≤ v_J(D^{|ξ})`. -/ +@[blueprint "lem:cutoff-detects-support-order" + (phase := "Translated truncations") + (title := "Detection of support order type by a translated truncation") + (statement := /-- + Let $K$ be a field, let $b\in K((\mathbb R^{\le0}))$, and let + $\rho<\omega_1$ be nonzero. If + \[ + \operatorname{ot}(\operatorname{supp}(b))\ge\omega^\rho, + \] + then there are $\xi\le0$ and $y\in\operatorname{supp}(b)$ such that + $y\le\xi$ and + \[ + v_J(b^{|\xi})\ge\omega^\rho. + \] + -/) + (proof := /-- + Choose an initial segment $B$ of $\operatorname{supp}(b)$ of order type + $\omega^\rho$, and let $\xi=\sup B$. Then $\xi\le0$ and lies above every point of the + nonempty set $B$. + + Since $\rho\ne0$, the ordinal $\omega^\rho$ is additively principal and at least $\omega$. + For every $\theta<\xi$, the part of $B$ above $\theta$ still has order type + $\omega^\rho$. At most one of its points is at or above $\xi$, so its part in + $(\theta,\xi)$ also has order type at least $\omega^\rho$. Thus every support interval + immediately below $\xi$ has order type at least $\omega^\rho$, which gives + $v_J(b^{|\xi})\ge\omega^\rho$. + -/)] +theorem exists_le_wpow_le_ordinalValue_translatedTruncation_of_le_supportOrderType (D : Series K) + {ρ : NatOrdinal} (hρ : ρ ≠ 0) (hot : (ω^ ρ).val ≤ (D : K⟦ℝ⟧).supportOrderType) : + ∃ ξ, ξ ≤ 0 ∧ (∃ y ∈ (D : K⟦ℝ⟧).support, y ≤ ξ) ∧ + ω^ ρ ≤ ordinalValue (translatedTruncation (D : K⟦ℝ⟧) ξ) := by + classical + -- an initial segment `S₀` of the support of order type exactly `ω^ρ` + obtain ⟨D₀, hD₀sub, hD₀ot⟩ : ∃ D₀ : K⟦ℝ⟧, D₀.support ⊆ (D : K⟦ℝ⟧).support ∧ + D₀.supportOrderType = (ω^ ρ).val := by + rcases hot.lt_or_eq with hlt | heq + · rw [supportOrderType_eq_setOrderType] at hlt + obtain ⟨x, _, hx⟩ := Set.IsPWO.exists_orderType_inter_Iio_eq _ hlt + refine ⟨truncLT x (D : K⟦ℝ⟧), support_truncLT_subset x _, ?_⟩ + rw [supportOrderType_eq_setOrderType] + rw [← hx] + apply Set.IsPWO.orderType_congr + rw [support_truncLT] + ext y + simp [and_comm] + · exact ⟨D, le_rfl, heq.symm⟩ + have hne : D₀.support.Nonempty := by + rw [Set.nonempty_iff_ne_empty] + intro h + have h0 : D₀.supportOrderType = 0 := by + rw [supportOrderType_eq_setOrderType] + exact (Set.IsPWO.orderType_eq_zero _).mpr h + rw [h0] at hD₀ot + exact absurd hD₀ot.symm (ne_of_gt (Ordinal.opow_pos _ Ordinal.omega0_pos)) + have hbdd : BddAbove D₀.support := + ⟨0, fun y hy ↦ HahnSeries.Nonpositive.support_subset D (hD₀sub hy)⟩ + -- `ξ`, the supremum of `S₀` + set ξ := sSup D₀.support with hξdef + have hξle : ξ ≤ 0 := csSup_le hne fun y hy ↦ HahnSeries.Nonpositive.support_subset D (hD₀sub hy) + have hyξ : ∃ y ∈ (D : K⟦ℝ⟧).support, y ≤ ξ := by + obtain ⟨y, hy⟩ := hne + exact ⟨y, hD₀sub hy, le_csSup hbdd hy⟩ + refine ⟨ξ, hξle, hyξ, ?_⟩ + have hprin : Ordinal.IsPrincipal (· + ·) (ω^ ρ).val := by + rw [NatOrdinal.val_wpow] + exact Ordinal.isPrincipal_add_omega0_opow _ + have hω : Ordinal.omega0 ≤ (ω^ ρ).val := by + rw [NatOrdinal.val_wpow] + exact Ordinal.left_le_opow _ (pos_iff_ne_zero.mpr (by simpa using hρ)) + -- the support on every interval `(θ, ξ)` has order type at least `ω^ρ` + have htail : ∀ θ, θ < ξ → (ω^ ρ).val ≤ ((D : K⟦ℝ⟧).isPWO_support.mono + (s := (D : K⟦ℝ⟧).support ∩ Set.Ioo θ ξ) Set.inter_subset_left).orderType := by + intro θ hθ + -- the part of `S₀` above `θ` has order type `ω^ρ` + have hsplit := supportOrderType_eq_truncLE_add_truncGT θ D₀ + rw [hD₀ot] at hsplit + obtain ⟨y, hy, hθy⟩ := exists_lt_of_lt_csSup hne hθ + have hpos : (truncGT θ D₀).supportOrderType ≠ 0 := by + rw [supportOrderType_eq_setOrderType, Ne, Set.IsPWO.orderType_eq_zero, support_truncGT] + exact Set.nonempty_iff_ne_empty.mp ⟨y, hy, hθy⟩ + have hlow : (truncLE θ D₀).supportOrderType < (ω^ ρ).val := by + by_contra hge + rw [not_lt] at hge + have : (ω^ ρ).val < (truncLE θ D₀).supportOrderType + (truncGT θ D₀).supportOrderType := + lt_of_lt_of_le (lt_add_of_pos_right _ (pos_iff_ne_zero.mpr hpos)) + (add_le_add hge le_rfl) + rw [← hsplit] at this + exact lt_irrefl _ this + have hhigh : (truncGT θ D₀).supportOrderType = (ω^ ρ).val := by + refine le_antisymm (by rw [hsplit]; exact le_add_self) (le_of_not_gt fun hlt ↦ ?_) + have := hprin hlow hlt + beta_reduce at this + rw [← hsplit] at this + exact lt_irrefl _ this + -- split the part above `θ` at `ξ`: at most one point is at or above `ξ` + set E := truncGT θ D₀ with hEdef + have hsplitE := supportOrderType_eq_truncLT_add_truncGE ξ E + rw [hhigh] at hsplitE + have hfin : (truncGE ξ E).supportOrderType < Ordinal.omega0 := by + rw [supportOrderType_eq_setOrderType, ← Set.IsPWO.finite_iff_orderType_lt_omega] + refine (Set.finite_singleton ξ).subset fun z hz ↦ ?_ + rw [support_truncGE] at hz + have hzξ : z ≤ ξ := le_csSup hbdd (support_truncGT_subset θ _ hz.1) + exact le_antisymm hzξ hz.2 + have hA : (ω^ ρ).val ≤ (truncLT ξ E).supportOrderType := by + by_contra hlt + rw [not_le] at hlt + have := hprin hlt (hfin.trans_le hω) + beta_reduce at this + rw [← hsplitE] at this + exact lt_irrefl _ this + refine hA.trans ?_ + rw [supportOrderType_eq_setOrderType] + refine Set.IsPWO.orderType_mono _ _ fun z hz ↦ ?_ + rw [support_truncLT, hEdef, support_truncGT] at hz + exact ⟨hD₀sub hz.1.1, hz.1.2, hz.2⟩ + have := le_ordinalValue_translatedTruncation_of_forall_le_orderType (D : K⟦ℝ⟧) ξ htail + rwa [NatOrdinal.of_val] at this + +/-- For a series supported in `(c, 0]` whose support has order type at least `ω^ρ`, `ρ ≠ 0`, there +is a cutoff `ξ ∈ (c, 0]` with `ω^ρ ≤ v_J(D^{|ξ})`. -/ +@[blueprint "lem:cutoff-detects-support-order-in-interval" + (phase := "Translated truncations") + (title := "Detection of interval support order type by a translated truncation") + (statement := /-- + Let $K$ be a field, let $b\in K((\mathbb R^{\le0}))$, let $c\in\mathbb R$, + and let $\rho<\omega_1$ be nonzero. If + \[ + \operatorname{supp}(b)\subseteq(c,0],\qquad + \operatorname{ot}(\operatorname{supp}(b))\ge\omega^\rho, + \] + then there is $\xi\in(c,0]$ such that + $v_J(b^{|\xi})\ge\omega^\rho$. + -/) + (proof := /-- + Apply \ref{lem:cutoff-detects-support-order}. Its cutoff $\xi$ lies above a point + $y\in\operatorname{supp}(b)$. Since $c deg B'`. Each `∂F/∂X_B` is +homogeneous of degree `σ_B := α ⊖ deg B`. + +* Every `σ_B` is a nonzero limit ordinal; `λ' < ω^β`, `τ + 1 < α ⊖ deg B'`, and + `α' = τ ⊕ deg B'`. +* If `σ_B ≼ α ⊖ deg B'`—equivalently, `deg B' ≼ deg B`—then the separation condition holds for + `((α ⊖ deg B') ⊖ σ_B, σ_B, τ)`. When the low-degree part equals `α_{<β}`, + `(σ_B)_{<β} = 0` and the last term of `σ_B` has exponent `ε ≥ β`; otherwise, + `(λ₀)_{≥ε} = (α_{<β})_{≥ε}` at the exponent `ε` of the last term of `(σ_B)_{<β}`; in both + cases `(α ⊖ deg B')_{≥ε} ≤ τ`. +* If `σ_B \not\preccurlyeq α ⊖ deg B'`, it precedes no degree + `e ∈ [τ, α ⊖ deg B')`, so `∂F/∂X_B` contributes nothing to the components of those degrees of an + element of the ideal (`componentsGE_mem_span_subtype`). +-/ + +universe v w + +open scoped NatOrdinal HahnSeries +open Berarducci HahnSeries MvPolynomial OrdinalGraded DirectSum + +public noncomputable section + +namespace Berarducci + +section Dropping + +variable {σ : Type*} {K : Type v} [Field K] (wt : σ → NatOrdinal) + +/-- **Generators contributing nothing in `[τ, h)`.** If the components of degree at least `τ` of +`P` lie in the ideal of the homogeneous generators `q j`, of degrees `c j`, `P` has degree below +`h`, and for every generator outside `A` the degree `c j` precedes no degree +`e ∈ [τ, h)`, then those components lie in the ideal of the generators in `A`. -/ +theorem componentsGE_mem_span_subtype {ι : Type w} [Finite ι] {q : ι → MvPolynomial σ K} + {c : ι → NatOrdinal} (hq : ∀ j, IsWeightedHomogeneous wt (q j) (c j)) {P : MvPolynomial σ K} + {τ h : NatOrdinal} (hP : componentsGE wt τ P ∈ Ideal.span (Set.range q)) + (hdeg : DegreeLT wt P h) (A : ι → Prop) + (hdrop : ∀ j, ¬ A j → ∀ e, τ ≤ e → e < h → ¬ ∃ β, β + c j = e) : + componentsGE wt τ P ∈ Ideal.span (Set.range fun j : {j // A j} ↦ q j.1) := by + classical + cases nonempty_fintype ι + let := weightedGradedAlgebra K wt + have hdec : ∀ (R : MvPolynomial σ K) (e : NatOrdinal), + (DirectSum.decompose (weightedHomogeneousSubmodule K wt) R e : MvPolynomial σ K) = + weightedHomogeneousComponent wt e R := fun R e ↦ by + rw [← decompose'_apply] + rfl + rw [componentsGE_eq_sum_weightedHomogeneousComponent] + refine Ideal.sum_mem _ fun e he ↦ ?_ + obtain ⟨he', hτe⟩ := Finset.mem_filter.mp he + obtain ⟨d, hd, rfl⟩ := Finset.mem_image.mp he' + have heh : Finsupp.weight wt d < h := degreeLT_iff.mp hdeg d hd + have hmem : weightedHomogeneousComponent wt (Finsupp.weight wt d) P ∈ Ideal.span (Set.range q) := + weightedHomogeneousComponent_mem_span_of_componentsGE_mem wt hq hP hτe + obtain ⟨u, -, hu0, hsum⟩ := exists_decompose_eq_sum_mul_of_mem_span + (𝒜 := weightedHomogeneousSubmodule K wt) + (fun j ↦ (mem_weightedHomogeneousSubmodule _ _ _ _).mpr (hq j)) hmem (Finsupp.weight wt d) + rw [hdec] at hsum + have hcomp : weightedHomogeneousComponent wt (Finsupp.weight wt d) + (weightedHomogeneousComponent wt (Finsupp.weight wt d) P) = + weightedHomogeneousComponent wt (Finsupp.weight wt d) P := by + rw [weightedHomogeneousComponent_of_mem (weightedHomogeneousComponent_mem wt P _), + ite_eq_left rfl] + rw [← hcomp, hsum] + rw [← Finset.sum_filter_add_sum_filter_not Finset.univ A] + have hzero : ∑ j ∈ Finset.univ.filter (fun j ↦ ¬ A j), q j * u j = 0 := + Finset.sum_eq_zero fun j hj ↦ by + rw [hu0 j (hdrop j (Finset.mem_filter.mp hj).2 _ hτe heh), mul_zero] + rw [hzero, add_zero] + exact Ideal.sum_mem _ fun j hj ↦ Ideal.mul_mem_right _ _ + (Ideal.subset_span ⟨⟨j, (Finset.mem_filter.mp hj).2⟩, rfl⟩) + +end Dropping + +variable {K : Type v} [Field K] {ι : Type w} {wt : ι → NatOrdinal} {x : ι → PrincipalSubring K} + +namespace Lifts.LimitOrdinalRelationAtCutoff + +variable {σ : Lifts wt x} {α : NatOrdinal} (S : σ.LimitOrdinalRelationAtCutoff α) + (hx : IsMinimalSystem (Berarducci.principalGrading K) wt x) +include S hx + +/-! ### The degree `σ_B = α ⊖ deg B` of `∂F/∂X_B` -/ + +theorem α_constantCoeff : α.constantCoeff = 0 := by + have h := congrArg NatOrdinal.constantCoeff S.hdegHD + rw [NatOrdinal.constantCoeff_add, NatOrdinal.constantCoeff_nsmul, S.vars_limit _ S.mem, + mul_zero, add_zero] at h + rw [← h, ← NatOrdinal.partGE_eq_self_of_forall_le S.degHD_terms, + NatOrdinal.constantCoeff_partGE (S.β_ne_zero hx)] + +section Cofactor + +variable {v : ι} (hv : v ∈ S.F.vars) {c : NatOrdinal} (hc : c + wt v = α) +include hv hc + +omit hx in +/-- The degree `σ_B := α ⊖ deg B` of `∂F/∂X_B` (the binder `c`, with `c ⊕ wt v = α`) is +nonzero. -/ +theorem cdeg_ne_zero : c ≠ 0 := by + rintro rfl + rw [zero_add] at hc + exact (S.vars_lt v hv).ne hc + +omit hv in +/-- The degree `σ_B` is a limit. -/ +theorem cdeg_constantCoeff : c.constantCoeff = 0 := by + have h := congrArg NatOrdinal.constantCoeff hc + rw [NatOrdinal.constantCoeff_add, S.α_constantCoeff hx] at h + omega + +omit hx hv in +/-- `∂F/∂X_B` is homogeneous of degree `σ_B`. -/ +theorem pderiv_hom : IsWeightedHomogeneous wt (pderiv v S.F) c := + isWeightedHomogeneous_pderiv wt S.hom v hc + +omit hx hv in +/-- `(σ_B)_{<β} ⊕ (deg B)_{<β} = α_{<β}`. -/ +theorem partLT_cdeg_add_degLT : NatOrdinal.partLT S.β c + S.degLT v = S.αLT := by + have e : NatOrdinal.partLT S.β α = NatOrdinal.partLT S.β (c + wt v) := congrArg _ hc.symm + rw [S.αLT_def, e, NatOrdinal.partLT_add, S.degLT_def] + +omit hx hv in +theorem partGE_cdeg_add : + NatOrdinal.partGE S.β c + NatOrdinal.partGE S.β (wt v) = S.αGE := by + have e : NatOrdinal.partGE S.β α = NatOrdinal.partGE S.β (c + wt v) := congrArg _ hc.symm + rw [S.αGE_def, e, NatOrdinal.partGE_add] + +omit hx hv in +/-- If the low-degree part of `B` equals `α_{<β}`, then `(σ_B)_{<β} = 0`. -/ +theorem partLT_cdeg_eq_zero_of_lowDegreePartEq (htop : S.LowDegreePartEq v) : + NatOrdinal.partLT S.β c = 0 := by + have h := S.partLT_cdeg_add_degLT hc + rw [(S.lowDegreePartEq_iff v).mp htop] at h + exact add_eq_right.mp h + +omit hx hv in +theorem partGE_cdeg_eq_self_of_lowDegreePartEq (htop : S.LowDegreePartEq v) : + NatOrdinal.partGE S.β c = c := by + have := NatOrdinal.partGE_add_partLT S.β c + rwa [S.partLT_cdeg_eq_zero_of_lowDegreePartEq hc htop, add_zero] at this + +omit hx hv in +/-- If the low-degree part of `B` is not `α_{<β}`, then `(σ_B)_{<β} ≠ 0`. -/ +theorem partLT_cdeg_ne_zero (htop : ¬ S.LowDegreePartEq v) : NatOrdinal.partLT S.β c ≠ 0 := by + intro h + have h' := S.partLT_cdeg_add_degLT hc + rw [h, zero_add] at h' + exact htop ((S.lowDegreePartEq_iff v).mpr h') + +end Cofactor + +/-! ### The degree `τ` when the low-degree part precedes `λ₀` -/ + +section Tau + +variable {v' : ι} {h : NatOrdinal} (hh : h + wt v' = α) {lam' : NatOrdinal} + (hlam' : S.degLT v' + lam' = S.lam₀) +include hlam' + +omit hx in +theorem lam'_lt_wpow : lam' < ω^ S.β := + (le_add_of_nonneg_left zero_le).trans_lt (hlam' ▸ S.lam₀_lt_wpow) + +omit hx in +theorem partGE_τ (h : NatOrdinal) : + NatOrdinal.partGE S.β (NatOrdinal.partGE S.β h + lam') = + NatOrdinal.partGE S.β h := by + rw [NatOrdinal.partGE_add, NatOrdinal.partGE_partGE, + NatOrdinal.partGE_eq_zero_of_lt (S.lam'_lt_wpow hlam'), add_zero] + +omit hx in +theorem partLT_τ (h : NatOrdinal) : + NatOrdinal.partLT S.β (NatOrdinal.partGE S.β h + lam') = lam' := by + have := NatOrdinal.partGE_add_partLT S.β (NatOrdinal.partGE S.β h + lam') + rw [S.partGE_τ hlam' h] at this + exact add_left_cancel this + +include hh + +omit hx hlam' in +/-- `(α ⊖ deg B')_{<β} ⊕ (deg B')_{<β} = α_{<β}` (the binder `h` is `α ⊖ deg B'`). -/ +theorem partLT_h_add_degLT : NatOrdinal.partLT S.β h + S.degLT v' = S.αLT := + S.partLT_cdeg_add_degLT hh + +omit hx in +/-- `λ' < (α ⊖ deg B')_{<β}`. -/ +theorem lam'_lt_partLT_h : lam' < NatOrdinal.partLT S.β h := by + have h1 := S.partLT_h_add_degLT hh + have h2 : S.degLT v' + lam' < S.degLT v' + NatOrdinal.partLT S.β h := by + rw [hlam', add_comm _ (NatOrdinal.partLT S.β h), h1] + rw [S.αLT_def]; exact S.lam₀_lt + exact lt_of_add_lt_add_left h2 + +/-- `τ + 1 < α ⊖ deg B'`. -/ +theorem τ_add_one_lt : NatOrdinal.partGE S.β h + lam' + 1 < h := by + have hlt := S.lam'_lt_partLT_h hh hlam' + have hcc : (NatOrdinal.partLT S.β h).constantCoeff = 0 := by + rw [NatOrdinal.constantCoeff_partLT (S.β_ne_zero hx)] + have := congrArg NatOrdinal.constantCoeff hh + rw [NatOrdinal.constantCoeff_add, S.α_constantCoeff hx] at this + omega + have h1 : lam' + 1 < NatOrdinal.partLT S.β h := by + refine lt_of_le_of_ne (Order.add_one_le_of_lt hlt) fun heq ↦ ?_ + have := congrArg NatOrdinal.constantCoeff heq + rw [hcc, show lam' + 1 = lam' + ((1 : ℕ) : NatOrdinal) by rw [Nat.cast_one], + NatOrdinal.constantCoeff_add_natCast] at this + omega + conv_rhs => rw [← NatOrdinal.partGE_add_partLT S.β h] + rw [add_assoc] + exact add_lt_add_right h1 _ + +omit hx in +/-- `α' = α_{≥β} ⊕ λ₀ = τ ⊕ deg B'`. -/ +theorem αGE_add_lam₀_eq : S.αGE + S.lam₀ = NatOrdinal.partGE S.β h + lam' + wt v' := by + have e : NatOrdinal.partGE S.β α = NatOrdinal.partGE S.β (h + wt v') := + congrArg _ hh.symm + rw [← hlam', S.αGE_def, e, NatOrdinal.partGE_add] + conv_rhs => rw [← S.partGE_add_degLT v'] + abel + +omit hx hh in +/-- Every degree `e ∈ [τ, α ⊖ deg B')` has the same part at or above `β` as `α ⊖ deg B'`. -/ +theorem partGE_eq_of_τ_le {e : NatOrdinal} + (hτe : NatOrdinal.partGE S.β h + lam' ≤ e) (heh : e < h) : + NatOrdinal.partGE S.β e = NatOrdinal.partGE S.β h := + le_antisymm (NatOrdinal.partGE_mono heh.le) (by + have := NatOrdinal.partGE_mono (β := S.β) hτe + rwa [S.partGE_τ hlam' h] at this) + +end Tau + +/-! ### The separation condition (n) at the generators considered at `B'` -/ + +section PartialDerivativeIndices + +variable {v : ι} (hv : v ∈ S.F.vars) {c : NatOrdinal} (hc : c + wt v = α) + {v' : ι} {h : NatOrdinal} (hh : h + wt v' = α) {lam' : NatOrdinal} + (hlam' : S.degLT v' + lam' = S.lam₀) +include hv hc hh hlam' + +omit hx hh hlam' in +/-- If the low-degree part of `B` equals `α_{<β}` and `ω^ε` is the last term of `σ_B`, then +`ε ≥ β`, so `h_{≥ε} ≤ h_{≥β} ⊕ λ'` for every ordinal `h`. -/ +theorem partGE_le_τ_of_lowDegreePartEq (htop : S.LowDegreePartEq v) {ε : NatOrdinal} + (hε : NatOrdinal.leastTerm c = ω^ ε) (h : NatOrdinal) : + NatOrdinal.partGE ε h ≤ NatOrdinal.partGE S.β h + lam' := by + have hβε : S.β ≤ ε := by + have h1 := NatOrdinal.wpow_le_leastTerm_partGE (β := S.β) (a := c) + (by rw [S.partGE_cdeg_eq_self_of_lowDegreePartEq hc htop]; exact S.cdeg_ne_zero hv hc) + rw [S.partGE_cdeg_eq_self_of_lowDegreePartEq hc htop, hε, NatOrdinal.wpow_le_wpow] at h1 + exact h1 + exact (NatOrdinal.partGE_le_partGE_of_le hβε h).trans (le_add_of_nonneg_right zero_le) + +omit hv in +/-- If the proper low-degree part of `B` does not precede `λ₀` and `ω^ε` is the last term of +`(σ_B)_{<β}`, then `(α ⊖ deg B')_{≥ε} ≤ τ`. -/ +theorem partGE_le_τ_of_hasProperLowDegreePartNotAlgebraicLE + (hL : S.HasProperLowDegreePartNotAlgebraicLE v) {ε : NatOrdinal} + (hε : NatOrdinal.leastTerm (NatOrdinal.partLT S.β c) = ω^ ε) : + NatOrdinal.partGE ε h ≤ NatOrdinal.partGE S.β h + lam' := by + have hεβ : ε ≤ S.β := by + have h1 := NatOrdinal.leastTerm_le + (S.partLT_cdeg_ne_zero hc + ((S.hasProperLowDegreePartNotAlgebraicLE_iff v).mp hL).2.2.1) + rw [hε] at h1 + exact (NatOrdinal.wpow_lt_wpow.mp (h1.trans_lt (NatOrdinal.partLT_lt _ _))).le + -- `(λ₀)_{≥ε} = (α_{<β})_{≥ε}` + have h5 := S.partGE_lam₀_eq_of_hasProperLowDegreePartNotAlgebraicLE + hx hL (S.partLT_cdeg_add_degLT hc) hε + -- `λ'_{≥ε} = ((α ⊖ deg B')_{<β})_{≥ε}` + have hlamε : NatOrdinal.partGE ε lam' = + NatOrdinal.partGE ε (NatOrdinal.partLT S.β h) := by + have e1 := congrArg (NatOrdinal.partGE ε) hlam' + have e2 := congrArg (NatOrdinal.partGE ε) (S.partLT_h_add_degLT hh) + rw [NatOrdinal.partGE_add] at e1 e2 + rw [h5, ← e2, add_comm (NatOrdinal.partGE ε (NatOrdinal.partLT S.β h))] at e1 + exact add_left_cancel e1 + calc NatOrdinal.partGE ε h + = NatOrdinal.partGE ε (NatOrdinal.partGE S.β h) + + NatOrdinal.partGE ε (NatOrdinal.partLT S.β h) := by + conv_lhs => rw [← NatOrdinal.partGE_add_partLT S.β h] + rw [NatOrdinal.partGE_add] + _ = NatOrdinal.partGE S.β h + NatOrdinal.partGE ε lam' := by + rw [NatOrdinal.partGE_partGE_of_ge hεβ, hlamε] + _ ≤ NatOrdinal.partGE S.β h + lam' := add_le_add_right (NatOrdinal.partGE_le _ _) _ + +omit hx hv hh in +/-- If the low-degree part of `B` equals `α_{<β}` and +`σ_B \not\preccurlyeq α ⊖ deg B'`, then `σ_B` precedes no degree in +`[τ, α ⊖ deg B')` in the algebraic order. -/ +theorem not_algebraicLE_of_lowDegreePartEq_of_not (htop : S.LowDegreePartEq v) + (hdrop : ¬ NatOrdinal.AlgebraicLE c h) + {e : NatOrdinal} (hτe : NatOrdinal.partGE S.β h + lam' ≤ e) (heh : e < h) : + ¬ NatOrdinal.AlgebraicLE c e := by + intro hce + apply hdrop + have h1 := hce.partGE S.β + rw [S.partGE_eq_of_τ_le hlam' hτe heh, + S.partGE_cdeg_eq_self_of_lowDegreePartEq hc htop] at h1 + exact h1.trans (NatOrdinal.algebraicLE_partGE _ _) + +omit hv in +/-- If the proper low-degree part of `B` does not precede `λ₀` and +`σ_B \not\preccurlyeq α ⊖ deg B'`, then `σ_B` precedes no degree in +`[τ, α ⊖ deg B')` in the algebraic order. -/ +theorem not_algebraicLE_of_hasProperLowDegreePartNotAlgebraicLE_of_not + (hL : S.HasProperLowDegreePartNotAlgebraicLE v) + (hdrop : ¬ NatOrdinal.AlgebraicLE c h) + {e : NatOrdinal} (hτe : NatOrdinal.partGE S.β h + lam' ≤ e) (heh : e < h) : + ¬ NatOrdinal.AlgebraicLE c e := by + intro hce + apply hdrop + have hGE := S.partGE_eq_of_τ_le hlam' hτe heh + -- the parts at or above `β` + have h1 : NatOrdinal.AlgebraicLE (NatOrdinal.partGE S.β c) (NatOrdinal.partGE S.β h) := by + have := hce.partGE S.β + rwa [hGE] at this + -- the parts below `β`: `s := e_{<β} ∈ [λ', (α ⊖ deg B')_{<β})` + set s := NatOrdinal.partLT S.β e with hsdef + have hlamεs : lam' ≤ s := by + have h2 : NatOrdinal.partGE S.β h + lam' ≤ NatOrdinal.partGE S.β h + s := by + calc NatOrdinal.partGE S.β h + lam' ≤ e := hτe + _ = NatOrdinal.partGE S.β e + NatOrdinal.partLT S.β e := + (NatOrdinal.partGE_add_partLT S.β e).symm + _ = NatOrdinal.partGE S.β h + s := by rw [hGE] + exact le_of_add_le_add_left h2 + have hsh : s < NatOrdinal.partLT S.β h := + NatOrdinal.partLT_lt_of_lt_of_partGE_eq heh hGE + -- the exponent `ε` of the last term of `(σ_B)_{<β}` + obtain ⟨ε, hε⟩ := + NatOrdinal.exists_leastTerm_eq_wpow + (S.partLT_cdeg_ne_zero hc + ((S.hasProperLowDegreePartNotAlgebraicLE_iff v).mp hL).2.2.1) + have h5 := S.partGE_lam₀_eq_of_hasProperLowDegreePartNotAlgebraicLE + hx hL (S.partLT_cdeg_add_degLT hc) hε + have hlamε : NatOrdinal.partGE ε lam' = + NatOrdinal.partGE ε (NatOrdinal.partLT S.β h) := by + have e1 := congrArg (NatOrdinal.partGE ε) hlam' + have e2 := congrArg (NatOrdinal.partGE ε) (S.partLT_h_add_degLT hh) + rw [NatOrdinal.partGE_add] at e1 e2 + rw [h5, ← e2, add_comm (NatOrdinal.partGE ε (NatOrdinal.partLT S.β h))] at e1 + exact add_left_cancel e1 + have hs : NatOrdinal.partGE ε s = NatOrdinal.partGE ε (NatOrdinal.partLT S.β h) := + le_antisymm (NatOrdinal.partGE_mono hsh.le) + (hlamε ▸ NatOrdinal.partGE_mono hlamεs) + -- `(σ_B)_{<β}`, all of whose terms are at least `ω^ε`, precedes `s`, hence precedes + -- `(α ⊖ deg B')_{<β}` + have h2 : NatOrdinal.AlgebraicLE (NatOrdinal.partLT S.β c) (NatOrdinal.partLT S.β h) := by + have h3 := (hce.partLT S.β).partGE ε + rw [NatOrdinal.partGE_eq_self_of_leastTerm_eq + (S.partLT_cdeg_ne_zero hc + ((S.hasProperLowDegreePartNotAlgebraicLE_iff v).mp hL).2.2.1) hε, + ← hsdef, hs] at h3 + exact h3.trans (NatOrdinal.algebraicLE_partGE _ _) + exact NatOrdinal.algebraicLE_of_partGE_of_partLT h1 h2 + +end PartialDerivativeIndices + +end Lifts.LimitOrdinalRelationAtCutoff + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/Partials.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/Partials.lean new file mode 100644 index 0000000000..7df53610a7 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/Partials.lean @@ -0,0 +1,394 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MvPolynomial.FinitePartVars + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.PartialDerivativeIndices +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.IdealFromTruncations + +import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Finset.FilterCard +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint + +/-! +# Partial derivatives and algebraic order of low-degree parts + +When `(deg B')_{<β} ≼ λ₀` in the algebraic order, + +`∂F/∂X_{B'} = ∑_B (∂F/∂X_B) U_B` + +over finitely many variables `B`: those whose low-degree part is all of `α_{<β}`, or larger +variables whose proper low-degree part does not precede `λ₀`. Moreover `∂U_B/∂X_{B₀} = 0`. + +*Proof*, by induction on the number of variables of `F` of degree above `deg B'`. Put +`λ' := λ₀ ⊖ (deg B')_{<β}` and `τ := (α ⊖ deg B')_{≥β} ⊕ λ'`. For all `γ < 0` +sufficiently close to `0`, the part at or above `τ` of +`pol((∂F/∂X_{B'})(b_𝓑)^{|γ})` lies in the ideal of the +`∂F/∂X_B` over the variables `B` of `F` with `deg B > deg B'` +(`exists_forall_componentsGE_pol_translatedTruncation_aeval_pderiv_mem`). A variable above `B'` +has a low-degree part equal to `α_{<β}`, outside the algebraic bound `λ₀`, or preceding `λ₀`; in +the last case `∂F/∂X_B` already lies in the ideal by induction. Among the retained derivatives, +those whose degree `σ_B ≼ α ⊖ deg B'` satisfy (n) against `τ`, and the others contribute nothing +in `[τ, α ⊖ deg B')`; so the translated truncations of +`(∂F/∂X_{B'})(b_𝓑)` satisfy (p) for the retained generators and `τ`, and ideal membership +of a +class from the condition (p) on its translated truncations +(`IsPrincipal.of_principalComponentMk_mem_span_of_forall_componentsGE_mem`) gives the class of +`(∂F/∂X_{B'})(b_𝓑)` in `P_{α ⊖ deg B'}` as a combination of the generators with +homogeneous +cofactors. Polynomial preimages of the cofactors and injectivity below `α` turn this into the +polynomial identity; the cofactors have degree below `δ = deg B₀`, so `∂U_B/∂X_{B₀} = 0`. +-/ + +universe v w + +open scoped NatOrdinal HahnSeries +open Berarducci HahnSeries MvPolynomial OrdinalGraded + +public noncomputable section + +namespace Berarducci + +variable {K : Type v} [Field K] {ι : Type w} {wt : ι → NatOrdinal} {x : ι → PrincipalSubring K} + +namespace Lifts.LimitOrdinalRelationAtCutoff + +variable {σ : Lifts wt x} {α : NatOrdinal} (S : σ.LimitOrdinalRelationAtCutoff α) + (hx : IsMinimalSystem (principalGrading K) wt x) (hinj : ∀ β < α, InjectiveAt K wt x β) + (hσ : σ.IsPrincipal) +include S hx hinj hσ + +/-- A variable contributes to the derivative at `v'` when its low-degree part is all of +`α_{<β}`, or when it is larger than `v'` and its proper low-degree part does not precede `λ₀`. -/ +def ContributesToPartialDerivativeAt (v' v : ι) : Prop := + v ∈ S.F.vars ∧ + (S.LowDegreePartEq v ∨ (S.HasProperLowDegreePartNotAlgebraicLE v ∧ wt v' < wt v)) + +omit hx hinj hσ in +theorem contributesToPartialDerivativeAt_iff (v' v : ι) : + S.ContributesToPartialDerivativeAt v' v ↔ + v ∈ S.F.vars ∧ + (S.LowDegreePartEq v ∨ (S.HasProperLowDegreePartNotAlgebraicLE v ∧ wt v' < wt v)) := + (Iff.rfl) + +omit hx hinj hσ in +theorem finite_setOf_contributesToPartialDerivativeAt (v' : ι) : + Finite {v // S.ContributesToPartialDerivativeAt v' v} := + (S.F.vars.finite_toSet.subset fun v + (hv : S.ContributesToPartialDerivativeAt v' v) ↦ hv.1).to_subtype + +/-- **The partial derivative when the low-degree part precedes `λ₀`.** If +`S.LowDegreePartAlgebraicLE v'`, then +`∂F/∂X_{v'} = ∑_v (∂F/∂X_v) U_v` over finitely many contributing variables, with +`∂U_v/∂X_{B₀} = 0`. -/ +@[blueprint "prop:partials-when-low-degree-part-is-algebraically-bounded" + (phase := "Limit ordinals in the degree induction") + (title := "Partial-derivative syzygy when $(w_{B'})_{<\\beta}\\oplus\\eta=\\lambda_0$ \ + for some $\\eta$") + (statement := /-- + Let $K$ be a field. Let $(x_i)_{i\in I}$ be a minimal homogeneous + generating system of $\widehat{\mathrm P}$, with + $x_i\in\mathrm P_{w_i}$, and choose principal series $b_i$ of degree + $w_i$ representing $x_i$. Assume evaluation at $(x_i)$ is injective on + every homogeneous degree below $\alpha$. + + Let $0\ne F\in K[X_i:i\in I]$ be weighted homogeneous of degree $\alpha$ + with $F(x)=0$. Suppose every variable of $F$ has weight below $\alpha$ + and zero constant Cantor coefficient. Choose $X_{B_0}$ of maximal weight + among the variables of $F$, and put $D=\deg_{X_{B_0}}F$. Suppose there are + ordinals $\beta,\Delta,\lambda_0,\alpha_1$ such that + \[ + \Delta\ne0,\qquad + \Delta\oplus D w_{B_0}=\alpha,\qquad + \lambda_0<\alpha_{<\beta}, + \] + every Cantor term of $\Delta$ is at least $\omega^\beta$, and the last + Cantor term of $w_{B_0}$ is below $\omega^\beta$. Assume also + \[ + \alpha_1\le\alpha_{\ge\beta}\oplus\lambda_0, + \qquad \alpha_1\le\alpha, + \] + that for some $\varepsilon_1>0$ every $\gamma\in(-\varepsilon_1,0)$ + satisfies + \[ + v_J\bigl(F(b)^{\vert\gamma}\bigr)<\omega^{\alpha_1}, + \] + and that in the convolution expansion of any monomial of $F$, every term + $\rho$ using at least two translated truncations satisfies + $\rho<\alpha_{\ge\beta}\oplus\lambda_0$. + + Let $X_{B'}$ occur in $F$, and suppose + $(w_{B'})_{<\beta}\preccurlyeq\lambda_0$ in the algebraic order. Then + there are a finite set $E$ of variables and + polynomials $(U_B)_{B\in E}$ such that every $B\in E$ occurs in $F$ and + either + \[ + (w_B)_{<\beta}=\alpha_{<\beta}, + \] + or + \[ + 0<(w_B)_{<\beta}\ne\alpha_{<\beta},\qquad + (w_B)_{<\beta}\not\preccurlyeq\lambda_0, + \qquad w_{B'} + intro v' hv' hn hdiff + obtain ⟨Θ, hΘdef⟩ : ∃ Θ, Θ = pderiv v' S.F := ⟨_, rfl⟩ + rw [← hΘdef] + rcases eq_or_ne Θ 0 with hΘ0 | hΘ0 + · exact ⟨∅, fun _ ↦ 0, fun v hv ↦ absurd hv (Finset.notMem_empty v), + fun v hv ↦ absurd hv (Finset.notMem_empty v), by rw [hΘ0, Finset.sum_empty]⟩ + -- the degree `h = α ⊖ deg v'` and `τ = h_{≥β} ⊕ λ'` + obtain ⟨h, hh⟩ := exists_add_wt_eq_of_mem_vars S.hom hv' + have hhα : h < α := by + rw [← hh]; exact lt_add_of_pos_right _ (pos_iff_ne_zero.mpr (hx.ne_zero v')) + have hΘhom : IsWeightedHomogeneous wt Θ h := by rw [hΘdef]; exact S.pderiv_hom hh + obtain ⟨lam', hlam'⟩ := NatOrdinal.algebraicLE_iff.mp + ((S.lowDegreePartAlgebraicLE_iff v').mp hdiff) + obtain ⟨τ, hτdef⟩ : ∃ τ : NatOrdinal, + τ = NatOrdinal.partGE S.β h + lam' := ⟨_, rfl⟩ + -- the variables above `v'` + have hτ : NatOrdinal.partGE S.β α + S.lam₀ ≤ τ + wt v' := by + have := S.αGE_add_lam₀_eq hh hlam' + rw [S.αGE_def, ← hτdef] at this + exact this.le + obtain ⟨ε₂, hε₂, h2⟩ := + σ.exists_forall_componentsGE_pol_translatedTruncation_aeval_pderiv_mem hx hinj hσ + S.hom S.vars_lt S.α₁_le S.α₁_le_α S.ε₁_pos S.truncation_lt S.remainder_lt v' hτ + rw [← hΘdef] at h2 + -- the partials of the variables above `v'` lie in the ideal of the generators + have habove : ∀ j ∈ S.F.vars, wt v' < wt j → + pderiv j S.F ∈ + Ideal.span (Set.range fun v : {v // S.ContributesToPartialDerivativeAt v' v} ↦ + pderiv v.1 S.F) := by + intro j hj hlt + by_cases htop : S.LowDegreePartEq j + · exact Ideal.subset_span ⟨⟨j, hj, Or.inl htop⟩, rfl⟩ + by_cases hL : S.HasProperLowDegreePartNotAlgebraicLE j + · exact Ideal.subset_span ⟨⟨j, hj, Or.inr ⟨hL, hlt⟩⟩, rfl⟩ + -- The low-degree part of `j` precedes `λ₀`: use the induction hypothesis. + have hdj : S.LowDegreePartAlgebraicLE j := by + by_contra hnd + rcases eq_or_ne (S.degLT j) 0 with ht | ht + · exact hnd ((S.lowDegreePartAlgebraicLE_iff j).mpr (by + rw [ht] + exact NatOrdinal.algebraicLE_zero _)) + · exact hL ((S.hasProperLowDegreePartNotAlgebraicLE_iff j).mpr ⟨hj, ht, htop, hnd⟩) + have hcard : (S.F.vars.filter fun v ↦ wt j < wt v).card < n := + (ConwayRefinement.card_filter_above_lt wt S.F.vars hj hlt).trans_eq hn + obtain ⟨s, U, hs, -, heq⟩ := ih _ hcard j hj rfl hdj + rw [heq] + refine Ideal.sum_mem _ fun v hv ↦ + Ideal.mul_mem_right _ _ (Ideal.subset_span ⟨⟨v, ?_⟩, rfl⟩) + exact ⟨(hs v hv).1, (hs v hv).2.elim Or.inl fun h' ↦ Or.inr ⟨h'.1, hlt.trans h'.2⟩⟩ + have h2' : ∀ γ : ℝ, -ε₂ < γ → γ < 0 → + componentsGE wt τ (σ.pol hx α + (translatedTruncation ((aeval σ.lift Θ : Series K) : K⟦ℝ⟧) γ)) ∈ + Ideal.span (Set.range fun v : {v // S.ContributesToPartialDerivativeAt v' v} ↦ + pderiv v.1 S.F) := by + intro γ hγε hγ0 + refine Ideal.span_le.mpr ?_ (h2 γ hγε hγ0) + rintro _ ⟨j, rfl⟩ + exact habove j.1 j.2.1 j.2.2 + -- the generator degrees `σ_v = α ⊖ deg v` and cofactor degrees `b_v = deg v ⊖ deg v'` + have : Finite {v // S.ContributesToPartialDerivativeAt v' v} := + S.finite_setOf_contributesToPartialDerivativeAt v' + have hcd : ∀ v : {v // S.ContributesToPartialDerivativeAt v' v}, ∃ c, c + wt v.1 = α := + fun v ↦ exists_add_wt_eq_of_mem_vars S.hom v.2.1 + choose cd hcd using hcd + have hqG : ∀ v : {v // S.ContributesToPartialDerivativeAt v' v}, + IsWeightedHomogeneous wt (pderiv v.1 S.F) (cd v) := + fun v ↦ S.pderiv_hom (hcd v) + -- generators with `σ_v ≼ h`, equivalently `deg v' ≼ deg v` + obtain ⟨A, hAdef⟩ : ∃ A : {v // S.ContributesToPartialDerivativeAt v' v} → Prop, + A = fun v ↦ NatOrdinal.AlgebraicLE (wt v') (wt v.1) := ⟨_, rfl⟩ + have hAiff : ∀ v, A v ↔ NatOrdinal.AlgebraicLE (wt v') (wt v.1) := fun v ↦ by rw [hAdef] + have : Finite {v : {v // S.ContributesToPartialDerivativeAt v' v} // A v} := + Finite.of_injective (fun v ↦ v.1) Subtype.val_injective + have hbA : ∀ v : {v : {v // S.ContributesToPartialDerivativeAt v' v} // A v}, + ∃ b, b + wt v' = wt v.1.1 := fun v ↦ by + obtain ⟨c, hc⟩ := NatOrdinal.algebraicLE_iff.mp ((hAiff v.1).mp v.2) + exact ⟨c, by rw [add_comm]; exact hc⟩ + choose b hb using hbA + have hbc : ∀ v : {v : {v // S.ContributesToPartialDerivativeAt v' v} // A v}, + b v + cd v.1 = h := by + intro v + have h1 : b v + cd v.1 + wt v' = h + wt v' := by + rw [add_right_comm, hb v, add_comm, hcd v.1, hh] + exact add_right_cancel h1 + -- for the other generators, `σ_v \not\preccurlyeq h` + have hnotA : ∀ v : {v // S.ContributesToPartialDerivativeAt v' v}, ¬ A v → + ¬ NatOrdinal.AlgebraicLE (cd v) h := by + intro v hA hce + obtain ⟨b', hb'⟩ := NatOrdinal.algebraicLE_iff.mp hce + refine hA ((hAiff v).mpr (NatOrdinal.algebraicLE_iff.mpr ⟨b', ?_⟩)) + have h1 : cd v + (b' + wt v') = cd v + wt v.1 := by + rw [← add_assoc, hb', hh, hcd v] + rw [add_comm] + exact add_left_cancel h1 + -- the ordinal value of `(∂F/∂X_{v'})(b_𝓑)` and of its translated truncations + have hu : ordinalValue (aeval σ.lift Θ) = ω^ h := + σ.ordinalValue_aeval_eq_of_injectiveAt (hinj h hhα) hΘhom hΘ0 + have hu' : ordinalValue (aeval σ.lift Θ) < ω^ (h + 1) := by + rw [hu]; exact NatOrdinal.wpow_lt_wpow.mpr (lt_add_one h) + obtain ⟨ε₃, hε₃, h3⟩ := exists_forall_ordinalValue_translatedTruncation_lt hu' + -- ideal membership of the class from the condition (p) on the translated truncations + have hτh : τ + 1 < h := hτdef ▸ S.τ_add_one_lt hx hh hlam' + have hsep : ∀ v : {v : {v // S.ContributesToPartialDerivativeAt v' v} // A v}, + ∀ θ, θ < cd v.1 → b v + θ < τ := by + intro v θ hθ + have hc0 := S.cdeg_ne_zero v.1.2.1 (hcd v.1) + obtain ⟨ε, hε⟩ := NatOrdinal.exists_leastTerm_eq_wpow hc0 + refine NatOrdinal.add_lt_of_lt_of_partGE_le hc0 hε (hbc v) ?_ hθ + rw [hτdef] + rcases v.1.2.2 with htop | ⟨hL, -⟩ + · exact S.partGE_le_τ_of_lowDegreePartEq v.1.2.1 (hcd v.1) htop hε h + · have hne := S.partLT_cdeg_ne_zero (hcd v.1) + ((S.hasProperLowDegreePartNotAlgebraicLE_iff _).mp hL).2.2.1 + rw [NatOrdinal.leastTerm_eq_leastTerm_partLT hne] at hε + exact S.partGE_le_τ_of_hasProperLowDegreePartNotAlgebraicLE hx (hcd v.1) hh hlam' hL hε + have htrunc : ∀ γ : ℝ, -(min ε₂ ε₃) < γ → γ < 0 → + componentsGE wt τ (σ.pol hx α + (translatedTruncation ((aeval σ.lift Θ : Series K) : K⟦ℝ⟧) γ)) ∈ + Ideal.span (Set.range fun v : + {v : {v // S.ContributesToPartialDerivativeAt v' v} // A v} ↦ pderiv v.1.1 S.F) := by + intro γ hγε hγ0 + have hγ₂ : -ε₂ < γ := by linarith [min_le_left ε₂ ε₃] + have hγ₃ : -ε₃ < γ := by linarith [min_le_right ε₂ ε₃] + refine componentsGE_mem_span_subtype wt hqG (h2' γ hγ₂ hγ0) + (σ.pol_degreeLT_of_lt hx hinj hhα.le (h3 γ hγ₃ hγ0)) A + fun v hA e hτe heh ⟨β', hβ'⟩ ↦ ?_ + have hce : NatOrdinal.AlgebraicLE (cd v) e := + NatOrdinal.algebraicLE_iff.mpr ⟨β', by rw [add_comm]; exact hβ'⟩ + rw [hτdef] at hτe + rcases v.2.2 with htop | ⟨hL, -⟩ + · exact S.not_algebraicLE_of_lowDegreePartEq_of_not + (hcd v) hlam' htop (hnotA v hA) hτe heh hce + · exact S.not_algebraicLE_of_hasProperLowDegreePartNotAlgebraicLE_of_not + hx (hcd v) hh hlam' hL (hnotA v hA) hτe heh hce + have hmem := IsPrincipal.of_principalComponentMk_mem_span_of_forall_componentsGE_mem σ hx hinj + hσ (ι' := {v : {v // S.ContributesToPartialDerivativeAt v' v} // A v}) + (q := fun v ↦ pderiv v.1.1 S.F) + (c := fun v ↦ cd v.1) (τ := τ) (h := h) (b := b) + (u := aeval σ.lift Θ) (η := -(min ε₂ ε₃)) + (fun v ↦ hqG v.1) (fun v ↦ S.cdeg_constantCoeff hx (hcd v.1)) + (fun v ↦ S.cdeg_ne_zero v.1.2.1 (hcd v.1)) hbc hsep hτh hhα hu hu' + (neg_neg_of_pos (lt_min hε₂ hε₃)) htrunc + -- back to polynomials + cases nonempty_fintype {v : {v // S.ContributesToPartialDerivativeAt v' v} // A v} + have hq' : ∀ v : {v : {v // S.ContributesToPartialDerivativeAt v' v} // A v}, + aeval x (pderiv v.1.1 S.F) ∈ principalGrading K (cd v.1) := + fun v ↦ aeval_mem_of_forall_mem hx.mem (hqG v.1) + obtain ⟨u, hu_mem, -, hsum⟩ := exists_eq_sum_mul_of_mem_span (𝒜 := principalGrading K) hq' + (of_mem_principalGrading _ _) hmem + have hU : ∀ v : {v : {v // S.ContributesToPartialDerivativeAt v' v} // A v}, + ∃ U : MvPolynomial ι K, + IsWeightedHomogeneous wt U (b v) ∧ aeval x U = u v := + fun v ↦ hx.exists_aeval_eq (principalGrading_gradeZeroScalars K) (b v) (u v) + (hu_mem v (b v) (hbc v)) + choose U hUhom hUu using hU + obtain ⟨Θ', hΘ'def⟩ : ∃ Θ', Θ' = Θ - ∑ v, pderiv v.1.1 S.F * U v := ⟨_, rfl⟩ + have hS : IsWeightedHomogeneous wt (∑ v, pderiv v.1.1 S.F * U v) h := + IsWeightedHomogeneous.sum _ _ _ fun v _ ↦ by + have := IsWeightedHomogeneous.mul (hqG v.1) (hUhom v) + rwa [add_comm, hbc v] at this + have hΘ'hom : IsWeightedHomogeneous wt Θ' h := by + rw [hΘ'def, sub_eq_add_neg] + refine IsWeightedHomogeneous.add hΘhom ?_ + intro d hd + rw [coeff_neg, neg_ne_zero] at hd + exact hS hd + have hΘ'0 : aeval x Θ' = 0 := by + rw [hΘ'def, map_sub, map_sum, ← (σ.aeval_represents hΘhom).of_principalComponentMk, hsum] + simp only [map_mul, hUu] + exact sub_self _ + have hΘ' : Θ' = 0 := (injectiveAt_iff h).mp (hinj h hhα) Θ' hΘ'hom hΘ'0 + have hΘeq : Θ = ∑ v, pderiv v.1.1 S.F * U v := by + rw [← sub_eq_zero, ← hΘ'def]; exact hΘ' + -- the cofactors have degree below `δ = deg B₀`, so `∂/∂X_{B₀}` annihilates them + have hUB₀ : ∀ v : {v : {v // S.ContributesToPartialDerivativeAt v' v} // A v}, + pderiv S.B₀ (U v) = 0 := by + intro v + have hbg : b v < wt S.B₀ := by + have h1 : b v < wt v.1.1 := by + rw [← hb v]; exact lt_add_of_pos_right _ (pos_iff_ne_zero.mpr (hx.ne_zero v')) + exact h1.trans_le (S.max _ v.1.2.1) + exact pderiv_eq_zero_of_degreeLT_le ((hUhom v).degreeLT hbg) le_rfl + -- Extend the cofactor family by zero, then reindex along the inclusion of contributing variables. + let index : {v : {v // S.ContributesToPartialDerivativeAt v' v} // A v} → ι := + fun v ↦ v.1.1 + have hinjv : Function.Injective index := fun v w hvw ↦ Subtype.ext (Subtype.ext hvw) + refine ⟨Finset.univ.image index, Function.extend index U (fun _ ↦ 0), ?_, ?_, ?_⟩ + · intro i hi + obtain ⟨v, -, rfl⟩ := Finset.mem_image.mp hi + exact v.1.2 + · intro i hi + obtain ⟨v, -, rfl⟩ := Finset.mem_image.mp hi + rw [hinjv.extend_apply] + exact hUB₀ v + · rw [hΘeq, Finset.sum_image fun v _ w _ h ↦ hinjv h] + exact Finset.sum_congr rfl fun v _ ↦ by rw [hinjv.extend_apply] + +end Lifts.LimitOrdinalRelationAtCutoff + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/Pieces.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/Pieces.lean new file mode 100644 index 0000000000..2e207d8729 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/Pieces.lean @@ -0,0 +1,248 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.SumAlongCutoffs +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.SeriesTruncations +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.IncreasingSequenceUnion + +/-! +# Pieces of a series and sums along a sequence of cutoffs: their translated truncations + +For reals `a < b ≤ 0` the *piece* of a series `u` on `(a, b]`, translated to `0`, is +`(u_{>a})^{|b}` — the upper truncation [LM24, Def. 3.2.2] followed by the translated truncation at +`b` [Ber00, Def. 6.1] (`piece a b u`). In the induction over degrees a series is cut into the +pieces on `(γ_k, γ_{k+1}]` along a sequence `γ_k ↑ 0`, and the cofactors found for the pieces are +combined into a sum along the cutoffs, `s = ∑_k (w_k)_{>c_k} t^{γ_k}` (the sum (m) of +`SumAlongCutoffs.lean`, here as a nonpositive series, `sumAlongCutoffsSeries`). This file records +how translated truncations pass through the two operations, modulo `J`: + +* `(piece a b u)^{|ξ} ≡ u^{|b + ξ}` for `a - b < ξ ≤ 0`; +* `s^{|γ_k + ξ} ≡ w_k^{|ξ}` for `c_k < ξ ≤ 0`, and the translated truncations of `s` at cutoffs + `ζ ≤ γ_0 + c_0` vanish; +* the support of `s` has order type at most `ω^e` when every `w_k` has support of order type + below `ω^e`. +-/ + +universe v + +open scoped NatOrdinal HahnSeries +open Berarducci HahnSeries + +public noncomputable section + +namespace Berarducci + +variable {K : Type v} [Field K] + +/-- A translated truncation at a cutoff below the whole support vanishes. -/ +theorem translatedTruncation_eq_zero_of_forall_lt {b : K⟦ℝ⟧} {ζ : ℝ} + (h : ∀ y ∈ b.support, ζ < y) : translatedTruncation b ζ = 0 := by + apply Subtype.ext + ext δ + rw [coeff_translatedTruncation, ZeroMemClass.coe_zero, HahnSeries.coeff_zero] + split_ifs with hδ + · by_contra hne + exact absurd (h (ζ + δ) ((HahnSeries.mem_support _ _).mpr hne)) (by linarith) + · rfl + +/-! ### Pieces -/ + +/-- The piece of the series `E` on `(a, b]`, translated so that `b` sits at `0`: `(E_{>a})^{|b}`, +the upper truncation `E_{>a}` followed by the translated truncation at `b`. -/ +def piece (a b : ℝ) (E : K⟦ℝ⟧) : Series K := + ⟨translate (-b) (truncGT a (truncLE b E)), by + rw [HahnSeries.mem_nonpositiveSubring, support_translate] + rintro δ ⟨y, hy, rfl⟩ + rw [support_truncGT] at hy + obtain ⟨hy1, -⟩ := hy + rw [support_truncLE] at hy1 + change -b + y ≤ 0 + linarith [hy1.2]⟩ + +theorem coe_piece (a b : ℝ) (E : K⟦ℝ⟧) : + ((piece a b E : Series K) : K⟦ℝ⟧) = translate (-b) (truncGT a (truncLE b E)) := + (rfl) + +theorem coeff_piece (a b : ℝ) (E : K⟦ℝ⟧) (δ : ℝ) : + ((piece a b E : Series K) : K⟦ℝ⟧).coeff δ = + if a < δ + b ∧ δ + b ≤ b then E.coeff (δ + b) else 0 := by + change (translate (-b) (truncGT a (truncLE b E))).coeff δ = _ + rw [coeff_translate, sub_neg_eq_add, HahnSeries.coeff_truncGT, HahnSeries.coeff_truncLE] + by_cases h1 : a < δ + b <;> by_cases h2 : δ + b ≤ b <;> simp [h1, h2] + +/-- **Translated truncations of interval pieces.** If `a - b < ξ ≤ 0`, then the translated +truncation at `ξ` of the restriction to `(a, b]`, translated so that `b` becomes `0`, is +congruent modulo `J` to the original series translated-truncated at `b + ξ`. -/ +@[blueprint "lem:window-truncation" + (phase := "Limit ordinals in the degree induction") + (title := "Translated truncations of interval pieces") + (statement := /-- + Let $K$ be a field, let $u\in K((\mathbb R))$, and let + $a,b,\xi\in\mathbb R$ satisfy $a-b<\xi\le0$. Put + \[ + p=t^{-b}\sum_{aa-b-\xi$, compare coefficients. If $\delta\le0$, then + $a0$, both coefficients are zero. The support + of the difference is therefore bounded above by $a-b-\xi<0$, so the + difference lies in $J$. + -/)] +theorem translatedTruncation_window_sub_mem (a b : ℝ) (E : K⟦ℝ⟧) {ξ : ℝ} (hξ : a - b < ξ) + (hξ0 : ξ ≤ 0) : + translatedTruncation ((piece a b E : Series K) : K⟦ℝ⟧) ξ - translatedTruncation E (b + ξ) ∈ + Nonpositive.negativeMonomialIdeal K := by + refine mem_negativeMonomialIdeal_of_forall_support_le (s := a - b - ξ) (by linarith) fun δ hδ ↦ ?_ + rw [HahnSeries.mem_support, AddSubgroupClass.coe_sub, HahnSeries.coeff_sub, + coeff_translatedTruncation, coeff_translatedTruncation, coeff_piece] at hδ + by_contra hlt + rw [not_le] at hlt + apply hδ + by_cases h0 : δ ≤ 0 + · rw [ite_eq_left h0, ite_eq_left h0, ite_eq_left ⟨by + linarith, by + linarith⟩, show ξ + δ + b = b + ξ + δ by + ring, + sub_self] + · rw [ite_eq_right h0, ite_eq_right h0, sub_zero] + +/-! ### Sums along a sequence of cutoffs -/ + +section SumAlongCutoffsSeries + +variable (w : ℕ → Series K) (c γ : ℕ → ℝ) (hγ : StrictMono γ) + (hdisj : ∀ k, γ k ≤ γ (k + 1) + c (k + 1)) (hneg : ∀ k, γ k < 0) +include hγ hdisj hneg + +/-- The sum (m), `∑_k (w_k)_{>c_k} t^{γ_k}`, as a nonpositive series. -/ +def sumAlongCutoffsSeries : Series K := + ⟨sumAlongCutoffs w c γ hγ hdisj, sumAlongCutoffs_mem w c γ hγ hdisj hneg⟩ + +theorem coe_sumAlongCutoffsSeries : + ((sumAlongCutoffsSeries w c γ hγ hdisj hneg : Series K) : K⟦ℝ⟧) = + sumAlongCutoffs w c γ hγ hdisj := + (rfl) + +/-- **Translated truncations of shifted truncation sums.** On the `k`-th support interval, the +translated truncation of the sum along cutoffs agrees modulo `J` with that of `w k`. -/ +@[blueprint "lem:cutoff-sum-truncation" + (phase := "Limit ordinals in the degree induction") + (title := "Translated truncations of shifted truncation sums") + (statement := /-- + Let $K$ be a field, let $w_k\in\Kser$, and let + $c_k,\gamma_k\in\mathbb R$. Suppose that $(\gamma_k)$ is strictly + increasing, $\gamma_k<0$, and + $\gamma_k\le\gamma_{k+1}+c_{k+1}$ for every $k$. Put + \[ + s=\sum_k\utrunc{w_k}{c_k}t^{\gamma_k}. + \] + For every $k$ and every $c_k<\xi\le0$, + \[ + \trunc s{\gamma_k+\xi}\equiv\trunc{w_k}\xi\pmod J. + \] + -/) + (proof := /-- + The shifted support intervals are strictly ordered, so + \ref{lem:increasing-union} ensures that their union is well ordered and the + series $s$ is defined. Fix $k$ and $c_k<\xi\le0$. Since $c_k-\xi<0$, it + suffices to compare coefficients at exponents $\delta>c_k-\xi$. If + $\delta\le0$, then $\gamma_k+\xi+\delta$ lies in the $k$-th interval, so + the coefficient of $s$ comes from its $k$-th summand and equals the + coefficient of $w_k$ at $\xi+\delta$. If $\delta>0$, both translated + truncations have zero coefficient. Their difference is supported at or + below $c_k-\xi<0$, and therefore lies in $J$. + -/)] +theorem translatedTruncation_sumAlongCutoffsSeries_sub_mem (k : ℕ) {ξ : ℝ} (hξ : c k < ξ) + (hξ0 : ξ ≤ 0) : + translatedTruncation ((sumAlongCutoffsSeries w c γ hγ hdisj hneg : Series K) : K⟦ℝ⟧) (γ k + ξ) - + translatedTruncation (w k : K⟦ℝ⟧) ξ ∈ Nonpositive.negativeMonomialIdeal K := by + refine mem_negativeMonomialIdeal_of_forall_support_le (s := c k - ξ) (by linarith) fun δ hδ ↦ ?_ + rw [HahnSeries.mem_support, AddSubgroupClass.coe_sub, HahnSeries.coeff_sub, + coeff_translatedTruncation, coeff_translatedTruncation, coe_sumAlongCutoffsSeries] at hδ + by_contra hlt + rw [not_le] at hlt + apply hδ + by_cases h0 : δ ≤ 0 + · rw [ite_eq_left h0, ite_eq_left h0, + coeff_sumAlongCutoffs_of_mem w c γ hγ hdisj (k := k) ⟨by linarith, by linarith⟩, + coeff_placedTerm, + ite_eq_left (by linarith), show γ k + ξ + δ - γ k = ξ + δ by ring, sub_self] + · rw [ite_eq_right h0, ite_eq_right h0, sub_zero] + +/-- At cutoffs `ζ ≤ γ_0 + c_0`, below the first interval, the translated truncations of the sum +(m) vanish. -/ +theorem translatedTruncation_sumAlongCutoffsSeries_eq_zero (hc0 : c 0 ≤ 0) {ζ : ℝ} + (hζ : ζ ≤ γ 0 + c 0) : + translatedTruncation ((sumAlongCutoffsSeries w c γ hγ hdisj hneg : Series K) : K⟦ℝ⟧) ζ = 0 := by + refine translatedTruncation_eq_zero_of_forall_lt fun y hy ↦ ?_ + rw [coe_sumAlongCutoffsSeries] at hy + obtain ⟨k, hk⟩ := Set.mem_iUnion.mp (support_sumAlongCutoffs_subset w c γ hγ hdisj hy) + have : γ 0 + c 0 ≤ γ k + c k := by + rcases k with _ | k + · exact le_rfl + · have h1 : γ 0 ≤ γ k := hγ.monotone (Nat.zero_le k) + have h2 := hdisj k + linarith + linarith [hk.1] + +/-- **Order type of a sum along cutoffs.** If every `w k` has support order type below `ω^e`, +then the sum along cutoffs has support order type at most `ω^e`. -/ +@[blueprint "lem:cutoff-sum-support" + (phase := "Limit ordinals in the degree induction") + (title := "Order type of a sum along cutoffs") + (statement := /-- + Let $K$ be a field, let $w_k\in K((\mathbb R^{\le0}))$, let + $(\gamma_k)$ be a strictly increasing sequence of negative real numbers, + and let $c_k\in\mathbb R$ satisfy + $\gamma_k\le\gamma_{k+1}+c_{k+1}$ for every $k$. Put + \[ + s=\sum_k (w_k)_{>c_k}t^{\gamma_k}. + \] + If $\operatorname{ot}(\operatorname{supp}(w_k))<\omega^\rho$ for every + $k$, then $\operatorname{ot}(\operatorname{supp}(s))\le\omega^\rho$. + -/) + (proof := /-- + The $k$-th summand is supported in $(\gamma_k+c_k,\gamma_k]$, and its + support order type is at most $\operatorname{ot}(\operatorname{supp}(w_k))$. + The cutoff inequality strictly orders these supports by $k$. By + \ref{lem:increasing-union-below-principal-ordinal}, their union has order + type at most $\omega^\rho$. The support of $s$ is contained in this union. + -/)] +theorem supportOrderType_sumAlongCutoffsSeries_le {e : NatOrdinal} + (hw : ∀ k, ((w k : Series K) : K⟦ℝ⟧).supportOrderType < (ω^ e).val) : + ((sumAlongCutoffsSeries w c γ hγ hdisj hneg : Series K) : K⟦ℝ⟧).supportOrderType ≤ + (ω^ e).val := by + rw [coe_sumAlongCutoffsSeries] + have hB : ∀ k, (placedTerm w c γ k).support.IsPWO := fun k ↦ support_placedTerm_isPWO w c γ k + have hord : ∀ j k, j < k → ∀ x ∈ (placedTerm w c γ j).support, + ∀ y ∈ (placedTerm w c γ k).support, x < y := + fun j k hjk x hx y hy ↦ placedTerm_support_lt w c γ hγ hdisj hjk hx hy + have hU : (⋃ k, (placedTerm w c γ k).support).IsPWO := Set.IsPWO.iUnion_of_ordered hB hord + have hsub : (sumAlongCutoffs w c γ hγ hdisj).support ⊆ ⋃ k, (placedTerm w c γ k).support := + fun y hy ↦ by + obtain ⟨k, hk⟩ := Set.mem_iUnion.mp (support_sumAlongCutoffs_subset w c γ hγ hdisj hy) + refine Set.mem_iUnion.mpr ⟨k, ?_⟩ + rw [HahnSeries.mem_support] at hy ⊢ + rwa [coeff_sumAlongCutoffs_of_mem w c γ hγ hdisj hk] at hy + rw [supportOrderType_eq_setOrderType] + refine (Set.IsPWO.orderType_mono _ hU hsub).trans ?_ + refine Set.IsPWO.orderType_iUnion_le_wpow_of_ordered hB hord (fun k ↦ ?_) + rw [← supportOrderType_eq_setOrderType] + exact (supportOrderType_placedTerm_le w c γ k).trans_lt (hw k) + +end SumAlongCutoffsSeries + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/Polynomiality.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/Polynomiality.lean new file mode 100644 index 0000000000..de49b347b1 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/Polynomiality.lean @@ -0,0 +1,113 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint +import Mathlib.RingTheory.AlgebraicIndependent.Basic + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.RealPartials + +/-! +# The polynomiality of `P̂` + +Let `K` be a field of characteristic `0` and `𝓑` a minimal system of homogeneous generators of +`P̂ = ⨁_α P_α`; in Lean the generators are `x i`, of degrees `wt i`. Evaluation +`K[X_B : B ∈ 𝓑] → P̂`, `X_B ↦ B`, is injective. + +For real Hahn series, Berarducci's ordinal value is `omega` raised to the Cantor–Bendixson rank of +zero in the closed support. Thus LM24's Cantor degree is that rank, and `P̂` is +canonically the associated graded algebra of the Cantor–Bendixson degree. Its polynomiality is the +generic degree-induction theorem. The interval-based partial-derivative argument is the remaining +step specific to the real exponent group. +-/ + +universe v w + +open scoped NatOrdinal +open MvPolynomial OrdinalGraded Berarducci + +public noncomputable section + +namespace Berarducci + +variable {K : Type v} [Field K] [CharZero K] {ι : Type w} {wt : ι → NatOrdinal} + {x : ι → PrincipalSubring K} + +private theorem algebraicIndependent_cantorBendixson + (hx : IsMinimalSystem (principalGrading K) wt x) : + AlgebraicIndependent K x := by + let e := principalSubringCantorBendixsonAlgEquiv (K := K) + let xg := fun i ↦ e (x i) + have hxg : IsMinimalSystem + (DirectSum.rangeLof K (HahnSeries.Nonpositive.cantorBendixsonDegreeValuation + (G := ℝ) (R := K)).Component) wt xg := + minimalSystem_cantorBendixson hx + obtain ⟨σ, hσ⟩ := Lifts.exists_isPrincipal hx + let σg := σ.cantorBendixson + have hσg : HahnSeries.Nonpositive.LiftFamily.HasLowerTruncationDegrees σg := + hσ.cantorBendixson + have haixg : AlgebraicIndependent K xg := + HahnSeries.Germ.algebraicIndependent_of_isMinimalSystem_of_limitOrdinalCases σg hxg hσg + (fun _ hinj S ↦ S.degreeOf_eq_one hxg hσg hinj) + (fun α hinj S v' hv' hlowDegree ↦ by + change HahnSeries.Germ.LimitOrdinalRelationAtCutoff σ.cantorBendixson α at S + change ∀ β < α, InjectiveAt K wt + (fun i ↦ principalSubringCantorBendixsonAlgEquiv (x i)) β at hinj + exact Lifts.RealPartialDecomposition.lowDegreePartAlgebraicLE_partials S hx hinj hσ hv' + hlowDegree) + have hxg_eq : e.toAlgHom ∘ x = xg := by rfl + rw [← hxg_eq] at haixg + exact (e.toAlgHom.algebraicIndependent_iff e.injective).mp haixg + +/-- **The polynomiality of `P̂`, degree by degree.** For a minimal system of homogeneous +generators `x` of degrees `wt`, evaluation is injective in every degree `α`: a polynomial +homogeneous of degree `α` that evaluates to `0` in `P̂` is `0`. -/ +theorem injectiveAt_of_isMinimalSystem (hx : IsMinimalSystem (principalGrading K) wt x) + (α : NatOrdinal) : InjectiveAt K wt x α := by + rw [OrdinalGraded.injectiveAt_iff] + intro F _ hF + apply algebraicIndependent_iff_injective_aeval.mp (algebraicIndependent_cantorBendixson hx) + rw [hF, map_zero] + +/-- **The algebraic independence of minimal systems in `P̂`.** Every minimal system of +homogeneous generators is algebraically independent. -/ +@[blueprint "thm:polynomial" + (phase := "Principal RV-elements") + (title := "Minimal homogeneous generators of $\\widehat{\\mathrm P}$ are algebraically \ + independent") + (statement := /-- + Let $K$ be a field of characteristic zero. If $(x_i)_{i\in I}$ is a + minimal homogeneous generating system of $\widehat{\mathrm P}$, with + $x_i\in\mathrm P_{w_i}$, then $(x_i)_{i\in I}$ is algebraically + independent over $K$. + -/) + (proof := /-- + Choose principal series representatives $b_i$ of the $x_i$. + By \ref{lem:principal-representatives-cantor-bendixson}, $(x_i)$ is a minimal + homogeneous generating system of + $\operatorname{gr}_{\delta_{\mathrm{CB}}}K((\mathbb R^{\le0}))$, and the + same $b_i$ have the required degree and translated-truncation + properties for the Cantor--Bendixson grading. + + Apply \ref{thm:cantor-bendixson-polynomiality}. Its two nontrivial relation + hypotheses follow from \ref{lem:linear-occurrence} and + \ref{lem:real-translated-truncation-partials}. Thus the + transported family is algebraically independent. Injectivity of the graded + isomorphism transports algebraic independence back to $(x_i)$ in + $\widehat{\mathrm P}$. + -/) + (highlight)] +theorem algebraicIndependent_of_isMinimalSystem + (hx : IsMinimalSystem (principalGrading K) wt x) : AlgebraicIndependent K x := + algebraicIndependent_cantorBendixson hx + +/-- **The polynomiality of `P̂`.** Evaluation `K[X_B : B ∈ 𝓑] → P̂` at a minimal system of +homogeneous generators is injective. -/ +theorem aeval_injective_of_isMinimalSystem (hx : IsMinimalSystem (principalGrading K) wt x) : + Function.Injective (aeval x : MvPolynomial ι K →ₐ[K] PrincipalSubring K) := + algebraicIndependent_iff_injective_aeval.mp (algebraicIndependent_of_isMinimalSystem hx) + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/PrincipalGraded.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/PrincipalGraded.lean new file mode 100644 index 0000000000..147e995999 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/PrincipalGraded.lean @@ -0,0 +1,830 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalSubring +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.DirectSum.InternalGrading +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.LoweringDerivation.FilteredModule +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.LoweringDerivation.Polynomial +public import Mathlib.Algebra.MvPolynomial.Eval +public import Mathlib.LinearAlgebra.Basis.VectorSpace +public import Mathlib.RingTheory.Ideal.Quotient.Operations + +import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.AssociatedGradedValuation +import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.DegreeAssociatedGradedDomain +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Statements.OrdinalValueDegree +import Mathlib.LinearAlgebra.Projection + +/-! +# The internal grading of `P̂`, its finite-degree part `P̂_{<ω}` and the quotient `P̂/I` + +The ring `P̂ = ⨁_{α<ω₁} P_α` is internally graded by its components `P_α` +(`principalGrading`), with `P_0 = K`. The objects of the theory of graded algebras over countable +ordinals, specialised to this grading, are the paper's: + +`P̂_{<ω} = ⨁_{n<ω} P_n` is the subalgebra of finite degree, `I = I_{≥1} = (P̂_{<ω})₊ P̂` is the +ideal generated by the elements of positive finite degree, `P̂/I` is the quotient by `I`, and +`(P̂_{<ω})₊² ∩ P_n = ∑_{i,j ≥ 1, i+j=n} P_i P_j` is the subspace of decomposables of `P_n`, with +quotient `P_n / ((P̂_{<ω})₊² ∩ P_n)`. The names below are abbreviations, or definitional aliases, +of the generic objects at `principalGrading K`, the decomposables being read inside the component +`P_n` through its homogeneous inclusion. +The ideal `(P̂_{<ω})₊ ⊆ P̂_{<ω}` of elements of positive degree, the elements of `P̂_{<ω}` with +vanishing degree-zero component, is specific to `P̂`; `I` is the least ideal of `P̂` containing it. + +A choice of complements `P_n = ((P̂_{<ω})₊² ∩ P_n) ⊕ E_n` and of bases of the `E_n` supplies a +minimal system `𝓑` of homogeneous generators of `P̂_{<ω}`. The system and the evaluation +`K[X_B : B ∈ 𝓑] → P̂_{<ω}` are noncanonical, but evaluation is surjective for every such choice. + +Everything here holds over every coefficient field, except that nonzero vectors of finite degree +have nonzero product: that is the multiplicativity of the ordinal value, Berarducci, Theorem 9.7, +and needs characteristic zero. +-/ + +universe v + +public noncomputable section + +open Berarducci LoweringDerivation + +namespace Berarducci + +open scoped DirectSum NatOrdinal + +variable {K : Type v} [Field K] + +/-! ### The internal grading of `P̂` -/ + +variable (K) in +/-- The internal grading of `P̂` by the spaces `P_α`. -/ +abbrev principalGrading : NatOrdinal → Submodule K (PrincipalSubring K) := + DirectSum.rangeLof K (PrincipalComponent K) + +theorem of_mem_principalGrading (α : NatOrdinal) (a : PrincipalComponent K α) : + DirectSum.of (PrincipalComponent K) α a ∈ principalGrading K α := + DirectSum.of_mem_rangeLof K _ α a + +variable (K) in +/-- Degree zero of the internal grading is the coefficient field: `P_0 = K`. -/ +theorem principalGrading_gradeZeroScalars : GradeZeroScalars (principalGrading K) := by + rw [gradeZeroScalars_iff] + intro x hx + obtain ⟨a, rfl⟩ := (DirectSum.mem_rangeLof_iff K _ _ x).mp hx + obtain ⟨k, rfl⟩ := principalComponentScalarHom_surjective K a + exact ⟨k, rfl⟩ + +/-! ### The finite-degree part `P̂_{<ω}` and its ideal `(P̂_{<ω})₊` -/ + +variable (K) in +/-- The subalgebra of finite degree `P̂_{<ω} = ⨁_{n<ω} P_n` of `P̂`. -/ +abbrev principalFiniteDegreePart : Subalgebra K (PrincipalSubring K) := + finiteDegreePart (principalGrading K) + +/-- Membership in `P̂_{<ω}` means that every nonzero homogeneous component has finite degree. -/ +@[simp] +theorem mem_principalFiniteDegreePart_iff (x : PrincipalSubring K) : + x ∈ principalFiniteDegreePart K ↔ + ∀ α, x α ≠ 0 → α < NatOrdinal.of Ordinal.omega0 := by + rw [mem_finiteDegreePart_iff, mem_finiteDegreeSubmodule_iff] + refine forall_congr' fun α ↦ ?_ + rw [DirectSum.coe_decompose_rangeLof, NatOrdinal.lt_omega0, DirectSum.lof_eq_of] + exact imp_congr_left (not_congr ⟨fun h0 ↦ DirectSum.of_injective α (h0.trans (map_zero _).symm), + fun h0 ↦ by rw [h0, map_zero]⟩) + +/-- A homogeneous vector of finite degree belongs to `P̂_{<ω}`. -/ +theorem principalSubring_of_nat_mem (n : ℕ) + (x : PrincipalComponent K (n : NatOrdinal)) : + DirectSum.of (PrincipalComponent K) (n : NatOrdinal) x ∈ + principalFiniteDegreePart K := + mem_finiteDegreePart_of_mem _ (of_mem_principalGrading _ x) + +variable (K) in +/-- The homogeneous inclusion `P_n → P̂_{<ω}` for a finite degree `n`. -/ +def finiteDegreeOf (n : ℕ) : + PrincipalComponent K (n : NatOrdinal) →ₗ[K] + principalFiniteDegreePart K where + toFun x := ⟨DirectSum.of (PrincipalComponent K) (n : NatOrdinal) x, + principalSubring_of_nat_mem n x⟩ + map_add' x y := by + apply Subtype.ext + exact map_add (DirectSum.of (PrincipalComponent K) (n : NatOrdinal)) x y + map_smul' k x := by + apply Subtype.ext + exact DirectSum.of_smul K (M := PrincipalComponent K) (n : NatOrdinal) k x + +/-- Coercing the inclusion `P_n → P̂_{<ω}` to `P̂` gives `DirectSum.of`. -/ +@[simp] +theorem coe_finiteDegreeOf (n : ℕ) + (x : PrincipalComponent K (n : NatOrdinal)) : + (finiteDegreeOf K n x : PrincipalSubring K) = + DirectSum.of (PrincipalComponent K) (n : NatOrdinal) x := by + rw [finiteDegreeOf] + rfl + +variable (K) in +/-- The inclusion `P_n → P̂_{<ω}` is injective. -/ +theorem finiteDegreeOf_injective (n : ℕ) : + Function.Injective (finiteDegreeOf K n) := by + intro x y hxy + apply DirectSum.of_injective (n : NatOrdinal) + exact congrArg Subtype.val hxy + +/-- In degree zero, the homogeneous inclusion agrees with the algebra map from `K`. -/ +theorem finiteDegreeOf_zero_scalar (k : K) : + finiteDegreeOf K 0 (principalComponentScalarHom K k) = + algebraMap K (principalFiniteDegreePart K) k := by + apply Subtype.ext + exact principalSubring_algebraMap_apply k + +variable (K) in +/-- The ideal `(P̂_{<ω})₊ = ⨁_{1≤n<ω} P_n` of elements of positive degree of `P̂_{<ω}`. -/ +def positiveFinitePrincipalIdeal : + Ideal (principalFiniteDegreePart K) where + carrier := {x | (x : PrincipalSubring K) 0 = 0} + zero_mem' := by simp + add_mem' := by + intro x y hx hy + change (x : PrincipalSubring K) 0 = 0 at hx + change (y : PrincipalSubring K) 0 = 0 at hy + change ((x : PrincipalSubring K) + y) 0 = 0 + simp [hx, hy] + smul_mem' := by + classical + intro x y hy + change (y : PrincipalSubring K) 0 = 0 at hy + change ((x : PrincipalSubring K) * y) 0 = 0 + calc + ((x : PrincipalSubring K) * y) 0 = + (∑ ij ∈ DFinsupp.support (x : PrincipalSubring K) ×ˢ + DFinsupp.support (y : PrincipalSubring K), + DirectSum.of (PrincipalComponent K) (ij.1 + ij.2) + (GradedMonoid.GMul.mul + ((x : PrincipalSubring K) ij.1) + ((y : PrincipalSubring K) ij.2))) 0 := + congrArg (fun z : PrincipalSubring K ↦ z 0) + (DirectSum.mul_eq_sum_support_ghas_mul + (A := PrincipalComponent K) x y) + _ = ∑ ij ∈ DFinsupp.support (x : PrincipalSubring K) ×ˢ + DFinsupp.support (y : PrincipalSubring K), + (DirectSum.of (PrincipalComponent K) (ij.1 + ij.2) + (GradedMonoid.GMul.mul + ((x : PrincipalSubring K) ij.1) + ((y : PrincipalSubring K) ij.2))) 0 := by + exact DFinsupp.finsetSum_apply _ _ _ + _ = 0 := by + apply Finset.sum_eq_zero + rintro ⟨i, j⟩ hij + by_cases hgrade : i + j = 0 + · have hj : j = 0 := (NatOrdinal.add_eq_zero_iff.mp hgrade).2 + have hyj : (y : PrincipalSubring K) j = 0 := hj ▸ hy + have hmulzero : GradedMonoid.GMul.mul + ((x : PrincipalSubring K) i) + ((y : PrincipalSubring K) j) = 0 := by + rw [hyj] + exact DirectSum.GNonUnitalNonAssocSemiring.mul_zero _ + rw [hmulzero, map_zero] + rfl + · rw [DirectSum.of_apply] + simp [hgrade] + +/-- Membership in `(P̂_{<ω})₊` is vanishing of the degree-zero component. -/ +@[simp] +theorem mem_positiveFinitePrincipalIdeal_iff_component_zero (x : principalFiniteDegreePart K) : + x ∈ positiveFinitePrincipalIdeal K ↔ + (x : PrincipalSubring K) 0 = 0 := + Iff.rfl + +/-- Equivalently, every nonzero component of an element of `(P̂_{<ω})₊` has positive degree. -/ +theorem mem_positiveFinitePrincipalIdeal_iff (x : principalFiniteDegreePart K) : + x ∈ positiveFinitePrincipalIdeal K ↔ + ∀ α, (x : PrincipalSubring K) α ≠ 0 → 0 < α := by + constructor + · intro hx α hα + change (x : PrincipalSubring K) 0 = 0 at hx + exact bot_lt_iff_ne_bot.mpr fun hzero ↦ hα (hzero ▸ hx) + · intro hx + change (x : PrincipalSubring K) 0 = 0 + by_contra hzero + exact (lt_irrefl 0) (hx 0 hzero) + +/-! ### The ideal `I = I_{≥1}` and the quotient `P̂/I` -/ + +variable (K) in +/-- The ideal `I = I_{≥1} = (P̂_{<ω})₊ P̂` of `P̂` generated by the elements of positive finite +degree. -/ +abbrev principalFibreIdeal : Ideal (PrincipalSubring K) := + fibreIdeal (principalGrading K) + +/-- The ideal `I` is the least ideal of `P̂` containing `(P̂_{<ω})₊`. -/ +theorem principalFibreIdeal_le_iff (I : Ideal (PrincipalSubring K)) : + principalFibreIdeal K ≤ I ↔ + ∀ x : principalFiniteDegreePart K, + x ∈ positiveFinitePrincipalIdeal K → + (x : PrincipalSubring K) ∈ I := by + classical + constructor + · intro h x hx + refine h ?_ + have hx0 : (x : PrincipalSubring K) 0 = 0 := + (mem_positiveFinitePrincipalIdeal_iff_component_zero x).mp hx + have hfin := (mem_principalFiniteDegreePart_iff _).mp x.2 + rw [← DirectSum.sum_support_of (β := PrincipalComponent K) (x : PrincipalSubring K)] + refine Submodule.sum_mem _ fun α hα ↦ ?_ + have hne : (x : PrincipalSubring K) α ≠ 0 := DFinsupp.mem_support_iff.mp hα + obtain ⟨n, hn⟩ := NatOrdinal.lt_omega0.mp (hfin α hne) + have hn0 : 1 ≤ n := Nat.one_le_iff_ne_zero.mpr fun h0 ↦ + hne (by rw [hn, h0, Nat.cast_zero]; exact hx0) + subst hn + exact mem_idealGE_of_mem _ hn0 (of_mem_principalGrading _ _) + · intro h + change idealGE (principalGrading K) 1 ≤ I + rw [idealGE_eq_span, Ideal.span_le] + intro y hy + obtain ⟨e, he, hye⟩ := (mem_idealGEGenerators_iff _ 1 y).mp hy + obtain ⟨F, rfl⟩ := (DirectSum.mem_rangeLof_iff K _ _ y).mp hye + have hmem : finiteDegreeOf K e F ∈ positiveFinitePrincipalIdeal K := by + rw [mem_positiveFinitePrincipalIdeal_iff_component_zero, coe_finiteDegreeOf] + exact DirectSum.of_eq_of_ne (e : NatOrdinal) 0 F + (Ne.symm (Nat.cast_ne_zero.mpr (Nat.one_le_iff_ne_zero.mp he))) + have hI := h _ hmem + rwa [coe_finiteDegreeOf, ← DirectSum.lof_eq_of K] at hI + +/-- Every element of `(P̂_{<ω})₊` belongs to the ideal `I` of `P̂` it generates. -/ +theorem coe_mem_principalFibreIdeal {x : principalFiniteDegreePart K} + (hx : x ∈ positiveFinitePrincipalIdeal K) : + (x : PrincipalSubring K) ∈ principalFibreIdeal K := + (principalFibreIdeal_le_iff _).mp le_rfl x hx + +variable (K) in +/-- The quotient `P̂/I` by the ideal `I = I_{≥1}` (the Lean noun is +"fibre": `P̂/I ≅ P̂ ⊗_{P̂_{<ω}} K` is the fibre of `P̂` over `P̂_{<ω} → K`). It is a definitional +alias rather than a reducible abbreviation, so that instance search on `P̂/I` stops here instead +of unfolding the quotient of the direct sum of components at every use. -/ +@[expose] def PrincipalFibre : Type (max 1 v) := + Fibre (principalGrading K) + +instance principalFibreCommRing : CommRing (PrincipalFibre K) := + inferInstanceAs (CommRing (Fibre (principalGrading K))) + +instance principalFibreAlgebra : Algebra K (PrincipalFibre K) := + inferInstanceAs (Algebra K (Fibre (principalGrading K))) + +variable (K) in +/-- The quotient map `π : P̂ → P̂/I`. -/ +abbrev principalFibreMap : + PrincipalSubring K →ₐ[K] PrincipalFibre K := + fibreMap (principalGrading K) + +/-- The quotient map `π : P̂ → P̂/I` is the usual ideal-quotient constructor on elements. -/ +theorem principalFibreMap_apply (x : PrincipalSubring K) : + principalFibreMap K x = + Ideal.Quotient.mk (principalFibreIdeal K) x := + (rfl) + +variable (K) in +/-- The kernel of `π : P̂ → P̂/I` is exactly `I`. -/ +@[simp] +theorem principalFibreMap_ker : + RingHom.ker (principalFibreMap K : + PrincipalSubring K →+* PrincipalFibre K) = + principalFibreIdeal K := + Ideal.Quotient.mkₐ_ker K (principalFibreIdeal K) + +/-- A class in `P̂/I` vanishes exactly when its representative lies in `I`. -/ +@[simp] +theorem principalFibreMap_eq_zero_iff (x : PrincipalSubring K) : + principalFibreMap K x = 0 ↔ x ∈ principalFibreIdeal K := + Ideal.Quotient.eq_zero_iff_mem + +variable (K) in +/-- The quotient map `π : P̂ → P̂/I` is surjective. -/ +theorem principalFibreMap_surjective : + Function.Surjective (principalFibreMap K) := + Ideal.Quotient.mkₐ_surjective K (principalFibreIdeal K) + +/-! ### Multiplication of components of finite degree and the decomposables -/ + +variable (K) in +/-- Multiplication `P_m × P_n → P_{m+n}` of two components of finite degree, with output degree the +natural number `m + n`. -/ +def principalComponentMulNat (m n : ℕ) : + PrincipalComponent K (m : NatOrdinal) → PrincipalComponent K (n : NatOrdinal) → + PrincipalComponent K ((m + n : ℕ) : NatOrdinal) := + fun x y ↦ + LinearEquiv.cast (R := K) (Nat.cast_add m n).symm (principalComponentMul x y) + +/-- Multiplication `P_m × P_n → P_{m+n}` is fixed-component multiplication transported across the +equality between the cast of `m + n` and the sum of the casts of `m` and `n`. -/ +theorem principalComponentMulNat_apply (m n : ℕ) + (x : PrincipalComponent K (m : NatOrdinal)) + (y : PrincipalComponent K (n : NatOrdinal)) : + principalComponentMulNat K m n x y = + LinearEquiv.cast (R := K) (Nat.cast_add m n).symm + (principalComponentMul x y) := + (rfl) + +/-- Multiplication in `P̂_{<ω}` agrees with multiplication +`P_m × P_n → P_{m+n}` of components. -/ +theorem finiteDegreeOf_mul (m n : ℕ) + (x : PrincipalComponent K (m : NatOrdinal)) + (y : PrincipalComponent K (n : NatOrdinal)) : + finiteDegreeOf K m x * finiteDegreeOf K n y = + finiteDegreeOf K (m + n) + (principalComponentMulNat K m n x y) := by + apply Subtype.ext + change ((finiteDegreeOf K m x : + principalFiniteDegreePart K) : PrincipalSubring K) * + ((finiteDegreeOf K n y : + principalFiniteDegreePart K) : PrincipalSubring K) = + ((finiteDegreeOf K (m + n) + (principalComponentMulNat K m n x y) : + principalFiniteDegreePart K) : PrincipalSubring K) + rw [coe_finiteDegreeOf, coe_finiteDegreeOf, + coe_finiteDegreeOf, DirectSum.of_mul_of] + apply DirectSum.of_eq_of_gradedMonoid_eq + have hmulEq : GradedMonoid.GMul.mul x y = principalComponentMul x y := + (principalComponentMul_eq_componentMul x y).symm + rw [hmulEq] + change (⟨(m : NatOrdinal) + (n : NatOrdinal), principalComponentMul x y⟩ : + GradedMonoid (PrincipalComponent K)) = + ⟨((m + n : ℕ) : NatOrdinal), principalComponentMulNat K m n x y⟩ + exact Sigma.ext (Nat.cast_add m n).symm (heq_of_cast_eq _ rfl) + +variable [CharZero K] in +/-- Multiplication of nonzero vectors of finite degree is nonzero: the ordinal value is +multiplicative (Berarducci, Theorem 9.7). -/ +theorem principalComponentMulNat_ne_zero {m n : ℕ} {x : PrincipalComponent K (m : NatOrdinal)} + {y : PrincipalComponent K (n : NatOrdinal)} + (hx : x ≠ 0) (hy : y ≠ 0) : + principalComponentMulNat K m n x y ≠ 0 := by + rw [principalComponentMulNat] + rw [← map_zero (LinearEquiv.cast (R := K) (M := PrincipalComponent K) + (Nat.cast_add m n).symm)] + apply (LinearEquiv.cast (R := K) (M := PrincipalComponent K) + (Nat.cast_add m n).symm).injective.ne + rw [principalComponentMul_eq_componentMul] + exact MaxAddDegree.componentMul_ne_zero + (ordinalValueDegreeValuation K) x y hx hy + +variable (K) in +/-- The subspace `(P̂_{<ω})₊² ∩ P_n = ∑_{i,j ≥ 1, i+j=n} P_i P_j` of decomposables of `P_n`: the +decomposable part of the internal grading in degree `n`, read inside the component through the +homogeneous inclusion. -/ +abbrev decomposablePrincipalComponent (n : ℕ) : + Submodule K (PrincipalComponent K (n : NatOrdinal)) := + (decomposable (principalGrading K) n).comap + (DirectSum.lof K NatOrdinal (PrincipalComponent K) (n : NatOrdinal)) + +/-- A homogeneous vector is decomposable exactly when its inclusion is a decomposable +element of `P̂`. -/ +theorem mem_decomposablePrincipalComponent_iff + (n : ℕ) (x : PrincipalComponent K (n : NatOrdinal)) : + x ∈ decomposablePrincipalComponent K n ↔ + DirectSum.of (PrincipalComponent K) (n : NatOrdinal) x ∈ + decomposable (principalGrading K) n := by + rw [Submodule.mem_comap, DirectSum.lof_eq_of] + +/-- A product of two homogeneous components of positive finite degree belongs to the decomposables +`(P̂_{<ω})₊² ∩ P_{i+j}`. -/ +theorem principalComponentMulNat_mem_decomposable {i j : ℕ} (hi : 0 < i) (hj : 0 < j) + (x : PrincipalComponent K (i : NatOrdinal)) + (y : PrincipalComponent K (j : NatOrdinal)) : + principalComponentMulNat K i j x y ∈ + decomposablePrincipalComponent K (i + j) := by + rw [mem_decomposablePrincipalComponent_iff] + have h := congrArg Subtype.val (finiteDegreeOf_mul i j x y) + rw [Subalgebra.coe_mul, coe_finiteDegreeOf, coe_finiteDegreeOf, coe_finiteDegreeOf] at h + rw [← h] + exact mul_mem_decomposable _ hi hj (of_mem_principalGrading _ _) (of_mem_principalGrading _ _) + +variable (K) in +/-- There are no decomposables in degrees zero and one. -/ +theorem decomposablePrincipalComponent_eq_bot_of_le_one {n : ℕ} (hn : n ≤ 1) : + decomposablePrincipalComponent K n = ⊥ := by + rw [eq_bot_iff] + intro z hz + rw [mem_decomposablePrincipalComponent_iff] at hz + have hle : decomposable (principalGrading K) n ≤ ⊥ := + decomposable_le _ fun i j hi hj hij ↦ (by omega : False).elim + rw [Submodule.mem_bot] + exact DirectSum.of_injective (n : NatOrdinal) + (((Submodule.mem_bot K).mp (hle hz)).trans (map_zero _).symm) + +variable (K) in +/-- There are no decomposables in degree zero. -/ +@[simp] +theorem decomposablePrincipalComponent_zero : + decomposablePrincipalComponent K 0 = ⊥ := + decomposablePrincipalComponent_eq_bot_of_le_one K (Nat.zero_le 1) + +variable (K) in +/-- There are no decomposables in degree one: `(P̂_{<ω})₊² ∩ P_1 = 0`. -/ +@[simp] +theorem decomposablePrincipalComponent_one : + decomposablePrincipalComponent K 1 = ⊥ := + decomposablePrincipalComponent_eq_bot_of_le_one K le_rfl + +variable (K) in +/-- The quotient `P_n / ((P̂_{<ω})₊² ∩ P_n)` of a finite-degree component by its +decomposables. -/ +abbrev PrincipalIndecomposableQuotient (n : ℕ) := + PrincipalComponent K (n : NatOrdinal) ⧸ decomposablePrincipalComponent K n + +variable (K) in +/-- The quotient map `P_n → P_n / ((P̂_{<ω})₊² ∩ P_n)`. -/ +def principalIndecomposableMk (n : ℕ) : + PrincipalComponent K (n : NatOrdinal) →ₗ[K] + PrincipalIndecomposableQuotient K n := + (decomposablePrincipalComponent K n).mkQ + +variable (K) in +/-- The kernel of `P_n → P_n / ((P̂_{<ω})₊² ∩ P_n)` is exactly the decomposables. -/ +@[simp] +theorem principalIndecomposableMk_ker (n : ℕ) : + LinearMap.ker (principalIndecomposableMk K n) = + decomposablePrincipalComponent K n := + by + rw [principalIndecomposableMk, Submodule.ker_mkQ] + +variable (K) in +/-- The quotient map `P_n → P_n / ((P̂_{<ω})₊² ∩ P_n)` is surjective. -/ +theorem principalIndecomposableMk_surjective (n : ℕ) : + Function.Surjective (principalIndecomposableMk K n) := + by + rw [principalIndecomposableMk] + exact Submodule.mkQ_surjective _ + +/-- A class in `P_n / ((P̂_{<ω})₊² ∩ P_n)` vanishes exactly when its representative is +decomposable. -/ +@[simp] +theorem principalIndecomposableMk_eq_zero_iff (n : ℕ) + (x : PrincipalComponent K (n : NatOrdinal)) : + principalIndecomposableMk K n x = 0 ↔ + x ∈ decomposablePrincipalComponent K n := by + rw [← LinearMap.mem_ker, principalIndecomposableMk_ker] + +variable (K) in +/-- A chosen complement `E_n` of the decomposables `(P̂_{<ω})₊² ∩ P_n` in `P_n`. -/ +noncomputable def principalIndecomposableComplement (n : ℕ) : + Submodule K (PrincipalComponent K (n : NatOrdinal)) := + Classical.choose (decomposablePrincipalComponent K n).exists_isCompl + +variable (K) in +/-- The chosen subspace `E_n` is complementary to the decomposables `(P̂_{<ω})₊² ∩ P_n`. -/ +theorem decomposablePrincipalComponent_isCompl_complement (n : ℕ) : + IsCompl (decomposablePrincipalComponent K n) + (principalIndecomposableComplement K n) := + Classical.choose_spec (decomposablePrincipalComponent K n).exists_isCompl + +variable (K) in +/-- The chosen index type for a basis of `E_n`: it indexes `𝓑_n = 𝓑 ∩ P_n`, the elements of degree +`n` of the minimal system. -/ +abbrev PrincipalCoordinateIndex (n : ℕ) := + Module.Free.ChooseBasisIndex K (principalIndecomposableComplement K n) + +variable (K) in +/-- A chosen basis `𝓑_n` of the complement `E_n`. -/ +noncomputable def principalCoordinateBasis (n : ℕ) : + Module.Basis (PrincipalCoordinateIndex K n) K + (principalIndecomposableComplement K n) := + Module.Free.chooseBasis K (principalIndecomposableComplement K n) + +variable (K) in +/-- The chosen complement `E_n` identified with the quotient `P_n / ((P̂_{<ω})₊² ∩ P_n)`. -/ +noncomputable def principalIndecomposableComplementEquiv (n : ℕ) : + principalIndecomposableComplement K n ≃ₗ[K] + PrincipalIndecomposableQuotient K n := + ((decomposablePrincipalComponent K n).quotientEquivOfIsCompl + (principalIndecomposableComplement K n) + (decomposablePrincipalComponent_isCompl_complement K n)).symm + +/-- The complement equivalence sends a vector to its class modulo the decomposables. -/ +@[simp] +theorem principalIndecomposableComplementEquiv_apply (n : ℕ) + (x : principalIndecomposableComplement K n) : + principalIndecomposableComplementEquiv K n x = + (decomposablePrincipalComponent K n).mkQ x := by + rw [principalIndecomposableComplementEquiv] + exact DFunLike.congr_fun + (Submodule.toLinearMap_symm_quotientEquivOfIsCompl + (decomposablePrincipalComponent_isCompl_complement K n)) x + +variable (K) in +/-- The basis of `P_n / ((P̂_{<ω})₊² ∩ P_n)` induced from the chosen basis `𝓑_n` of `E_n`. -/ +noncomputable def principalIndecomposableBasis (n : ℕ) : + Module.Basis (PrincipalCoordinateIndex K n) K + (PrincipalIndecomposableQuotient K n) := + (principalCoordinateBasis K n).map + (principalIndecomposableComplementEquiv K n) + +/-- The functional on `P_n / ((P̂_{<ω})₊² ∩ P_n)` dual to one basis vector `B ∈ 𝓑_n`. -/ +noncomputable def principalCoordinateFunctional (n : ℕ) + (i : PrincipalCoordinateIndex K n) : + Module.Dual K (PrincipalIndecomposableQuotient K n) := + (principalIndecomposableBasis K n).coord i + +/-- The dual functionals form the Kronecker dual family of the basis `𝓑_n`. -/ +@[simp] +theorem principalCoordinateFunctional_basis (n : ℕ) + (i j : PrincipalCoordinateIndex K n) : + principalCoordinateFunctional n i + (principalIndecomposableBasis K n j) = if i = j then 1 else 0 := by + classical + rw [principalCoordinateFunctional, Module.Basis.coord_apply] + simp [Finsupp.single_apply, eq_comm] + +variable (K) in +/-- The minimal system `𝓑` of homogeneous generators of `P̂_{<ω}`, as an index type: an element +`B ∈ 𝓑` is a positive finite degree `n` together with an index into the chosen basis `𝓑_n` of +`E_n`. -/ +abbrev MinimalSystem := + Σ n : {n : ℕ // 0 < n}, PrincipalCoordinateIndex K n + +/-- The degree `deg B` of an element `B ∈ 𝓑`, a positive natural number. -/ +abbrev minimalSystemDegree (x : MinimalSystem K) : ℕ := + x.1 + +/-- Every `B ∈ 𝓑` has positive degree. -/ +theorem minimalSystemDegree_pos (x : MinimalSystem K) : + 0 < minimalSystemDegree x := + x.1.property + +/-- An element `B ∈ 𝓑` as a vector of its component `P_{deg B}`. -/ +noncomputable def minimalSystemComponent (x : MinimalSystem K) : + PrincipalComponent K (minimalSystemDegree x : NatOrdinal) := + (principalCoordinateBasis K x.1 x.2).1 + +theorem minimalSystemComponent_eq (x : MinimalSystem K) : + minimalSystemComponent x = (principalCoordinateBasis K x.1 x.2).1 := + (rfl) + +/-- The class of `B ∈ 𝓑` modulo the decomposables is the corresponding basis vector of +`P_n / ((P̂_{<ω})₊² ∩ P_n)`. -/ +@[simp] +theorem minimalSystemComponent_mkQ (x : MinimalSystem K) : + Submodule.Quotient.mk (minimalSystemComponent x) = + principalIndecomposableBasis K x.1 x.2 := by + rw [minimalSystemComponent, + principalIndecomposableBasis, Module.Basis.map_apply, + principalIndecomposableComplementEquiv_apply] + rfl + +/-- The named quotient map sends `B ∈ 𝓑` to the corresponding basis vector of the quotient of +its component by the decomposables. -/ +@[simp] +theorem principalIndecomposableMk_minimalSystemComponent + (x : MinimalSystem K) : + principalIndecomposableMk K + (minimalSystemDegree x) + (minimalSystemComponent x) = + principalIndecomposableBasis K x.1 x.2 := by + rw [principalIndecomposableMk] + exact minimalSystemComponent_mkQ x + +/-- The functional on `P_{deg B} / ((P̂_{<ω})₊² ∩ P_{deg B})` dual to `B ∈ 𝓑`. -/ +noncomputable def minimalSystemFunctional (x : MinimalSystem K) : + Module.Dual K (PrincipalIndecomposableQuotient K x.1) := + principalCoordinateFunctional x.1 x.2 + +/-- `B ∈ 𝓑` evaluates to one under its dual functional. -/ +@[simp] +theorem minimalSystemFunctional_self (x : MinimalSystem K) : + minimalSystemFunctional x + (principalIndecomposableBasis K x.1 x.2) = 1 := by + rw [minimalSystemFunctional, + principalCoordinateFunctional_basis] + simp + +/-- The dual functional of `B ∈ 𝓑_n` evaluates the basis `𝓑_n` by the Kronecker formula. -/ +@[simp] +theorem minimalSystemFunctional_basis + (n : {n : ℕ // 0 < n}) (i j : PrincipalCoordinateIndex K n) : + minimalSystemFunctional ⟨n, i⟩ + (principalIndecomposableBasis K n j) = + if i = j then 1 else 0 := by + rw [minimalSystemFunctional, + principalCoordinateFunctional_basis] + +variable (K) in +/-- In degree one the chosen complement is the whole component `P_1`: `(P̂_{<ω})₊² ∩ P_1 = 0`, there +being no two positive degrees with sum one. -/ +theorem principalIndecomposableComplement_one_eq_top : + principalIndecomposableComplement K 1 = ⊤ := by + have h := decomposablePrincipalComponent_isCompl_complement K 1 + rw [decomposablePrincipalComponent_one] at h + have hsup := h.sup_eq_top + rwa [bot_sup_eq] at hsup + +variable (K) in +/-- `𝓑_1 = 𝓑 ∩ P_1` is a `K`-basis of the whole component `P_1`. Its coordinate representation +expands every element of `P_1` in the elements of `𝓑` of degree one. -/ +noncomputable def principalCoordinateBasisOne : + Module.Basis (PrincipalCoordinateIndex K 1) K + (PrincipalComponent K ((1 : ℕ) : NatOrdinal)) := + (principalCoordinateBasis K 1).map + ((LinearEquiv.ofEq _ _ (principalIndecomposableComplement_one_eq_top K)).trans + (Submodule.topEquiv)) + +/-- The basis vectors of `P_1` are the elements of `𝓑` of degree one. -/ +@[simp] +theorem principalCoordinateBasisOne_apply (i : PrincipalCoordinateIndex K 1) : + principalCoordinateBasisOne K i = + minimalSystemComponent ⟨⟨1, Nat.one_pos⟩, i⟩ := by + rw [principalCoordinateBasisOne, Module.Basis.map_apply, LinearEquiv.trans_apply] + rfl + +/-- Every `B ∈ 𝓑` is a nonzero vector of its component. -/ +theorem minimalSystemComponent_ne_zero (x : MinimalSystem K) : + minimalSystemComponent x ≠ 0 := by + rw [minimalSystemComponent] + intro hzero + apply (principalCoordinateBasis K x.1).ne_zero x.2 + exact Subtype.ext hzero + +/-- An element `B ∈ 𝓑` regarded as an element of `P̂_{<ω}`. -/ +noncomputable def minimalSystemElement (x : MinimalSystem K) : + principalFiniteDegreePart K := + finiteDegreeOf K + (minimalSystemDegree x) + (minimalSystemComponent x) + +/-- `B ∈ 𝓑` is homogeneous of degree `deg B`. -/ +theorem minimalSystemElement_eq (x : MinimalSystem K) : + minimalSystemElement x = + finiteDegreeOf K (minimalSystemDegree x) (minimalSystemComponent x) := + (rfl) + +/-- The element of `P̂` underlying `B ∈ 𝓑` is its homogeneous inclusion. -/ +@[simp] +theorem coe_minimalSystemElement (x : MinimalSystem K) : + ((minimalSystemElement x : + principalFiniteDegreePart K) : PrincipalSubring K) = + DirectSum.of (PrincipalComponent K) + (minimalSystemDegree x : NatOrdinal) + (minimalSystemComponent x) := by + rw [minimalSystemElement, coe_finiteDegreeOf] + +/-- Every `B ∈ 𝓑` belongs to `(P̂_{<ω})₊`. -/ +theorem minimalSystemElement_mem_positive (x : MinimalSystem K) : + minimalSystemElement x ∈ + positiveFinitePrincipalIdeal K := by + change (DirectSum.of (PrincipalComponent K) + (minimalSystemDegree x : NatOrdinal) + (minimalSystemComponent x)) 0 = 0 + rw [DirectSum.of_apply] + split_ifs with hzero + · exact ((Nat.cast_ne_zero.mpr + (Nat.ne_of_gt (minimalSystemDegree_pos x))) hzero).elim + · rfl + +/-- Every `B ∈ 𝓑` is nonzero in `P̂_{<ω}`. -/ +theorem minimalSystemElement_ne_zero (x : MinimalSystem K) : + minimalSystemElement x ≠ 0 := by + intro hzero + apply minimalSystemComponent_ne_zero x + apply finiteDegreeOf_injective K + (minimalSystemDegree x) + rw [map_zero] + exact hzero + +variable (K) in +/-- The evaluation `K[X_B : B ∈ 𝓑] → P̂_{<ω}`, `X_B ↦ B`. -/ +noncomputable def finiteDegreePolynomialEval : + MvPolynomial (MinimalSystem K) K →ₐ[K] + principalFiniteDegreePart K := + MvPolynomial.aeval minimalSystemElement + +/-- The evaluation `K[X_B : B ∈ 𝓑] → P̂_{<ω}` sends each indeterminate `X_B` to `B`. -/ +@[simp] +theorem finiteDegreePolynomialEval_X (x : MinimalSystem K) : + finiteDegreePolynomialEval K (MvPolynomial.X x) = + minimalSystemElement x := by + rw [finiteDegreePolynomialEval, MvPolynomial.aeval_X] + +private theorem finiteDegreeOf_mem_polynomialRange + (n : ℕ) (x : PrincipalComponent K (n : NatOrdinal)) : + finiteDegreeOf K n x ∈ + (finiteDegreePolynomialEval K).range := by + induction n using Nat.strong_induction_on with + | h n ih => + let A := (finiteDegreePolynomialEval K).range + rcases n.eq_zero_or_pos with rfl | hn + · obtain ⟨k, hk⟩ := principalComponentScalarHom_surjective K x + have hk' : principalComponentScalarHom K k = x := by + simpa only [Nat.cast_zero] using hk + refine ⟨MvPolynomial.C k, ?_⟩ + change finiteDegreePolynomialEval K (MvPolynomial.C k) = _ + rw [finiteDegreePolynomialEval, MvPolynomial.aeval_C, + ← hk', finiteDegreeOf_zero_scalar] + · let D := decomposablePrincipalComponent K n + let E := principalIndecomposableComplement K n + have hCompl : IsCompl D E := + decomposablePrincipalComponent_isCompl_complement K n + obtain ⟨d, e, hde, _⟩ := + Submodule.existsUnique_add_of_isCompl hCompl x + rw [← hde, map_add] + apply A.add_mem + · change finiteDegreeOf K n (d : + PrincipalComponent K (n : NatOrdinal)) ∈ A + -- the image of `A` in `P̂` contains every product `P_i P_j` with `i + j = n` + let N : Submodule K (PrincipalSubring K) := + (Subalgebra.toSubmodule A).map (principalFiniteDegreePart K).val.toLinearMap + have hN : decomposable (principalGrading K) n ≤ N := by + refine decomposable_le _ fun i j hi hj hij ↦ Submodule.mul_le.mpr fun a ha b hb ↦ ?_ + obtain ⟨a', rfl⟩ := (DirectSum.mem_rangeLof_iff K _ _ a).mp ha + obtain ⟨b', rfl⟩ := (DirectSum.mem_rangeLof_iff K _ _ b).mp hb + subst hij + refine ⟨finiteDegreeOf K i a' * finiteDegreeOf K j b', + A.mul_mem (ih i (by omega) a') (ih j (by omega) b'), ?_⟩ + rw [AlgHom.toLinearMap_apply, Subalgebra.coe_val, Subalgebra.coe_mul, + coe_finiteDegreeOf, coe_finiteDegreeOf, DirectSum.lof_eq_of, DirectSum.lof_eq_of] + obtain ⟨s, hs, hsd⟩ := hN (Submodule.mem_comap.mp d.2) + rw [AlgHom.toLinearMap_apply, Subalgebra.coe_val] at hsd + have hds : finiteDegreeOf K n (d : PrincipalComponent K (n : NatOrdinal)) = s := by + apply Subtype.ext + rw [coe_finiteDegreeOf, ← DirectSum.lof_eq_of K, ← hsd] + rw [hds] + exact hs + · change finiteDegreeOf K n (e : + PrincipalComponent K (n : NatOrdinal)) ∈ A + let B := principalCoordinateBasis K n + have he : e ∈ Submodule.span K (Set.range B) := by + rw [B.span_eq] + exact Submodule.mem_top + refine Submodule.span_induction (R := K) (M := E) + (s := Set.range B) (p := fun y _ ↦ + finiteDegreeOf K n (y : + PrincipalComponent K (n : NatOrdinal)) ∈ A) ?_ ?_ ?_ ?_ he + · intro z hz + obtain ⟨i, rfl⟩ := hz + let q : MinimalSystem K := ⟨⟨n, hn⟩, i⟩ + refine ⟨MvPolynomial.X q, ?_⟩ + change finiteDegreePolynomialEval K (MvPolynomial.X q) = _ + rw [finiteDegreePolynomialEval_X] + rfl + · change finiteDegreeOf K n (0 : + PrincipalComponent K (n : NatOrdinal)) ∈ A + rw [map_zero] + exact A.zero_mem + · intro y z _ _ hy hz + simpa using A.add_mem hy hz + · intro k y _ hy + simpa using A.smul_mem hy k + +variable (K) in +/-- The minimal system `𝓑` generates `P̂_{<ω}`: the evaluation `K[X_B : B ∈ 𝓑] → P̂_{<ω}` is +surjective. -/ +theorem finiteDegreePolynomialEval_surjective : + Function.Surjective (finiteDegreePolynomialEval K) := by + intro x + let A := (finiteDegreePolynomialEval K).range + let p : PrincipalSubring K → Prop := fun y ↦ + ∀ hy : ∀ α, y α ≠ 0 → α < NatOrdinal.of Ordinal.omega0, + (⟨y, (mem_principalFiniteDegreePart_iff y).mpr hy⟩ : principalFiniteDegreePart K) ∈ A + have hx : ∀ α, (x : PrincipalSubring K) α ≠ 0 → α < NatOrdinal.of Ordinal.omega0 := + (mem_principalFiniteDegreePart_iff _).mp x.2 + change (⟨(x : PrincipalSubring K), (mem_principalFiniteDegreePart_iff _).mpr hx⟩ : + principalFiniteDegreePart K) ∈ A + refine DFinsupp.induction (p := p) (x : PrincipalSubring K) ?_ ?_ hx + · intro hy + change (0 : principalFiniteDegreePart K) ∈ A + exact A.zero_mem + · intro α b y hyα hb hy hfinite + have hαFinite : α < NatOrdinal.of Ordinal.omega0 := by + apply hfinite α + change (DFinsupp.single α b + y) α ≠ 0 + simp [hyα, hb] + obtain ⟨n, hn⟩ := NatOrdinal.lt_omega0.mp hαFinite + subst α + have hyFinite : ∀ β, y β ≠ 0 → + β < NatOrdinal.of Ordinal.omega0 := by + intro β hyβ + apply hfinite β + by_cases hβ : (n : NatOrdinal) = β + · subst β + simpa [hyα] using hb + · change (DFinsupp.single (n : NatOrdinal) b + y) β ≠ 0 + simpa [DFinsupp.single_apply, hβ] using hyβ + have hsingle := finiteDegreeOf_mem_polynomialRange n b + have hyRange := hy hyFinite + have hsum : + (⟨DFinsupp.single (n : NatOrdinal) b + y, + (mem_principalFiniteDegreePart_iff _).mpr hfinite⟩ : principalFiniteDegreePart K) = + finiteDegreeOf K n b + + (⟨y, (mem_principalFiniteDegreePart_iff y).mpr hyFinite⟩ : + principalFiniteDegreePart K) := by + apply Subtype.ext + change DFinsupp.single (n : NatOrdinal) b + y = + ((finiteDegreeOf K n b : + principalFiniteDegreePart K) : PrincipalSubring K) + + (show PrincipalSubring K from y) + rw [coe_finiteDegreeOf] + ext β + simp only [DFinsupp.add_apply, DirectSum.add_apply] + rw [DirectSum.of_apply, DFinsupp.single_apply] + rw [hsum] + exact A.add_mem hsingle hyRange + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/PrincipalIdealGE.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/PrincipalIdealGE.lean new file mode 100644 index 0000000000..2bee51f153 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/PrincipalIdealGE.lean @@ -0,0 +1,69 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.PrincipalGraded + +/-! +# The ideals `I_{≥j}` + +For `j : ℕ`, the ideal `I_{≥j}` of `P̂` is generated by the homogeneous elements of +finite degree at least `j`, that is, by the components `P_e` with `j ≤ e < ω`: + +`I_{≥j} = ∑_{j ≤ e < ω} P_e P̂`. + +These are the ideals `I_{≥j}` of the internal grading of `P̂`. They form a decreasing +multiplicative filtration `I_{≥•}` with `I_{≥0} = P̂` and `I_{≥1} = I`, and a homogeneous element +of `I_{≥j}` vanishes as soon as `j` exceeds the finite part of its degree (the constant term of +its Cantor normal form). +-/ + +open scoped DirectSum NatOrdinal + +universe v + +public noncomputable section + +namespace Berarducci + +open Berarducci LoweringDerivation + +variable {K : Type v} [Field K] + +variable (K) in +/-- The ideal `I_{≥j} = ∑_{j ≤ e < ω} P_e P̂` generated by the homogeneous elements of finite degree +at least `j`. -/ +abbrev principalIdealGE (j : ℕ) : Ideal (PrincipalSubring K) := + idealGE (principalGrading K) j + +/-- A homogeneous element of finite degree at least `j` belongs to `I_{≥j}`. -/ +theorem principalIdealGEGenerator_mem {j e : ℕ} (hje : j ≤ e) + (F : PrincipalComponent K (e : NatOrdinal)) : + DirectSum.of (PrincipalComponent K) (e : NatOrdinal) F ∈ principalIdealGE K j := + mem_idealGE_of_mem _ hje (of_mem_principalGrading _ F) + +variable (K) in +/-- `I_{≥1} = I = (P̂_{<ω})₊ P̂`. -/ +theorem principalIdealGE_one : principalIdealGE K 1 = principalFibreIdeal K := + (rfl) + +/-- A homogeneous element of `I_{≥j}` whose degree has finite part below `j` is zero. -/ +theorem eq_zero_of_homogeneous_mem_principalIdealGE {j : ℕ} {δ : NatOrdinal} + (hδ : δ.constantCoeff < j) (x : PrincipalComponent K δ) + (hx : DirectSum.of (PrincipalComponent K) δ x ∈ principalIdealGE K j) : x = 0 := + DirectSum.of_injective δ ((eq_zero_of_mem_idealGE_of_constantCoeff_lt _ + (of_mem_principalGrading δ x) hx hδ).trans (map_zero _).symm) + +/-- Every component of an element of `I_{≥j}` in a degree whose finite part is below `j` is +zero. -/ +theorem principalIdealGE_component_eq_zero {j : ℕ} (x : PrincipalSubring K) + (hx : x ∈ principalIdealGE K j) {δ : NatOrdinal} (hδ : δ.constantCoeff < j) : + x δ = 0 := by + refine eq_zero_of_homogeneous_mem_principalIdealGE hδ (x δ) ?_ + have := idealGE_isHomogeneous (principalGrading K) j δ hx + rwa [DirectSum.coe_decompose_rangeLof, DirectSum.lof_eq_of] at this + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/PrincipalRepresentatives.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/PrincipalRepresentatives.lean new file mode 100644 index 0000000000..c4329bf236 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/PrincipalRepresentatives.lean @@ -0,0 +1,260 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.OrdinalValueCutoffs +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.TruncationExpansion + +/-! +# Translated truncations of polynomials in principal representatives + +Let the lifts `b_B` of the generators be principal series of degree `deg B` (Lean: `σ.lift i` +principal of degree `wt i`, `Lifts.IsPrincipal`). Every translated truncation of a monomial +`X^d(b_𝓑)` at a cutoff `ζ < 0` has ordinal value below `ω^(deg d)`: by the convolution formula +[Ber00, Lem. 7.5], `(X^{d'}(b_𝓑) b_B)^{|ζ}` is congruent modulo `J` to a finite sum of products of +translated truncations, and in every product at least one factor is a translated truncation at a +cutoff `< 0`, whose ordinal value is below `ω^(degree of the factor)` — for `b_B` because it is +principal, for `X^{d'}(b_𝓑)` by induction. Hence, with principal-series representatives, +`v_J(Q(b_𝓑)^{|ζ}) < ω^(deg Q)` for every `ζ < 0` and `Q` homogeneous. +-/ + +universe v w + +open scoped NatOrdinal HahnSeries +open Berarducci HahnSeries MvPolynomial OrdinalGraded + +public noncomputable section + +namespace Berarducci + +variable {K : Type v} [Field K] {ι : Type w} {wt : ι → NatOrdinal} {x : ι → PrincipalSubring K} + +/-- Below `ω^g` one is below some `ω^(b+1)` with `b + 1 ≤ g`. -/ +theorem exists_lt_wpow_add_one_of_lt_wpow {y g : NatOrdinal} (hg : g ≠ 0) (h : y < ω^ g) : + ∃ b, b + 1 ≤ g ∧ y < ω^ (b + 1) := by + obtain ⟨z, hz, n, hn⟩ := (NatOrdinal.lt_wpow_iff hg).mp h + exact ⟨z, Order.add_one_le_of_lt hz, hn.trans (NatOrdinal.wpow_mul_natCast_lt (lt_add_one z) n)⟩ + +namespace Lifts + +/-- The lifts are principal series of the degrees of the generators. -/ +def IsPrincipal (σ : Lifts wt x) : Prop := + ∀ i, HahnSeries.Nonpositive.IsPrincipal (σ.lift i) ∧ + (σ.lift i : K⟦ℝ⟧).degree = (wt i : WithBot NatOrdinal) + +/-- A lift family is principal exactly when each lift is principal of its assigned degree. -/ +theorem isPrincipal_iff (σ : Lifts wt x) : + IsPrincipal σ ↔ ∀ i, HahnSeries.Nonpositive.IsPrincipal (σ.lift i) ∧ + (σ.lift i : K⟦ℝ⟧).degree = (wt i : WithBot NatOrdinal) := + Iff.rfl + +/-- Principal-series representatives exist for a minimal system of homogeneous generators. -/ +theorem exists_isPrincipal + (hx : IsMinimalSystem (Berarducci.principalGrading K) wt x) : + ∃ σ : Lifts wt x, σ.IsPrincipal := by + classical + have hne : ∀ i, x i ≠ 0 := fun i h0 ↦ by + have := hx.independent (wt i) (Finsupp.single i 1) (fun j hj ↦ by + rw [Finsupp.mem_support_single] at hj + rw [hj.1]) (by rw [Finsupp.linearCombination_single, h0, smul_zero]; exact zero_mem _) + exact one_ne_zero (Finsupp.single_eq_zero.mp this) + have h : ∀ i, ∃ p : Series K, Represents p (wt i) (x i) ∧ + HahnSeries.Nonpositive.IsPrincipal p ∧ (p : K⟦ℝ⟧).degree = (wt i : WithBot NatOrdinal) := by + intro i + obtain ⟨a, ha⟩ := (DirectSum.mem_rangeLof_iff K _ _ _).mp (hx.mem i) + rw [DirectSum.lof_eq_of] at ha + have ha0 : a ≠ 0 := fun h ↦ hne i (by rw [← ha, h, map_zero]) + obtain ⟨p, hp, hprin, hdeg, hpa⟩ := exists_principal_representative_of_ne_zero (wt i) a ha0 + exact ⟨p, represents_iff.mpr ⟨hp, by rw [hpa, ha]⟩, hprin, hdeg⟩ + choose p hp hprin hdeg using h + exact ⟨⟨p, hp⟩, fun i ↦ ⟨hprin i, hdeg i⟩⟩ + +variable {σ : Lifts wt x} (hσ : σ.IsPrincipal) +include hσ + +/-- A translated truncation of a principal-series representative at a cutoff `ζ < 0` has ordinal +value below `ω^(wt i)`. -/ +theorem IsPrincipal.ordinalValue_translatedTruncation_lift_lt (i : ι) {ζ : ℝ} (hζ : ζ < 0) : + ordinalValue (translatedTruncation (σ.lift i : K⟦ℝ⟧) ζ) < ω^ (wt i) := + ordinalValue_translatedTruncation_lt_of_isPrincipal (hσ i).1 (hσ i).2 hζ + +omit hσ in +/-- The product of a series of ordinal value below `ω^(a+1)` and one of ordinal value below `ω^g`, +`g ≠ 0`, has ordinal value below `ω^(a ⊕ g)`. -/ +theorem ordinalValue_mul_lt_wpow_add {u v : Series K} {a g : NatOrdinal} (hg : g ≠ 0) + (hu : ordinalValue u < ω^ (a + 1)) (hv : ordinalValue v < ω^ g) : + ordinalValue (u * v) < ω^ (a + g) := by + obtain ⟨b, hb, hvb⟩ := exists_lt_wpow_add_one_of_lt_wpow hg hv + refine (ordinalValue_mul_lt_wpow_add_one hu hvb).trans_le (NatOrdinal.wpow_le_wpow.mpr ?_) + rw [add_assoc] + exact add_le_add_right hb a + +/-- With principal-series representatives, `v_J((X^d(b_𝓑))^{|ζ}) < ω^(deg d)` for every +cutoff `ζ < 0`. -/ +@[blueprint "lem:principal-representatives-truncation" + (phase := "Translated truncations") + (title := "Translated truncations of monomials in principal series") + (statement := /-- + Let $K$ be a field. For each $i\in I$, let + $x_i\in\mathrm P_{w_i}\subseteq\widehat{\mathrm P}$ and choose a principal + series $b_i$ of degree $w_i$ representing $x_i$, where $w_i\ne0$. Then, + for every monomial $X^d$ and every $\zeta<0$, + \[ + v_J((X^d(b_i))^{|\zeta})<\omega^{\operatorname{wt}(d)}. + \] + -/) + (proof := /-- + Argue by strong induction on the number of factors of $X^d$. The constant + monomial has zero translated truncation. Otherwise write + $X^d=X^{d'}X_i$. By \ref{lem:homogeneous-evaluation-represents}, + $X^{d'}(b_i)$ and $b_i$ satisfy the ordinary ordinal-value bounds, and + \ref{lem:convolution-formula} expresses the translated truncation of their + product as a finite sum modulo $J$. + + Since $\zeta<0$, each convolution summand contains a proper translated + truncation. If its first cutoff is negative, the induction hypothesis lowers + the first factor. At cutoff $0$, the second factor is lowered by + \ref{lem:principal-truncations-lower-value}. Multiplicativity and strict + monotonicity of Hessenberg's natural sum put every product below + $\omega^{\operatorname{wt}(d)}$; the ultrametric inequality gives the same + bound for the finite sum. + -/)] +theorem IsPrincipal.ordinalValue_translatedTruncation_aeval_monomial_lt + (hwt : ∀ i, wt i ≠ 0) (d : ι →₀ ℕ) {ζ : ℝ} (hζ : ζ < 0) : + ordinalValue (translatedTruncation ((aeval σ.lift (monomial d (1 : K)) : Series K) : K⟦ℝ⟧) ζ) < + ω^ (Finsupp.weight wt d) := by + classical + suffices h : ∀ n : ℕ, ∀ d : ι →₀ ℕ, Finsupp.degree d = n → ∀ ζ : ℝ, ζ < 0 → + ordinalValue (translatedTruncation ((aeval σ.lift (monomial d (1 : K)) : Series K) : K⟦ℝ⟧) ζ) + < ω^ (Finsupp.weight wt d) from h _ d rfl ζ hζ + clear hζ ζ + intro n + induction n using Nat.strong_induction_on with + | _ n ih => + intro d hdn ζ hζ + rcases eq_or_ne d 0 with rfl | hd0 + · rw [monomial_zero', C_1, map_one] + have htr : translatedTruncation ((1 : Series K) : K⟦ℝ⟧) ζ = 0 := by + rw [Subring.coe_one, ← HahnSeries.C_one] + exact translatedTruncation_C_of_neg 1 hζ + rw [htr, ordinalValue_zero] + exact NatOrdinal.wpow_pos _ + · -- peel one occurrence `X_i` + obtain ⟨i, hi⟩ := Finsupp.support_nonempty_iff.mpr hd0 + set d' := d - Finsupp.single i 1 with hd'def + have hdd' : d' + Finsupp.single i 1 = d := + Finsupp.sub_add_single_one_cancel (Finsupp.mem_support_iff.mp hi) + have hwd : Finsupp.weight wt d' + wt i = Finsupp.weight wt d := by + rw [← hdd', map_add, Finsupp.weight_single, one_smul] + have hdeg : Finsupp.degree d' < n := by + rw [← hdn, ← hdd', map_add, Finsupp.degree_single] + omega + set M' : Series K := aeval σ.lift (monomial d' (1 : K)) with hM'def + have hprod : aeval σ.lift (monomial d (1 : K)) = M' * σ.lift i := by + rw [← hdd', monomial_add_single_one, map_mul, aeval_X] + -- the a priori bounds on the factors and their translated truncations + have hM' : ordinalValue M' < ω^ (Finsupp.weight wt d' + 1) := + Berarducci.Represents.ordinalValue_lt + (σ.aeval_represents (isWeightedHomogeneous_monomial wt d' (1 : K) rfl)) + have hli : ordinalValue (σ.lift i) < ω^ (wt i + 1) := + Berarducci.Represents.ordinalValue_lt (σ.represents i) + have hterm : ∀ β ∈ convolutionIndex (M' : K⟦ℝ⟧) (σ.lift i : K⟦ℝ⟧) ζ, + ordinalValue (translatedTruncation (M' : K⟦ℝ⟧) β * + translatedTruncation (σ.lift i : K⟦ℝ⟧) (ζ - β)) < ω^ (Finsupp.weight wt d) := by + intro β hβ + obtain ⟨hζβ, hβ0⟩ := mem_Icc_of_mem_convolutionIndex hβ + rcases lt_or_eq_of_le hβ0 with hβneg | rfl + · -- the first factor is a translated truncation at the cutoff `β < 0` + have h1 := ih _ hdeg d' rfl β hβneg + have h2 : ordinalValue (translatedTruncation (σ.lift i : K⟦ℝ⟧) (ζ - β)) < + ω^ (wt i + 1) := by + rcases lt_or_eq_of_le (sub_nonpos.mpr hζβ) with hneg | h0 + · exact (hσ.ordinalValue_translatedTruncation_lift_lt i hneg).trans + (NatOrdinal.wpow_lt_wpow.mpr (lt_add_one _)) + · rw [h0, translatedTruncation_zero] + exact hli + rcases eq_or_ne d' 0 with hd'0 | hd'0 + · -- `X^{d'} = 1`: its translated truncation at `β < 0` vanishes + have h0 : translatedTruncation (M' : K⟦ℝ⟧) β = 0 := by + rw [hM'def, hd'0, monomial_zero', C_1, map_one, Subring.coe_one, ← HahnSeries.C_one] + exact translatedTruncation_C_of_neg 1 hβneg + rw [h0, zero_mul, ordinalValue_zero] + exact NatOrdinal.wpow_pos _ + · have hw0 : Finsupp.weight wt d' ≠ 0 := by + obtain ⟨j, hj⟩ := Finsupp.support_nonempty_iff.mpr hd'0 + intro h0 + have := Finsupp.le_weight_of_mem_support wt d' hj + rw [h0] at this + exact hwt j (le_antisymm this zero_le) + have := ordinalValue_mul_lt_wpow_add (u := translatedTruncation (σ.lift i : K⟦ℝ⟧) (ζ - β)) + (v := translatedTruncation ((aeval σ.lift (monomial d' (1 : K)) : Series K) : K⟦ℝ⟧) β) + (a := wt i) (g := Finsupp.weight wt d') hw0 h2 h1 + rw [mul_comm, add_comm, hwd] at this + exact this + · -- `β = 0`: the second factor is a translated truncation at the cutoff `ζ < 0` + rw [translatedTruncation_zero, sub_zero] + have := ordinalValue_mul_lt_wpow_add (hwt i) hM' + (hσ.ordinalValue_translatedTruncation_lift_lt i hζ) + rwa [hwd] at this + -- the translated truncation of the product is congruent modulo `J` to the convolution sum + have hgerm : toGerm (translatedTruncation ((M' * σ.lift i : Series K) : K⟦ℝ⟧) ζ) = + toGerm (∑ β ∈ convolutionIndex (M' : K⟦ℝ⟧) (σ.lift i : K⟦ℝ⟧) ζ, + translatedTruncation (M' : K⟦ℝ⟧) β * translatedTruncation (σ.lift i : K⟦ℝ⟧) (ζ - β)) := by + rw [← germAt_apply, Subring.coe_mul, germAt_mul_of_subset M' (σ.lift i) ζ subset_rfl, map_sum] + simp only [germAt_apply, map_mul] + rw [hprod, ordinalValue_eq_of_sub_mem_negativeMonomialIdeal (toGerm_eq_toGerm_iff.mp hgerm)] + exact ordinalValue_sum_lt _ _ (NatOrdinal.wpow_pos _) hterm + +/-- With principal-series representatives, `v_J(q(b_𝓑)^{|ζ}) < ω^c` for `q ∈ K[X]` +homogeneous of degree `c` and every cutoff `ζ < 0`. -/ +@[blueprint "lem:principal-representatives-homogeneous-polynomial-truncation" + (phase := "Translated truncations") + (title := "Translated truncations of weighted-homogeneous polynomials") + (statement := /-- + Let $K$ be a field. For each $i\in I$, let + $x_i\in\mathrm P_{w_i}\subseteq\widehat{\mathrm P}$ and choose a principal + series $b_i$ of degree $w_i$ representing $x_i$, where $w_i\ne0$. If + $Q\in K[X_i:i\in I]$ is weighted homogeneous of degree $\sigma$, then, for + every $\zeta<0$, + \[ + v_J((Q(b_i))^{|\zeta})<\omega^\sigma. + \] + -/) + (proof := /-- + Expand $Q$ over its finite monomial support. Every occurring monomial has + weight $\sigma$, so + \ref{lem:principal-representatives-truncation} bounds the ordinal value of its + translated truncation by $\omega^\sigma$. Multiplication by its scalar + coefficient preserves this bound, and the ultrametric inequality gives it + for the finite sum. + -/)] +theorem IsPrincipal.ordinalValue_translatedTruncation_aeval_lt (hwt : ∀ i, wt i ≠ 0) + {q : MvPolynomial ι K} {c : NatOrdinal} (hq : IsWeightedHomogeneous wt q c) {ζ : ℝ} + (hζ : ζ < 0) : + ordinalValue (translatedTruncation ((aeval σ.lift q : Series K) : K⟦ℝ⟧) ζ) < ω^ c := by + classical + have hsplit : translatedTruncation ((aeval σ.lift q : Series K) : K⟦ℝ⟧) ζ = + ∑ d ∈ q.support, (HahnSeries.Nonpositive.C : K →+* Series K) (q.coeff d) * + translatedTruncation ((aeval σ.lift (monomial d (1 : K)) : Series K) : K⟦ℝ⟧) ζ := by + conv_lhs => rw [q.as_sum, map_sum] + rw [AddSubmonoidClass.coe_finsetSum, ← translatedTruncationAddMonoidHom_apply, map_sum] + refine Finset.sum_congr rfl fun d _ ↦ ?_ + have hmon : monomial d (q.coeff d) = C (q.coeff d) * monomial d (1 : K) := by + rw [C_mul_monomial, mul_one] + rw [translatedTruncationAddMonoidHom_apply, hmon, map_mul, aeval_C, + HahnSeries.Nonpositive.algebraMap_apply, Subring.coe_mul, HahnSeries.Nonpositive.coe_C, + translatedTruncation_C_mul] + rw [hsplit] + refine ordinalValue_sum_lt _ _ (NatOrdinal.wpow_pos _) fun d hd ↦ ?_ + have := hσ.ordinalValue_translatedTruncation_aeval_monomial_lt hwt d hζ + rw [hq (mem_support_iff.mp hd)] at this + exact ordinalValue_C_mul_lt _ this + +end Lifts + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/ProductCondition.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/ProductCondition.lean new file mode 100644 index 0000000000..ccee46b1dc --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/ProductCondition.lean @@ -0,0 +1,180 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.PrincipalRepresentatives +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MvPolynomial.ComponentsSpan + +/-! +# The translated truncations of a term `u · q(b_𝓑)` satisfy (p) + +Let `q ∈ K[X]` be homogeneous of degree `c`, evaluated at principal-series representatives, and let +`u` be a series +of ordinal value below `ω^(b+1)` whose translated truncations at cutoffs `ζ < 0` have ordinal +value below `ω^b` (for instance a principal series of degree `b`), with `b ⊕ c < α`. The +separation condition (n) for `(b, c, τ)` — `b ⊕ θ < τ` for every `θ < c` — gives, for every +cutoff `ζ ≤ 0`, that `pol((u q(b_𝓑))^{|ζ})_{≥τ}` lies in the ideal `(q)`: the translated +truncations of `u · q(b_𝓑)` satisfy the condition (p) for `(q; τ)`. By the convolution formula, +read in polynomials [Ber00, Lem. 7.5], +`pol((u q(b_𝓑))^{|ζ}) = pol(u^{|ζ}) · q + ∑ pol(u^{|β}) pol(q(b_𝓑)^{|ζ - β})`, the first term lies +in `(q)` and every other term has as a factor the polynomial of a translated truncation of +`q(b_𝓑)` at a cutoff `< 0`, hence has degree below `τ`. +-/ + +universe v w + +open scoped NatOrdinal HahnSeries +open Berarducci HahnSeries MvPolynomial OrdinalGraded + +public noncomputable section + +namespace Berarducci + +variable {K : Type v} [Field K] {ι : Type w} {wt : ι → NatOrdinal} {x : ι → PrincipalSubring K} + +namespace Lifts + +variable (σ : Lifts wt x) (hx : IsMinimalSystem (Berarducci.principalGrading K) wt x) + {α : NatOrdinal} (hinj : ∀ β < α, InjectiveAt K wt x β) (hσ : σ.IsPrincipal) +include hinj hσ + +/-- **High-degree components of translated truncations of a polynomial multiple.** Under the +displayed ordinal-value and Hessenberg-sum bounds, the components of degree at least `τ` of +`pol((u * q(b_𝓑))^{|ζ})` lie in the principal ideal generated by `q`. -/ +@[blueprint "lem:term-truncation-condition" + (phase := "Translated truncations") + (title := "High-degree components of translated truncations of a polynomial multiple") + (statement := /-- + Let $K$ be a field and let $\mathcal B$ be a minimal homogeneous generating + system of $\widehat{\mathrm P}$, with principal representatives $b_B$. + Assume evaluation is injective in every degree below $\alpha$. Let + $Q\in K[X_B:B\in\mathcal B]$ be weighted homogeneous of degree $\sigma$. + Suppose + \[ + v_J(u)<\omega^{\rho+1},\qquad + v_J(u^{|\zeta})<\omega^\rho\quad(\zeta<0), + \] + \[ + \rho\oplus\sigma<\alpha,\qquad + \rho\oplus\theta<\tau\quad(\theta<\sigma). + \] + Then, for every $\xi\le0$, + \[ + \operatorname{pol}_{<\alpha} + \!\left((uQ(b_B))^{|\xi}\right)_{\ge\tau} + \in (Q)\subseteq K[X_B:B\in\mathcal B]. + \] + -/) + (proof := /-- + By \ref{prop:polynomial-representative-exists}, translated truncations of + ordinal value below $\omega^\alpha$ have polynomial representatives of + degree below $\alpha$; \ref{prop:polynomial-evaluation-ordinal-value} gives + the needed uniqueness. + Expand the translated truncation of $uQ(b_B)$ by convolution. The endpoint + term is $\operatorname{pol}_{<\alpha}(u^{|\xi})Q$, so its components of + degree at least $\tau$ lie in $(Q)$. In every other term the $Q(b_B)$ factor + is translated-truncated at a negative cutoff. By + \ref{lem:principal-representatives-homogeneous-polynomial-truncation}, its polynomial + representative has degree below $\sigma$, while the representative of the + $u$ factor has degree at most $\rho$. Thus $\rho\oplus\theta<\tau$ makes the + component of degree at least $\tau$ vanish. Summing proves the claim. + -/)] +theorem componentsGE_pol_translatedTruncation_mul_aeval_mem {q : MvPolynomial ι K} + {c : NatOrdinal} (hq : IsWeightedHomogeneous wt q c) {u : Series K} {b : NatOrdinal} + (hu : ordinalValue u < ω^ (b + 1)) + (hucut : ∀ ζ : ℝ, ζ < 0 → ordinalValue (translatedTruncation (u : K⟦ℝ⟧) ζ) < ω^ b) + (hbc : b + c < α) {τ : NatOrdinal} (hsep : ∀ θ, θ < c → b + θ < τ) {ζ : ℝ} (hζ : ζ ≤ 0) : + componentsGE wt τ + (σ.pol hx α (translatedTruncation ((u * aeval σ.lift q : Series K) : K⟦ℝ⟧) ζ)) ∈ + Ideal.span (Set.range fun _ : Unit ↦ q) := by + classical + have hwt : ∀ i, wt i ≠ 0 := hx.ne_zero + have hbα : b < α := (NatOrdinal.le_add_right).trans_lt hbc + have hcα : c < α := (NatOrdinal.le_add_left).trans_lt hbc + set v : Series K := aeval σ.lift q with hvdef + have hv : ordinalValue v < ω^ (c + 1) := (σ.aeval_represents hq).ordinalValue_lt + have hvcut : ∀ ξ : ℝ, ξ < 0 → ordinalValue (translatedTruncation (v : K⟦ℝ⟧) ξ) < ω^ c := + fun ξ hξ ↦ hσ.ordinalValue_translatedTruncation_aeval_lt hwt hq hξ + -- the convolution index set, with the endpoints added + set S : Finset ℝ := insert 0 (insert ζ (convolutionIndex (u : K⟦ℝ⟧) (v : K⟦ℝ⟧) ζ)) with hSdef + have hS1 : convolutionIndex (u : K⟦ℝ⟧) (v : K⟦ℝ⟧) ζ ⊆ S := + (Finset.subset_insert _ _).trans (Finset.subset_insert _ _) + have hS2 : ∀ β ∈ S, ζ ≤ β ∧ β ≤ 0 := by + intro β hβ + rw [hSdef, Finset.mem_insert, Finset.mem_insert] at hβ + rcases hβ with rfl | rfl | hβ + · exact ⟨hζ, le_rfl⟩ + · exact ⟨le_rfl, hζ⟩ + · exact mem_Icc_of_mem_convolutionIndex hβ + -- ordinal value bounds on the translated truncations of the factors + have hucut' : ∀ β, β ≤ 0 → ordinalValue (translatedTruncation (u : K⟦ℝ⟧) β) < ω^ (b + 1) := by + intro β hβ + rcases lt_or_eq_of_le hβ with h | rfl + · exact (hucut β h).trans (NatOrdinal.wpow_lt_wpow.mpr (lt_add_one b)) + · rw [translatedTruncation_zero]; exact hu + have hvcut' : ∀ β, β ≤ 0 → ordinalValue (translatedTruncation (v : K⟦ℝ⟧) β) < ω^ (c + 1) := by + intro β hβ + rcases lt_or_eq_of_le hβ with h | rfl + · exact (hvcut β h).trans (NatOrdinal.wpow_lt_wpow.mpr (lt_add_one c)) + · rw [translatedTruncation_zero]; exact hv + have hb1 : b + 1 ≤ α := Order.add_one_le_of_lt hbα + have hc1 : c + 1 ≤ α := Order.add_one_le_of_lt hcα + -- the a priori ordinal value bound on the translated truncation of the product + have hprod : ordinalValue (translatedTruncation ((u * v : Series K) : K⟦ℝ⟧) ζ) < ω^ α := by + have hgerm : toGerm (translatedTruncation ((u * v : Series K) : K⟦ℝ⟧) ζ) = + toGerm (∑ β ∈ S, translatedTruncation (u : K⟦ℝ⟧) β * + translatedTruncation (v : K⟦ℝ⟧) (ζ - β)) := by + rw [← germAt_apply, Subring.coe_mul, germAt_mul_of_subset u v ζ hS1, map_sum] + simp only [germAt_apply, map_mul] + rw [ordinalValue_eq_of_sub_mem_negativeMonomialIdeal (toGerm_eq_toGerm_iff.mp hgerm)] + refine ordinalValue_sum_lt _ _ (NatOrdinal.wpow_pos α) fun β hβ ↦ ?_ + obtain ⟨hζβ, hβ0⟩ := hS2 β hβ + refine (ordinalValue_mul_lt_wpow_add_one (hucut' β hβ0) + (hvcut' (ζ - β) (by linarith))).trans_le (NatOrdinal.wpow_le_wpow.mpr ?_) + exact Order.add_one_le_of_lt hbc + -- the term bounds for the convolution formula + have hterm : ∀ β ∈ S, + ordinalValue (translatedTruncation (u : K⟦ℝ⟧) β) < ω^ α ∧ + ordinalValue (translatedTruncation (v : K⟦ℝ⟧) (ζ - β)) < ω^ α ∧ + DegreeLT wt (σ.pol hx α (translatedTruncation (u : K⟦ℝ⟧) β) * + σ.pol hx α (translatedTruncation (v : K⟦ℝ⟧) (ζ - β))) α := by + intro β hβ + obtain ⟨hζβ, hβ0⟩ := hS2 β hβ + have h1 := hucut' β hβ0 + have h2 := hvcut' (ζ - β) (by linarith) + refine ⟨h1.trans_le (NatOrdinal.wpow_le_wpow.mpr hb1), + h2.trans_le (NatOrdinal.wpow_le_wpow.mpr hc1), ?_⟩ + have hdu : DegreeLE wt (σ.pol hx α (translatedTruncation (u : K⟦ℝ⟧) β)) b := + degreeLT_add_one_iff_degreeLE.mp (σ.pol_degreeLT_of_lt hx hinj hb1 h1) + have hdv : DegreeLE wt (σ.pol hx α (translatedTruncation (v : K⟦ℝ⟧) (ζ - β))) c := + degreeLT_add_one_iff_degreeLE.mp (σ.pol_degreeLT_of_lt hx hinj hc1 h2) + exact (hdu.mul hdv).degreeLT hbc + rw [σ.pol_translatedTruncation_mul_eq_sum hx hinj hS1 hprod hterm, componentsGE_sum] + refine Ideal.sum_mem _ fun β hβ ↦ ?_ + obtain ⟨hζβ, hβ0⟩ := hS2 β hβ + rcases eq_or_lt_of_le hζβ with rfl | hlt + · -- the term `pol(u^{|ζ}) · q` + rw [sub_self, translatedTruncation_zero, hvdef, σ.pol_aeval hx hinj (hq.degreeLT hcα)] + exact componentsGE_mem_span wt (fun _ : Unit ↦ hq) + (Ideal.mul_mem_left _ _ (Ideal.subset_span ⟨(), rfl⟩)) τ + · -- a translated truncation of `q(b_𝓑)` at a cutoff `< 0`: degree below `τ` + have hdu : DegreeLE wt (σ.pol hx α (translatedTruncation (u : K⟦ℝ⟧) β)) b := + degreeLT_add_one_iff_degreeLE.mp (σ.pol_degreeLT_of_lt hx hinj hb1 (hucut' β hβ0)) + have hdv : DegreeLT wt (σ.pol hx α (translatedTruncation (v : K⟦ℝ⟧) (ζ - β))) c := + σ.pol_degreeLT_of_lt hx hinj hcα.le (hvcut (ζ - β) (by linarith)) + rw [componentsGE_eq_zero_of_forall_lt wt fun d hd ↦ ?_] + · exact zero_mem _ + obtain ⟨d₁, hd₁, d₂, hd₂, hw⟩ := exists_add_eq_weight_of_mem_support_mul (wt := wt) hd + rw [← hw] + calc Finsupp.weight wt d₁ + Finsupp.weight wt d₂ + ≤ b + Finsupp.weight wt d₂ := add_le_add_left ((degreeLE_iff).mp hdu d₁ hd₁) _ + _ < τ := hsep _ ((degreeLT_iff).mp hdv d₂ hd₂) + +end Lifts + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/ProductTruncation.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/ProductTruncation.lean new file mode 100644 index 0000000000..e5ec77901d --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/ProductTruncation.lean @@ -0,0 +1,88 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.ProductValues + +/-! +# The translated truncation of a product against that of its first factor + +For nonpositive series `u`, `v` and a cutoff `ζ < 0`, the convolution formula [Ber00, Lem. 7.5] +reads `(u v)^{|ζ} ≡ u^{|ζ} v + ∑_{ζ < β ≤ 0} u^{|β} v^{|ζ - β} (mod J)`. When every translated +truncation of `u` has ordinal value below `ω^(a+1)`, every translated truncation of `v` at a cutoff +`< 0` has ordinal value below `ω^g`, and the separation condition (n) holds for `(a, g, τ)` — +`a ⊕ θ < τ` for every `θ < g` — the sum has ordinal value below `ω^τ`: +`v_J((u v)^{|ζ} - u^{|ζ} v) < ω^τ`. This is the computation behind the terms `u′·Q(b_𝓑)` of a +sum along a sequence of cutoffs and behind the combined cofactors alike. +-/ + +universe v + +open scoped NatOrdinal HahnSeries +open Berarducci HahnSeries + +public noncomputable section + +namespace Berarducci + +variable {K : Type v} [Field K] + +/-- **The convolution formula modulo `J`** (cf. [Ber00, Lem. 7.5]). For `S` containing the +convolution index set, `(u v)^{|ζ} - ∑_{β ∈ S} u^{|β} v^{|ζ - β} ∈ J`. -/ +theorem translatedTruncation_mul_sub_sum_mem_negativeMonomialIdeal (u v : Series K) (ζ : ℝ) + {S : Finset ℝ} (hS : convolutionIndex (u : K⟦ℝ⟧) (v : K⟦ℝ⟧) ζ ⊆ S) : + translatedTruncation ((u * v : Series K) : K⟦ℝ⟧) ζ - + ∑ β ∈ S, translatedTruncation (u : K⟦ℝ⟧) β * translatedTruncation (v : K⟦ℝ⟧) (ζ - β) ∈ + Nonpositive.negativeMonomialIdeal K := by + rw [← toGerm_eq_toGerm_iff, ← germAt_apply, Subring.coe_mul, germAt_mul_of_subset u v ζ hS, + map_sum] + simp only [germAt_apply, map_mul] + +/-- **The translated truncation of a product against that of its first factor.** If every +translated truncation of `u` has ordinal value below `ω^(a+1)`, every translated truncation of `v` +at a cutoff `< 0` has ordinal value below `ω^g`, and (n) holds for `(a, g, τ)` (`a ⊕ θ < τ` for +every `θ < g`), then for every cutoff `ζ < 0` the difference `(u v)^{|ζ} - u^{|ζ} v` has ordinal +value below `ω^τ`. -/ +theorem ordinalValue_translatedTruncation_mul_sub_mul_lt {u v : Series K} {a g τ : NatOrdinal} + (hu : ∀ β : ℝ, β ≤ 0 → ordinalValue (translatedTruncation (u : K⟦ℝ⟧) β) < ω^ (a + 1)) + (hv : ∀ β : ℝ, β < 0 → ordinalValue (translatedTruncation (v : K⟦ℝ⟧) β) < ω^ g) + (hsep : ∀ θ, θ < g → a + θ < τ) {ζ : ℝ} (hζ : ζ < 0) : + ordinalValue (translatedTruncation ((u * v : Series K) : K⟦ℝ⟧) ζ - + translatedTruncation (u : K⟦ℝ⟧) ζ * v) < ω^ τ := by + classical + set S : Finset ℝ := insert 0 (insert ζ (convolutionIndex (u : K⟦ℝ⟧) (v : K⟦ℝ⟧) ζ)) with hSdef + have hS1 : convolutionIndex (u : K⟦ℝ⟧) (v : K⟦ℝ⟧) ζ ⊆ S := + (Finset.subset_insert _ _).trans (Finset.subset_insert _ _) + have hζS : ζ ∈ S := Finset.mem_insert_of_mem (Finset.mem_insert_self _ _) + have hS2 : ∀ β ∈ S, ζ ≤ β ∧ β ≤ 0 := by + intro β hβ + rw [hSdef, Finset.mem_insert, Finset.mem_insert] at hβ + rcases hβ with rfl | rfl | hβ + · exact ⟨hζ.le, le_rfl⟩ + · exact ⟨le_rfl, hζ.le⟩ + · exact mem_Icc_of_mem_convolutionIndex hβ + have hmem := translatedTruncation_mul_sub_sum_mem_negativeMonomialIdeal u v ζ hS1 + -- split off the term `β = ζ` + rw [← Finset.add_sum_erase _ _ hζS, sub_self, translatedTruncation_zero] at hmem + have heq : translatedTruncation ((u * v : Series K) : K⟦ℝ⟧) ζ - + translatedTruncation (u : K⟦ℝ⟧) ζ * v = + (translatedTruncation ((u * v : Series K) : K⟦ℝ⟧) ζ - + (translatedTruncation (u : K⟦ℝ⟧) ζ * v + ∑ β ∈ S.erase ζ, + translatedTruncation (u : K⟦ℝ⟧) β * translatedTruncation (v : K⟦ℝ⟧) (ζ - β))) + + ∑ β ∈ S.erase ζ, + translatedTruncation (u : K⟦ℝ⟧) β * translatedTruncation (v : K⟦ℝ⟧) (ζ - β) := by + ring + rw [heq] + refine (ordinalValue_add_le_max _ _).trans_lt (max_lt ?_ ?_) + · rw [ordinalValue_of_mem_negativeMonomialIdeal hmem] + exact NatOrdinal.wpow_pos τ + · refine ordinalValue_sum_lt _ _ (NatOrdinal.wpow_pos τ) fun β hβ ↦ ?_ + obtain ⟨hne, hβS⟩ := Finset.mem_erase.mp hβ + obtain ⟨hζβ, hβ0⟩ := hS2 β hβS + have hlt : ζ < β := lt_of_le_of_ne hζβ fun h ↦ hne h.symm + exact ordinalValue_mul_lt_wpow_of_forall_add_lt (hu β hβ0) (hv (ζ - β) (by linarith)) hsep + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/ProductValues.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/ProductValues.lean new file mode 100644 index 0000000000..235f46b1d9 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/ProductValues.lean @@ -0,0 +1,127 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.PrincipalRepresentatives + +/-! +# Ordinal values of the translated truncations of a term `u · q(b_𝓑)` + +Let `q ∈ K[X]` be homogeneous of degree `c`, evaluated at principal-series representatives, and let +`u` be a series +of ordinal value below `ω^(b+1)` whose translated truncations at cutoffs `ζ < 0` have ordinal +value below `ω^b`. Under the separation condition (n) for `(b, c, τ)` — `b ⊕ θ < τ` for every +`θ < c` — and `τ ≤ ρ := b ⊕ c`, every translated truncation of the term `u · q(b_𝓑)` at a cutoff +`ζ < 0` has ordinal value below `ω^ρ`: in the convolution formula [Ber00, Lem. 7.5] +`(u q(b_𝓑))^{|ζ} ≡ u^{|ζ} q(b_𝓑) + ∑ u^{|β} q(b_𝓑)^{|ζ - β}` the first term has ordinal value +below `ω^ρ` since `v_J(u^{|ζ}) < ω^b`, and the others have ordinal value below `ω^τ ≤ ω^ρ`. +-/ + +universe v w + +open scoped NatOrdinal HahnSeries +open Berarducci HahnSeries MvPolynomial + +public noncomputable section + +namespace Berarducci + +variable {K : Type v} [Field K] + +/-- A product with a factor of ordinal value below `1` (a factor in `J`) has ordinal value `0`. -/ +theorem ordinalValue_mul_eq_zero_of_lt_one {u v : Series K} (hv : ordinalValue v < 1) : + ordinalValue (u * v) = 0 := by + have hv0 : ordinalValue v = 0 := by + by_contra h + exact absurd (Order.one_le_iff_pos.mpr (pos_iff_ne_zero.mpr h)) (not_le.mpr hv) + rw [ordinalValue_eq_zero_iff] at hv0 ⊢ + exact Ideal.mul_mem_left _ _ hv0 + +/-- The product of a series of ordinal value below `ω^(a+1)` and one of ordinal value below `ω^g` +has ordinal value below `ω^(a ⊕ g)`; for `g = 0` the second factor lies in `J`, and so does the +product. -/ +theorem ordinalValue_mul_lt_wpow_add' {u v : Series K} {a g : NatOrdinal} + (hu : ordinalValue u < ω^ (a + 1)) (hv : ordinalValue v < ω^ g) : + ordinalValue (u * v) < ω^ (a + g) := by + rcases eq_or_ne g 0 with rfl | hg + · rw [NatOrdinal.wpow_zero] at hv + rw [ordinalValue_mul_eq_zero_of_lt_one hv] + exact NatOrdinal.wpow_pos _ + · exact Lifts.ordinalValue_mul_lt_wpow_add hg hu hv + +/-- **The separation condition (n) bounds a product.** If `v_J(u) < ω^(a+1)`, `v_J(v) < ω^g`, and +(n) holds for `(a, g, τ)` (`a ⊕ θ < τ` for every `θ < g`), the product has ordinal value below +`ω^τ`. -/ +theorem ordinalValue_mul_lt_wpow_of_forall_add_lt {u v : Series K} {a g τ : NatOrdinal} + (hu : ordinalValue u < ω^ (a + 1)) (hv : ordinalValue v < ω^ g) + (hsep : ∀ θ, θ < g → a + θ < τ) : ordinalValue (u * v) < ω^ τ := by + rcases eq_or_ne g 0 with rfl | hg + · rw [NatOrdinal.wpow_zero] at hv + rw [ordinalValue_mul_eq_zero_of_lt_one hv] + exact NatOrdinal.wpow_pos _ + · obtain ⟨θ, hθ, hvθ⟩ := exists_lt_wpow_add_one_of_lt_wpow hg hv + exact (ordinalValue_mul_lt_wpow_add_one hu hvθ).trans_le + (NatOrdinal.wpow_le_wpow.mpr (Order.add_one_le_of_lt (hsep θ (Order.add_one_le_iff.mp hθ)))) + +variable {ι : Type w} {wt : ι → NatOrdinal} {x : ι → PrincipalSubring K} + +namespace Lifts + +variable {σ : Lifts wt x} (hσ : σ.IsPrincipal) +include hσ + +/-- **Translated truncations of a term `u · q(b_𝓑)`.** With principal-series representatives, for +`q` homogeneous of +degree `c`, `u` with `v_J(u) < ω^(b+1)` whose translated truncations at cutoffs `< 0` have ordinal +value below `ω^b`, `ρ = b ⊕ c`, `τ ≤ ρ` and (n) for `(b, c, τ)` (`b ⊕ θ < τ` for every `θ < c`): +every translated truncation of `u · q(b_𝓑)` at a cutoff `ζ < 0` has ordinal value below `ω^ρ`. -/ +theorem IsPrincipal.ordinalValue_translatedTruncation_mul_aeval_lt (hwt : ∀ i, wt i ≠ 0) + {q : MvPolynomial ι K} {c : NatOrdinal} (hq : IsWeightedHomogeneous wt q c) {u : Series K} + {b : NatOrdinal} (hu : ordinalValue u < ω^ (b + 1)) + (hucut : ∀ ζ : ℝ, ζ < 0 → ordinalValue (translatedTruncation (u : K⟦ℝ⟧) ζ) < ω^ b) + {τ ρ : NatOrdinal} (hbc : b + c = ρ) (hτρ : τ ≤ ρ) (hsep : ∀ θ, θ < c → b + θ < τ) {ζ : ℝ} + (hζ : ζ < 0) : + ordinalValue (translatedTruncation ((u * aeval σ.lift q : Series K) : K⟦ℝ⟧) ζ) < ω^ ρ := by + classical + set v : Series K := aeval σ.lift q with hvdef + have hv : ordinalValue v < ω^ (c + 1) := (σ.aeval_represents hq).ordinalValue_lt + have hvcut : ∀ ξ : ℝ, ξ < 0 → ordinalValue (translatedTruncation (v : K⟦ℝ⟧) ξ) < ω^ c := + fun ξ hξ ↦ hσ.ordinalValue_translatedTruncation_aeval_lt hwt hq hξ + set S : Finset ℝ := insert 0 (insert ζ (convolutionIndex (u : K⟦ℝ⟧) (v : K⟦ℝ⟧) ζ)) with hSdef + have hS1 : convolutionIndex (u : K⟦ℝ⟧) (v : K⟦ℝ⟧) ζ ⊆ S := + (Finset.subset_insert _ _).trans (Finset.subset_insert _ _) + have hS2 : ∀ β ∈ S, ζ ≤ β ∧ β ≤ 0 := by + intro β hβ + rw [hSdef, Finset.mem_insert, Finset.mem_insert] at hβ + rcases hβ with rfl | rfl | hβ + · exact ⟨hζ.le, le_rfl⟩ + · exact ⟨le_rfl, hζ.le⟩ + · exact mem_Icc_of_mem_convolutionIndex hβ + have hucut' : ∀ β, β ≤ 0 → ordinalValue (translatedTruncation (u : K⟦ℝ⟧) β) < ω^ (b + 1) := by + intro β hβ + rcases lt_or_eq_of_le hβ with h | rfl + · exact (hucut β h).trans (NatOrdinal.wpow_lt_wpow.mpr (lt_add_one b)) + · rw [translatedTruncation_zero]; exact hu + have hgerm : toGerm (translatedTruncation ((u * v : Series K) : K⟦ℝ⟧) ζ) = + toGerm (∑ β ∈ S, translatedTruncation (u : K⟦ℝ⟧) β * + translatedTruncation (v : K⟦ℝ⟧) (ζ - β)) := by + rw [← germAt_apply, Subring.coe_mul, germAt_mul_of_subset u v ζ hS1, map_sum] + simp only [germAt_apply, map_mul] + rw [ordinalValue_eq_of_sub_mem_negativeMonomialIdeal (toGerm_eq_toGerm_iff.mp hgerm)] + refine ordinalValue_sum_lt _ _ (NatOrdinal.wpow_pos ρ) fun β hβ ↦ ?_ + obtain ⟨hζβ, hβ0⟩ := hS2 β hβ + rcases eq_or_lt_of_le hζβ with rfl | hlt + · -- the term `u^{|ζ} · q(b_𝓑)`: the translated truncation of `u` at `ζ < 0` against the whole + -- of `q(b_𝓑)` + rw [sub_self, translatedTruncation_zero, mul_comm, ← hbc, add_comm] + exact ordinalValue_mul_lt_wpow_add' hv (hucut _ hζ) + · -- a translated truncation of `q(b_𝓑)` at a cutoff `< 0`: ordinal value below `ω^τ ≤ ω^ρ` + exact (ordinalValue_mul_lt_wpow_of_forall_add_lt (hucut' β hβ0) (hvcut (ζ - β) (by linarith)) + hsep).trans_le (NatOrdinal.wpow_le_wpow.mpr hτρ) + +end Lifts + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/RealPartials.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/RealPartials.lean new file mode 100644 index 0000000000..a791a155d8 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/RealPartials.lean @@ -0,0 +1,226 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.AlgebraicIndependence +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.CantorBendixsonRepresentatives +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.Partials + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint + +/-! +# The real partial-derivative argument + +The polynomiality induction for the Cantor–Bendixson degree is generic. For real exponents, a +relation whose degree is a limit ordinal in the generic Hahn ring gives the corresponding relation +in `P̂` after replacing an eventual left-neighborhood statement by an interval `(-ε, 0)`. The +required partial-derivative decomposition then follows from real translated truncations. +-/ + +universe v w + +open scoped HahnSeries NatOrdinal Topology + +open Filter Berarducci HahnSeries MvPolynomial + +public noncomputable section + +namespace Berarducci + +variable {K : Type v} [Field K] [CharZero K] +variable {ι : Type w} {wt : ι → NatOrdinal} {x : ι → PrincipalSubring K} +variable {σ : Lifts wt x} {α : NatOrdinal} + +namespace Lifts + +namespace RealPartialDecomposition + +variable (S : HahnSeries.Germ.LimitOrdinalRelationAtCutoff σ.cantorBendixson α) + +/-- A generic relation of limit-ordinal degree reinterpreted in the real principal subring. -/ +@[expose] def principal : σ.LimitOrdinalRelationAtCutoff α := by + let hex := eventually_nhdsLT_iff_exists.mp S.truncation_lt + let l := Classical.choose hex + have hl := (Classical.choose_spec hex).1 + have htrunc := (Classical.choose_spec hex).2 + refine + { F := S.F + hom := S.hom + eval_zero := ?_ + ne_zero := S.ne_zero + vars_lt := S.vars_lt + vars_limit := S.vars_limit + B₀ := S.B₀ + mem := S.mem + max := S.max + β := S.β + degHD := S.degHD + hdegHD := S.hdegHD + degHD_terms := S.degHD_terms + degHD_ne_zero := S.degHD_ne_zero + term_lt := S.term_lt + lam₀ := S.lam₀ + lam₀_lt := S.lam₀_lt + α₁ := S.α₁ + α₁_le := S.α₁_le + α₁_le_α := S.α₁_le_α + ε₁ := -l + ε₁_pos := neg_pos.mpr hl + truncation_lt := ?_ + remainder_lt := S.remainder_lt } + · apply principalSubringCantorBendixsonAlgEquiv.injective + rw [map_zero, principalSubringCantorBendixsonAlgEquiv_aeval, S.eval_zero] + · intro γ hγl hγ0 + apply (ordinalValueDegree_lt_coe_iff _ _).mp + rw [show -l = -l by rfl] at hγl + have hcb := htrunc γ (by linarith) hγ0 + rw [show σ.cantorBendixson.lift = σ.lift by + funext i + exact cantorBendixson_lift σ i] at hcb + rw [ordinalValueDegree_eq_cantorBendixsonDegree] + simpa only [translatedTruncLE_eq_translatedTruncation] using hcb + +@[simp] +theorem principal_F : (principal S).F = S.F := rfl + +@[simp] +theorem principal_B₀ : (principal S).B₀ = S.B₀ := rfl + +@[simp] +theorem principal_lowDegreePartEq (i : ι) : + (principal S).LowDegreePartEq i ↔ S.LowDegreePartEq i := by + rw [Berarducci.Lifts.LimitOrdinalRelationAtCutoff.lowDegreePartEq_iff, + HahnSeries.Germ.LimitOrdinalRelationAtCutoff.lowDegreePartEq_iff, + Berarducci.Lifts.LimitOrdinalRelationAtCutoff.degLT_def, + Berarducci.Lifts.LimitOrdinalRelationAtCutoff.αLT_def, + HahnSeries.Germ.LimitOrdinalRelationAtCutoff.degLT_def, + HahnSeries.Germ.LimitOrdinalRelationAtCutoff.αLT_def] + rfl + +@[simp] +theorem principal_lowDegreePartAlgebraicLE (i : ι) : + (principal S).LowDegreePartAlgebraicLE i ↔ S.LowDegreePartAlgebraicLE i := by + rw [Berarducci.Lifts.LimitOrdinalRelationAtCutoff.lowDegreePartAlgebraicLE_iff, + HahnSeries.Germ.LimitOrdinalRelationAtCutoff.lowDegreePartAlgebraicLE_iff, + Berarducci.Lifts.LimitOrdinalRelationAtCutoff.degLT_def, + HahnSeries.Germ.LimitOrdinalRelationAtCutoff.degLT_def] + rfl + +@[simp] +theorem principal_hasProperLowDegreePartNotAlgebraicLE (i : ι) : + (principal S).HasProperLowDegreePartNotAlgebraicLE i ↔ + S.HasProperLowDegreePartNotAlgebraicLE i := by + rw [Berarducci.Lifts.LimitOrdinalRelationAtCutoff.hasProperLowDegreePartNotAlgebraicLE_iff, + HahnSeries.Germ.LimitOrdinalRelationAtCutoff.hasProperLowDegreePartNotAlgebraicLE_iff] + simp only [principal_F, principal_lowDegreePartEq, principal_lowDegreePartAlgebraicLE, + Berarducci.Lifts.LimitOrdinalRelationAtCutoff.degLT_def, + HahnSeries.Germ.LimitOrdinalRelationAtCutoff.degLT_def] + rfl + +@[simp] +theorem principal_contributesToPartialDerivativeAt (v' v : ι) : + (principal S).ContributesToPartialDerivativeAt v' v ↔ + S.ContributesToPartialDerivativeAt v' v := by + rw [Berarducci.Lifts.LimitOrdinalRelationAtCutoff.contributesToPartialDerivativeAt_iff, + HahnSeries.Germ.LimitOrdinalRelationAtCutoff.contributesToPartialDerivativeAt_iff] + simp only [principal_F, principal_lowDegreePartEq, principal_hasProperLowDegreePartNotAlgebraicLE] + +/-- The partial-derivative decomposition at a variable whose part of the degree below `β` +precedes `λ₀` in the algebraic order. -/ +@[blueprint "lem:real-translated-truncation-partials" + (phase := "Principal RV-elements") + (title := "Transport of the Jacobian syzygy to the Cantor--Bendixson grading") + (statement := /-- + Let $K$ be a field of characteristic zero. Let $(x_i)_{i\in I}$ be a + minimal homogeneous generating system of $\widehat{\mathrm P}$, with + $x_i\in\mathrm P_{w_i}$, and choose principal series $b_i$ of degree + $w_i$ representing $x_i$. Under the canonical isomorphism + \[ + \widehat{\mathrm P}\simeq_K + \operatorname{gr}_{\delta_{\mathrm{CB}}}K((\mathbb R^{\le0})), + \] + write $\bar x_i$ for the image of $x_i$, and assume evaluation at + $(\bar x_i)$ is injective on every homogeneous degree below $\alpha$. + + Let $0\ne F\in K[X_i:i\in I]$ be weighted homogeneous of degree $\alpha$ + with $F(\bar x)=0$. Suppose every variable of $F$ has weight below + $\alpha$ and zero constant Cantor coefficient. Choose $X_{B_0}$ of + maximal weight among the variables of $F$, and put + $D=\deg_{X_{B_0}}F$. Suppose there are ordinals + $\beta,\Delta,\lambda_0,\alpha_1$ such that + \[ + \Delta\ne0,\qquad + \Delta\oplus D w_{B_0}=\alpha,\qquad + \lambda_0<\alpha_{<\beta}, + \] + every Cantor term of $\Delta$ is at least $\omega^\beta$, and the last + Cantor term of $w_{B_0}$ is below $\omega^\beta$. Assume also + \[ + \alpha_1\le\alpha_{\ge\beta}\oplus\lambda_0, + \qquad \alpha_1\le\alpha, + \] + that for all $\gamma<0$ sufficiently close to $0$, + \[ + \delta_{\mathrm{CB}}\bigl(F(b)^{\vert\gamma}\bigr)<\alpha_1, + \] + and that in the convolution expansion of any monomial of $F$, every term + $\rho$ using at least two translated truncations satisfies + $\rho<\alpha_{\ge\beta}\oplus\lambda_0$. + + Let $X_{B'}$ occur in $F$, and suppose + $(w_{B'})_{<\beta}\preccurlyeq\lambda_0$ in the algebraic order. Then + there are a finite set $E$ of variables and + polynomials $(U_B)_{B\in E}$ such that every $B\in E$ occurs in $F$ and + either + \[ + (w_B)_{<\beta}=\alpha_{<\beta}, + \] + or + \[ + 0<(w_B)_{<\beta}\ne\alpha_{<\beta},\qquad + (w_B)_{<\beta}\not\preccurlyeq\lambda_0, + \qquad w_{B'} 0`). -/ +def shift (ξ : ℝ) (u : Series K) : Series K := + if h : ξ ≤ 0 then Nonpositive.single ξ (1 : K) h * u else 0 + +theorem coe_shift_of_le {ξ : ℝ} (hξ : ξ ≤ 0) (u : Series K) : + ((shift ξ u : Series K) : K⟦ℝ⟧) = translate ξ (u : K⟦ℝ⟧) := by + rw [shift, dite_eq_left hξ, Subring.coe_mul, Nonpositive.coe_single, single_one_mul_eq_translate] + +theorem shift_mul {ξ : ℝ} (hξ : ξ ≤ 0) (u v : Series K) : + shift ξ u * v = shift ξ (u * v) := by + rw [shift, shift, dite_eq_left hξ, dite_eq_left hξ, mul_assoc] + +/-- The translated truncation of a shift: `(t^ξ u)^{|ζ} = u^{|ζ - ξ}`. -/ +theorem translatedTruncation_shift {ξ : ℝ} (hξ : ξ ≤ 0) (u : Series K) (ζ : ℝ) : + translatedTruncation ((shift ξ u : Series K) : K⟦ℝ⟧) ζ = + translatedTruncation (u : K⟦ℝ⟧) (ζ - ξ) := by + rw [coe_shift_of_le hξ, translatedTruncation_translate] + +theorem supportOrderType_shift {ξ : ℝ} (hξ : ξ ≤ 0) (u : Series K) : + ((shift ξ u : Series K) : K⟦ℝ⟧).supportOrderType = (u : K⟦ℝ⟧).supportOrderType := by + rw [coe_shift_of_le hξ, supportOrderType_translate] + +/-! ### Sums -/ + +/-- A finite sum of series whose supports have order type below `ω^e` has support of order type +below `ω^e`. -/ +theorem supportOrderType_sum_lt_wpow {ι' : Type*} (s : Finset ι') (f : ι' → Series K) + {e : NatOrdinal} (h : ∀ i ∈ s, ((f i : Series K) : K⟦ℝ⟧).supportOrderType < (ω^ e).val) : + ((∑ i ∈ s, f i : Series K) : K⟦ℝ⟧).supportOrderType < (ω^ e).val := by + classical + induction s using Finset.induction_on with + | empty => + rw [Finset.sum_empty, Subring.coe_zero, supportOrderType_eq_setOrderType] + simp only [HahnSeries.support_zero] + rw [(Set.isPWO_empty.orderType_eq_zero).mpr rfl] + exact Ordinal.opow_pos _ Ordinal.omega0_pos + | insert a s ha ih => + rw [Finset.sum_insert ha, Subring.coe_add] + refine (supportOrderType_add_le_naturalAdd _ _).trans_lt ?_ + have h1 : NatOrdinal.of ((f a : Series K) : K⟦ℝ⟧).supportOrderType < ω^ e := by + rw [← NatOrdinal.of_val (ω^ e)] + exact NatOrdinal.of.lt_iff_lt.mpr (h a (Finset.mem_insert_self a s)) + have h2 : NatOrdinal.of ((∑ i ∈ s, f i : Series K) : K⟦ℝ⟧).supportOrderType < ω^ e := by + rw [← NatOrdinal.of_val (ω^ e)] + exact NatOrdinal.of.lt_iff_lt.mpr (ih fun i hi ↦ h i (Finset.mem_insert_of_mem hi)) + exact NatOrdinal.val.lt_iff_lt.mpr (NatOrdinal.add_lt_wpow h1 h2) + +/-! ### Representatives -/ + +theorem Represents.of_eq {u : Series K} {β β' : NatOrdinal} {e : PrincipalSubring K} (h : β = β') + (hu : Represents u β e) : Represents u β' e := by + subst h; exact hu + +/-- A finite sum of representatives represents the sum. -/ +theorem represents_sum {ι' : Type*} (s : Finset ι') (f : ι' → Series K) (β : NatOrdinal) + (e : ι' → PrincipalSubring K) (h : ∀ i ∈ s, Represents (f i) β (e i)) : + Represents (∑ i ∈ s, f i) β (∑ i ∈ s, e i) := by + classical + induction s using Finset.induction_on with + | empty => rw [Finset.sum_empty, Finset.sum_empty]; exact represents_zero β + | insert a s ha ih => + rw [Finset.sum_insert ha, Finset.sum_insert ha] + exact (h a (Finset.mem_insert_self a s)).add (ih fun i hi ↦ h i (Finset.mem_insert_of_mem hi)) + +/-- **Principal representatives.** Every element of `P_β ⊆ P̂` is represented by a series of +support order type at most `ω^β` whose translated truncations at cutoffs `ζ < 0` have ordinal +value below `ω^β`: a principal series of degree `β`, or `0`. -/ +theorem exists_represents_of_mem_principalGrading {β : NatOrdinal} {e : PrincipalSubring K} + (he : e ∈ principalGrading K β) : + ∃ p : Series K, Represents p β e ∧ (p : K⟦ℝ⟧).supportOrderType ≤ (ω^ β).val ∧ + ∀ ζ : ℝ, ζ < 0 → ordinalValue (translatedTruncation (p : K⟦ℝ⟧) ζ) < ω^ β := by + obtain ⟨a, rfl⟩ := (DirectSum.mem_rangeLof_iff K _ β e).mp he + rw [DirectSum.lof_eq_of] + rcases eq_or_ne a 0 with rfl | ha + · refine ⟨0, by rw [map_zero]; exact represents_zero β, ?_, fun ζ _ ↦ ?_⟩ + · rw [Subring.coe_zero, supportOrderType_eq_setOrderType] + simp only [HahnSeries.support_zero] + rw [(Set.isPWO_empty.orderType_eq_zero).mpr rfl] + exact bot_le + · rw [Subring.coe_zero, translatedTruncation_zero_input, ordinalValue_zero] + exact NatOrdinal.wpow_pos β + · obtain ⟨p, hp, hprin, hdeg, hpa⟩ := exists_principal_representative_of_ne_zero β a ha + exact ⟨p, represents_iff.mpr ⟨hp, by rw [hpa]⟩, + (hprin.supportOrderType_eq_wpow_of_degree_eq hdeg).le, + fun ζ hζ ↦ ordinalValue_translatedTruncation_lt_of_isPrincipal hprin hdeg hζ⟩ + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/SuccessorLeibniz.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/SuccessorLeibniz.lean new file mode 100644 index 0000000000..d7d6719ae5 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/SuccessorLeibniz.lean @@ -0,0 +1,205 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.DerivAt +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalSubring +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.LeibnizRemainder + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Convolution +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValueSubmultiplicative +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValueImage +import Mathlib.Topology.Instances.Real.Lemmas + +/-! +# The Leibniz rule on the spaces `P_α` + +Let `u ∈ J_{ω^(α+1)}` and `v ∈ J_{ω^(β+1)}` with `α` a successor, and put `δ = α + β`, so that +`δ⁻ = α⁻ + β`. Berarducci's convolution formula writes `(uv)^{|γ}` modulo `J` as the finite sum +of the products `u^{|ξ} v^{|ζ}` over `ξ + ζ = γ`. The pairs `(γ, 0)` and `(0, γ)` contribute +`u^{|γ} v` and `u v^{|γ}`; every other pair has `ξ, ζ ∈ (γ, 0)`, and for `γ` close to zero the +truncation drop gives `v_J(u^{|ξ}) ≤ ω^{α⁻}` and `v_J(v^{|ζ}) < ω^β`, so by submultiplicativity +the product has ordinal value below `ω^{α⁻ + β} = ω^{δ⁻}`. Hence + +`(uv)^{|γ} ≡ u^{|γ} v + u v^{|γ} (mod J_{ω^{δ⁻}})` + +for all `γ < 0` close to zero, and in the component `P_{δ⁻}` indexed by the predecessor of `δ` +this reads +`π_{δ⁻}((uv)^{|γ}) = π_{α⁻}(u^{|γ}) π_β(v) + π_α(u) π_{β⁻}(v^{|γ})`, the last term being zero +when `β` is not a successor because its ordinal value then already lies below `ω^{δ⁻}`. +-/ + +open Filter Topology +open scoped HahnSeries NatOrdinal + +universe v + +public noncomputable section + +namespace Berarducci + +open Berarducci HahnSeries + +variable {K : Type v} [Field K] + +/-! ### The identity in the homogeneous component `P_{δ⁻}` -/ + +/-- If `v_J(a - b - c) < ω^δ`, then `π_δ(a) = π_δ(b) + π_δ(c)`. -/ +theorem principalComponentMk_eq_add_of_sub_sub_lt (delta : NatOrdinal) {a b c : Series K} + (ha : ordinalValue a < ω^ (delta + 1)) (hb : ordinalValue b < ω^ (delta + 1)) + (hc : ordinalValue c < ω^ (delta + 1)) (h : ordinalValue (a - b - c) < ω^ delta) : + principalComponentMk delta a ha = + principalComponentMk delta b hb + principalComponentMk delta c hc := by + have hbc : ordinalValue (b + c) < ω^ (delta + 1) := + (ordinalValue_add_le_max b c).trans_lt (max_lt hb hc) + rw [← principalComponentMk_add delta b c hb hc hbc, principalComponentMk_eq_iff] + rwa [sub_add_eq_sub_sub] + +/-- Homogeneous inclusions of the same representative in equal grades agree. -/ +theorem of_principalComponentMk_congr_of_eq + {alpha beta : NatOrdinal} (h : alpha = beta) (b : Series K) + (hb : ordinalValue b < ω^ (beta + 1)) : + DirectSum.of (PrincipalComponent K) beta (principalComponentMk beta b hb) = + DirectSum.of (PrincipalComponent K) alpha + (principalComponentMk alpha b (by rw [h]; exact hb)) := by + subst h + rfl + +/-- Multiplication of homogeneous inclusions is homogeneous multiplication. -/ +theorem of_principalComponentMul {alpha beta : NatOrdinal} + (x : PrincipalComponent K alpha) (y : PrincipalComponent K beta) : + DirectSum.of (PrincipalComponent K) (alpha + beta) (principalComponentMul x y) = + DirectSum.of (PrincipalComponent K) alpha x * DirectSum.of (PrincipalComponent K) beta y := by + rw [principalComponentMul_eq_componentMul, DirectSum.of_mul_of] + rfl + +/-- If `β` is not a successor and `β' < β`, then `α + β' < (α + β)⁻`. -/ +private theorem add_lt_removeOne_add_of_constantCoeff_eq_zero + {alpha beta beta' : NatOrdinal} (halpha : 0 < alpha.constantCoeff) + (hbeta : beta.constantCoeff = 0) (hlt : beta' < beta) : + alpha + beta' < (alpha + beta).removeNat 1 := by + have hpos : 0 < (alpha + beta).constantCoeff := by + rw [NatOrdinal.constantCoeff_add]; omega + have hsucc : (alpha + beta).removeNat 1 + 1 = alpha + beta := by + simpa using NatOrdinal.removeNat_add_natCast hpos + have hle : alpha + beta' ≤ (alpha + beta).removeNat 1 := by + rw [← Order.lt_add_one_iff, hsucc] + exact add_lt_add_right hlt alpha + refine lt_of_le_of_ne hle fun heq ↦ ?_ + have hc := congrArg NatOrdinal.constantCoeff heq + rw [NatOrdinal.constantCoeff_add, NatOrdinal.constantCoeff_removeNat, + NatOrdinal.constantCoeff_add, hbeta] at hc + omega + +/-- For `β` not a successor, the term `u v^{|γ}` vanishes in `P_{(α+β)⁻}` near zero. -/ +theorem eventually_ordinalValue_mul_translatedTruncation_lt_of_constantCoeff_eq_zero + {alpha beta : NatOrdinal} (halpha : 0 < alpha.constantCoeff) + (hbeta : beta.constantCoeff = 0) (u v : Series K) + (hu : ordinalValue u < ω^ (alpha + 1)) (hv : ordinalValue v < ω^ (beta + 1)) : + ∀ᶠ γ in 𝓝[<] (0 : ℝ), + ordinalValue (u * translatedTruncation (v : K⟦ℝ⟧) γ) < ω^ ((alpha + beta).removeNat 1) := by + filter_upwards + [eventually_ordinalValue_translatedTruncation_lt_wpow_of_ordinalValue_lt_wpow_add_one + beta v hv] with γ hγ + have hu' : ordinalValue u ≤ ω^ alpha := by + rcases ordinalValue_eq_zero_or_isAdditivelyPrincipal u with hzero | hprin + · rw [hzero]; exact bot_le + · have hxi := Ordinal.natOrdinal_of_eq_wpow_log hprin + rw [NatOrdinal.of_val] at hxi + rw [hxi] at hu ⊢ + exact NatOrdinal.wpow_le_wpow.mpr (Order.lt_add_one_iff.mp (NatOrdinal.wpow_lt_wpow.mp hu)) + rcases ordinalValue_eq_zero_or_isAdditivelyPrincipal (translatedTruncation (v : K⟦ℝ⟧) γ) with + hzero | hprin + · calc ordinalValue (u * translatedTruncation (v : K⟦ℝ⟧) γ) ≤ + ordinalValue u * ordinalValue (translatedTruncation (v : K⟦ℝ⟧) γ) := + ordinalValue_mul_le_naturalMul _ _ + _ = 0 := by rw [hzero, mul_zero] + _ < _ := NatOrdinal.wpow_pos _ + · have hxi := Ordinal.natOrdinal_of_eq_wpow_log hprin + rw [NatOrdinal.of_val] at hxi + set beta' := + NatOrdinal.of (Ordinal.log Ordinal.omega0 (ordinalValue (translatedTruncation (v : K⟦ℝ⟧) + γ)).val) + rw [hxi] at hγ + have hlt : beta' < beta := NatOrdinal.wpow_lt_wpow.mp hγ + calc ordinalValue (u * translatedTruncation (v : K⟦ℝ⟧) γ) ≤ + ordinalValue u * ordinalValue (translatedTruncation (v : K⟦ℝ⟧) γ) := + ordinalValue_mul_le_naturalMul _ _ + _ ≤ ω^ alpha * ω^ beta' := by rw [hxi]; exact mul_le_mul_left hu' _ + _ = ω^ (alpha + beta') := (NatOrdinal.wpow_add alpha beta').symm + _ < ω^ ((alpha + beta).removeNat 1) := + NatOrdinal.wpow_lt_wpow.mpr + (add_lt_removeOne_add_of_constantCoeff_eq_zero halpha hbeta hlt) + +/-- **Leibniz identity on representatives, both grades successors.** In `P̂`, near zero, +`π_{δ⁻}((uv)^{|γ}) = π_{α⁻}(u^{|γ}) π_β(v) + π_α(u) π_{β⁻}(v^{|γ})` with `δ = α + β`. -/ +theorem eventually_of_derivAt_mul_of_pos {alpha beta : NatOrdinal} + (halpha : 0 < alpha.constantCoeff) (hbeta : 0 < beta.constantCoeff) + (u v : Series K) (hu : ordinalValue u < ω^ (alpha + 1)) (hv : ordinalValue v < ω^ (beta + 1)) : + ∀ᶠ γ in 𝓝[<] (0 : ℝ), + DirectSum.of (PrincipalComponent K) ((alpha + beta).removeNat 1) + (derivAt (alpha + beta) (u * v) γ) = + DirectSum.of (PrincipalComponent K) (alpha.removeNat 1) (derivAt alpha u γ) * + DirectSum.of (PrincipalComponent K) beta (principalComponentMk beta v hv) + + DirectSum.of (PrincipalComponent K) alpha (principalComponentMk alpha u hu) * + DirectSum.of (PrincipalComponent K) (beta.removeNat 1) + (derivAt beta v γ) := by + have hsum : 0 < (alpha + beta).constantCoeff := by + rw [NatOrdinal.constantCoeff_add]; omega + have huv : ordinalValue (u * v) < ω^ (alpha + beta + 1) := ordinalValue_mul_lt_wpow_add_one hu hv + filter_upwards [eventually_derivAt_eq_principalComponentMk alpha halpha u hu, + eventually_derivAt_eq_principalComponentMk beta hbeta v hv, + eventually_derivAt_eq_principalComponentMk (alpha + beta) hsum (u * v) huv, + eventually_ordinalValue_leibnizRemainder_lt halpha u v hu hv] with γ ⟨hγu, hcu⟩ ⟨hγv, hcv⟩ + ⟨hγuv, hcuv⟩ hrem + have h1 : (alpha + beta).removeNat 1 = alpha.removeNat 1 + beta := + NatOrdinal.removeOne_add_right alpha beta halpha + have h2 : (alpha + beta).removeNat 1 = alpha + beta.removeNat 1 := by + rw [add_comm, NatOrdinal.removeOne_add_right beta alpha hbeta, add_comm] + rw [hcu, hcv, hcuv, ← of_principalComponentMul, ← of_principalComponentMul, + principalComponentMul_mk, principalComponentMul_mk, of_principalComponentMk_congr_of_eq h1, + of_principalComponentMk_congr_of_eq h2, ← map_add] + congr 1 + apply principalComponentMk_eq_add_of_sub_sub_lt + rw [h1] + exact hrem + +/-- **Leibniz identity on representatives, `β` not a successor.** In `P̂`, near zero, +`π_{δ⁻}((uv)^{|γ}) = π_{α⁻}(u^{|γ}) π_β(v)` with `δ = α + β`; the term `u v^{|γ}` vanishes in +`P_{δ⁻}`. -/ +theorem eventually_of_derivAt_mul_of_eq_zero {alpha beta : NatOrdinal} + (halpha : 0 < alpha.constantCoeff) (hbeta : beta.constantCoeff = 0) + (u v : Series K) (hu : ordinalValue u < ω^ (alpha + 1)) (hv : ordinalValue v < ω^ (beta + 1)) : + ∀ᶠ γ in 𝓝[<] (0 : ℝ), + DirectSum.of (PrincipalComponent K) ((alpha + beta).removeNat 1) + (derivAt (alpha + beta) (u * v) γ) = + DirectSum.of (PrincipalComponent K) (alpha.removeNat 1) (derivAt alpha u γ) * + DirectSum.of (PrincipalComponent K) beta (principalComponentMk beta v hv) := by + have hsum : 0 < (alpha + beta).constantCoeff := by + rw [NatOrdinal.constantCoeff_add]; omega + have huv : ordinalValue (u * v) < ω^ (alpha + beta + 1) := ordinalValue_mul_lt_wpow_add_one hu hv + filter_upwards [eventually_derivAt_eq_principalComponentMk alpha halpha u hu, + eventually_derivAt_eq_principalComponentMk (alpha + beta) hsum (u * v) huv, + eventually_ordinalValue_leibnizRemainder_lt halpha u v hu hv, + eventually_ordinalValue_mul_translatedTruncation_lt_of_constantCoeff_eq_zero halpha hbeta u v + hu hv] + with γ ⟨hγu, hcu⟩ ⟨hγuv, hcuv⟩ hrem hlimit + have h1 : (alpha + beta).removeNat 1 = alpha.removeNat 1 + beta := + NatOrdinal.removeOne_add_right alpha beta halpha + rw [hcu, hcuv, ← of_principalComponentMul, principalComponentMul_mk, + of_principalComponentMk_congr_of_eq h1] + congr 1 + rw [principalComponentMk_eq_iff] + have hsplit : translatedTruncation ((u * v : Series K) : K⟦ℝ⟧) γ - translatedTruncation (u : + K⟦ℝ⟧) γ * v = + (translatedTruncation ((u * v : Series K) : K⟦ℝ⟧) γ - translatedTruncation (u : K⟦ℝ⟧) γ * v - + u * translatedTruncation (v : K⟦ℝ⟧) γ) + u * translatedTruncation (v : K⟦ℝ⟧) γ := by + abel + rw [hsplit] + exact (ordinalValue_add_le_max _ _).trans_lt (max_lt (h1 ▸ hrem) hlimit) + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/SuccessorSupportBound.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/SuccessorSupportBound.lean new file mode 100644 index 0000000000..160789af33 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/SuccessorSupportBound.lean @@ -0,0 +1,338 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.TruncationsIdeal +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.Shift +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.GradedRing.HomogeneousSpan + +/-! +# Lowering the order type of the support below `ω^(τ+1)` + +Let the polynomials `q j ∈ K[X]` be homogeneous of degrees `c j` (the degrees `σ_j` of the +generators) that are zero or limits, with `b j ⊕ c j = τ + 1` (`b j` the cofactor degrees `ρ_j`), +and let the separation condition (n) hold for every `(b j, c j, τ)`: `b j ⊕ θ < τ` for every +`θ < c j`. Let `τ + 1 < α` and assume evaluation injective below `α`. Let `D` be a series whose +support has order type below `ω^(τ+2)` and whose translated truncations `D^{|ξ}`, `ξ ≤ 0`, +satisfy (p) for `(q_1, …, q_m; τ)`: above the degree `τ`, the polynomial of every translated +truncation of `D` lies in the ideal `(q_1, …, q_m)`. + +The cutoffs `ξ` at which the ordinal value of `D` is at least `ω^(τ+1)` are finitely many. At +each of them the class of `D^{|ξ}` in `P_{τ+1}` lies in the ideal `(q_1(𝓑), …, q_m(𝓑))` — ideal +membership of a class from the condition (p) on its translated truncations, in degree `τ + 1` +(`of_principalComponentMk_mem_span_of_forall_componentsGE_mem`) — so +`D^{|ξ} ≡ ∑_j u_{ξj} · q_j(b_𝓑)` +modulo `J_{ω^(τ+1)}` with `u_{ξj}` principal representatives of classes in `P_{b j}`; subtract the +terms `t^ξ u_{ξj} · q_j(b_𝓑)`. Every translated truncation of the result has ordinal value below +`ω^(τ+1)`: at `ξ` the class vanishes, and the other terms contribute translated truncations of +`u_{ξj} · q_j(b_𝓑)` at cutoffs `ζ < 0` (of ordinal value below `ω^(τ+1)`) or elements of `J`; at +every other cutoff `D^{|ζ}` itself has ordinal value below `ω^(τ+1)`. Hence the support of the +result has order type below `ω^(τ+1)`, and the cofactors `∑_ξ t^ξ u_{ξj}` have support of order +type below `ω^(b j + 1)`. +-/ + +universe v w + +open scoped NatOrdinal HahnSeries +open Berarducci HahnSeries MvPolynomial DirectSum OrdinalGraded + +public noncomputable section + +namespace Berarducci + +variable {K : Type v} [Field K] + +/-- **Finiteness of translated truncations above an ordinal-value bound.** The cutoffs `ξ ≤ 0` +at which the ordinal value of `d^{|ξ}` is at least `ω^ρ` are finite when the support of `d` has +order type below `ω^(ρ+1)`. -/ +@[blueprint "lem:successor-large-truncations-finite" + (phase := "Limit ordinals in the degree induction") + (title := "Finiteness of translated truncations above an ordinal-value bound") + (statement := /-- + Let $K$ be a field, let $d\in\Kser$, and let $\rho<\omega_1$. If + \[ + \ot(\supp d)<\omega^{\rho+1}, + \] + then the set + \[ + \{\xi\le0:\vJ(\trunc d\xi)\ge\omega^\rho\} + \] + is finite. + -/) + (proof := /-- + Among negative cutoffs, infinitely many such points would contain a strictly + increasing sequence. The support in every interval between consecutive + points would have order type at least $\omega^\rho$, so these disjoint + successive blocks would force the support at or below $0$ to have order type + at least $\omega^\rho\cdot\omega=\omega^{\rho+1}$, a contradiction. Adding + the possible cutoff $0$ preserves finiteness. + -/)] +theorem finite_setOf_wpow_le_ordinalValue_translatedTruncation {ρ : NatOrdinal} (D : Series K) + (hD : (D : K⟦ℝ⟧).supportOrderType < (ω^ (ρ + 1)).val) : + {ξ : ℝ | ξ ≤ 0 ∧ ω^ ρ ≤ ordinalValue (translatedTruncation (D : K⟦ℝ⟧) ξ)}.Finite := by + refine ((cutoffsGE_finite_of_supportOrderType_lt D hD).union (Set.finite_singleton 0)).subset + fun ξ ⟨hξ, h⟩ ↦ ?_ + rcases hξ.lt_or_eq with hlt | rfl + · exact Or.inl (mem_cutoffsGE_iff.mpr ⟨hlt, h⟩) + · exact Or.inr rfl + +/-- Below a point, a finite set of reals leaves a gap. -/ +theorem exists_pos_forall_le_sub_of_finite {S : Set ℝ} (hS : S.Finite) (ξ : ℝ) : + ∃ ε > 0, ∀ ξ' ∈ S, ξ' < ξ → ξ' ≤ ξ - ε := by + classical + set T := hS.toFinset.filter (· < ξ) with hTdef + by_cases hT : T.Nonempty + · refine ⟨ξ - T.max' hT, ?_, fun ξ' hξ' hlt ↦ ?_⟩ + · have := (Finset.mem_filter.mp (T.max'_mem hT)).2 + linarith + · have : ξ' ≤ T.max' hT := + T.le_max' ξ' (Finset.mem_filter.mpr ⟨hS.mem_toFinset.mpr hξ', hlt⟩) + linarith + · refine ⟨1, one_pos, fun ξ' hξ' hlt ↦ ?_⟩ + exact absurd ⟨ξ', Finset.mem_filter.mpr ⟨hS.mem_toFinset.mpr hξ', hlt⟩⟩ hT + +variable {ι : Type w} {wt : ι → NatOrdinal} {x : ι → PrincipalSubring K} + +namespace Lifts + +variable (σ : Lifts wt x) (hx : IsMinimalSystem (principalGrading K) wt x) {α : NatOrdinal} + (hinj : ∀ β < α, InjectiveAt K wt x β) +include hinj + +/-- **The class of `D^{|ξ}` modulo `J_{ω^(τ+1)}`.** If the translated truncations of `D` satisfy +(p) for `(q_1, …, q_m; τ)` and those at the cutoffs of some interval `(ξ - ε, ξ)`, `ξ ≤ 0`, have +ordinal value below `ω^(τ+1)`, then `D^{|ξ}` is, modulo `J_{ω^(τ+1)}`, a combination +`∑_j w_j · q_j(b_𝓑)` in which each `w j` has ordinal value below `ω^(b j + 1)`, support of order +type at most `ω^(b j)` and translated truncations at cutoffs `ζ < 0` of ordinal value below +`ω^(b j)` (a principal representative of a class in `P_{b j}`, or zero). -/ +theorem exists_forall_ordinalValue_translatedTruncation_sub_sum_mul_aeval_lt {ι' : Type*} + [Fintype ι'] {q : ι' → MvPolynomial ι K} {c : ι' → NatOrdinal} + (hq : ∀ j, IsWeightedHomogeneous wt (q j) (c j)) (hc : ∀ j, (c j).constantCoeff = 0) + {τ : NatOrdinal} (hτ : τ + 1 < α) {b : ι' → NatOrdinal} (hb : ∀ j, b j + c j = τ + 1) + {D : Series K} (hD : (D : K⟦ℝ⟧).supportOrderType < (ω^ (τ + 1 + 1)).val) + (htrunc : ∀ ξ : ℝ, ξ ≤ 0 → + componentsGE wt τ (σ.pol hx α (translatedTruncation (D : K⟦ℝ⟧) ξ)) ∈ + Ideal.span (Set.range q)) + {ξ : ℝ} (hξ : ξ ≤ 0) {ε : ℝ} (hε : 0 < ε) (hgap : ∀ δ : ℝ, -ε < δ → δ < 0 → + ordinalValue (translatedTruncation (D : K⟦ℝ⟧) (ξ + δ)) < ω^ (τ + 1)) : + ∃ w : ι' → Series K, (∀ j, ((w j : Series K) : K⟦ℝ⟧).supportOrderType ≤ (ω^ (b j)).val) ∧ + (∀ j, ∀ ζ : ℝ, ζ < 0 → ordinalValue (translatedTruncation (w j : K⟦ℝ⟧) ζ) < ω^ (b j)) ∧ + (∀ j, ordinalValue (w j) < ω^ (b j + 1)) ∧ + ordinalValue (translatedTruncation (D : K⟦ℝ⟧) ξ - ∑ j, w j * aeval σ.lift (q j)) < + ω^ (τ + 1) := by + classical + have hu : ordinalValue (translatedTruncation (D : K⟦ℝ⟧) ξ) < ω^ (τ + 1 + 1) := + ordinalValue_translatedTruncation_lt_of_supportOrderType_lt hD ξ + -- the class of `D^{|ξ}` lies in the ideal + have hmem := σ.of_principalComponentMk_mem_span_of_forall_componentsGE_mem hx hinj hq hc hτ hu hε + (fun δ h1 h2 ↦ by + rw [translatedTruncation_translatedTruncation _ _ h2.le] + exact hgap δ h1 h2) + (fun δ h1 h2 ↦ by + rw [translatedTruncation_translatedTruncation _ _ h2.le] + exact htrunc (ξ + δ) (by linarith)) + have hq' : ∀ j, aeval x (q j) ∈ principalGrading K (c j) := + fun j ↦ aeval_mem_of_forall_mem hx.mem (hq j) + obtain ⟨w', hw', -, hsum⟩ := OrdinalGraded.exists_eq_sum_mul_of_mem_span + (𝒜 := principalGrading K) hq' (of_mem_principalGrading _ _) hmem + -- principal representatives of the cofactors + have hrep : ∀ j, ∃ p : Series K, Represents p (b j) (w' j) ∧ + (p : K⟦ℝ⟧).supportOrderType ≤ (ω^ (b j)).val ∧ + ∀ ζ : ℝ, ζ < 0 → ordinalValue (translatedTruncation (p : K⟦ℝ⟧) ζ) < ω^ (b j) := + fun j ↦ exists_represents_of_mem_principalGrading (hw' j (b j) (hb j)) + choose w hwrep hwot hwcut using hrep + refine ⟨w, hwot, hwcut, fun j ↦ (hwrep j).ordinalValue_lt, ?_⟩ + -- both `D^{|ξ}` and `∑_j w_j · q_j(b_𝓑)` represent the same class + have hrepS : Represents (∑ j, w j * aeval σ.lift (q j)) (τ + 1) + (∑ j, w' j * aeval x (q j)) := + represents_sum _ _ _ _ fun j _ ↦ ((hwrep j).mul (σ.aeval_represents (hq j))).of_eq (hb j) + have hX : DirectSum.of (PrincipalComponent K) (τ + 1) + (principalComponentMk (τ + 1) (translatedTruncation (D : K⟦ℝ⟧) ξ) hu) = + ∑ j, w' j * aeval x (q j) := by + rw [hsum] + exact Finset.sum_congr rfl fun j _ ↦ mul_comm _ _ + have hmk := DirectSum.of_injective (τ + 1) (hX.trans hrepS.of_principalComponentMk.symm) + exact (principalComponentMk_eq_iff _ _ _ hu hrepS.ordinalValue_lt).mp hmk + +variable (hσ : σ.IsPrincipal) +include hσ + +/-- **Support-order reduction at a successor degree.** For weighted homogeneous `q j` of degrees +`c j` that are zero or limits, suppose `b j ⊕ c j = τ + 1` and +`b j ⊕ θ < τ` whenever `θ < c j`. If `τ + 1 < α`, the chosen representatives are principal, +the support of `D` has order type below `ω^(τ+2)`, and every translated truncation has its +degree-at-least-`τ` polynomial part in `(q_1, …, q_m)`, then suitable cofactors lower the support +order type of the remainder below `ω^(τ+1)`. -/ +@[blueprint "lem:successor-support-lowering" + (phase := "Limit ordinals in the degree induction") + (title := "Support-order reduction at a successor degree") + (statement := /-- + Let $K$ be a field, let $(x_i)_{i\in I}$ be a minimal homogeneous + generating system of $\Ph$, with $x_i\in\Prin_{w_i}$, and choose principal + series $b_i$ representing the $x_i$. Fix $\alpha<\omega_1$, and assume + that evaluation at $(x_i)$ is injective in every weighted degree below + $\alpha$. + + Let $Q_1,\ldots,Q_m\in K[X_i:i\in I]$ be weighted homogeneous of degrees + $\sigma_1,\ldots,\sigma_m$, each a limit ordinal or $0$. Let + $\rho_1,\ldots,\rho_m$ and $\tau$ satisfy + \[ + \rho_j\nsum\sigma_j=\tau+1,\qquad + \rho_j\nsum\theta<\tau\quad(\theta<\sigma_j),\qquad + \tau+1<\alpha. + \] + Let $d\in\Kser$ satisfy + $\ot(\supp d)<\omega^{\tau+2}$, and suppose that, for every $\xi\le0$, + \[ + \partGE{\pol(\trunc d\xi)}{\tau}\in(Q_1,\ldots,Q_m). + \] + Then there are $u_1,\ldots,u_m\in\Kser$ such that + $\ot(\supp u_j)<\omega^{\rho_j+1}$ for every $j$ and + \[ + \ot\!\left(\supp\left(d-\sum_j u_jQ_j(b_i)\right)\right) + <\omega^{\tau+1}. + \] + -/) + (proof := /-- + By \ref{lem:successor-large-truncations-finite}, the set $L$ of cutoffs + $\xi\le0$ for which $\vJ(\trunc d\xi)\ge\omega^{\tau+1}$ is finite. For + each $\xi\in L$, choose an interval immediately below $\xi$ containing no + other point of $L$. Applying \ref{lem:lower-below-successor} to + $\trunc d\xi$ places its class in $\Prin_{\tau+1}$ in the ideal generated + by the $Q_j(x_i)$. By + \ref{lem:homogeneous-element-of-generated-ideal}, there are cofactor classes + of degrees $\rho_j$; choose principal representatives $w_{\xi j}$, shift them + to $\xi$, and sum over the finite set $L$. + + At a cutoff in $L$, the term placed there cancels its class. At every other + placement, the translated truncation either lies in $J$, because its cutoff + is positive, or is a proper translated truncation bounded by + \ref{lem:principal-representatives-homogeneous-polynomial-truncation} and the + separation hypothesis. Thus every translated truncation of the remainder + has ordinal value below $\omega^{\tau+1}$. + By \ref{cor:small-truncations-small-support}, its support has order type + below $\omega^{\tau+1}$. Each $u_j$ is a finite sum of shifts of series with + support order type at most $\omega^{\rho_j}$, so its support has order type + below $\omega^{\rho_j+1}$. + -/)] +theorem IsPrincipal.exists_supportOrderType_sub_sum_mul_aeval_lt {ι' : Type*} [Fintype ι'] + {q : ι' → MvPolynomial ι K} {c : ι' → NatOrdinal} + (hq : ∀ j, IsWeightedHomogeneous wt (q j) (c j)) (hc : ∀ j, (c j).constantCoeff = 0) + {τ : NatOrdinal} (hτ : τ + 1 < α) {b : ι' → NatOrdinal} (hb : ∀ j, b j + c j = τ + 1) + (hsep : ∀ j, ∀ θ, θ < c j → b j + θ < τ) + {D : Series K} (hD : (D : K⟦ℝ⟧).supportOrderType < (ω^ (τ + 1 + 1)).val) + (htrunc : ∀ ξ : ℝ, ξ ≤ 0 → + componentsGE wt τ (σ.pol hx α (translatedTruncation (D : K⟦ℝ⟧) ξ)) ∈ + Ideal.span (Set.range q)) : + ∃ u : ι' → Series K, (∀ j, ((u j : Series K) : K⟦ℝ⟧).supportOrderType < (ω^ (b j + 1)).val) ∧ + ((D - ∑ j, u j * aeval σ.lift (q j) : Series K) : K⟦ℝ⟧).supportOrderType < + (ω^ (τ + 1)).val := by + classical + have hwt : ∀ i, wt i ≠ 0 := hx.ne_zero + -- the cutoffs at which the ordinal value of `D` is at least `ω^(τ+1)` + set L : Set ℝ := {ξ | ξ ≤ 0 ∧ ω^ (τ + 1) ≤ ordinalValue (translatedTruncation (D : K⟦ℝ⟧) ξ)} + with hLdef + have hL : L.Finite := finite_setOf_wpow_le_ordinalValue_translatedTruncation D hD + have hmemL : ∀ ξ, ξ ∈ hL.toFinset ↔ + ξ ≤ 0 ∧ ω^ (τ + 1) ≤ ordinalValue (translatedTruncation (D : K⟦ℝ⟧) ξ) := + fun ξ ↦ hL.mem_toFinset + -- at each of them, representatives of the cofactors of its class + have hpt : ∀ ξ ∈ hL.toFinset, ∃ w : ι' → Series K, + (∀ j, ((w j : Series K) : K⟦ℝ⟧).supportOrderType ≤ (ω^ (b j)).val) ∧ + (∀ j, ∀ ζ : ℝ, ζ < 0 → ordinalValue (translatedTruncation (w j : K⟦ℝ⟧) ζ) < ω^ (b j)) ∧ + (∀ j, ordinalValue (w j) < ω^ (b j + 1)) ∧ + ordinalValue (translatedTruncation (D : K⟦ℝ⟧) ξ - ∑ j, w j * aeval σ.lift (q j)) < + ω^ (τ + 1) := by + intro ξ hξ + obtain ⟨hξ0, -⟩ := (hmemL ξ).mp hξ + obtain ⟨ε, hε, hgap⟩ := exists_pos_forall_le_sub_of_finite hL ξ + refine σ.exists_forall_ordinalValue_translatedTruncation_sub_sum_mul_aeval_lt hx hinj hq hc hτ + hb hD htrunc hξ0 hε fun δ h1 h2 ↦ ?_ + by_contra hge + rw [not_lt] at hge + have : ξ + δ ∈ L := ⟨by linarith, hge⟩ + have := hgap _ this (by linarith) + linarith + choose! w hw using hpt + -- the cofactors + refine ⟨fun j ↦ ∑ ξ ∈ hL.toFinset, shift ξ (w ξ j), fun j ↦ ?_, ?_⟩ + · refine supportOrderType_sum_lt_wpow _ _ fun ξ hξ ↦ ?_ + rw [supportOrderType_shift ((hmemL ξ).mp hξ).1] + exact ((hw ξ hξ).1 j).trans_lt (NatOrdinal.val.lt_iff_lt.mpr + (NatOrdinal.wpow_lt_wpow.mpr (lt_add_one _))) + -- the corrected series and its translated truncations + have heq : (D - ∑ j, (∑ ξ ∈ hL.toFinset, shift ξ (w ξ j)) * aeval σ.lift (q j) : Series K) = + D - ∑ ξ ∈ hL.toFinset, ∑ j, shift ξ (w ξ j * aeval σ.lift (q j)) := by + congr 1 + rw [Finset.sum_comm] + refine Finset.sum_congr rfl fun j _ ↦ ?_ + rw [Finset.sum_mul] + exact Finset.sum_congr rfl fun ξ hξ ↦ shift_mul ((hmemL ξ).mp hξ).1 _ _ + beta_reduce + rw [heq] + have hcut : ∀ ζ : ℝ, + translatedTruncation ((D - ∑ ξ ∈ hL.toFinset, ∑ j, shift ξ (w ξ j * aeval σ.lift (q j)) : + Series K) : K⟦ℝ⟧) ζ = + translatedTruncation (D : K⟦ℝ⟧) ζ - ∑ ξ ∈ hL.toFinset, ∑ j, + translatedTruncation ((w ξ j * aeval σ.lift (q j) : Series K) : K⟦ℝ⟧) (ζ - ξ) := by + intro ζ + rw [← translatedTruncationAddMonoidHom_apply, AddSubgroupClass.coe_sub, map_sub, + AddSubmonoidClass.coe_finsetSum, map_sum, translatedTruncationAddMonoidHom_apply ζ (D : K⟦ℝ⟧), + sub_right_inj] + refine Finset.sum_congr rfl fun ξ hξ ↦ ?_ + rw [AddSubmonoidClass.coe_finsetSum, map_sum] + refine Finset.sum_congr rfl fun j _ ↦ ?_ + rw [translatedTruncationAddMonoidHom_apply, translatedTruncation_shift ((hmemL ξ).mp hξ).1] + -- every translated truncation of the corrected series has value below `ω^(τ+1)` + refine supportOrderType_lt_of_forall_ordinalValue_translatedTruncation_lt _ + (lt_of_le_of_lt zero_le (lt_add_one τ)).ne' fun ζ hζ ↦ ?_ + rw [hcut ζ] + -- the terms placed at cutoffs other than `ζ` have small translated truncations at `ζ` + have hblock : ∀ ξ ∈ hL.toFinset, ξ ≠ ζ → ∀ j, + ordinalValue (translatedTruncation ((w ξ j * aeval σ.lift (q j) : Series K) : K⟦ℝ⟧) (ζ - ξ)) + < ω^ (τ + 1) := by + intro ξ hξ hne j + rcases lt_or_gt_of_ne hne with hlt | hgt + · -- `ζ - ξ > 0`: the translated truncation lies in `J` + rw [ordinalValue_translatedTruncation_eq_zero_of_forall_support_le (s := 0) + (fun y hy ↦ Nonpositive.support_subset _ hy) (by linarith)] + exact NatOrdinal.wpow_pos _ + · -- `ζ - ξ < 0`: a translated truncation of `w_{ξj} · q_j(b_𝓑)` at a cutoff below `0` + exact hσ.ordinalValue_translatedTruncation_mul_aeval_lt hwt (hq j) ((hw ξ hξ).2.2.1 j) + ((hw ξ hξ).2.1 j) (hb j) (lt_add_one τ).le (hsep j) (by linarith) + have hsmall : ∀ (s : Finset ℝ), (∀ ξ ∈ s, ξ ≠ ζ) → s ⊆ hL.toFinset → + ordinalValue (∑ ξ ∈ s, ∑ j, + translatedTruncation ((w ξ j * aeval σ.lift (q j) : Series K) : K⟦ℝ⟧) (ζ - ξ)) < + ω^ (τ + 1) := fun s hs hsub ↦ + ordinalValue_sum_lt _ _ (NatOrdinal.wpow_pos _) fun ξ hξ ↦ + ordinalValue_sum_lt _ _ (NatOrdinal.wpow_pos _) fun j _ ↦ hblock ξ (hsub hξ) (hs ξ hξ) j + by_cases hζL : ζ ∈ hL.toFinset + · -- at a cutoff where the ordinal value of `D` reaches `ω^(τ+1)`: the class vanishes + rw [← Finset.add_sum_erase _ _ hζL, ← sub_sub] + have h1 := (hw ζ hζL).2.2.2 + have h2 := hsmall (hL.toFinset.erase ζ) (fun ξ hξ ↦ (Finset.mem_erase.mp hξ).1) + (Finset.erase_subset _ _) + have h3 : ∑ j, translatedTruncation ((w ζ j * aeval σ.lift (q j) : Series K) : K⟦ℝ⟧) (ζ - ζ) = + ∑ j, w ζ j * aeval σ.lift (q j) := by + refine Finset.sum_congr rfl fun j _ ↦ ?_ + rw [sub_self, translatedTruncation_zero] + rw [h3, sub_eq_add_neg _ (∑ ξ ∈ _, _)] + refine (ordinalValue_add_le_max _ _).trans_lt (max_lt h1 ?_) + rwa [ordinalValue_neg] + · -- elsewhere `D^{|ζ}` is small + have h1 : ordinalValue (translatedTruncation (D : K⟦ℝ⟧) ζ) < ω^ (τ + 1) := by + by_contra hge + rw [not_lt] at hge + exact hζL ((hmemL ζ).mpr ⟨hζ, hge⟩) + have h2 := hsmall hL.toFinset (fun ξ hξ hne ↦ hζL (hne ▸ hξ)) subset_rfl + rw [sub_eq_add_neg] + refine (ordinalValue_add_le_max _ _).trans_lt (max_lt h1 ?_) + rwa [ordinalValue_neg] + +end Lifts + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/SumAlongCutoffs.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/SumAlongCutoffs.lean new file mode 100644 index 0000000000..ad5f924c1b --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/SumAlongCutoffs.lean @@ -0,0 +1,378 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalComponent +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Truncation +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.TruncationDrop +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.IncreasingSequenceUnion +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Translation +public import Mathlib.RingTheory.HahnSeries.Summable +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Germ +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValueDegree +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.PrincipalAddition +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.TruncationPolynomial + +/-! +# Sums along a sequence of cutoffs: prescribed classes at prescribed cutoffs + +Given series `w_k`, negative reals `c_k` and cutoffs `γ_k`, their *sum along the sequence of +cutoffs* `γ_k` is + + `s = ∑_k (w_k)_{>c_k} t^{γ_k}`, `γ_0 < γ_1 < ⋯ < 0`, `sup_k γ_k = 0`, `c_k < 0`, + `γ_k ≤ γ_{k+1} + c_{k+1}`, + +whose `k`-th term `(w_k)_{>c_k} t^{γ_k}` (`placedTerm w c γ k`) places the upper truncation +`(w_k)_{>c_k}` [LM24, Def. 3.2.2] at `γ_k`. The intervals `(γ_k + c_k, γ_k]` are pairwise disjoint +and increasing, so the supports of the terms form an increasing sequence of well-ordered sets and +their union is well ordered ([Ber00, Lem. 4.1] is the two-set case); on `(γ_k + c_k, γ_k]` the +coefficients of `s` are those of the `k`-th term, and off these intervals they vanish +(`sumAlongCutoffs`). This is the construction behind Berarducci's "hyper-series" [Ber00, §6]. + +Let `δ` be an ordinal, `γ_0 < γ_1 < ⋯ < 0` cutoffs with supremum `0`, and `a_k ∈ P_δ` classes. +There is a series `s ∈ J_{ω^(δ+2)}` whose translated truncation at `γ_k` represents `a_k` in `P_δ` +for every `k`, and whose translated truncation at every other cutoff `ξ ∈ (γ_0, 0)` has ordinal +value below `ω^δ` (`exists_sumAlongCutoffs`): choose principal representatives `w_k` of the `a_k`, +choose `c_k < 0` so close to `0` that the translated truncations of `w_k` at the cutoffs in +`(c_k, 0)` have ordinal value below `ω^δ` and that `γ_k ≤ γ_{k+1} + c_{k+1}`, and take this sum. +Its support is the union of an increasing sequence of sets of order type at most `ω^δ`, hence has +order type at most `ω^δ · ω = ω^(δ+1)`. + +Read through the derivation `∂` on `P_{δ+1}`, this says that every function at `0⁻` with values in +`P_δ` vanishing outside a sequence `γ_k ↑ 0` is a derivative. +-/ + +universe v + +open scoped NatOrdinal HahnSeries +open Berarducci HahnSeries + +public noncomputable section + +namespace Berarducci + +variable {K : Type v} [Field K] + +/-! ### The terms of a sum along cutoffs -/ + +/-- The `k`-th term `(w_k)_{>c_k} t^{γ_k}` of the sum along cutoffs: the part of +`w k` with exponents in `(c k, 0]`, placed at `γ k`. -/ +def placedTerm (w : ℕ → Series K) (c γ : ℕ → ℝ) (k : ℕ) : K⟦ℝ⟧ := + HahnSeries.translate (γ k) (truncGT (c k) (w k : K⟦ℝ⟧)) + +theorem coeff_placedTerm (w : ℕ → Series K) (c γ : ℕ → ℝ) (k : ℕ) (x : ℝ) : + (placedTerm w c γ k).coeff x = if c k < x - γ k then (w k : K⟦ℝ⟧).coeff (x - γ k) else 0 := by + rw [placedTerm, coeff_translate] + split_ifs with h + · exact coeff_truncGT_of_lt h _ + · exact coeff_truncGT_of_le (not_lt.mp h) _ + +/-- The support of the `k`-th term lies in `(γ k + c k, γ k]`. -/ +theorem support_placedTerm_subset (w : ℕ → Series K) (c γ : ℕ → ℝ) (k : ℕ) : + (placedTerm w c γ k).support ⊆ Set.Ioc (γ k + c k) (γ k) := by + intro x hx + rw [HahnSeries.mem_support, coeff_placedTerm] at hx + split_ifs at hx with h + · have hle : x - γ k ≤ 0 := + HahnSeries.Nonpositive.support_subset (w k) ((HahnSeries.mem_support _ _).mpr hx) + exact ⟨by linarith, by linarith⟩ + · exact absurd rfl hx + +/-- The support of a term in the sum along cutoffs is partially well ordered. -/ +theorem support_placedTerm_isPWO (w : ℕ → Series K) (c γ : ℕ → ℝ) (k : ℕ) : + (placedTerm w c γ k).support.IsPWO := + (placedTerm w c γ k).isPWO_support + +/-- The order type of the support of the `k`-th term is at most that of `w k`. -/ +theorem supportOrderType_placedTerm_le (w : ℕ → Series K) (c γ : ℕ → ℝ) (k : ℕ) : + (placedTerm w c γ k).supportOrderType ≤ (w k : K⟦ℝ⟧).supportOrderType := by + rw [placedTerm, supportOrderType_translate, supportOrderType_eq_setOrderType, + supportOrderType_eq_setOrderType] + exact Set.IsPWO.orderType_mono _ _ (support_truncGT_subset (c k) (w k : K⟦ℝ⟧)) + +section Family + +variable (w : ℕ → Series K) (c γ : ℕ → ℝ) (hγ : StrictMono γ) + (hdisj : ∀ k, γ k ≤ γ (k + 1) + c (k + 1)) +include hγ hdisj + +/-- The intervals `(γ k + c k, γ k]` are pairwise disjoint and increasing. -/ +theorem placedTerm_interval_lt {j k : ℕ} (hjk : j < k) {x y : ℝ} + (hx : x ∈ Set.Ioc (γ j + c j) (γ j)) + (hy : y ∈ Set.Ioc (γ k + c k) (γ k)) : x < y := by + have h1 : γ j ≤ γ (k - 1) := hγ.monotone (by omega) + have h2 : γ (k - 1) ≤ γ k + c k := by + have := hdisj (k - 1) + rwa [Nat.sub_add_cancel (by omega : 1 ≤ k)] at this + linarith [hx.2, hy.1] + +/-- The supports of the terms form an increasing sequence of sets: for `j < k`, every point of +the support of the `j`-th term lies below every point of the support of the `k`-th. -/ +theorem placedTerm_support_lt {j k : ℕ} (hjk : j < k) {x y : ℝ} + (hx : x ∈ (placedTerm w c γ j).support) + (hy : y ∈ (placedTerm w c γ k).support) : x < y := + placedTerm_interval_lt c γ hγ hdisj hjk (support_placedTerm_subset w c γ j hx) + (support_placedTerm_subset w c γ k hy) + +/-- The terms in the sum along cutoffs form a summable family. -/ +def placedTerms : SummableFamily ℝ K ℕ where + toFun := placedTerm w c γ + isPWO_iUnion_support' := + Set.IsPWO.iUnion_of_ordered (fun k ↦ support_placedTerm_isPWO w c γ k) + fun j k hjk x hx y hy ↦ placedTerm_support_lt w c γ hγ hdisj hjk hx hy + finite_co_support' x := by + refine Set.Subsingleton.finite fun j hj k hk ↦ ?_ + by_contra hne + rcases Ne.lt_or_gt hne with h | h + · exact (placedTerm_support_lt w c γ hγ hdisj h hj hk).false + · exact (placedTerm_support_lt w c γ hγ hdisj h hk hj).false + +theorem placedTerms_apply (k : ℕ) : placedTerms w c γ hγ hdisj k = placedTerm w c γ k := (rfl) + +/-- The sum along the sequence of cutoffs `γ_k`, `s = ∑_k (w_k)_{>c_k} t^{γ_k}`. -/ +def sumAlongCutoffs : K⟦ℝ⟧ := (placedTerms w c γ hγ hdisj).hsum + +/-- The support of the sum along cutoffs lies in the union of the intervals +`(γ k + c k, γ k]`. -/ +theorem support_sumAlongCutoffs_subset : + (sumAlongCutoffs w c γ hγ hdisj).support ⊆ ⋃ k, Set.Ioc (γ k + c k) (γ k) := + SummableFamily.support_hsum_subset.trans + (Set.iUnion_mono fun k ↦ support_placedTerm_subset w c γ k) + +/-- On the `k`-th interval, the coefficient of the sum is that of its `k`-th term. -/ +theorem coeff_sumAlongCutoffs_of_mem {k : ℕ} {x : ℝ} (hx : x ∈ Set.Ioc (γ k + c k) (γ k)) : + (sumAlongCutoffs w c γ hγ hdisj).coeff x = (placedTerm w c γ k).coeff x := by + rw [sumAlongCutoffs, SummableFamily.coeff_hsum] + rw [finsum_eq_single _ k] + · rfl + · intro j hjk + by_contra hne + have hmem : x ∈ (placedTerm w c γ j).support := (HahnSeries.mem_support _ _).mpr hne + have hj := support_placedTerm_subset w c γ j hmem + rcases Ne.lt_or_gt hjk with h | h + · exact (placedTerm_interval_lt c γ hγ hdisj h hj hx).false + · exact (placedTerm_interval_lt c γ hγ hdisj h hx hj).false + +/-- Off every interval `(γ k + c k, γ k]` the coefficient of the sum along cutoffs vanishes. -/ +theorem coeff_sumAlongCutoffs_eq_zero {x : ℝ} (hx : ∀ k, x ∉ Set.Ioc (γ k + c k) (γ k)) : + (sumAlongCutoffs w c γ hγ hdisj).coeff x = 0 := by + by_contra h + have := support_sumAlongCutoffs_subset w c γ hγ hdisj ((HahnSeries.mem_support _ _).mpr h) + obtain ⟨k, hk⟩ := Set.mem_iUnion.mp this + exact hx k hk + +/-- The sum along cutoffs is a nonpositive series. -/ +theorem sumAlongCutoffs_mem (hneg : ∀ k, γ k < 0) : + sumAlongCutoffs w c γ hγ hdisj ∈ HahnSeries.nonpositiveSubring ℝ K := by + rw [HahnSeries.mem_nonpositiveSubring] + intro x hx + obtain ⟨k, hk⟩ := Set.mem_iUnion.mp (support_sumAlongCutoffs_subset w c γ hγ hdisj hx) + exact hk.2.trans (hneg k).le + +end Family + +/-! ### Representatives -/ + +/-- Every class in `P_δ` has a representative `w ∈ J_{ω^(δ+1)}` of support order type at most +`ω^δ`: a principal series of degree `δ`, or `0`. -/ +theorem exists_representative_supportOrderType_le (δ : NatOrdinal) (a : PrincipalComponent K δ) : + ∃ w : Series K, ∃ hw : ordinalValue w < ω^ (δ + 1), + principalComponentMk δ w hw = a ∧ (w : K⟦ℝ⟧).supportOrderType ≤ (ω^ δ).val := by + rcases eq_or_ne a 0 with rfl | ha + · have h0 : ordinalValue (0 : Series K) < ω^ (δ + 1) := by + rw [ordinalValue_zero]; exact NatOrdinal.wpow_pos _ + refine ⟨0, h0, (principalComponentMk_eq_zero_iff δ 0 h0).mpr (by + rw [ordinalValue_zero]; exact NatOrdinal.wpow_pos _), ?_⟩ + rw [Subring.coe_zero, supportOrderType_eq_setOrderType] + have : ((0 : K⟦ℝ⟧).isPWO_support).orderType = 0 := + (Set.IsPWO.orderType_eq_zero _).mpr HahnSeries.support_zero + rw [this] + exact bot_le + · obtain ⟨p, hp, hprin, hdeg, hpa⟩ := exists_principal_representative_of_ne_zero δ a ha + exact ⟨p, hp, hpa, (hprin.supportOrderType_eq_wpow_of_degree_eq hdeg).le⟩ + +/-! ### Prescribed classes at prescribed cutoffs -/ + +/-- **A sum along a sequence of cutoffs with prescribed classes at the cutoffs.** Let +`γ_0 < γ_1 < ⋯ < 0` have supremum `0` and let `a_k ∈ P_δ`. There is `s ∈ J_{ω^(δ+2)}` whose +translated truncation at `γ_k` represents `a_k` in `P_δ` for every `k`, and whose translated +truncation at every `ξ ∈ (γ_0, 0)` other than the `γ_k` has ordinal value below `ω^δ`. -/ +@[blueprint "prop:realise-derivative" + (phase := "Translated truncations") + (title := "Prescribed $\\mathrm P_\\delta$ classes at translated truncations") + (statement := /-- + Let $K$ be a field and let $\delta$ be a countable ordinal. Let + $(\gamma_k)_{k\in\mathbb N}$ be a strictly increasing sequence of negative + reals cofinal below $0$, and let $a_k\in\mathrm P_\delta$ for every $k$. + Then there is a series $s\in K((\mathbb R^{\le0}))$ such that + \[ + v_J(s)<\omega^{\delta\oplus1\oplus1}. + \] + For every $k$, + \[ + v_J(s^{\vert\gamma_k})<\omega^{\delta\oplus1},\qquad + s^{\vert\gamma_k}+J_{\omega^\delta}=a_k + \quad\text{in }\mathrm P_\delta. + \] + Moreover, if $\gamma_0<\xi<0$ and $\xi\ne\gamma_k$ for every $k$, then + \[ + v_J(s^{\vert\xi})<\omega^\delta. + \] + -/) + (proof := /-- + By \ref{fact:principal-series-representatives}, choose a principal series + $w_k$ representing each nonzero $a_k$, and choose $w_k=0$ when $a_k=0$. + Each support has order type at most $\omega^\delta$. By + \ref{lem:truncation-drop}, choose $c_k<0$ such that every proper translated + truncation of $w_k$ at a point of $(c_k,0)$ has ordinal value below + $\omega^\delta$; enlarge $c_k$ if necessary so that + $\gamma_{k-1}\le\gamma_k+c_k$ for $k\ge1$. + + Place $(w_k)_{>c_k}$ in the interval + $(\gamma_k+c_k,\gamma_k]$. These intervals are disjoint and strictly + increasing. By \ref{lem:increasing-union-order-type}, their union is well + ordered and has order type at most $\omega^{\delta\oplus1}$. Hence the Hahn + sum $s$ exists and + $v_J(s)<\omega^{\delta\oplus1\oplus1}$. + + At $\gamma_k$, every earlier interval contributes only an element of $J$, + the $k$-th interval has the same germ as $w_k$, and every later interval is + excluded. Thus $s^{\vert\gamma_k}$ represents $a_k$. Between two prescribed + cutoffs, its germ is either zero or the germ of a proper translated + truncation of one $w_k$, whose ordinal value is below $\omega^\delta$ by the + choice of $c_k$. + -/)] +theorem exists_sumAlongCutoffs (δ : NatOrdinal) (γ : ℕ → ℝ) (hγ : StrictMono γ) + (hneg : ∀ k, γ k < 0) + (hcof : ∀ η < (0 : ℝ), ∃ k, η < γ k) (a : ℕ → PrincipalComponent K δ) : + ∃ s : Series K, ordinalValue s < ω^ (δ + 1 + 1) ∧ + (∀ k, ∃ hk : ordinalValue (translatedTruncation (s : K⟦ℝ⟧) (γ k)) < ω^ (δ + 1), + principalComponentMk δ (translatedTruncation (s : K⟦ℝ⟧) (γ k)) hk = a k) ∧ + (∀ ξ : ℝ, γ 0 < ξ → ξ < 0 → (∀ k, ξ ≠ γ k) → + ordinalValue (translatedTruncation (s : K⟦ℝ⟧) ξ) < ω^ δ) := by + classical + -- representatives `w_k`, and an `ε_k` such that their translated truncations at the cutoffs in + -- `(-ε_k, 0)` have ordinal value below `ω^δ` + choose w hw hwa hwot using fun k ↦ exists_representative_supportOrderType_le δ (a k) + have hwin : ∀ k, ∃ ε > 0, ∀ ξ : ℝ, -ε < ξ → ξ < 0 → + ordinalValue (translatedTruncation ((w k : Series K) : K⟦ℝ⟧) ξ) < ω^ δ := fun k ↦ + exists_forall_ordinalValue_translatedTruncation_lt (hw k) + choose ε hε hwin using hwin + -- the reals `c_k` + set c : ℕ → ℝ := fun k ↦ if k = 0 then -ε 0 else max (γ (k - 1) - γ k) (-ε k) with hcdef + have hc : ∀ k, c k < 0 := by + intro k + simp only [hcdef] + split_ifs with hk + · subst hk; linarith [hε 0] + · exact max_lt (sub_neg.mpr (hγ (by omega))) (by linarith [hε k]) + have hcε : ∀ k, -ε k ≤ c k := by + intro k + simp only [hcdef] + split_ifs with hk + · subst hk; exact le_rfl + · exact le_max_right _ _ + have hdisj : ∀ k, γ k ≤ γ (k + 1) + c (k + 1) := by + intro k + simp only [hcdef, ite_eq_right (Nat.succ_ne_zero k), Nat.add_sub_cancel] + linarith [le_max_left (γ k - γ (k + 1)) (-ε (k + 1))] + -- the sum along cutoffs + set s' := sumAlongCutoffs w c γ hγ hdisj with hs'def + set s : Series K := ⟨s', sumAlongCutoffs_mem w c γ hγ hdisj hneg⟩ with hsdef + have hscoe : (s : K⟦ℝ⟧) = s' := rfl + refine ⟨s, ?_, ?_, ?_⟩ + · -- the ordinal value of `s` + have hU : (⋃ k, (placedTerm w c γ k).support).IsPWO := + (placedTerms w c γ hγ hdisj).isPWO_iUnion_support + have hUle : hU.orderType ≤ (ω^ (δ + 1)).val := by + refine Set.IsPWO.orderType_iUnion_le_of_ordered (fun k ↦ support_placedTerm_isPWO w c γ k) + (fun j k hjk x hx y hy ↦ placedTerm_support_lt w c γ hγ hdisj hjk hx hy) (ρ := (ω^ δ).val) + (fun k ↦ ?_) fun n ↦ ?_ + · rw [← supportOrderType_eq_setOrderType] + exact (supportOrderType_placedTerm_le w c γ k).trans (hwot k) + · rw [NatOrdinal.of_val] + refine NatOrdinal.val.lt_iff_lt.mpr ?_ + rw [nsmul_eq_mul, mul_comm] + exact NatOrdinal.wpow_mul_natCast_lt (lt_add_one δ) n + have hsupp : (s : K⟦ℝ⟧).support ⊆ ⋃ k, (placedTerm w c γ k).support := + SummableFamily.support_hsum_subset + calc ordinalValue s ≤ NatOrdinal.of (s : K⟦ℝ⟧).supportOrderType := + ordinalValue_le_supportOrderType s + _ ≤ NatOrdinal.of (ω^ (δ + 1)).val := by + rw [supportOrderType_eq_setOrderType] + exact NatOrdinal.of.le_iff_le.mpr + ((Set.IsPWO.orderType_mono _ hU hsupp).trans hUle) + _ = ω^ (δ + 1) := NatOrdinal.of_val _ + _ < ω^ (δ + 1 + 1) := NatOrdinal.wpow_lt_wpow.mpr (lt_add_one _) + · -- the classes at the cutoffs + intro k + have hgerm : toGerm (translatedTruncation (s : K⟦ℝ⟧) (γ k)) = toGerm (w k) := by + rw [toGerm_eq_toGerm_iff_exists_coeff_eq] + refine ⟨c k, hc k, fun η hη1 hη2 ↦ ?_⟩ + rw [coeff_translatedTruncation, ite_eq_left hη2, hscoe, + coeff_sumAlongCutoffs_of_mem w c γ hγ hdisj (k := k) ⟨by linarith, by linarith⟩, + coeff_placedTerm, + add_sub_cancel_left, ite_eq_left hη1] + have hval : ordinalValue (translatedTruncation (s : K⟦ℝ⟧) (γ k)) = ordinalValue (w k) := + ordinalValue_eq_of_sub_mem_negativeMonomialIdeal (toGerm_eq_toGerm_iff.mp hgerm) + refine ⟨hval ▸ hw k, ?_⟩ + rw [← hwa k, principalComponentMk_eq_iff, + ordinalValue_eq_zero_iff.mpr (toGerm_eq_toGerm_iff.mp hgerm)] + exact NatOrdinal.wpow_pos _ + · -- the translated truncations between the cutoffs + intro ξ hξ0 hξneg hξne + -- the first cutoff above `ξ` + have hex : ∃ k, ξ < γ k := hcof ξ hξneg + set k := Nat.find hex with hkdef + have hk : ξ < γ k := Nat.find_spec hex + have hk0 : k ≠ 0 := by + intro h + rw [h] at hk + exact hξ0.not_gt hk + have hkpred : γ (k - 1) < ξ := by + have hnot : ¬ ξ < γ (k - 1) := Nat.find_min hex (by omega) + exact lt_of_le_of_ne (not_lt.mp hnot) (fun h ↦ hξne (k - 1) h.symm) + rcases le_or_gt ξ (γ k + c k) with hle | hgt + · -- `ξ ≤ γ k + c k`: the translated truncation lies in `J` + have hgerm : toGerm (translatedTruncation (s : K⟦ℝ⟧) ξ) = toGerm 0 := by + rw [toGerm_eq_toGerm_iff_exists_coeff_eq] + refine ⟨γ (k - 1) - ξ, by linarith, fun η hη1 hη2 ↦ ?_⟩ + rw [coeff_translatedTruncation, ite_eq_left hη2, hscoe, Subring.coe_zero, + HahnSeries.coeff_zero] + refine coeff_sumAlongCutoffs_eq_zero w c γ hγ hdisj fun j hj ↦ ?_ + rcases lt_trichotomy j k with hjk | rfl | hjk + · -- `j < k`: the interval lies below `γ (k - 1) < ξ + η` + have : γ j ≤ γ (k - 1) := hγ.monotone (by omega) + linarith [hj.2] + · -- `j = k`: `ξ + η ≤ γ k + c k` + linarith [hj.1] + · -- `j > k`: the interval lies above `γ k > ξ + η` + have h1 : γ k ≤ γ (j - 1) := hγ.monotone (by omega) + have h2 : γ (j - 1) ≤ γ j + c j := by + have := hdisj (j - 1) + rwa [Nat.sub_add_cancel (by omega : 1 ≤ j)] at this + linarith [hj.1] + rw [ordinalValue_eq_of_sub_mem_negativeMonomialIdeal (toGerm_eq_toGerm_iff.mp hgerm), + ordinalValue_zero] + exact NatOrdinal.wpow_pos _ + · -- `γ k + c k < ξ < γ k`: the translated truncation is, modulo `J`, one of `w k` + have hgerm : toGerm (translatedTruncation (s : K⟦ℝ⟧) ξ) = + toGerm (translatedTruncation ((w k : Series K) : K⟦ℝ⟧) (ξ - γ k)) := by + rw [toGerm_eq_toGerm_iff_exists_coeff_eq] + refine ⟨γ k + c k - ξ, by linarith, fun η hη1 hη2 ↦ ?_⟩ + rw [coeff_translatedTruncation, coeff_translatedTruncation, ite_eq_left hη2, ite_eq_left + hη2, hscoe, + coeff_sumAlongCutoffs_of_mem w c γ hγ hdisj (k := k) ⟨by linarith, by linarith⟩, + coeff_placedTerm, + ite_eq_left (by linarith)] + congr 1 + ring + rw [ordinalValue_eq_of_sub_mem_negativeMonomialIdeal (toGerm_eq_toGerm_iff.mp hgerm)] + exact hwin k (ξ - γ k) (by linarith [hcε k]) (by linarith) + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/SupportLoweringPieces.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/SupportLoweringPieces.lean new file mode 100644 index 0000000000..83875986bb --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/SupportLoweringPieces.lean @@ -0,0 +1,479 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.SuccessorSupportBound +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.CombinedCofactors +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.ProductCondition + +/-! +# Lowering the order type of the support below `ω^ρ`, `ρ ≥ τ + 2`, by cutting into pieces + +Let the polynomials `q j ∈ K[X]` be homogeneous of degrees `c j` (the degrees `σ_j` of the +generators) with `e j ⊕ c j = ρ` (`e j` the cofactor degrees), `τ + 1 < ρ < α`, and let the +separation condition (n) hold for every `(e j, c j, τ)`: `e j ⊕ θ < τ` for every `θ < c j`. +Assume evaluation injective below `α`. Let `D` be a series whose support has order type below +`ω^(ρ+1)` and whose translated truncations satisfy (p) for `(q_1, …, q_m; τ)`. Suppose +(induction hypothesis) that every series `E` with support of order type below `ω^ρ` whose +translated truncations satisfy (p) admits cofactors `w j`, with supports of order type below +`ω^(e j)`, such that all translated truncations of `E - ∑_j w_j · q_j(b_𝓑)` have ordinal value +below `ω^(τ+1)`. + +At each of the finitely many cutoffs `ξ` at which the ordinal value of `D` is at least `ω^ρ`, +take an interval `(ξ - ε, ξ)` containing no such cutoff and the piece `E_ξ` of `D` on +`(ξ - ε, ξ]`, translated to `0`, and cut it into the pieces on `(γ_k, γ_{k+1}]`, +`γ_k := -ε/(k+1)`; each piece has support of order type below `ω^ρ` and translated truncations +satisfying (p), so the induction hypothesis applies; combine the cofactors of the pieces into the +combined cofactors `C^ξ_j` (`CombinedCofactors`). The difference `E_ξ - ∑_j C^ξ_j · q_j(b_𝓑)` +has translated truncations of ordinal value below `ω^(τ+1)` at every cutoff in `(-ε, 0)`, hence +ordinal value below `ω^(τ+2) ≤ ω^ρ` +(`ordinalValue_lt_wpow_add_one_of_forall_translatedTruncation_lt`). Subtracting the terms +`t^ξ C^ξ_j · q_j(b_𝓑)` leaves a series all of whose translated truncations have ordinal value +below `ω^ρ` — so its support has order type below `ω^ρ` — and whose translated truncations still +satisfy (p) (`ProductCondition`). +-/ + +universe v w + +open scoped NatOrdinal HahnSeries +open Berarducci HahnSeries MvPolynomial DirectSum OrdinalGraded + +public noncomputable section + +namespace Berarducci + +variable {K : Type v} [Field K] + +/-- A point of the support of the piece of `E` on `(a, b]`, translated to `0`, lies above +`a - b`. -/ +theorem lt_of_mem_support_piece {a b : ℝ} {E : K⟦ℝ⟧} {y : ℝ} + (hy : y ∈ ((piece a b E : Series K) : K⟦ℝ⟧).support) : a - b < y := by + rw [HahnSeries.mem_support, coeff_piece] at hy + by_contra h + rw [not_lt] at h + exact hy (ite_eq_right fun h' ↦ absurd h'.1 (not_lt.mpr (by linarith))) + +/-- The sequence `γ_k := -ε/(k+1)`: strictly increasing, negative, with supremum `0`. -/ +theorem strictMono_neg_div_succ {ε : ℝ} (hε : 0 < ε) : + StrictMono fun k : ℕ ↦ -ε / ((k : ℝ) + 1) := fun k l hkl ↦ by + simp only + rw [neg_div, neg_div, neg_lt_neg_iff] + exact div_lt_div_of_pos_left hε (by positivity) (by exact_mod_cast Nat.succ_lt_succ hkl) + +theorem neg_div_succ_neg {ε : ℝ} (hε : 0 < ε) (k : ℕ) : -ε / ((k : ℝ) + 1) < 0 := by + rw [neg_div, neg_lt_zero] + exact div_pos hε (by positivity) + +theorem exists_lt_neg_div_succ (ε : ℝ) {η : ℝ} (hη : η < 0) : + ∃ k : ℕ, η < -ε / ((k : ℝ) + 1) := by + obtain ⟨k, hk⟩ := exists_nat_gt (ε / -η) + refine ⟨k, ?_⟩ + have hk1 : (0 : ℝ) < (k : ℝ) + 1 := by positivity + have hη' : 0 < -η := neg_pos.mpr hη + rw [div_lt_iff₀ hη'] at hk + rw [neg_div, lt_neg, div_lt_iff₀ hk1] + nlinarith + +variable {ι : Type w} {wt : ι → NatOrdinal} {x : ι → PrincipalSubring K} + +namespace Lifts + +variable (σ : Lifts wt x) (hx : IsMinimalSystem (principalGrading K) wt x) {α : NatOrdinal} + (hinj : ∀ β < α, InjectiveAt K wt x β) (hσ : σ.IsPrincipal) +include hinj + +/-- The polynomial of a difference. -/ +theorem pol_sub {u u' : Series K} (hu : ordinalValue u < ω^ α) (hu' : ordinalValue u' < ω^ α) : + σ.pol hx α (u - u') = σ.pol hx α u - σ.pol hx α u' := by + have hneg : ordinalValue (-u') < ω^ α := by rwa [ordinalValue_neg] + rw [sub_eq_add_neg, σ.pol_add hx hinj hu hneg, sub_eq_add_neg] + congr 1 + have : (-u' : Series K) = (HahnSeries.Nonpositive.C : K →+* Series K) (-1) * u' := by + rw [map_neg, map_one, neg_one_mul] + rw [this, σ.pol_C_mul hx hinj (-1) hu', map_neg, map_one, neg_one_mul] + +include hσ + +/-- Correct one exceptional cutoff by combining cofactors on intervals approaching it. -/ +private theorem IsPrincipal.exists_cofactors_at_cutoff_of_pieces {ι' : Type*} + [Fintype ι'] {q : ι' → MvPolynomial ι K} {c : ι' → NatOrdinal} + (hq : ∀ j, IsWeightedHomogeneous wt (q j) (c j)) {τ ρ : NatOrdinal} (hτρ : τ + 1 < ρ) + (hρα : ρ < α) {e : ι' → NatOrdinal} + (hsep : ∀ j, ∀ θ, θ < c j → e j + θ < τ) + {D : Series K} (hD : (D : K⟦ℝ⟧).supportOrderType < (ω^ (ρ + 1)).val) + (htrunc : ∀ ξ : ℝ, ξ ≤ 0 → + componentsGE wt τ (σ.pol hx α (translatedTruncation (D : K⟦ℝ⟧) ξ)) ∈ + Ideal.span (Set.range q)) + (hIH : ∀ E : Series K, (E : K⟦ℝ⟧).supportOrderType < (ω^ ρ).val → + (∀ ξ : ℝ, ξ ≤ 0 → + componentsGE wt τ (σ.pol hx α (translatedTruncation (E : K⟦ℝ⟧) ξ)) ∈ + Ideal.span (Set.range q)) → + ∃ w : ι' → Series K, (∀ j, ((w j : Series K) : K⟦ℝ⟧).supportOrderType < (ω^ (e j)).val) ∧ + ∀ ξ : ℝ, ξ ≤ 0 → ordinalValue (translatedTruncation + ((E - ∑ j, w j * aeval σ.lift (q j) : Series K) : K⟦ℝ⟧) ξ) < ω^ (τ + 1)) + {ξ ε : ℝ} (hξ0 : ξ ≤ 0) (hε : 0 < ε) + (hnolevel : ∀ θ, ξ - ε < θ → θ < ξ → + ordinalValue (translatedTruncation (D : K⟦ℝ⟧) θ) < ω^ ρ) : + ∃ C : ι' → Series K, + (∀ j, ((C j : Series K) : K⟦ℝ⟧).supportOrderType ≤ (ω^ (e j)).val) ∧ + (∀ j, ∀ ζ : ℝ, ζ < 0 → + ordinalValue (translatedTruncation (C j : K⟦ℝ⟧) ζ) < ω^ (e j)) ∧ + ordinalValue (translatedTruncation (D : K⟦ℝ⟧) ξ - + ∑ j, C j * aeval σ.lift (q j)) < ω^ ρ := by + classical + have hwt : ∀ i, wt i ≠ 0 := hx.ne_zero + have hρ0 : ρ ≠ 0 := (lt_of_le_of_lt zero_le hτρ).ne' + have hτ2ρ : τ + 1 + 1 ≤ ρ := Order.add_one_le_of_lt hτρ + have hρα' : ρ + 1 ≤ α := Order.add_one_le_of_lt hρα + have hDα : ∀ ζ, ordinalValue (translatedTruncation (D : K⟦ℝ⟧) ζ) < ω^ α := fun ζ ↦ + (ordinalValue_translatedTruncation_lt_of_supportOrderType_lt hD ζ).trans_le + (NatOrdinal.wpow_le_wpow.mpr hρα') + -- the generators evaluated at the lifts, `q_j(b_𝓑)` + set qt : ι' → Series K := fun j ↦ aeval σ.lift (q j) with hqtdef + have hqcut : ∀ j, ∀ β : ℝ, β < 0 → + ordinalValue (translatedTruncation (qt j : K⟦ℝ⟧) β) < ω^ (c j) := fun j β hβ ↦ + hσ.ordinalValue_translatedTruncation_aeval_lt hwt (hq j) hβ + -- the piece `E` of `D` on `(ξ - ε, ξ]`, translated to `0` + set E : Series K := piece (ξ - ε) ξ (D : K⟦ℝ⟧) with hEdef + have hEcut : ∀ θ : ℝ, -ε < θ → θ ≤ 0 → + translatedTruncation (E : K⟦ℝ⟧) θ - translatedTruncation (D : K⟦ℝ⟧) (ξ + θ) ∈ + Nonpositive.negativeMonomialIdeal K := fun θ h1 h2 ↦ + translatedTruncation_window_sub_mem (ξ - ε) ξ (D : K⟦ℝ⟧) (by linarith) h2 + -- the pieces on `(γ k, γ (k+1)]` + set γ : ℕ → ℝ := fun k ↦ -ε / ((k : ℝ) + 1) with hγdef + have hγ : StrictMono γ := strictMono_neg_div_succ hε + have hneg : ∀ k, γ k < 0 := neg_div_succ_neg hε + have hcof : ∀ η < (0 : ℝ), ∃ k, η < γ k := fun η hη ↦ exists_lt_neg_div_succ ε hη + have hγ0 : γ 0 = -ε := by simp [hγdef] + have hγ0le : ∀ k, -ε ≤ γ k := fun k ↦ hγ0 ▸ hγ.monotone (Nat.zero_le k) + -- each piece has support of order type below `ω^ρ` and translated truncations satisfying (p) + have hwin : ∀ k, ∃ w : ι' → Series K, + (∀ j, ((w j : Series K) : K⟦ℝ⟧).supportOrderType < (ω^ (e j)).val) ∧ + ∀ θ : ℝ, θ ≤ 0 → ordinalValue (translatedTruncation + ((piece (γ k) (γ (k + 1)) (E : K⟦ℝ⟧) - ∑ j, w j * qt j : Series K) : K⟦ℝ⟧) θ) < + ω^ (τ + 1) := by + intro k + set Dk : Series K := piece (γ k) (γ (k + 1)) (E : K⟦ℝ⟧) with hDkdef + have hDkzero : ∀ θ, θ ≤ γ k - γ (k + 1) → translatedTruncation (Dk : K⟦ℝ⟧) θ = 0 := + fun θ hθ ↦ translatedTruncation_eq_zero_of_forall_lt fun y hy ↦ + lt_of_le_of_lt hθ (lt_of_mem_support_piece hy) + have hDkcut : ∀ θ, γ k - γ (k + 1) < θ → θ ≤ 0 → + translatedTruncation (Dk : K⟦ℝ⟧) θ - + translatedTruncation (D : K⟦ℝ⟧) (ξ + (γ (k + 1) + θ)) ∈ + Nonpositive.negativeMonomialIdeal K := by + intro θ h1 h2 + have h3 := translatedTruncation_window_sub_mem (γ k) (γ (k + 1)) (E : K⟦ℝ⟧) h1 h2 + have h4 := hEcut (γ (k + 1) + θ) (by linarith [hγ0le k]) (by linarith [hneg (k + 1)]) + have := add_mem h3 h4 + rwa [sub_add_sub_cancel] at this + have hin : ∀ θ, γ k - γ (k + 1) < θ → θ ≤ 0 → + ξ - ε < ξ + (γ (k + 1) + θ) ∧ ξ + (γ (k + 1) + θ) < ξ := fun θ h1 h2 ↦ + ⟨by linarith [hγ0le k], by linarith [hneg (k + 1)]⟩ + have hDkot : (Dk : K⟦ℝ⟧).supportOrderType < (ω^ ρ).val := by + refine supportOrderType_lt_of_forall_ordinalValue_translatedTruncation_lt Dk hρ0 + fun θ hθ ↦ ?_ + rcases le_or_gt θ (γ k - γ (k + 1)) with h | h + · rw [hDkzero θ h, ordinalValue_zero] + exact NatOrdinal.wpow_pos _ + · rw [ordinalValue_eq_of_sub_mem_negativeMonomialIdeal (hDkcut θ h hθ)] + exact hnolevel _ (hin θ h hθ).1 (hin θ h hθ).2 + have hDkctrl : ∀ θ : ℝ, θ ≤ 0 → + componentsGE wt τ (σ.pol hx α (translatedTruncation (Dk : K⟦ℝ⟧) θ)) ∈ + Ideal.span (Set.range q) := by + intro θ hθ + rcases le_or_gt θ (γ k - γ (k + 1)) with h | h + · rw [hDkzero θ h, σ.pol_zero hx hinj, componentsGE_zero] + exact Ideal.zero_mem _ + · have hval : ordinalValue (translatedTruncation (Dk : K⟦ℝ⟧) θ) < ω^ α := by + rw [ordinalValue_eq_of_sub_mem_negativeMonomialIdeal (hDkcut θ h hθ)] + exact hDα _ + rw [σ.pol_congr hx hinj hval (toGerm_eq_toGerm_iff.mpr (hDkcut θ h hθ))] + exact htrunc _ (by linarith [hneg (k + 1)]) + exact hIH Dk hDkot hDkctrl + choose w hw1 hw2 using hwin + -- combine the cofactors of the pieces + refine ⟨fun j ↦ combinedCofactor γ hγ hneg w j, + fun j ↦ supportOrderType_combinedCofactor_le γ hγ hneg w hw1 j, + fun j ζ hζ ↦ + ordinalValue_translatedTruncation_combinedCofactor_lt γ hγ hneg hcof w hw1 j hζ, ?_⟩ + have hres : ∀ ζ, -ε < ζ → ζ < 0 → ordinalValue (translatedTruncation + ((E - ∑ j, combinedCofactor γ hγ hneg w j * qt j : Series K) : K⟦ℝ⟧) ζ) < ω^ (τ + 1) := + fun ζ h1 h2 ↦ + ordinalValue_translatedTruncation_sub_sum_combinedCofactor_mul_lt E γ hγ hneg hcof w + hw1 hqcut hsep (fun k θ _ h2 ↦ hw2 k θ h2) (by rw [hγ0]; exact h1) h2 + have hwhole : ordinalValue (E - ∑ j, combinedCofactor γ hγ hneg w j * qt j) < ω^ (τ + 1 + 1) := + ordinalValue_lt_wpow_add_one_of_forall_translatedTruncation_lt (neg_neg_of_pos hε) hres + have hE0 : translatedTruncation (D : K⟦ℝ⟧) ξ - E ∈ Nonpositive.negativeMonomialIdeal K := by + have := hEcut 0 (by linarith) le_rfl + rw [translatedTruncation_zero, add_zero] at this + rw [← neg_sub] + exact neg_mem this + have hsame : ordinalValue (translatedTruncation (D : K⟦ℝ⟧) ξ - + ∑ j, combinedCofactor γ hγ hneg w j * qt j) = + ordinalValue (E - ∑ j, combinedCofactor γ hγ hneg w j * qt j) := by + apply ordinalValue_eq_of_sub_mem_negativeMonomialIdeal + rw [sub_sub_sub_cancel_right] + exact hE0 + rw [hsame] + exact hwhole.trans_le (NatOrdinal.wpow_le_wpow.mpr hτ2ρ) + +/-- **Support-order reduction by interval decomposition.** Under the stated homogeneous-degree, +separation, and translated-truncation ideal hypotheses, cofactors reduce the support order type +below `ω^ρ` while preserving the translated-truncation ideal condition. -/ +@[blueprint "lem:lower-by-pieces" + (phase := "Limit ordinals in the degree induction") + (title := "Support-order reduction by interval decomposition") + (statement := /-- + Let $K$ be a field and let $\mathcal B$ be a minimal homogeneous generating + system of $\widehat{\mathrm P}$ with principal representatives $b_B$. + Assume evaluation is injective below $\alpha$. Let $I$ be a finite index + set, and let $Q_j\in K[X_B:B\in\mathcal B]$ be weighted homogeneous of + degree $\sigma_j$, for $j\in I$. Let + $\tau+1<\mu<\alpha$, and suppose + \[ + \rho_j\oplus\sigma_j=\mu,\qquad + \rho_j\oplus\theta<\tau\quad(\theta<\sigma_j) + \] + for every $j$. + + Let $u\in K((\mathbb R^{\le0}))$ satisfy + \[ + \operatorname{ot}(\operatorname{supp}(u))<\omega^{\mu+1} + \] + and, for every $\xi\le0$, + \[ + \operatorname{pol}_{<\alpha}(u^{|\xi})_{\ge\tau} + \in (Q_j:j\in I). + \] + Suppose every series $c$ with + $\operatorname{ot}(\operatorname{supp}(c))<\omega^\mu$ and the same + high-degree ideal condition admits series $w_j$ such that + \[ + \operatorname{ot}(\operatorname{supp}(w_j))<\omega^{\rho_j} + \] + and + \[ + v_J\!\left((c-\sum_jw_jQ_j(b_B))^{|\xi}\right) + <\omega^{\tau+1}\quad(\xi\le0). + \] + Then there are series $u_j$ such that + \[ + \operatorname{ot}(\operatorname{supp}(u_j))<\omega^{\rho_j+1}, + \] + \[ + \operatorname{ot}\!\left( + \operatorname{supp}(u-\sum_ju_jQ_j(b_B))\right)<\omega^\mu, + \] + and every translated truncation of the remainder satisfies the same + high-degree ideal condition. + -/) + (proof := /-- + By \ref{lem:successor-large-truncations-finite}, only finitely many cutoffs + $\xi\le0$ have $v_J(u^{|\xi})\ge\omega^\mu$. Around each such cutoff choose + an interval containing no other large cutoff. + \ref{lem:window-truncation} transfers the high-degree ideal condition to the + corresponding interval piece, and + \ref{cor:small-truncations-small-support} gives support order below + $\omega^\mu$ for its successive subpieces. Apply the assumed induction + hypothesis to those subpieces. + + Assemble their cofactors as sums along cutoffs. + \ref{lem:cutoff-sum-truncation} identifies their translated truncations, + while \ref{lem:cutoff-sum-support} bounds each local combined cofactor by + $\omega^{\rho_j}$. This non-strict bound is sufficient: there are only + finitely many exceptional cutoffs, so the finite sum of their shifted local + corrections has support order strictly below $\omega^{\rho_j+1}$. The + contrapositive consequence of + \ref{lem:truncation-values} bounds the local residual value by + $\omega^{\tau+2}\le\omega^\mu$, since $\tau+1<\mu$. + + Shift the local corrections back to their exceptional cutoffs and add + them. The corrections preserve the high-degree ideal + condition by \ref{lem:term-truncation-condition}. They cancel all large + cutoffs, so \ref{cor:small-truncations-small-support} gives support order + below $\omega^\mu$ for the final remainder. + -/)] +theorem IsPrincipal.exists_supportOrderType_sub_sum_mul_aeval_lt_of_pieces {ι' : Type*} + [Fintype ι'] {q : ι' → MvPolynomial ι K} {c : ι' → NatOrdinal} + (hq : ∀ j, IsWeightedHomogeneous wt (q j) (c j)) {τ ρ : NatOrdinal} (hτρ : τ + 1 < ρ) + (hρα : ρ < α) {e : ι' → NatOrdinal} (he : ∀ j, e j + c j = ρ) + (hsep : ∀ j, ∀ θ, θ < c j → e j + θ < τ) + {D : Series K} (hD : (D : K⟦ℝ⟧).supportOrderType < (ω^ (ρ + 1)).val) + (htrunc : ∀ ξ : ℝ, ξ ≤ 0 → + componentsGE wt τ (σ.pol hx α (translatedTruncation (D : K⟦ℝ⟧) ξ)) ∈ + Ideal.span (Set.range q)) + (hIH : ∀ E : Series K, (E : K⟦ℝ⟧).supportOrderType < (ω^ ρ).val → + (∀ ξ : ℝ, ξ ≤ 0 → + componentsGE wt τ (σ.pol hx α (translatedTruncation (E : K⟦ℝ⟧) ξ)) ∈ + Ideal.span (Set.range q)) → + ∃ w : ι' → Series K, (∀ j, ((w j : Series K) : K⟦ℝ⟧).supportOrderType < (ω^ (e j)).val) ∧ + ∀ ξ : ℝ, ξ ≤ 0 → ordinalValue (translatedTruncation + ((E - ∑ j, w j * aeval σ.lift (q j) : Series K) : K⟦ℝ⟧) ξ) < ω^ (τ + 1)) : + ∃ u : ι' → Series K, (∀ j, ((u j : Series K) : K⟦ℝ⟧).supportOrderType < (ω^ (e j + 1)).val) ∧ + ((D - ∑ j, u j * aeval σ.lift (q j) : Series K) : K⟦ℝ⟧).supportOrderType < (ω^ ρ).val ∧ + ∀ ζ : ℝ, ζ ≤ 0 → componentsGE wt τ (σ.pol hx α (translatedTruncation + ((D - ∑ j, u j * aeval σ.lift (q j) : Series K) : K⟦ℝ⟧) ζ)) ∈ Ideal.span (Set.range q) := by + classical + have hwt : ∀ i, wt i ≠ 0 := hx.ne_zero + have hρ0 : ρ ≠ 0 := (lt_of_le_of_lt zero_le hτρ).ne' + have hτ2ρ : τ + 1 + 1 ≤ ρ := Order.add_one_le_of_lt hτρ + have hρα' : ρ + 1 ≤ α := Order.add_one_le_of_lt hρα + have hDα : ∀ ζ, ordinalValue (translatedTruncation (D : K⟦ℝ⟧) ζ) < ω^ α := fun ζ ↦ + (ordinalValue_translatedTruncation_lt_of_supportOrderType_lt hD ζ).trans_le + (NatOrdinal.wpow_le_wpow.mpr hρα') + -- the generators evaluated at the lifts, `q_j(b_𝓑)` + set qt : ι' → Series K := fun j ↦ aeval σ.lift (q j) with hqtdef + have hqv : ∀ j, ordinalValue (qt j) < ω^ (c j + 1) := fun j ↦ + (σ.aeval_represents (hq j)).ordinalValue_lt + have hqcut : ∀ j, ∀ β : ℝ, β < 0 → + ordinalValue (translatedTruncation (qt j : K⟦ℝ⟧) β) < ω^ (c j) := fun j β hβ ↦ + hσ.ordinalValue_translatedTruncation_aeval_lt hwt (hq j) hβ + -- the cutoffs at which the ordinal value of `D` is at least `ω^ρ` + set L : Set ℝ := {ξ | ξ ≤ 0 ∧ ω^ ρ ≤ ordinalValue (translatedTruncation (D : K⟦ℝ⟧) ξ)} with hLdef + have hL : L.Finite := finite_setOf_wpow_le_ordinalValue_translatedTruncation D hD + have hmemL : ∀ ξ, ξ ∈ hL.toFinset ↔ + ξ ≤ 0 ∧ ω^ ρ ≤ ordinalValue (translatedTruncation (D : K⟦ℝ⟧) ξ) := fun ξ ↦ hL.mem_toFinset + -- at each of them, combined cofactors lowering the ordinal value of `D^{|ξ}` below `ω^ρ` + have hpt : ∀ ξ ∈ hL.toFinset, ∃ C : ι' → Series K, + (∀ j, ((C j : Series K) : K⟦ℝ⟧).supportOrderType ≤ (ω^ (e j)).val) ∧ + (∀ j, ∀ ζ : ℝ, ζ < 0 → ordinalValue (translatedTruncation (C j : K⟦ℝ⟧) ζ) < ω^ (e j)) ∧ + ordinalValue (translatedTruncation (D : K⟦ℝ⟧) ξ - ∑ j, C j * qt j) < ω^ ρ := by + intro ξ hξ + obtain ⟨hξ0, -⟩ := (hmemL ξ).mp hξ + obtain ⟨ε, hε, hgap⟩ := exists_pos_forall_le_sub_of_finite hL ξ + have hnolevel : ∀ θ, ξ - ε < θ → θ < ξ → + ordinalValue (translatedTruncation (D : K⟦ℝ⟧) θ) < ω^ ρ := by + intro θ h1 h2 + by_contra hge + rw [not_lt] at hge + have := hgap θ ⟨by linarith, hge⟩ h2 + linarith + exact IsPrincipal.exists_cofactors_at_cutoff_of_pieces σ hx hinj hσ hq hτρ hρα hsep + hD htrunc hIH hξ0 hε hnolevel + choose! C hC using hpt + -- the terms `C^ξ_j · q_j(b_𝓑)`: translated truncations of small ordinal value, satisfying (p) + have hCv : ∀ ξ ∈ hL.toFinset, ∀ j, ordinalValue (C ξ j) < ω^ (e j + 1) := fun ξ hξ j ↦ + (ordinalValue_le_supportOrderType _).trans_lt (by + rw [← NatOrdinal.of_val (ω^ (e j + 1)), NatOrdinal.of.lt_iff_lt] + exact ((hC ξ hξ).1 j).trans_lt + (NatOrdinal.val.lt_iff_lt.mpr (NatOrdinal.wpow_lt_wpow.mpr (lt_add_one _)))) + have hblock : ∀ ξ ∈ hL.toFinset, ∀ j, ∀ θ : ℝ, + ordinalValue (translatedTruncation ((C ξ j * qt j : Series K) : K⟦ℝ⟧) θ) < ω^ (ρ + 1) := by + intro ξ hξ j θ + rcases lt_trichotomy θ 0 with h | rfl | h + · exact (hσ.ordinalValue_translatedTruncation_mul_aeval_lt hwt (hq j) (hCv ξ hξ j) + ((hC ξ hξ).2.1 j) (he j) ((lt_add_one τ).le.trans hτρ.le) (hsep j) h).trans + (NatOrdinal.wpow_lt_wpow.mpr (lt_add_one ρ)) + · rw [translatedTruncation_zero, ← he j] + exact ordinalValue_mul_lt_wpow_add_one (hCv ξ hξ j) (hqv j) + · rw [ordinalValue_translatedTruncation_eq_zero_of_forall_support_le (s := 0) + (fun y hy ↦ Nonpositive.support_subset _ hy) h] + exact NatOrdinal.wpow_pos _ + have hblockρ : ∀ ξ ∈ hL.toFinset, ξ ≠ 0 → ∀ j, ∀ θ : ℝ, θ ≠ 0 → + ordinalValue (translatedTruncation ((C ξ j * qt j : Series K) : K⟦ℝ⟧) θ) < ω^ ρ := by + intro ξ hξ _ j θ hθ + rcases lt_or_gt_of_ne hθ with h | h + · exact hσ.ordinalValue_translatedTruncation_mul_aeval_lt hwt (hq j) (hCv ξ hξ j) + ((hC ξ hξ).2.1 j) (he j) ((lt_add_one τ).le.trans hτρ.le) (hsep j) h + · rw [ordinalValue_translatedTruncation_eq_zero_of_forall_support_le (s := 0) + (fun y hy ↦ Nonpositive.support_subset _ hy) h] + exact NatOrdinal.wpow_pos _ + have hblockctrl : ∀ ξ ∈ hL.toFinset, ∀ j, ∀ θ : ℝ, + componentsGE wt τ (σ.pol hx α (translatedTruncation ((C ξ j * qt j : Series K) : K⟦ℝ⟧) θ)) + ∈ Ideal.span (Set.range q) := by + intro ξ hξ j θ + rcases le_or_gt θ 0 with h | h + · have := σ.componentsGE_pol_translatedTruncation_mul_aeval_mem hx hinj hσ (hq j) (hCv ξ hξ j) + ((hC ξ hξ).2.1 j) (he j ▸ hρα) (hsep j) h + exact Ideal.span_mono (by rintro _ ⟨_, rfl⟩; exact ⟨j, rfl⟩) this + · rw [σ.pol_eq_zero_of_mem hx hinj + (translatedTruncation_mem_negativeMonomialIdeal_of_forall_support_le (s := 0) + (fun y hy ↦ Nonpositive.support_subset _ hy) h), componentsGE_zero] + exact Ideal.zero_mem _ + -- the cofactors and the corrected series + refine ⟨fun j ↦ ∑ ξ ∈ hL.toFinset, shift ξ (C ξ j), fun j ↦ ?_, ?_⟩ + · refine supportOrderType_sum_lt_wpow _ _ fun ξ hξ ↦ ?_ + rw [supportOrderType_shift ((hmemL ξ).mp hξ).1] + exact ((hC ξ hξ).1 j).trans_lt (NatOrdinal.val.lt_iff_lt.mpr + (NatOrdinal.wpow_lt_wpow.mpr (lt_add_one _))) + have heq : (D - ∑ j, (∑ ξ ∈ hL.toFinset, shift ξ (C ξ j)) * qt j : Series K) = + D - ∑ ξ ∈ hL.toFinset, ∑ j, shift ξ (C ξ j * qt j) := by + congr 1 + rw [Finset.sum_comm] + refine Finset.sum_congr rfl fun j _ ↦ ?_ + rw [Finset.sum_mul] + exact Finset.sum_congr rfl fun ξ hξ ↦ shift_mul ((hmemL ξ).mp hξ).1 _ _ + beta_reduce + rw [heq] + have hcut : ∀ ζ : ℝ, + translatedTruncation + ((D - ∑ ξ ∈ hL.toFinset, ∑ j, shift ξ (C ξ j * qt j) : Series K) : K⟦ℝ⟧) ζ = + translatedTruncation (D : K⟦ℝ⟧) ζ - ∑ ξ ∈ hL.toFinset, ∑ j, + translatedTruncation ((C ξ j * qt j : Series K) : K⟦ℝ⟧) (ζ - ξ) := by + intro ζ + rw [← translatedTruncationAddMonoidHom_apply, AddSubgroupClass.coe_sub, map_sub, + AddSubmonoidClass.coe_finsetSum, map_sum, translatedTruncationAddMonoidHom_apply ζ (D : K⟦ℝ⟧), + sub_right_inj] + refine Finset.sum_congr rfl fun ξ hξ ↦ ?_ + rw [AddSubmonoidClass.coe_finsetSum, map_sum] + refine Finset.sum_congr rfl fun j _ ↦ ?_ + rw [translatedTruncationAddMonoidHom_apply, translatedTruncation_shift ((hmemL ξ).mp hξ).1] + refine ⟨?_, ?_⟩ + · -- every translated truncation of the corrected series has value below `ω^ρ` + refine supportOrderType_lt_of_forall_ordinalValue_translatedTruncation_lt _ hρ0 fun ζ hζ ↦ ?_ + rw [hcut ζ] + have hsmall : ∀ (s : Finset ℝ), (∀ ξ ∈ s, ξ ≠ ζ) → s ⊆ hL.toFinset → + ordinalValue (∑ ξ ∈ s, ∑ j, + translatedTruncation ((C ξ j * qt j : Series K) : K⟦ℝ⟧) (ζ - ξ)) < ω^ ρ := fun s hs hsub ↦ + ordinalValue_sum_lt _ _ (NatOrdinal.wpow_pos _) fun ξ hξ ↦ + ordinalValue_sum_lt _ _ (NatOrdinal.wpow_pos _) fun j _ ↦ by + rcases lt_or_gt_of_ne (hs ξ hξ) with h | h + · rw [ordinalValue_translatedTruncation_eq_zero_of_forall_support_le (s := 0) + (fun y hy ↦ Nonpositive.support_subset _ hy) (by linarith)] + exact NatOrdinal.wpow_pos _ + · exact hσ.ordinalValue_translatedTruncation_mul_aeval_lt hwt (hq j) (hCv ξ (hsub hξ) j) + ((hC ξ (hsub hξ)).2.1 j) (he j) ((lt_add_one τ).le.trans hτρ.le) (hsep j) + (by linarith) + by_cases hζL : ζ ∈ hL.toFinset + · rw [← Finset.add_sum_erase _ _ hζL, ← sub_sub] + have h1 := (hC ζ hζL).2.2 + have h2 := hsmall (hL.toFinset.erase ζ) (fun ξ hξ ↦ (Finset.mem_erase.mp hξ).1) + (Finset.erase_subset _ _) + have h3 : ∑ j, translatedTruncation ((C ζ j * qt j : Series K) : K⟦ℝ⟧) (ζ - ζ) = + ∑ j, C ζ j * qt j := by + refine Finset.sum_congr rfl fun j _ ↦ ?_ + rw [sub_self, translatedTruncation_zero] + rw [h3, sub_eq_add_neg _ (∑ ξ ∈ _, _)] + refine (ordinalValue_add_le_max _ _).trans_lt (max_lt h1 ?_) + rwa [ordinalValue_neg] + · have h1 : ordinalValue (translatedTruncation (D : K⟦ℝ⟧) ζ) < ω^ ρ := by + by_contra hge + rw [not_lt] at hge + exact hζL ((hmemL ζ).mpr ⟨hζ, hge⟩) + have h2 := hsmall hL.toFinset (fun ξ hξ hne ↦ hζL (hne ▸ hξ)) subset_rfl + rw [sub_eq_add_neg] + refine (ordinalValue_add_le_max _ _).trans_lt (max_lt h1 ?_) + rwa [ordinalValue_neg] + · -- the translated truncations of the corrected series still satisfy (p) + intro ζ hζ + rw [hcut ζ] + have hbα : ∀ ξ ∈ hL.toFinset, ∀ j, ordinalValue + (translatedTruncation ((C ξ j * qt j : Series K) : K⟦ℝ⟧) (ζ - ξ)) < ω^ α := + fun ξ hξ j ↦ (hblock ξ hξ j _).trans_le (NatOrdinal.wpow_le_wpow.mpr hρα') + rw [σ.pol_sub hx hinj (hDα ζ) (ordinalValue_sum_lt _ _ (NatOrdinal.wpow_pos _) fun ξ hξ ↦ + ordinalValue_sum_lt _ _ (NatOrdinal.wpow_pos _) fun j _ ↦ hbα ξ hξ j), + σ.pol_sum hx hinj _ _ fun ξ hξ ↦ ordinalValue_sum_lt _ _ (NatOrdinal.wpow_pos _) + fun j _ ↦ hbα ξ hξ j, + componentsGE_sub, componentsGE_sum] + refine Ideal.sub_mem _ (htrunc ζ hζ) (Ideal.sum_mem _ fun ξ hξ ↦ ?_) + rw [σ.pol_sum hx hinj _ _ fun j _ ↦ hbα ξ hξ j, componentsGE_sum] + exact Ideal.sum_mem _ fun j _ ↦ hblockctrl ξ hξ j _ + +end Lifts + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/Syzygy.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/Syzygy.lean new file mode 100644 index 0000000000..6f76218c93 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/Syzygy.lean @@ -0,0 +1,250 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MvPolynomial.RemainderBound +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.PrincipalRepresentatives +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MvPolynomial.ComponentsSpan +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.GradedRing.HomogeneousSpan + +/-! +# High-degree components of truncated partial derivatives + +Let `F ∈ K[X]` be homogeneous of degree `α` in variables of degree below `α`. Suppose that the +translated truncations of `F(b_𝓑)` have ordinal value below `ω^{α₁}` for all `γ < 0` sufficiently +close to `0`. Let `α''` be at least `α₁` and exceed the degree of every term of the expansion of a +monomial of `F` by the convolution formula in which at least two factors are translated truncations +at cutoffs `ζ < 0` (`TermDegree wt d k ρ` with `2 ≤ k`). For an index `B′` and a degree `τ` with +`α'' ≤ τ ⊕ deg B′`, the differentiated form of the Leibniz rule with remainder +(`exists_forall_pol_translatedTruncation_aeval_pderiv`) gives, for all `γ < 0` sufficiently close +to `0`, + +`pol((∂F/∂X_{B′})(b_𝓑)^{|γ}) = ∂/∂X_{B′}[pol(G^{|γ})] − ∑_B (∂ pol(b_B^{|γ})/∂X_{B′}) ∂F/∂X_B + − ∂R_γ/∂X_{B′} + R′_γ`, + +with `R_γ`, `R′_γ` the remainders for `F` and for `∂F/∂X_{B′}`. The components of degree at least +`τ` of the first term and of the two remainder terms vanish: a monomial `m′` of any of them has +`X_{B′} m′` of degree below `α''`, hence `m′` of degree below `τ`. In the sum only the `B` with +`deg B > deg B′` contribute, `pol(b_B^{|γ})` having degree below `deg B`. Hence the components of +degree at least `τ` of `pol((∂F/∂X_{B′})(b_𝓑)^{|γ})` lie in the ideal `(∂F/∂X_B : deg B > deg B′)`. +-/ + +universe v w + +open scoped NatOrdinal HahnSeries +open Berarducci HahnSeries MvPolynomial OrdinalGraded + +public noncomputable section + +namespace Berarducci + +variable {K : Type v} [Field K] {ι : Type w} {wt : ι → NatOrdinal} + +/-! ### Partial derivatives -/ + +/-- A monomial `d'` of `∂_i p` has `d' · X_i` a monomial of `p`. -/ +theorem add_single_mem_support_of_mem_support_pderiv {i : ι} {p : MvPolynomial ι K} {d' : ι →₀ ℕ} + (hd' : d' ∈ (pderiv i p).support) : d' + Finsupp.single i 1 ∈ p.support := by + obtain ⟨d, hd, hdi, rfl⟩ := exists_mem_support_of_mem_support_pderiv hd' + rwa [tsub_add_cancel_of_le (Finsupp.single_le_iff.mpr (Nat.one_le_iff_ne_zero.mpr hdi))] + +/-- A polynomial all of whose monomials have degree below `g ≤ wt v` has no monomial containing +`X_v`: its partial derivative with respect to `X_v` vanishes. -/ +theorem pderiv_eq_zero_of_degreeLT_le {P : MvPolynomial ι K} {g : NatOrdinal} + (hP : DegreeLT wt P g) {v : ι} (hg : g ≤ wt v) : pderiv v P = 0 := by + by_contra h + obtain ⟨d', hd'⟩ := support_nonempty.mpr h + obtain ⟨d, hd, hw⟩ := exists_add_eq_weight_of_mem_support_pderiv wt hd' + have h1 := degreeLT_iff.mp hP d hd + rw [← hw] at h1 + exact absurd (hg.trans (le_add_of_nonneg_left zero_le)) (not_le.mpr h1) + +/-! ### Components of a product with a homogeneous factor -/ + +open scoped Classical in +/-- The component of degree `γ` of `P · Q`, `Q` homogeneous of degree `c`, is the component of +degree `γ ⊖ c` of `P` times `Q`, and `0` if `c \not\preccurlyeq γ` in the algebraic order. -/ +theorem weightedHomogeneousComponent_mul_of_isWeightedHomogeneous {P Q : MvPolynomial ι K} + {c : NatOrdinal} (hQ : IsWeightedHomogeneous wt Q c) (γ : NatOrdinal) : + weightedHomogeneousComponent wt γ (P * Q) = + if h : ∃ β, β + c = γ then weightedHomogeneousComponent wt (Classical.choose h) P * Q + else 0 := by + classical + let := weightedGradedAlgebra K wt + have hdec : ∀ (R : MvPolynomial ι K) (e : NatOrdinal), + (DirectSum.decompose (weightedHomogeneousSubmodule K wt) R e : MvPolynomial ι K) = + weightedHomogeneousComponent wt e R := fun R e ↦ by + rw [← decompose'_apply] + rfl + have := coe_decompose_mul_of_left_mem (𝒜 := weightedHomogeneousSubmodule K wt) + ((mem_weightedHomogeneousSubmodule _ _ _ _).mpr hQ) P γ + rw [mul_comm, ← hdec, this] + split_ifs with h + · rw [hdec, mul_comm] + · rfl + +variable {x : ι → PrincipalSubring K} + +namespace Lifts + +variable (σ : Lifts wt x) (hx : IsMinimalSystem (Berarducci.principalGrading K) wt x) + {α : NatOrdinal} (hinj : ∀ β < α, InjectiveAt K wt x β) (hσ : σ.IsPrincipal) +include hinj hσ + +/-- **The polynomial of a truncated partial derivative, above a degree `τ`.** Let `F` be homogeneous +of degree `α` in variables of degree `< α`, whose evaluation `F(b_𝓑)` has translated truncations of +ordinal value below `ω^{α₁}` for all `γ < 0` sufficiently close to `0`, with `α₁ ≤ α''` and +`α₁ ≤ α`; let every term of the expansion of a monomial of `F` with at least two translated +truncations have degree below `α''`. For an index `v'` and a degree `τ` with +`α'' ≤ τ ⊕ wt v'`: for all `γ < 0` sufficiently close to `0`, the components of degree at least `τ` +of `pol((∂F/∂X_{v'})(b_𝓑)^{|γ})` lie in the ideal of the `∂F/∂X_j` over the variables `j` of `F` +with `wt v' < wt j`. The index `v'` need not occur in `F`. -/ +@[blueprint "lem:differentiated-relation" + (phase := "Translated truncations") + (title := "High-degree Jacobian ideal membership") + (statement := /-- + Let $K$ be a field, let $(x_i)_{i\in I}$ be a minimal homogeneous + generating system of $\widehat{\mathrm P}$ with + $x_i\in\mathrm P_{w_i}$, and choose principal series $b_i$ of degree + $w_i$ representing the $x_i$. Assume that evaluation at $(x_i)$ is + injective in every weighted degree below $\alpha<\omega_1$. For a series + $a$ of ordinal value below $\omega^\alpha$, write $P_a$ for its resulting + polynomial representative. + + Let $F\in K[X_i:i\in I]$ be weighted-homogeneous of degree $\alpha$, and + suppose $w_i<\alpha$ for every variable $X_i$ occurring in $F$. Choose + ordinals $\alpha_1,\alpha''$ such that + $\alpha_1\le\alpha''$ and $\alpha_1\le\alpha$. Suppose that, for some + $\varepsilon_1>0$, + \[ + v_J((F(b_i))^{|\gamma})<\omega^{\alpha_1} + \qquad(-\varepsilon_1<\gamma<0). + \] + Assume also that every term obtained from a monomial of $F$ by replacing + the weights of at least two variable factors, counted with multiplicity, + by strictly smaller ordinals has weight below $\alpha''$. + + Fix $i'\in I$ and an ordinal $\tau$ with + $\alpha''\le\tau\oplus w_{i'}$. Then, for every $\gamma<0$ sufficiently + close to $0$, + \[ + \bigl(P_{((\partial_{i'}F)(b_i))^{|\gamma}}\bigr)_{\ge\tau} + \in + \bigl(\partial_jF: + j\in\operatorname{vars}(F),\ w_{i'} 0, ∀ γ : ℝ, -ε < γ → γ < 0 → + componentsGE wt τ (σ.pol hx α + (translatedTruncation ((aeval σ.lift (pderiv v' F) : Series K) : K⟦ℝ⟧) γ)) ∈ + Ideal.span (Set.range fun j : {j : ι // j ∈ F.vars ∧ wt v' < wt j} ↦ pderiv j.1 F) := by + classical + have hFdeg : ∀ d ∈ F.support, Finsupp.weight wt d ≤ α := + fun d hd ↦ (hF (mem_support_iff.mp hd)).le + obtain ⟨ε₂, hε₂, hD⟩ := σ.exists_forall_pol_translatedTruncation_aeval_pderiv hx hinj F hFdeg + hvars v' + refine ⟨min ε₁ ε₂, lt_min hε₁ hε₂, fun γ hγε hγ0 ↦ ?_⟩ + have hγ₁ : -ε₁ < γ := by linarith [min_le_left ε₁ ε₂] + have hγ₂ : -ε₂ < γ := by linarith [min_le_right ε₁ ε₂] + obtain ⟨E, E', hE, hE', heq⟩ := hD γ hγ₂ hγ0 + rw [heq, componentsGE_add, componentsGE_sub, componentsGE_sub] + -- a monomial `m'` with `v' m'` of degree below `α''` has degree below `τ` + have hlow : ∀ d' : ι →₀ ℕ, Finsupp.weight wt d' + wt v' < α'' → Finsupp.weight wt d' < τ := + fun d' h ↦ lt_of_add_lt_add_right (h.trans_le hτ) + -- `∂/∂X_{v'} pol(G^{|γ})` + have h1 : componentsGE wt τ (pderiv v' (σ.pol hx α + (translatedTruncation ((aeval σ.lift F : Series K) : K⟦ℝ⟧) γ))) = 0 := by + refine componentsGE_eq_zero_of_forall_lt wt fun d' hd' ↦ ?_ + obtain ⟨d, hd, hw⟩ := exists_add_eq_weight_of_mem_support_pderiv wt hd' + refine hlow d' ?_ + rw [hw] + exact (degreeLT_iff.mp (σ.pol_degreeLT_of_lt hx hinj hα₁α (hG γ hγ₁ hγ0)) d hd).trans_le hα₁ + -- the remainder for `F`, differentiated + have h2 : componentsGE wt τ (pderiv v' E) = 0 := by + refine componentsGE_eq_zero_of_forall_lt wt fun d' hd' ↦ ?_ + obtain ⟨d, hd, hw⟩ := exists_add_eq_weight_of_mem_support_pderiv wt hd' + obtain ⟨d₀, hd₀, k, hk, hρ⟩ := hE d hd + refine hlow d' ?_ + rw [hw] + exact hwin d₀ hd₀ k _ hk hρ + -- the remainder for `∂F/∂X_{v'}` + have h3 : componentsGE wt τ E' = 0 := by + refine componentsGE_eq_zero_of_forall_lt wt fun d' hd' ↦ ?_ + obtain ⟨d, hd, k, hk, hρ⟩ := hE' d' hd' + refine hlow d' ?_ + exact hwin _ (add_single_mem_support_of_mem_support_pderiv hd) k _ hk (hρ.untrunc v') + rw [h1, h2, h3, zero_sub, sub_zero, add_zero] + refine neg_mem ?_ + -- the sum: only the variables of degree above `wt v'` contribute + rw [← Finset.sum_filter_add_sum_filter_not F.vars fun j ↦ wt v' < wt j, componentsGE_add] + have hzero : ∑ j ∈ F.vars.filter (fun j ↦ ¬ wt v' < wt j), + pderiv v' (σ.pol hx α (translatedTruncation (σ.lift j : K⟦ℝ⟧) γ)) * pderiv j F = 0 := by + refine Finset.sum_eq_zero fun j hj ↦ ?_ + have hj' := (Finset.mem_filter.mp hj).2 + rw [not_lt] at hj' + have hdeg : DegreeLT wt (σ.pol hx α (translatedTruncation (σ.lift j : K⟦ℝ⟧) γ)) (wt j) := + σ.pol_degreeLT_of_lt hx hinj (hvars j (Finset.mem_filter.mp hj).1).le + (hσ.ordinalValue_translatedTruncation_lift_lt j hγ0) + rw [pderiv_eq_zero_of_degreeLT_le hdeg hj', zero_mul] + rw [hzero, componentsGE_zero, add_zero] + -- the generators are homogeneous + have hgen : ∀ j : {j : ι // j ∈ F.vars ∧ wt v' < wt j}, + ∃ c, IsWeightedHomogeneous wt (pderiv j.1 F) c := by + intro j + by_cases h : ∃ β, β + wt j.1 = α + · obtain ⟨β, hβ⟩ := h + exact ⟨β, isWeightedHomogeneous_pderiv wt hF j.1 hβ⟩ + · exact ⟨0, by + rw [pderiv_eq_zero_of_isWeightedHomogeneous wt hF j.1 h] + exact isWeightedHomogeneous_zero _ _ _⟩ + choose c hc using hgen + have : Finite {j : ι // j ∈ F.vars ∧ wt v' < wt j} := + (F.vars.finite_toSet.subset fun j (hj : j ∈ F.vars ∧ wt v' < wt j) ↦ hj.1).to_subtype + refine componentsGE_mem_span wt hc ?_ τ + refine Ideal.sum_mem _ fun j hj ↦ ?_ + have hj' := Finset.mem_filter.mp hj + exact Ideal.mul_mem_left _ _ (Ideal.subset_span ⟨⟨j, hj'.1, hj'.2⟩, rfl⟩) + +end Lifts + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/TruncationExpansion.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/TruncationExpansion.lean new file mode 100644 index 0000000000..317573f860 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/TruncationExpansion.lean @@ -0,0 +1,589 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MvPolynomial.TermDegree +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.LeadingCoefficient +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.TruncationPolynomial + +/-! +# The Leibniz rule with remainder, read in polynomials + +Let `𝓑` be a minimal system of homogeneous generators with lifts `b_B`, and assume evaluation +injective below `α`. For a monomial `X^d = X_{B_1} ⋯ X_{B_n}` (factors listed with multiplicity) +the convolution formula [Ber00, Lem. 7.5], iterated over the factors, expresses the polynomial of +the translated truncation `(X^d(b_𝓑))^{|γ}` as a sum over the nonempty sets `S` of truncated +factors of products `∏_{s ∈ S} pol(b_s^{|ζ_s}) ∏_{s ∉ S} X_s` with `∑_{s ∈ S} ζ_s = γ`. The terms +with exactly one truncated factor sum to `∑_B pol(b_B^{|γ}) ∂X^d/∂X_B`; the remaining terms — +at least two truncated factors — have degrees of the form `⨁_{s ∉ S} deg s ⊕ ⨁_{s ∈ S} ρ_s` with +`ρ_s < deg s`. The Leibniz rule with remainder [Ber00, Lem. 7.7] +(`exists_forall_pol_translatedTruncation_aeval`): for all `γ < 0` sufficiently close to `0`, +`pol(G(b_𝓑)^{|γ}) = ∑_B pol(b_B^{|γ}) ∂G/∂X_B + R_γ`, where every monomial of the remainder `R_γ` +has such a degree, for some monomial of `G` and some set of at least two truncated factors. + +The degrees are recorded by the inductive predicate `TermDegree wt d k ρ`: `ρ` is the degree of a +term of the expansion of the monomial `d` with `k` truncated factors. +-/ + +universe v w + +open scoped NatOrdinal HahnSeries +open Berarducci MvPolynomial OrdinalGraded + +public noncomputable section + +namespace Berarducci + +variable {K : Type v} [Field K] {ι : Type w} [DecidableEq ι] {wt : ι → NatOrdinal} + {x : ι → PrincipalSubring K} + +/-- A common punctured neighborhood works for finitely many eventual properties. -/ +theorem exists_forall_of_forall_exists_forall {ι' : Type*} (s : Finset ι') (p : ι' → ℝ → Prop) + (h : ∀ i ∈ s, ∃ ε > 0, ∀ γ : ℝ, -ε < γ → γ < 0 → p i γ) : + ∃ ε > 0, ∀ γ : ℝ, -ε < γ → γ < 0 → ∀ i ∈ s, p i γ := by + classical + induction s using Finset.induction_on with + | empty => exact ⟨1, one_pos, fun _ _ _ i hi ↦ absurd hi (Finset.notMem_empty i)⟩ + | insert a s ha ih => + obtain ⟨ε₁, hε₁, h₁⟩ := h a (Finset.mem_insert_self a s) + obtain ⟨ε₂, hε₂, h₂⟩ := ih fun i hi ↦ h i (Finset.mem_insert_of_mem hi) + refine ⟨min ε₁ ε₂, lt_min hε₁ hε₂, fun γ hγε hγ0 i hi ↦ ?_⟩ + have hγ₁ : -ε₁ < γ := by have := min_le_left ε₁ ε₂; linarith + have hγ₂ : -ε₂ < γ := by have := min_le_right ε₁ ε₂; linarith + rcases Finset.mem_insert.mp hi with rfl | hi + · exact h₁ γ hγ₁ hγ0 + · exact h₂ γ hγ₂ hγ0 i hi + +/-! ### Degrees of the terms of the expansion -/ + +/-! ### The remainder -/ + +variable (wt) in +/-- `E` is a *remainder* for the monomial `d`: every monomial of `E` has the degree of a term of +the expansion of `d` with at least two truncated factors. -/ +def IsRemainder (d : ι →₀ ℕ) (E : MvPolynomial ι K) : Prop := + ∀ d' ∈ E.support, ∃ k, 2 ≤ k ∧ TermDegree wt d k (Finsupp.weight wt d') + +omit [DecidableEq ι] in +theorem isRemainder_zero (d : ι →₀ ℕ) : IsRemainder wt d (0 : MvPolynomial ι K) := fun d' hd' ↦ by + rw [support_zero] at hd' + exact absurd hd' (Finset.notMem_empty d') + +omit [DecidableEq ι] in +theorem IsRemainder.add {d : ι →₀ ℕ} {E E' : MvPolynomial ι K} (hE : IsRemainder wt d E) + (hE' : IsRemainder wt d E') : IsRemainder wt d (E + E') := by + classical + intro d' hd' + rcases Finset.mem_union.mp (support_add hd') with h | h + · exact hE d' h + · exact hE' d' h + +omit [DecidableEq ι] in +theorem IsRemainder.sum {ι' : Type*} {d : ι →₀ ℕ} (s : Finset ι') (E : ι' → MvPolynomial ι K) + (hE : ∀ j ∈ s, IsRemainder wt d (E j)) : IsRemainder wt d (∑ j ∈ s, E j) := by + classical + induction s using Finset.induction_on with + | empty => rw [Finset.sum_empty]; exact isRemainder_zero d + | insert a s ha ih => + rw [Finset.sum_insert ha] + exact (hE a (Finset.mem_insert_self a s)).add (ih fun j hj ↦ hE j (Finset.mem_insert_of_mem hj)) + +omit [DecidableEq ι] in +/-- Multiplying a remainder for `d` by `X_i` gives a remainder for `d + single i 1`. -/ +theorem IsRemainder.mul_X {d : ι →₀ ℕ} {E : MvPolynomial ι K} (hE : IsRemainder wt d E) (i : ι) : + IsRemainder wt (d + Finsupp.single i 1) (E * X i) := fun d' hd' ↦ by + classical + obtain ⟨d₁, hd₁, d₂, hd₂, hw⟩ := exists_add_eq_weight_of_mem_support_mul (wt := wt) hd' + obtain ⟨k, hk, hT⟩ := hE d₁ hd₁ + rw [X, support_monomial, ite_eq_right one_ne_zero, Finset.mem_singleton] at hd₂ + subst hd₂ + rw [Finsupp.weight_single, one_smul] at hw + exact ⟨k, hk, hw ▸ TermDegree.untrunc i hT⟩ + +omit [DecidableEq ι] in +/-- Multiplying a polynomial whose monomials have degrees of terms of `d` with at least one +truncated factor by a polynomial of degree `< wt i` gives a remainder for `d + single i 1`. -/ +theorem isRemainder_mul_of_degreeLT {d : ι →₀ ℕ} {P Q : MvPolynomial ι K} + (hP : ∀ d' ∈ P.support, ∃ k, 1 ≤ k ∧ TermDegree wt d k (Finsupp.weight wt d')) {i : ι} + (hQ : DegreeLT wt Q (wt i)) : IsRemainder wt (d + Finsupp.single i 1) (P * Q) := fun d' hd' ↦ by + classical + obtain ⟨d₁, hd₁, d₂, hd₂, hw⟩ := exists_add_eq_weight_of_mem_support_mul (wt := wt) hd' + obtain ⟨k, hk, hT⟩ := hP d₁ hd₁ + refine ⟨k + 1, by omega, hw ▸ TermDegree.trunc i ((degreeLT_iff).mp hQ d₂ hd₂) hT⟩ + +/-! ### The Leibniz rule for monomials -/ + +namespace Lifts + +variable (σ : Lifts wt x) (hx : IsMinimalSystem (Berarducci.principalGrading K) wt x) + {α : NatOrdinal} (hinj : ∀ β < α, InjectiveAt K wt x β) +include hinj + +omit [DecidableEq ι] in +/-- The polynomial of a lift is its variable. -/ +theorem pol_lift {i : ι} (hi : wt i < α) : σ.pol hx α (σ.lift i) = X i := by + have h : σ.lift i = aeval σ.lift (X i : MvPolynomial ι K) := (aeval_X _ _).symm + rw [h] + exact σ.pol_aeval hx hinj ((isWeightedHomogeneous_X K wt i).degreeLT hi) + +omit [DecidableEq ι] in +/-- The polynomial of a monomial in the lifts is the monomial. -/ +theorem pol_aeval_monomial {d : ι →₀ ℕ} (hd : Finsupp.weight wt d < α) : + σ.pol hx α (aeval σ.lift (monomial d (1 : K))) = monomial d 1 := + σ.pol_aeval hx hinj ((isWeightedHomogeneous_monomial wt d (1 : K) rfl).degreeLT hd) + +omit [DecidableEq ι] hinj in +/-- The first-order terms of the expansion of a monomial: every monomial of +`∑_j Tj j * ∂X^d/∂X_j` has the degree of a term of `d` with one truncated factor, provided each +`Tj j` (in the application, `pol(b_j^{|γ})`) has degree `< wt j`. -/ +theorem forall_termDegree_sum_mul_pderiv_monomial (d : ι →₀ ℕ) (Tj : ι → MvPolynomial ι K) + (hTj : ∀ j ∈ d.support, DegreeLT wt (Tj j) (wt j)) : + ∀ d' ∈ (∑ j ∈ d.support, Tj j * pderiv j (monomial d (1 : K))).support, + ∃ k, 1 ≤ k ∧ TermDegree wt d k (Finsupp.weight wt d') := by + classical + intro d' hd' + obtain ⟨j, hj, hd'j⟩ := Finset.mem_biUnion.mp (support_sum hd') + obtain ⟨d₁, hd₁, d₂, hd₂, hw⟩ := exists_add_eq_weight_of_mem_support_mul (wt := wt) hd'j + rw [pderiv_monomial, support_monomial] at hd₂ + split_ifs at hd₂ with h0 + · exact absurd hd₂ (Finset.notMem_empty d₂) + · rw [Finset.mem_singleton] at hd₂ + subst hd₂ + have hdj : d - Finsupp.single j 1 + Finsupp.single j 1 = d := + Finsupp.sub_add_single_one_cancel (Finsupp.mem_support_iff.mp hj) + refine ⟨1, le_rfl, ?_⟩ + have := TermDegree.trunc_left j ((degreeLT_iff).mp (hTj j hj) d₁ hd₁) + (termDegree_weight wt (d - Finsupp.single j 1)) + rw [add_comm (Finsupp.single j 1), hdj] at this + rwa [← hw] + +omit [DecidableEq ι] hinj in +/-- Splitting off one factor: `X^{d + e_i} = X^d · X_i`. -/ +theorem monomial_add_single_one (d : ι →₀ ℕ) (i : ι) : + monomial (d + Finsupp.single i 1) (1 : K) = monomial d 1 * X i := by + rw [X, MvPolynomial.monomial_mul_monomial, mul_one] + +omit [DecidableEq ι] hinj in +/-- The first-order terms after splitting off one factor: +`∑_j T_j ∂(X^d X_i)/∂X_j = (∑_j T_j ∂X^d/∂X_j) X_i + T_i X^d`. -/ +theorem sum_mul_pderiv_monomial_add_single (d : ι →₀ ℕ) (i : ι) (T : ι → MvPolynomial ι K) : + ∑ j ∈ (d + Finsupp.single i 1).support, T j * pderiv j (monomial (d + Finsupp.single i 1) 1) = + (∑ j ∈ d.support, T j * pderiv j (monomial d (1 : K))) * X i + T i * monomial d 1 := by + classical + have hmem : i ∈ (d + Finsupp.single i 1).support := by + rw [Finsupp.mem_support_iff, Finsupp.add_apply, Finsupp.single_eq_same] + omega + have hsub : d.support ⊆ (d + Finsupp.single i 1).support := fun j hj ↦ by + rw [Finsupp.mem_support_iff] at hj ⊢ + rw [Finsupp.add_apply] + omega + simp only [monomial_add_single_one, pderiv_mul, mul_add, Finset.sum_add_distrib] + congr 1 + · rw [Finset.sum_mul, ← Finset.sum_subset hsub] + · exact Finset.sum_congr rfl fun j _ ↦ by ring + · intro j _ hj + rw [pderiv_monomial, Finsupp.notMem_support_iff.mp hj, Nat.cast_zero, mul_zero, monomial_zero, + zero_mul, mul_zero] + · rw [Finset.sum_eq_single i] + · rw [pderiv_X_self, mul_one] + · intro j _ hji + rw [pderiv_X_of_ne (Ne.symm hji), mul_zero, mul_zero] + · intro h + exact absurd hmem h + +omit [DecidableEq ι] in +/-- **The Leibniz rule with remainder for a monomial.** For `X^d` of degree `≤ α` in variables of +degree `< α`, and all `γ < 0` sufficiently close to `0`, `v_J((X^d(b_𝓑))^{|γ}) < ω^α` and the +polynomial of `(X^d(b_𝓑))^{|γ}` is `∑_j pol(b_j^{|γ}) ∂X^d/∂X_j + R_γ` with `R_γ` a remainder +for `d`. -/ +theorem exists_forall_pol_translatedTruncation_aeval_monomial (d : ι →₀ ℕ) + (hd : Finsupp.weight wt d ≤ α) (hvars : ∀ i ∈ d.support, wt i < α) : + ∃ ε > 0, ∀ γ : ℝ, -ε < γ → γ < 0 → + ordinalValue (translatedTruncation ((aeval σ.lift (monomial d (1 : K)) : Series K) : K⟦ℝ⟧) γ) + < ω^ α ∧ + ∃ E : MvPolynomial ι K, IsRemainder wt d E ∧ + σ.pol hx α (translatedTruncation ((aeval σ.lift (monomial d (1 : K)) : Series K) : K⟦ℝ⟧) γ) + = ∑ j ∈ d.support, σ.pol hx α (translatedTruncation (σ.lift j : K⟦ℝ⟧) γ) * + pderiv j (monomial d 1) + E := by + classical + -- strong induction on the number of factors + suffices h : ∀ n : ℕ, ∀ d : ι →₀ ℕ, Finsupp.degree d = n → Finsupp.weight wt d ≤ α → + (∀ i ∈ d.support, wt i < α) → ∃ ε > 0, ∀ γ : ℝ, -ε < γ → γ < 0 → + ordinalValue (translatedTruncation ((aeval σ.lift (monomial d (1 : K)) : Series K) : K⟦ℝ⟧) γ) + < ω^ α ∧ + ∃ E : MvPolynomial ι K, IsRemainder wt d E ∧ + σ.pol hx α (translatedTruncation ((aeval σ.lift (monomial d (1 : K)) : Series K) : K⟦ℝ⟧) γ) + = ∑ j ∈ d.support, σ.pol hx α (translatedTruncation (σ.lift j : K⟦ℝ⟧) γ) * + pderiv j (monomial d 1) + E from h _ d rfl hd hvars + intro n + induction n using Nat.strong_induction_on with + | _ n ih => + intro d hdn hd hvars + rcases eq_or_ne d 0 with rfl | hd0 + · -- the constant monomial + refine ⟨1, one_pos, fun γ _ hγ0 ↦ ?_⟩ + have h1 : aeval σ.lift (monomial (0 : ι →₀ ℕ) (1 : K)) = (1 : Series K) := by + rw [monomial_zero', C_1, map_one] + have htr : translatedTruncation ((1 : Series K) : K⟦ℝ⟧) γ = 0 := by + rw [Subring.coe_one, ← HahnSeries.C_one] + exact translatedTruncation_C_of_neg 1 hγ0 + rw [h1, htr, ordinalValue_zero] + refine ⟨NatOrdinal.wpow_pos α, 0, isRemainder_zero 0, ?_⟩ + simp only [σ.pol_zero hx hinj, Finsupp.support_zero, Finset.sum_empty, add_zero] + · -- split off one factor `X_i` + obtain ⟨i, hi⟩ := Finsupp.support_nonempty_iff.mpr hd0 + set d' := d - Finsupp.single i 1 with hd'def + have hdd' : d' + Finsupp.single i 1 = d := + Finsupp.sub_add_single_one_cancel (Finsupp.mem_support_iff.mp hi) + have hwd : Finsupp.weight wt d' + wt i = Finsupp.weight wt d := by + rw [← hdd', map_add, Finsupp.weight_single, one_smul] + have hdeg : Finsupp.degree d' < n := by + rw [← hdn, ← hdd', map_add, Finsupp.degree_single] + omega + have hwi : wt i < α := hvars i hi + have hwd'α : Finsupp.weight wt d' < α := by + have : Finsupp.weight wt d' < Finsupp.weight wt d' + wt i := + lt_add_of_pos_right _ (pos_iff_ne_zero.mpr (hx.ne_zero i)) + exact this.trans_le (hwd ▸ hd) + have hsub : d'.support ⊆ d.support := by + rw [hd'def] + exact Finsupp.support_tsub + obtain ⟨ε', hε', ih'⟩ := ih _ hdeg d' rfl hwd'α.le fun j hj ↦ hvars j (hsub hj) + -- the translated truncations of the lifts of the variables of `d` have value below `ω^{wt j}` + obtain ⟨εd, hεd, hdrop⟩ := exists_forall_of_forall_exists_forall d.support + (fun j β ↦ ordinalValue (translatedTruncation (σ.lift j : K⟦ℝ⟧) β) < ω^ (wt j)) + fun j _ ↦ exists_forall_ordinalValue_translatedTruncation_lt + (Berarducci.Represents.ordinalValue_lt (σ.represents j)) + -- the convolution formula for `X^{d'}(b_𝓑) · b_i` + set M' : Series K := aeval σ.lift (monomial d' (1 : K)) with hM'def + have hM' : ordinalValue M' < ω^ (Finsupp.weight wt d' + 1) := + Berarducci.Represents.ordinalValue_lt + (σ.aeval_represents (isWeightedHomogeneous_monomial wt d' (1 : K) rfl)) + have hli : ordinalValue (σ.lift i) < ω^ (wt i + 1) := + Berarducci.Represents.ordinalValue_lt (σ.represents i) + obtain ⟨εL, hεL, hL2⟩ := σ.exists_forall_pol_translatedTruncation_mul hx hinj hM' hli hwd'α hwi + (hwd ▸ hd) + -- the translated truncations of the product have value below `ω^{deg d}` + have hprod : aeval σ.lift (monomial d (1 : K)) = M' * σ.lift i := by + rw [← hdd', monomial_add_single_one, map_mul, aeval_X] + have hMprod : ordinalValue (M' * σ.lift i) < ω^ (Finsupp.weight wt d + 1) := by + rw [← hprod] + exact Berarducci.Represents.ordinalValue_lt + (σ.aeval_represents (isWeightedHomogeneous_monomial wt d (1 : K) rfl)) + obtain ⟨εP, hεP, hdropP⟩ := exists_forall_ordinalValue_translatedTruncation_lt hMprod + refine ⟨min (min ε' εd) (min εL εP), lt_min (lt_min hε' hεd) (lt_min hεL hεP), + fun γ hγε hγ0 ↦ ?_⟩ + have hm1 := min_le_left (min ε' εd) (min εL εP) + have hm2 := min_le_right (min ε' εd) (min εL εP) + have hγ' : -ε' < γ := by have := min_le_left ε' εd; linarith + have hγd : -εd < γ := by have := min_le_right ε' εd; linarith + have hγL : -εL < γ := by have := min_le_left εL εP; linarith + have hγP : -εP < γ := by have := min_le_right εL εP; linarith + refine ⟨?_, ?_⟩ + · rw [hprod] + exact (hdropP γ hγP hγ0).trans_le (NatOrdinal.wpow_le_wpow.mpr hd) + -- the index set of the convolution formula, with `0` and `γ` added + set S : Finset ℝ := insert 0 (insert γ (convolutionIndex (M' : K⟦ℝ⟧) (σ.lift i : K⟦ℝ⟧) γ)) + with hSdef + have hS1 : convolutionIndex (M' : K⟦ℝ⟧) (σ.lift i : K⟦ℝ⟧) γ ⊆ S := + (Finset.subset_insert _ _).trans (Finset.subset_insert _ _) + have hS2 : (S : Set ℝ) ⊆ Set.Icc γ 0 := by + intro β hβ + rw [hSdef, Finset.coe_insert, Finset.coe_insert] at hβ + rcases hβ with rfl | rfl | hβ + · exact ⟨hγ0.le, le_rfl⟩ + · exact ⟨le_rfl, hγ0.le⟩ + · exact mem_Icc_of_mem_convolutionIndex hβ + have h0S : (0 : ℝ) ∈ S := Finset.mem_insert_self _ _ + have hγS : γ ∈ S := Finset.mem_insert_of_mem (Finset.mem_insert_self _ _) + have hconv := hL2 γ hγL hγ0 S hS1 hS2 + rw [sum_eq_add_add_sum_erase h0S hγS hγ0.ne] at hconv + -- the two first-order terms of the convolution formula + rw [translatedTruncation_zero, sub_zero, σ.pol_aeval_monomial hx hinj hwd'α, sub_self, + translatedTruncation_zero, σ.pol_lift hx hinj hwi] at hconv + -- the induction hypothesis at `γ` + obtain ⟨-, E', hE', hexp'⟩ := ih' γ hγ' hγ0 + -- the remaining terms form a remainder + set R : MvPolynomial ι K := ∑ β ∈ (S.erase 0).erase γ, + σ.pol hx α (translatedTruncation (M' : K⟦ℝ⟧) β) * + σ.pol hx α (translatedTruncation (σ.lift i : K⟦ℝ⟧) (γ - β)) with hRdef + have hR : IsRemainder wt d R := by + rw [← hdd'] + refine IsRemainder.sum _ _ fun β hβ ↦ ?_ + have hβγ : β ≠ γ := (Finset.mem_erase.mp hβ).1 + have hβ0 : β ≠ 0 := (Finset.mem_erase.mp (Finset.mem_erase.mp hβ).2).1 + have hβS : β ∈ S := (Finset.mem_erase.mp (Finset.mem_erase.mp hβ).2).2 + obtain ⟨hβ1, hβ2⟩ := hS2 hβS + have hβlt : β < 0 := lt_of_le_of_ne hβ2 hβ0 + have hβgt : γ < β := lt_of_le_of_ne hβ1 (Ne.symm hβγ) + -- the degree of the truncated lift + have hQ : DegreeLT wt (σ.pol hx α (translatedTruncation (σ.lift i : K⟦ℝ⟧) (γ - β))) + (wt i) := + σ.pol_degreeLT_of_lt hx hinj hwi.le (hdrop (γ - β) (by linarith) (by linarith) i hi) + -- the expansion of `(X^{d'}(b_𝓑))^{|β}` + obtain ⟨-, E'', hE'', hexp''⟩ := ih' β (by linarith) hβlt + refine isRemainder_mul_of_degreeLT (fun d₁ hd₁ ↦ ?_) hQ + rw [hexp''] at hd₁ + rcases Finset.mem_union.mp (support_add hd₁) with h | h + · exact forall_termDegree_sum_mul_pderiv_monomial d' _ + (fun j hj ↦ σ.pol_degreeLT_of_lt hx hinj (hvars j (hsub hj)).le + (hdrop β (by linarith) hβlt j (hsub hj))) d₁ h + · obtain ⟨k, hk, hT⟩ := hE'' d₁ h + exact ⟨k, by omega, hT⟩ + refine ⟨E' * X i + R, (hdd' ▸ hE'.mul_X i).add hR, ?_⟩ + -- combine + rw [hprod, hconv, hexp', ← hdd', sum_mul_pderiv_monomial_add_single] + ring + +omit [DecidableEq ι] hinj in +/-- The ordinal value of a scalar multiple. -/ +theorem ordinalValue_C_mul_lt (k : K) {u : Series K} {β : NatOrdinal} (hu : ordinalValue u < ω^ β) : + ordinalValue ((HahnSeries.Nonpositive.C : K →+* Series K) k * u) < ω^ β := by + rcases eq_or_ne k 0 with rfl | hk + · rw [map_zero, zero_mul, ordinalValue_zero] + exact NatOrdinal.wpow_pos β + · rwa [ordinalValue_C_mul hk] + +omit [DecidableEq ι] in +/-- **The Leibniz rule with remainder [Ber00, Lem. 7.7], read in polynomials.** For `H ∈ K[X]` +with monomials of degree `≤ α` in variables of degree `< α`, and all `γ < 0` sufficiently close to +`0`, `v_J(H(b_𝓑)^{|γ}) < ω^α` and `pol(H(b_𝓑)^{|γ}) = ∑_j pol(b_j^{|γ}) ∂H/∂X_j + R_γ`, where +every monomial of the remainder `R_γ` has the degree of a term of the expansion of some monomial +of `H` with at least two truncated factors. -/ +@[blueprint "lem:leibniz-remainder" + (phase := "Translated truncations") + (title := "Polynomial Leibniz rule for translated truncations") + (statement := /-- + Let $K$ be a field, let $(x_i)_{i\in I}$ be a minimal homogeneous + generating system of $\widehat{\mathrm P}$ with + $x_i\in\mathrm P_{w_i}$, and choose series $b_i$ representing the $x_i$. + Assume that evaluation at $(x_i)$ is injective in every weighted degree + below $\alpha<\omega_1$. For a series $a$ of ordinal value below + $\omega^\alpha$, write $P_a$ for its resulting polynomial representative. + + Let $G\in K[X_i:i\in I]$. Suppose every monomial $X^d$ of $G$ has weight + at most $\alpha$, and $w_i<\alpha$ for every variable $X_i$ occurring in + $G$. Then, for every $\gamma<0$ sufficiently close to $0$, + \[ + v_J((G(b_i))^{|\gamma})<\omega^\alpha + \] + and there is a polynomial $R_\gamma$ such that + \[ + P_{(G(b_i))^{|\gamma}} + =\sum_{i\in\operatorname{vars}(G)} + P_{b_i^{|\gamma}}\frac{\partial G}{\partial X_i}+R_\gamma. + \] + More precisely, for every monomial $X^{d'}$ of $R_\gamma$, there are a + monomial $X^d$ of $G$, an integer $k\ge2$, a factorisation + \[ + X^d=X^{d_0}X_{i_1}\cdots X_{i_k}, + \] + with factors listed with multiplicity, and ordinals $\rho_r 0, ∀ γ : ℝ, -ε < γ → γ < 0 → + ordinalValue (translatedTruncation ((aeval σ.lift H : Series K) : K⟦ℝ⟧) γ) < ω^ α ∧ + ∃ E : MvPolynomial ι K, + (∀ d' ∈ E.support, ∃ d ∈ H.support, ∃ k, 2 ≤ k ∧ + TermDegree wt d k (Finsupp.weight wt d')) ∧ + σ.pol hx α (translatedTruncation ((aeval σ.lift H : Series K) : K⟦ℝ⟧) γ) = + ∑ j ∈ H.vars, σ.pol hx α (translatedTruncation (σ.lift j : K⟦ℝ⟧) γ) * pderiv j H + + E := by + classical + -- the expansions of the monomials, on a common interval `(-ε, 0)` + obtain ⟨ε, hε, hmono⟩ := exists_forall_of_forall_exists_forall H.support + (fun d γ ↦ ordinalValue (translatedTruncation + ((aeval σ.lift (monomial d (1 : K)) : Series K) : K⟦ℝ⟧) γ) < ω^ α ∧ + ∃ E : MvPolynomial ι K, IsRemainder wt d E ∧ + σ.pol hx α (translatedTruncation ((aeval σ.lift (monomial d (1 : K)) : Series K) : K⟦ℝ⟧) γ) + = ∑ j ∈ d.support, σ.pol hx α (translatedTruncation (σ.lift j : K⟦ℝ⟧) γ) * + pderiv j (monomial d 1) + E) + fun d hd ↦ σ.exists_forall_pol_translatedTruncation_aeval_monomial hx hinj d (hH d hd) + fun i hi ↦ hvars i ((mem_vars_iff_mem_support i).mpr ⟨d, hd, hi⟩) + refine ⟨ε, hε, fun γ hγε hγ0 ↦ ?_⟩ + -- the translated truncation of `H(b_𝓑)` as a sum over the monomials of `H` + have hmon : ∀ d, monomial d (H.coeff d) = C (H.coeff d) * monomial d (1 : K) := fun d ↦ by + rw [C_mul_monomial, mul_one] + have hcoe : ∀ d, aeval σ.lift (monomial d (H.coeff d)) = + (HahnSeries.Nonpositive.C : K →+* Series K) (H.coeff d) * + aeval σ.lift (monomial d (1 : K)) := fun d ↦ by + rw [hmon, map_mul, aeval_C, HahnSeries.Nonpositive.algebraMap_apply] + have hsplit : translatedTruncation ((aeval σ.lift H : Series K) : K⟦ℝ⟧) γ = + ∑ d ∈ H.support, (HahnSeries.Nonpositive.C : K →+* Series K) (H.coeff d) * + translatedTruncation ((aeval σ.lift (monomial d (1 : K)) : Series K) : K⟦ℝ⟧) γ := by + conv_lhs => rw [H.as_sum, map_sum] + rw [AddSubmonoidClass.coe_finsetSum, ← translatedTruncationAddMonoidHom_apply, map_sum] + refine Finset.sum_congr rfl fun d _ ↦ ?_ + rw [translatedTruncationAddMonoidHom_apply, hcoe, Subring.coe_mul, + HahnSeries.Nonpositive.coe_C, translatedTruncation_C_mul] + have hval : ∀ d ∈ H.support, + ordinalValue ((HahnSeries.Nonpositive.C : K →+* Series K) (H.coeff d) * + translatedTruncation ((aeval σ.lift (monomial d (1 : K)) : Series K) : K⟦ℝ⟧) γ) < ω^ α := + fun d hd ↦ ordinalValue_C_mul_lt _ (hmono γ hγε hγ0 d hd).1 + refine ⟨?_, ?_⟩ + · rw [hsplit] + exact ordinalValue_sum_lt _ _ (NatOrdinal.wpow_pos α) hval + -- the expansions of the monomials + choose E hE hexp using fun d (hd : d ∈ H.support) ↦ (hmono γ hγε hγ0 d hd).2 + refine ⟨∑ d ∈ H.support.attach, C (H.coeff d.1) * E d.1 d.2, fun d' hd' ↦ ?_, ?_⟩ + · obtain ⟨d, _, hd'd⟩ := Finset.mem_biUnion.mp (support_sum hd') + have hd'E : d' ∈ (E d.1 d.2).support := by + rw [C_mul'] at hd'd + exact support_smul hd'd + obtain ⟨k, hk, hT⟩ := hE d.1 d.2 d' hd'E + exact ⟨d.1, d.2, k, hk, hT⟩ + -- abbreviations + set T : ι → MvPolynomial ι K := fun j ↦ σ.pol hx α (translatedTruncation (σ.lift j : K⟦ℝ⟧) γ) + with hTdef + have hsupp : ∀ d : ι →₀ ℕ, ∀ j, j ∉ d.support → pderiv j (monomial d (1 : K)) = 0 := + fun d j hj ↦ by + rw [pderiv_monomial, Finsupp.notMem_support_iff.mp hj, Nat.cast_zero, mul_zero, monomial_zero] + have hsub : ∀ d ∈ H.support, d.support ⊆ H.vars := fun d hd j hj ↦ + (mem_vars_iff_mem_support j).mpr ⟨d, hd, hj⟩ + -- the left-hand side + have hlhs : σ.pol hx α (translatedTruncation ((aeval σ.lift H : Series K) : K⟦ℝ⟧) γ) = + ∑ d ∈ H.support.attach, (C (H.coeff d.1) * ∑ j ∈ H.vars, T j * pderiv j (monomial d.1 1) + + C (H.coeff d.1) * E d.1 d.2) := by + rw [hsplit, σ.pol_sum hx hinj _ _ hval, ← Finset.sum_attach H.support] + refine Finset.sum_congr rfl fun d _ ↦ ?_ + rw [σ.pol_C_mul hx hinj _ (hmono γ hγε hγ0 _ d.2).1, hexp d.1 d.2, mul_add] + congr 2 + exact Finset.sum_subset (hsub d.1 d.2) fun j _ hj ↦ by rw [hsupp d.1 j hj, mul_zero] + -- the right-hand side + have hpd : ∀ j, pderiv j H = + ∑ d ∈ H.support.attach, C (H.coeff d.1) * pderiv j (monomial d.1 1) := fun j ↦ by + conv_lhs => rw [H.as_sum, map_sum, ← Finset.sum_attach H.support] + exact Finset.sum_congr rfl fun d _ ↦ by rw [hmon, pderiv_C_mul] + rw [hlhs, Finset.sum_add_distrib] + congr 1 + simp only [hpd, Finset.mul_sum] + rw [Finset.sum_comm] + refine Finset.sum_congr rfl fun d _ ↦ Finset.sum_congr rfl fun j _ ↦ by ring + +omit [DecidableEq ι] in +/-- **The Leibniz rule with remainder, differentiated.** Differentiating the Leibniz rule for `F` +with respect to `X_v` and comparing with the rule for `∂F/∂X_v`: for all `γ < 0` sufficiently +close to `0`, +`pol((∂F/∂X_v)(b_𝓑)^{|γ}) = ∂/∂X_v [pol(F(b_𝓑)^{|γ})] - ∑_j (∂/∂X_v pol(b_j^{|γ})) ∂F/∂X_j +- ∂R_γ/∂X_v + R'_γ`, where every monomial of `R_γ`, resp. `R'_γ`, has the degree of a term of the +expansion of a monomial of `F`, resp. of `∂F/∂X_v`, with at least two truncated factors. -/ +@[blueprint "lem:differentiated-leibniz-remainder" + (phase := "Translated truncations") + (title := "Differentiated polynomial Leibniz rule") + (statement := /-- + Let $K$ be a field, let $(x_i)_{i\in I}$ be a minimal homogeneous + generating system of $\widehat{\mathrm P}$ with + $x_i\in\mathrm P_{w_i}$, and choose series $b_i$ representing the $x_i$. + Assume that evaluation at $(x_i)$ is injective in every weighted degree + below $\alpha<\omega_1$, and write $P_a$ for the polynomial representative + of a series $a$ of ordinal value below $\omega^\alpha$. + + Let $F\in K[X_i:i\in I]$. Suppose every monomial of $F$ has weight at most + $\alpha$, and $w_i<\alpha$ for every variable $X_i$ occurring in $F$. For + every $v\in I$ and every $\gamma<0$ sufficiently close to $0$, there are + polynomials $R_\gamma,R'_\gamma$ such that + \[ + P_{((\partial_vF)(b_i))^{|\gamma}} + =\partial_vP_{(F(b_i))^{|\gamma}} + -\sum_{j\in\operatorname{vars}(F)} + (\partial_vP_{b_j^{|\gamma}})\,\partial_jF + -\partial_vR_\gamma+R'_\gamma, + \] + where every monomial of $R_\gamma$, respectively $R'_\gamma$, is obtained + from a monomial of $F$, respectively $\partial_vF$, by replacing the + weights of at least two variable factors, counted with multiplicity, by + strictly smaller ordinals. + -/) + (proof := /-- + Partial differentiation weakly decreases every monomial weight and + introduces no new variables. Hence \ref{lem:leibniz-remainder} applies to + both $F$ and $\partial_vF$ on one + common punctured interval. Differentiate the expansion for $F$, use the + polynomial product rule and commutativity of partial derivatives, and + subtract the expansion for $\partial_vF$. Variables of $F$ absent from + $\partial_vF$ contribute zero, so both sums may be indexed by + $\operatorname{vars}(F)$. Rearrangement gives the displayed identity while + preserving the two remainder conditions. + -/)] +theorem exists_forall_pol_translatedTruncation_aeval_pderiv (F : MvPolynomial ι K) + (hF : ∀ d ∈ F.support, Finsupp.weight wt d ≤ α) (hvars : ∀ i ∈ F.vars, wt i < α) (v : ι) : + ∃ ε > 0, ∀ γ : ℝ, -ε < γ → γ < 0 → + ∃ E E' : MvPolynomial ι K, + (∀ d' ∈ E.support, ∃ d ∈ F.support, ∃ k, 2 ≤ k ∧ + TermDegree wt d k (Finsupp.weight wt d')) ∧ + (∀ d' ∈ E'.support, ∃ d ∈ (pderiv v F).support, ∃ k, 2 ≤ k ∧ + TermDegree wt d k (Finsupp.weight wt d')) ∧ + σ.pol hx α (translatedTruncation ((aeval σ.lift (pderiv v F) : Series K) : K⟦ℝ⟧) γ) = + pderiv v (σ.pol hx α (translatedTruncation ((aeval σ.lift F : Series K) : K⟦ℝ⟧) γ)) - + ∑ j ∈ F.vars, pderiv v (σ.pol hx α (translatedTruncation (σ.lift j : K⟦ℝ⟧) γ)) * + pderiv j F - pderiv v E + E' := by + classical + have hΘ : ∀ d ∈ (pderiv v F).support, Finsupp.weight wt d ≤ α := fun d' hd' ↦ by + obtain ⟨d, hd, hw⟩ := exists_add_eq_weight_of_mem_support_pderiv wt hd' + exact (NatOrdinal.le_add_right.trans hw.le).trans (hF d hd) + have hvarsΘ : ∀ i ∈ (pderiv v F).vars, wt i < α := fun i hi ↦ hvars i (vars_pderiv_subset v F hi) + obtain ⟨ε₁, hε₁, h₁⟩ := σ.exists_forall_pol_translatedTruncation_aeval hx hinj F hF hvars + obtain ⟨ε₂, hε₂, h₂⟩ := σ.exists_forall_pol_translatedTruncation_aeval hx hinj (pderiv v F) hΘ + hvarsΘ + refine ⟨min ε₁ ε₂, lt_min hε₁ hε₂, fun γ hγε hγ0 ↦ ?_⟩ + have hγ₁ : -ε₁ < γ := by have := min_le_left ε₁ ε₂; linarith + have hγ₂ : -ε₂ < γ := by have := min_le_right ε₁ ε₂; linarith + obtain ⟨-, E, hE, hexpF⟩ := h₁ γ hγ₁ hγ0 + obtain ⟨-, E', hE', hexpΘ⟩ := h₂ γ hγ₂ hγ0 + refine ⟨E, E', hE, hE', ?_⟩ + set T : ι → MvPolynomial ι K := fun j ↦ σ.pol hx α (translatedTruncation (σ.lift j : K⟦ℝ⟧) γ) + with hTdef + -- differentiate the expansion of `F` + have hdF : pderiv v (σ.pol hx α (translatedTruncation ((aeval σ.lift F : Series K) : K⟦ℝ⟧) γ)) = + ∑ j ∈ F.vars, pderiv v (T j) * pderiv j F + ∑ j ∈ F.vars, T j * pderiv j (pderiv v F) + + pderiv v E := by + rw [hexpF, map_add, map_sum, ← Finset.sum_add_distrib] + congr 1 + exact Finset.sum_congr rfl fun j _ ↦ by rw [pderiv_mul, pderiv_pderiv_comm] + -- the expansion of `∂F/∂X_v`, summed over the variables of `F` + have hexpΘ' : σ.pol hx α (translatedTruncation ((aeval σ.lift (pderiv v F) : Series K) : K⟦ℝ⟧) γ) + = ∑ j ∈ F.vars, T j * pderiv j (pderiv v F) + E' := by + rw [hexpΘ] + congr 1 + exact Finset.sum_subset (vars_pderiv_subset v F) fun j _ hj ↦ by + rw [pderiv_eq_zero_of_notMem_vars hj, mul_zero] + rw [hexpΘ', hdF] + ring + +end Lifts + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/TruncationPolynomial.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/TruncationPolynomial.lean new file mode 100644 index 0000000000..b5189a306b --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/TruncationPolynomial.lean @@ -0,0 +1,463 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.Lifts +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Convolution +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.TruncationDrop +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MvPolynomial.OrdinalExpansion +import Mathlib.Topology.Order.LeftRightNhds + +/-! +# The polynomial of a translated truncation, and the convolution formula read in polynomials + +Fix a minimal system of homogeneous generators `𝓑` of `P̂` with lifts `b_B`, a degree `α`, and +assume evaluation `K[X] → P̂` injective in every degree below `α`; `pol` then identifies the +classes modulo `J` of ordinal value below `ω^α` with the polynomials of degree below `α` +(`Lifts.pol_eq_of_toGerm_aeval_eq`). This file records the calculus of `pol`: it respects +congruence modulo `J`, sums, scalars, and products whose polynomial has degree below `α`; a series +of ordinal value below `ω^(β+1)` has polynomial of degree at most `β`. + +Berarducci's convolution formula `(uv)^{|γ} ≡ ∑_ξ u^{|ξ} v^{|γ-ξ} (mod J)` [Ber00, Lem. 7.5] then +reads, for `u, v` of ordinal value below `ω^(β_u+1)`, `ω^(β_v+1)` with `β_u, β_v < α` and +`β_u ⊕ β_v ≤ α`, and all `γ < 0` sufficiently close to `0`, as the polynomial identity +`pol((uv)^{|γ}) = ∑_ξ pol(u^{|ξ}) · pol(v^{|γ-ξ})` +(`Lifts.exists_forall_pol_translatedTruncation_mul`). The sum may be taken over any finite set of +cutoffs containing Berarducci's index set and contained in `[γ, 0]`; the terms at `ξ = 0` and +`ξ = γ` are the boundary terms `pol(u) · pol(v^{|γ})` and `pol(u^{|γ}) · pol(v)`. +-/ + +universe v w + +open scoped NatOrdinal HahnSeries +open Berarducci MvPolynomial OrdinalGraded Filter Topology + +public noncomputable section + +namespace Berarducci + +variable {K : Type v} [Field K] + +/-! ### The quantifier "for all `γ < 0` sufficiently close to `0`" with an explicit `ε` -/ + +/-- A property holds for all `γ < 0` sufficiently close to `0` exactly when there is `ε > 0` such +that it holds for all `γ ∈ (-ε, 0)`. -/ +theorem eventually_nhdsLT_zero_iff {p : ℝ → Prop} : + (∀ᶠ γ in 𝓝[<] (0 : ℝ), p γ) ↔ ∃ ε > 0, ∀ γ : ℝ, -ε < γ → γ < 0 → p γ := by + rw [Filter.eventually_iff, mem_nhdsLT_iff_exists_Ioo_subset] + constructor + · rintro ⟨l, hl, hsub⟩ + exact ⟨-l, by simpa using hl, fun γ h1 h2 ↦ hsub ⟨by linarith, h2⟩⟩ + · rintro ⟨ε, hε, h⟩ + exact ⟨-ε, by simpa using hε, fun γ hγ ↦ h γ hγ.1 hγ.2⟩ + +/-- If `v_J(u) < ω^(β+1)`, there is `ε > 0` such that `v_J(u^{|γ}) < ω^β` for all `γ ∈ (-ε, 0)`. -/ +theorem exists_forall_ordinalValue_translatedTruncation_lt {β : NatOrdinal} {u : Series K} + (hu : ordinalValue u < ω^ (β + 1)) : + ∃ ε > 0, ∀ γ : ℝ, -ε < γ → γ < 0 → + ordinalValue (translatedTruncation (u : K⟦ℝ⟧) γ) < ω^ β := + eventually_nhdsLT_zero_iff.mp + (eventually_ordinalValue_translatedTruncation_lt_wpow_of_ordinalValue_lt_wpow_add_one β u hu) + +/-- The translated truncation of a constant at a negative cutoff is zero. -/ +theorem translatedTruncation_C_of_neg (k : K) {γ : ℝ} (hγ : γ < 0) : + translatedTruncation (HahnSeries.C k : K⟦ℝ⟧) γ = 0 := by + apply Subtype.ext + ext δ + rw [coeff_translatedTruncation, Subring.coe_zero, HahnSeries.coeff_zero] + split_ifs with hδ + · rw [HahnSeries.C_apply, HahnSeries.coeff_single, ite_eq_right (by linarith)] + · rfl + +/-! ### Degree at most `β` -/ + +variable {ι : Type w} {wt : ι → NatOrdinal} {x : ι → PrincipalSubring K} + +variable (wt) in +/-- Every monomial of `F` has degree at most `β`. -/ +def DegreeLE (F : MvPolynomial ι K) (β : NatOrdinal) : Prop := + ∀ d ∈ F.support, Finsupp.weight wt d ≤ β + +theorem degreeLE_iff {F : MvPolynomial ι K} {β : NatOrdinal} : + DegreeLE wt F β ↔ ∀ d ∈ F.support, Finsupp.weight wt d ≤ β := + Iff.rfl + +theorem degreeLT_add_one_iff_degreeLE {F : MvPolynomial ι K} {β : NatOrdinal} : + DegreeLT wt F (β + 1) ↔ DegreeLE wt F β := by + rw [degreeLT_iff, degreeLE_iff] + exact forall₂_congr fun _ _ ↦ Order.lt_add_one_iff + +theorem DegreeLE.degreeLT {F : MvPolynomial ι K} {β α : NatOrdinal} (hF : DegreeLE wt F β) + (h : β < α) : DegreeLT wt F α := + degreeLT_iff.mpr fun d hd ↦ (hF d hd).trans_lt h + +theorem DegreeLT.degreeLE {F : MvPolynomial ι K} {β : NatOrdinal} (hF : DegreeLT wt F β) : + DegreeLE wt F β := fun d hd ↦ (degreeLT_iff.mp hF d hd).le + +theorem _root_.MvPolynomial.IsWeightedHomogeneous.degreeLE {F : MvPolynomial ι K} + {β : NatOrdinal} (hF : IsWeightedHomogeneous wt F β) : DegreeLE wt F β := + fun _ hd ↦ (hF (mem_support_iff.mp hd)).le + +theorem DegreeLE.mul {F G : MvPolynomial ι K} {β β' : NatOrdinal} (hF : DegreeLE wt F β) + (hG : DegreeLE wt G β') : DegreeLE wt (F * G) (β + β') := by + classical + intro d hd + obtain ⟨d1, hd1, d2, hd2, rfl⟩ := Finset.mem_add.mp (support_mul F G hd) + rw [map_add] + exact add_le_add (hF d1 hd1) (hG d2 hd2) + +theorem DegreeLE.mul_degreeLT {F G : MvPolynomial ι K} {β β' : NatOrdinal} (hF : DegreeLE wt F β) + (hG : DegreeLT wt G β') : DegreeLT wt (F * G) (β + β') := by + classical + rw [degreeLT_iff] at hG ⊢ + intro d hd + obtain ⟨d1, hd1, d2, hd2, rfl⟩ := Finset.mem_add.mp (support_mul F G hd) + rw [map_add] + exact add_lt_add_of_le_of_lt (hF d1 hd1) (hG d2 hd2) + +theorem DegreeLT.mul_degreeLE {F G : MvPolynomial ι K} {β β' : NatOrdinal} (hF : DegreeLT wt F β) + (hG : DegreeLE wt G β') : DegreeLT wt (F * G) (β + β') := by + classical + rw [degreeLT_iff] at hF ⊢ + intro d hd + obtain ⟨d1, hd1, d2, hd2, rfl⟩ := Finset.mem_add.mp (support_mul F G hd) + rw [map_add] + exact add_lt_add_of_lt_of_le (hF d1 hd1) (hG d2 hd2) + +theorem DegreeLT.mul {F G : MvPolynomial ι K} {β β' : NatOrdinal} (hF : DegreeLT wt F β) + (hG : DegreeLT wt G β') : DegreeLT wt (F * G) (β + β') := + hF.mul_degreeLE hG.degreeLE + +/-! ### The calculus of `pol` -/ + +namespace Lifts + +variable (σ : Lifts wt x) (hx : IsMinimalSystem (Berarducci.principalGrading K) wt x) + {α : NatOrdinal} (hinj : ∀ β < α, InjectiveAt K wt x β) +include hinj + +theorem pol_zero : σ.pol hx α (0 : Series K) = 0 := + σ.pol_eq_zero_of_mem hx hinj (Ideal.zero_mem _) + +/-- `pol` depends only on the class modulo `J`. -/ +theorem pol_congr {u u' : Series K} (hu : ordinalValue u < ω^ α) (h : toGerm u = toGerm u') : + σ.pol hx α u = σ.pol hx α u' := by + have hu' : ordinalValue u' < ω^ α := by + rwa [← ordinalValue_eq_of_sub_mem_negativeMonomialIdeal (toGerm_eq_toGerm_iff.mp h)] + exact (σ.pol_eq_of_toGerm_aeval_eq hx hinj hu' (σ.pol_degreeLT hx α u) + (by rw [σ.toGerm_aeval_pol hx hu, h])).symm + +theorem pol_sum {ι' : Type*} (s : Finset ι') (f : ι' → Series K) + (h : ∀ i ∈ s, ordinalValue (f i) < ω^ α) : + σ.pol hx α (∑ i ∈ s, f i) = ∑ i ∈ s, σ.pol hx α (f i) := by + classical + induction s using Finset.induction_on with + | empty => rw [Finset.sum_empty, Finset.sum_empty]; exact σ.pol_zero hx hinj + | insert a s ha ih => + rw [Finset.sum_insert ha, Finset.sum_insert ha, + σ.pol_add hx hinj (h a (Finset.mem_insert_self a s)) + (ordinalValue_sum_lt s f (NatOrdinal.wpow_pos α) fun i hi ↦ + h i (Finset.mem_insert_of_mem hi)), + ih fun i hi ↦ h i (Finset.mem_insert_of_mem hi)] + +/-- `pol` of a scalar multiple. -/ +theorem pol_C_mul (k : K) {u : Series K} (hu : ordinalValue u < ω^ α) : + σ.pol hx α ((HahnSeries.Nonpositive.C : K →+* Series K) k * u) = + C k * σ.pol hx α u := by + rcases eq_or_ne k 0 with rfl | hk + · rw [map_zero, zero_mul, map_zero, zero_mul]; exact σ.pol_zero hx hinj + refine σ.pol_eq_of_toGerm_aeval_eq hx hinj (by rwa [ordinalValue_C_mul hk]) ?_ ?_ + · rw [C_mul', degreeLT_iff] + exact fun d hd ↦ degreeLT_iff.mp (σ.pol_degreeLT hx α u) d (support_smul hd) + · rw [map_mul, aeval_C, HahnSeries.Nonpositive.algebraMap_apply, map_mul, map_mul, + σ.toGerm_aeval_pol hx hu] + +/-- `pol` of a product whose polynomial has degree below `α`, together with the ordinal value +bound on the product. -/ +theorem pol_mul {u u' : Series K} (hu : ordinalValue u < ω^ α) (hu' : ordinalValue u' < ω^ α) + (hFG : DegreeLT wt (σ.pol hx α u * σ.pol hx α u') α) : + ordinalValue (u * u') < ω^ α ∧ σ.pol hx α (u * u') = σ.pol hx α u * σ.pol hx α u' := by + have hgerm : toGerm (aeval σ.lift (σ.pol hx α u * σ.pol hx α u')) = toGerm (u * u') := by + rw [map_mul, map_mul, σ.toGerm_aeval_pol hx hu, σ.toGerm_aeval_pol hx hu', map_mul] + have hval : ordinalValue (u * u') < ω^ α := by + rw [← ordinalValue_eq_of_sub_mem_negativeMonomialIdeal (toGerm_eq_toGerm_iff.mp hgerm)] + exact σ.ordinalValue_aeval_lt_of_degreeLT hFG + exact ⟨hval, σ.pol_eq_of_toGerm_aeval_eq hx hinj hval hFG hgerm⟩ + +/-- A series of ordinal value below `ω^α'`, `α' ≤ α`, has polynomial of degree below `α'`. -/ +theorem pol_degreeLT_of_lt {α' : NatOrdinal} (hα' : α' ≤ α) {u : Series K} + (hu : ordinalValue u < ω^ α') : DegreeLT wt (σ.pol hx α u) α' := by + obtain ⟨F, hF, hFu⟩ := σ.exists_degreeLT_toGerm_aeval_eq hx α' u hu + rw [σ.pol_eq_of_toGerm_aeval_eq hx hinj (hu.trans_le (NatOrdinal.wpow_le_wpow.mpr hα')) + (hF.mono hα') hFu] + exact hF + +/-- A series of ordinal value below `ω^(β+1)`, `β < α`, has polynomial of degree at most `β`. -/ +theorem pol_degreeLE {β : NatOrdinal} (hβ : β < α) {u : Series K} + (hu : ordinalValue u < ω^ (β + 1)) : DegreeLE wt (σ.pol hx α u) β := + degreeLT_add_one_iff_degreeLE.mp (σ.pol_degreeLT_of_lt hx hinj (Order.add_one_le_of_lt hβ) hu) + +/-- The polynomial of the translated truncation of a constant at a cutoff `γ < 0` is zero. -/ +theorem pol_translatedTruncation_C (k : K) {γ : ℝ} (hγ : γ < 0) : + σ.pol hx α (translatedTruncation + (((HahnSeries.Nonpositive.C : K →+* Series K) k : Series K) : K⟦ℝ⟧) γ) = 0 := by + rw [HahnSeries.Nonpositive.coe_C, translatedTruncation_C_of_neg k hγ] + exact σ.pol_zero hx hinj + +end Lifts + +/-! ### The convolution formula over an enlarged index set -/ + +/-- The cutoffs of Berarducci's index set lie in `[γ, 0]` for nonpositive series. -/ +theorem mem_Icc_of_mem_convolutionIndex {u v : Series K} {γ β : ℝ} + (h : β ∈ convolutionIndex (u : K⟦ℝ⟧) (v : K⟦ℝ⟧) γ) : β ∈ Set.Icc γ 0 := by + rw [mem_convolutionIndex] at h + have h1 : β ≤ 0 := closure_minimal (HahnSeries.Nonpositive.support_subset u) isClosed_Iic h.1 + have h2 : γ - β ≤ 0 := + closure_minimal (HahnSeries.Nonpositive.support_subset v) isClosed_Iic h.2 + exact ⟨by linarith, h1⟩ + +/-- The germ convolution formula over a finite set containing every cutoff whose germ product +is nonzero; omitted zero terms do not need to be listed. -/ +theorem germAt_mul_of_support_subset (u v : Series K) (γ : ℝ) {S : Finset ℝ} + (hS : ∀ ξ : ℝ, + germAt (u : K⟦ℝ⟧) ξ * germAt (v : K⟦ℝ⟧) (γ - ξ) ≠ 0 → ξ ∈ S) : + germAt ((u : K⟦ℝ⟧) * (v : K⟦ℝ⟧)) γ = + ∑ ξ ∈ S, germAt (u : K⟦ℝ⟧) ξ * germAt (v : K⟦ℝ⟧) (γ - ξ) := by + classical + rw [germAt_mul] + calc + ∑ ξ ∈ convolutionIndex (u : K⟦ℝ⟧) (v : K⟦ℝ⟧) γ, + germAt (u : K⟦ℝ⟧) ξ * germAt (v : K⟦ℝ⟧) (γ - ξ) = + ∑ ξ ∈ convolutionIndex (u : K⟦ℝ⟧) (v : K⟦ℝ⟧) γ ∩ S, + germAt (u : K⟦ℝ⟧) ξ * germAt (v : K⟦ℝ⟧) (γ - ξ) := by + symm + refine Finset.sum_subset Finset.inter_subset_left fun ξ hξ hnot ↦ ?_ + by_contra hne + exact hnot (Finset.mem_inter.mpr ⟨hξ, hS ξ hne⟩) + _ = ∑ ξ ∈ S, germAt (u : K⟦ℝ⟧) ξ * germAt (v : K⟦ℝ⟧) (γ - ξ) := by + refine Finset.sum_subset Finset.inter_subset_right fun ξ hξ hnot ↦ ?_ + have hI : ξ ∉ convolutionIndex (u : K⟦ℝ⟧) (v : K⟦ℝ⟧) γ := + fun hi ↦ hnot (Finset.mem_inter.mpr ⟨hi, hξ⟩) + rw [mem_convolutionIndex, not_and_or] at hI + rcases hI with h | h + · rw [germAt_eq_zero_of_not_mem_closure_support h, zero_mul] + · rw [germAt_eq_zero_of_not_mem_closure_support h, mul_zero] + +/-- Berarducci's convolution formula [Ber00, Lem. 7.5] summed over any finite set of cutoffs +containing his index set: the extra terms vanish. -/ +theorem germAt_mul_of_subset (u v : Series K) (γ : ℝ) {S : Finset ℝ} + (hS : convolutionIndex (u : K⟦ℝ⟧) (v : K⟦ℝ⟧) γ ⊆ S) : + germAt ((u : K⟦ℝ⟧) * (v : K⟦ℝ⟧)) γ = + ∑ β ∈ S, germAt (u : K⟦ℝ⟧) β * germAt (v : K⟦ℝ⟧) (γ - β) := by + apply germAt_mul_of_support_subset u v γ + intro ξ hξ + by_contra hξS + have hξI : ξ ∉ convolutionIndex (u : K⟦ℝ⟧) (v : K⟦ℝ⟧) γ := + fun hi ↦ hξS (hS hi) + rw [mem_convolutionIndex, not_and_or] at hξI + rcases hξI with h | h + · exact hξ (by rw [germAt_eq_zero_of_not_mem_closure_support h, zero_mul]) + · exact hξ (by rw [germAt_eq_zero_of_not_mem_closure_support h, mul_zero]) + +/-! ### The convolution formula, read in polynomials -/ + +namespace Lifts + +variable (σ : Lifts wt x) (hx : IsMinimalSystem (Berarducci.principalGrading K) wt x) + {α : NatOrdinal} (hinj : ∀ β < α, InjectiveAt K wt x β) +include hinj + +/-- **The convolution formula, read in polynomials** (cf. [Ber00, Lem. 7.5]). For `u, v` of ordinal +value below `ω^(β_u+1)`, `ω^(β_v+1)` with `β_u, β_v < α` and `β_u ⊕ β_v ≤ α`, there is `ε > 0` such +that for all `γ ∈ (-ε, 0)`: `pol((uv)^{|γ}) = ∑_ξ pol(u^{|ξ}) · pol(v^{|γ-ξ})`, the sum over any +finite set of cutoffs `ξ` (the Lean binder `β`) containing Berarducci's index set and contained in +`[γ, 0]`. -/ +@[blueprint "lem:polynomial-convolution-formula" + (phase := "Translated truncations") + (title := "Convolution formula for polynomial representatives") + (statement := /-- + Let $K$ be a field. Let $(x_i)_{i\in I}$ be a minimal homogeneous generating system of + $\widehat{\mathrm P}$, with $x_i\in\mathrm P_{w_i}$, and choose series + $b_i$ representing the $x_i$. Assume that evaluation at $(x_i)$ is + injective in every weighted degree below $\alpha<\omega_1$. For every + series $a$ with $v_J(a)<\omega^\alpha$, write + $\operatorname{pol}_{<\alpha}(a)$ for the unique polynomial whose + monomials have weight below $\alpha$ and such that + \[ + a\equiv \operatorname{pol}_{<\alpha}(a)(b_i)\pmod J. + \] + + Let $u,v\in K((\mathbb R^{\le0}))$ satisfy + \[ + v_J(u)<\omega^{\beta+1},\qquad + v_J(v)<\omega^{\beta'+1},\qquad + \beta,\beta'<\alpha,\qquad \beta\oplus\beta'\le\alpha. + \] + For $\gamma\in\mathbb R$, put + \[ + C_\gamma(u,v)=\{\xi\in\mathrm{cl}(\operatorname{supp}(u)): + \gamma-\xi\in\mathrm{cl}(\operatorname{supp}(v))\}. + \] + Then there is $\varepsilon>0$ such that, for every + $\gamma\in(-\varepsilon,0)$ and every finite + $S$ with $C_\gamma(u,v)\subseteq S\subseteq[\gamma,0]$, + \[ + \operatorname{pol}_{<\alpha}((uv)^{|\gamma}) + =\sum_{\xi\in S} + \operatorname{pol}_{<\alpha}(u^{|\xi}) + \operatorname{pol}_{<\alpha}(v^{|\gamma-\xi}). + \] + -/) + (proof := /-- + By \ref{lem:truncation-drop}, choose one interval on which the translated truncations of + $u$, $v$, and $uv$ have the required lower ordinal values. By + \ref{prop:polynomial-representative-exists} and + \ref{prop:polynomial-evaluation-ordinal-value}, their degree-$<\alpha$ + polynomial representatives exist and are unique. + + Fix $\gamma$ in this interval and $\xi\in S$. Since $\gamma<0$ and + $\gamma\le\xi\le0$, at least one of $\xi$ and $\gamma-\xi$ is negative. Its translated + truncation has polynomial weight strictly below $\beta$ or $\beta'$, while the other has + weight at most the corresponding ordinal. Hence the product has weight strictly below + $\beta\oplus\beta'\le\alpha$. + + \ref{lem:convolution-formula} gives the displayed identity modulo $J$ over + $C_\gamma(u,v)$. Every additional term indexed by $S$ vanishes modulo $J$. Uniqueness of the + polynomial representatives turns this congruence into the asserted polynomial identity. + -/)] +theorem exists_forall_pol_translatedTruncation_mul {u v : Series K} {βu βv : NatOrdinal} + (hu : ordinalValue u < ω^ (βu + 1)) (hv : ordinalValue v < ω^ (βv + 1)) + (hβu : βu < α) (hβv : βv < α) (hsum : βu + βv ≤ α) : + ∃ ε > 0, ∀ γ : ℝ, -ε < γ → γ < 0 → ∀ S : Finset ℝ, + convolutionIndex (u : K⟦ℝ⟧) (v : K⟦ℝ⟧) γ ⊆ S → (S : Set ℝ) ⊆ Set.Icc γ 0 → + σ.pol hx α (translatedTruncation ((u * v : Series K) : K⟦ℝ⟧) γ) = + ∑ β ∈ S, σ.pol hx α (translatedTruncation (u : K⟦ℝ⟧) β) * + σ.pol hx α (translatedTruncation (v : K⟦ℝ⟧) (γ - β)) := by + obtain ⟨εu, hεu, hdropu⟩ := exists_forall_ordinalValue_translatedTruncation_lt hu + obtain ⟨εv, hεv, hdropv⟩ := exists_forall_ordinalValue_translatedTruncation_lt hv + have huv : ordinalValue (u * v) < ω^ (βu + βv + 1) := ordinalValue_mul_lt_wpow_add_one hu hv + obtain ⟨εuv, hεuv, hdropuv⟩ := exists_forall_ordinalValue_translatedTruncation_lt huv + have hβuα : βu + 1 ≤ α := Order.add_one_le_of_lt hβu + have hβvα : βv + 1 ≤ α := Order.add_one_le_of_lt hβv + refine ⟨min εu (min εv εuv), lt_min hεu (lt_min hεv hεuv), fun γ hγε hγ0 S hS hSIcc ↦ ?_⟩ + have hγu : -εu < γ := by + have := min_le_left εu (min εv εuv); linarith + have hγv : -εv < γ := by + have := (min_le_right εu (min εv εuv)).trans (min_le_left εv εuv); linarith + have hγuv : -εuv < γ := by + have := (min_le_right εu (min εv εuv)).trans (min_le_right εv εuv); linarith + -- the ordinal value of the translated truncation of the product + have hprod : ordinalValue (translatedTruncation ((u * v : Series K) : K⟦ℝ⟧) γ) < ω^ α := + (hdropuv γ hγuv hγ0).trans_le (NatOrdinal.wpow_le_wpow.mpr hsum) + -- each term of the convolution sum + have hterm : ∀ β ∈ S, + ordinalValue (translatedTruncation (u : K⟦ℝ⟧) β) < ω^ α ∧ + ordinalValue (translatedTruncation (v : K⟦ℝ⟧) (γ - β)) < ω^ α ∧ + DegreeLT wt (σ.pol hx α (translatedTruncation (u : K⟦ℝ⟧) β) * + σ.pol hx α (translatedTruncation (v : K⟦ℝ⟧) (γ - β))) α := by + intro β hβ + obtain ⟨hγβ, hβ0⟩ := hSIcc hβ + -- the first factor + have hfirst : (ordinalValue (translatedTruncation (u : K⟦ℝ⟧) β) < ω^ α ∧ + DegreeLE wt (σ.pol hx α (translatedTruncation (u : K⟦ℝ⟧) β)) βu) ∧ + (β < 0 → ordinalValue (translatedTruncation (u : K⟦ℝ⟧) β) < ω^ βu ∧ + DegreeLT wt (σ.pol hx α (translatedTruncation (u : K⟦ℝ⟧) β)) βu) := by + rcases eq_or_lt_of_le hβ0 with rfl | hβneg + · rw [translatedTruncation_zero] + exact ⟨⟨hu.trans_le (NatOrdinal.wpow_le_wpow.mpr hβuα), σ.pol_degreeLE hx hinj hβu hu⟩, + fun h ↦ absurd h (lt_irrefl 0)⟩ + · have hlt := hdropu β (by linarith) hβneg + exact ⟨⟨hlt.trans_le (NatOrdinal.wpow_le_wpow.mpr hβu.le), + (σ.pol_degreeLT_of_lt hx hinj hβu.le hlt).degreeLE⟩, + fun _ ↦ ⟨hlt, σ.pol_degreeLT_of_lt hx hinj hβu.le hlt⟩⟩ + -- the second factor + have hsecond : (ordinalValue (translatedTruncation (v : K⟦ℝ⟧) (γ - β)) < ω^ α ∧ + DegreeLE wt (σ.pol hx α (translatedTruncation (v : K⟦ℝ⟧) (γ - β))) βv) ∧ + (γ - β < 0 → ordinalValue (translatedTruncation (v : K⟦ℝ⟧) (γ - β)) < ω^ βv ∧ + DegreeLT wt (σ.pol hx α (translatedTruncation (v : K⟦ℝ⟧) (γ - β))) βv) := by + rcases eq_or_lt_of_le (sub_nonpos.mpr hγβ) with h0 | hneg + · rw [h0, translatedTruncation_zero] + exact ⟨⟨hv.trans_le (NatOrdinal.wpow_le_wpow.mpr hβvα), σ.pol_degreeLE hx hinj hβv hv⟩, + fun h ↦ absurd h (lt_irrefl 0)⟩ + · have hlt := hdropv (γ - β) (by linarith) hneg + exact ⟨⟨hlt.trans_le (NatOrdinal.wpow_le_wpow.mpr hβv.le), + (σ.pol_degreeLT_of_lt hx hinj hβv.le hlt).degreeLE⟩, + fun _ ↦ ⟨hlt, σ.pol_degreeLT_of_lt hx hinj hβv.le hlt⟩⟩ + refine ⟨hfirst.1.1, hsecond.1.1, ?_⟩ + -- at least one cutoff is negative, as `γ < 0` + rcases lt_or_eq_of_le hβ0 with hβneg | hβzero + · exact ((hfirst.2 hβneg).2.mul_degreeLE hsecond.1.2).mono hsum + · have hneg : γ - β < 0 := by rw [hβzero, sub_zero]; exact hγ0 + exact (hfirst.1.2.mul_degreeLT (hsecond.2 hneg).2).mono hsum + -- the translated truncation of the product is congruent modulo `J` to the convolution sum + have hgerm : toGerm (translatedTruncation ((u * v : Series K) : K⟦ℝ⟧) γ) = + toGerm (∑ β ∈ S, translatedTruncation (u : K⟦ℝ⟧) β * + translatedTruncation (v : K⟦ℝ⟧) (γ - β)) := by + rw [← germAt_apply, Subring.coe_mul, germAt_mul_of_subset u v γ hS, map_sum] + simp only [germAt_apply, map_mul] + rw [σ.pol_congr hx hinj hprod hgerm, + σ.pol_sum hx hinj S _ fun β hβ ↦ (σ.pol_mul hx hinj (hterm β hβ).1 (hterm β hβ).2.1 + (hterm β hβ).2.2).1] + exact Finset.sum_congr rfl fun β hβ ↦ + (σ.pol_mul hx hinj (hterm β hβ).1 (hterm β hβ).2.1 (hterm β hβ).2.2).2 + + +/-- At a fixed cutoff, the polynomial convolution formula may be summed over any finite set +containing all nonzero germ products, provided the product truncation and all listed factors have +ordinal value below `ω^α` and each listed polynomial product has degree below `α`. -/ +theorem pol_translatedTruncation_mul_eq_sum_of_nonzero_terms {u v : Series K} {γ : ℝ} {S : Finset ℝ} + (hS : ∀ ξ : ℝ, + germAt (u : K⟦ℝ⟧) ξ * germAt (v : K⟦ℝ⟧) (γ - ξ) ≠ 0 → ξ ∈ S) + (hprod : ordinalValue (translatedTruncation ((u * v : Series K) : K⟦ℝ⟧) γ) < ω^ α) + (hterm : ∀ β ∈ S, + ordinalValue (translatedTruncation (u : K⟦ℝ⟧) β) < ω^ α ∧ + ordinalValue (translatedTruncation (v : K⟦ℝ⟧) (γ - β)) < ω^ α ∧ + DegreeLT wt (σ.pol hx α (translatedTruncation (u : K⟦ℝ⟧) β) * + σ.pol hx α (translatedTruncation (v : K⟦ℝ⟧) (γ - β))) α) : + σ.pol hx α (translatedTruncation ((u * v : Series K) : K⟦ℝ⟧) γ) = + ∑ β ∈ S, σ.pol hx α (translatedTruncation (u : K⟦ℝ⟧) β) * + σ.pol hx α (translatedTruncation (v : K⟦ℝ⟧) (γ - β)) := by + have hgerm : toGerm (translatedTruncation ((u * v : Series K) : K⟦ℝ⟧) γ) = + toGerm (∑ β ∈ S, translatedTruncation (u : K⟦ℝ⟧) β * + translatedTruncation (v : K⟦ℝ⟧) (γ - β)) := by + rw [← germAt_apply, Subring.coe_mul, germAt_mul_of_support_subset u v γ hS, map_sum] + simp only [germAt_apply, map_mul] + rw [σ.pol_congr hx hinj hprod hgerm, + σ.pol_sum hx hinj S _ fun β hβ ↦ (σ.pol_mul hx hinj (hterm β hβ).1 (hterm β hβ).2.1 + (hterm β hβ).2.2).1] + exact Finset.sum_congr rfl fun β hβ ↦ + (σ.pol_mul hx hinj (hterm β hβ).1 (hterm β hβ).2.1 (hterm β hβ).2.2).2 + +/-- **The convolution formula at a fixed cutoff.** If the translated truncation of the product and +every term of the convolution sum at `γ` have ordinal value below `ω^α`, and each term's polynomial +has degree below `α`, then the polynomial of `(uv)^{|γ}` is the convolution sum of polynomials. -/ +theorem pol_translatedTruncation_mul_eq_sum {u v : Series K} {γ : ℝ} {S : Finset ℝ} + (hS : convolutionIndex (u : K⟦ℝ⟧) (v : K⟦ℝ⟧) γ ⊆ S) + (hprod : ordinalValue (translatedTruncation ((u * v : Series K) : K⟦ℝ⟧) γ) < ω^ α) + (hterm : ∀ β ∈ S, + ordinalValue (translatedTruncation (u : K⟦ℝ⟧) β) < ω^ α ∧ + ordinalValue (translatedTruncation (v : K⟦ℝ⟧) (γ - β)) < ω^ α ∧ + DegreeLT wt (σ.pol hx α (translatedTruncation (u : K⟦ℝ⟧) β) * + σ.pol hx α (translatedTruncation (v : K⟦ℝ⟧) (γ - β))) α) : + σ.pol hx α (translatedTruncation ((u * v : Series K) : K⟦ℝ⟧) γ) = + ∑ β ∈ S, σ.pol hx α (translatedTruncation (u : K⟦ℝ⟧) β) * + σ.pol hx α (translatedTruncation (v : K⟦ℝ⟧) (γ - β)) := by + refine σ.pol_translatedTruncation_mul_eq_sum_of_nonzero_terms hx hinj ?_ hprod hterm + intro ξ hξ + by_contra hξS + have hξI : ξ ∉ convolutionIndex (u : K⟦ℝ⟧) (v : K⟦ℝ⟧) γ := + fun hi ↦ hξS (hS hi) + rw [mem_convolutionIndex, not_and_or] at hξI + rcases hξI with h | h + · exact hξ (by rw [germAt_eq_zero_of_not_mem_closure_support h, zero_mul]) + · exact hξ (by rw [germAt_eq_zero_of_not_mem_closure_support h, mul_zero]) + +end Lifts + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/TruncationsIdeal.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/TruncationsIdeal.lean new file mode 100644 index 0000000000..6fbd0ecd33 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/TruncationsIdeal.lean @@ -0,0 +1,162 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.DerivationIdeal +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.OrdinalValueCutoffs +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MvPolynomial.ComponentsSpan +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.FinitePart + +/-! +# Ideal membership of a class from the condition (p) on its translated truncations + +Let `q j ∈ K[X]` be finitely many homogeneous polynomials `Q_1, …, Q_m` of degrees `c j` that are +zero or limits, and let `τ + 1 < α`, evaluation being injective below `α`. If `u ∈ J_{ω^(τ+2)}` +and, for all real cutoffs `δ < 0` sufficiently close to `0`, the translated truncation `u^{|δ}` +lies in `J_{ω^(τ+1)}` and the translated truncations satisfy (p) for `(Q_1, …, Q_m; τ)` — the part +`pol(u^{|δ})_{≥τ}` of degree at least `τ` of the polynomial of `u^{|δ}` modulo `J` lies in the +ideal `(Q_1, …, Q_m) ⊆ K[X]` — then the class of `u` in `P_{τ+1}` lies in the ideal +`(Q_1(𝓑), …, Q_m(𝓑)) ⊆ P̂`. + +This is ideal membership of a class from ideal membership of its derivative +(`mem_span_of_principalSubringDerivation_eq_coe`) applied to the class of `u`: its derivative is the +class in `Fun_{0⁻}(P̂)` of `δ ↦ u^{|δ} + J_{ω^τ}`, and `u^{|δ} + J_{ω^τ} ∈ P_τ` is the evaluation +`pol(u^{|δ})_τ(𝓑)` of the degree-`τ` component of the polynomial of `u^{|δ}`, an element of the +ideal. +-/ + +universe v w + +open scoped NatOrdinal HahnSeries +open Berarducci HahnSeries MvPolynomial DirectSum OrdinalGraded + +public noncomputable section + +namespace Berarducci + +variable {K : Type v} [Field K] {ι : Type w} {wt : ι → NatOrdinal} {x : ι → PrincipalSubring K} + +/-- Evaluation carries the ideal of `K[X]` generated by the `q j` into the ideal of `P̂` generated +by the evaluations `(q j)(𝓑)`. -/ +theorem aeval_mem_span_range_of_mem_span {ι' : Type*} {q : ι' → MvPolynomial ι K} + {P : MvPolynomial ι K} (hP : P ∈ Ideal.span (Set.range q)) : + aeval x P ∈ Ideal.span (Set.range fun j ↦ aeval x (q j)) := by + have := Ideal.mem_map_of_mem (aeval x : MvPolynomial ι K →ₐ[K] PrincipalSubring K).toRingHom hP + rw [Ideal.map_span, ← Set.range_comp] at this + exact this + +/-- `τ + 1` has positive finite part. -/ +theorem constantCoeff_add_one_pos (τ : NatOrdinal) : 0 < (τ + 1).constantCoeff := by + have := NatOrdinal.constantCoeff_add_natCast τ 1 + rw [Nat.cast_one] at this + rw [this] + exact Nat.succ_pos _ + +/-- `(τ + 1) ⊖ 1 = τ`: removing `1` from the finite part of `τ + 1` gives back `τ`. -/ +theorem removeNat_one_add_one (τ : NatOrdinal) : (τ + 1).removeNat 1 = τ := by + have h := NatOrdinal.removeNat_add_natCast (a := τ + 1) (n := 1) (by + have := constantCoeff_add_one_pos τ + omega) + rw [Nat.cast_one] at h + exact add_right_cancel h + +namespace Lifts + +variable (σ : Lifts wt x) (hx : IsMinimalSystem (principalGrading K) wt x) {α : NatOrdinal} + (hinj : ∀ β < α, InjectiveAt K wt x β) +include hinj + +/-- **Ideal membership in `P_(τ+1)` from translated truncations.** For `τ + 1 < α` and +`u ∈ J_{ω^(τ+2)}`, suppose that the translated truncations `u^{|δ}` for `-ε < δ < 0` +lie in `J_{ω^(τ+1)}` and that `pol(u^{|δ})_{≥τ}` lies in the ideal `(q_1, …, q_m)`. +Then the class of `u` in `P_{τ+1}` lies in the ideal of `P̂` generated by the evaluations +`(q j)(𝓑)`. -/ +@[blueprint "lem:lower-below-successor" + (phase := "Translated truncations") + (title := "Ideal membership in $\\mathrm P_{\\tau+1}$ from translated truncations") + (statement := /-- + Let $K$ be a field, let $(x_i)_{i\in I}$ be a minimal homogeneous + generating system of $\Ph$, with $x_i\in\Prin_{w_i}$, and choose series + $b_i$ representing $x_i$. Fix + $\alpha<\omega_1$, and assume that evaluation at $(x_i)$ is injective in + every weighted degree below $\alpha$. + + Let $Q_1,\ldots,Q_m\in K[X_i:i\in I]$ be weighted homogeneous of degrees + $\sigma_1,\ldots,\sigma_m$, each a limit ordinal or $0$. Let + $\tau+1<\alpha$, and let $u\in\Kser$ satisfy + $\vJ(u)<\omega^{\tau+2}$. Suppose there is $\varepsilon>0$ such that, for + every $-\varepsilon<\gamma<0$, + \[ + \vJ(\trunc u\gamma)<\omega^{\tau+1},\qquad + \partGE{\pol(\trunc u\gamma)}{\tau}\in(Q_1,\ldots,Q_m). + \] + Then the class $u+J_{\omega^{\tau+1}}\in\Prin_{\tau+1}$ belongs, inside + $\Ph$, to the ideal generated by + $Q_1(x_i),\ldots,Q_m(x_i)$. + -/) + (proof := /-- + For every $\gamma\in(-\varepsilon,0)$, + \ref{lem:polynomial-homogeneous-component-represents-class} identifies the + class of $\trunc u\gamma$ in $\Prin_\tau$ with the evaluation of the + degree-$\tau$ component of $\pol(\trunc u\gamma)$. Since the part of degree + at least $\tau$ lies in the homogeneous ideal $(Q_1,\ldots,Q_m)$, its + degree-$\tau$ component does too. Hence every value of the derivative of + $u+J_{\omega^{\tau+1}}$, sufficiently close to $0$, lies in the ideal + generated by the $Q_j(x_i)$. Applying \ref{prop:ideal-from-derivative} gives + the asserted ideal membership in $\Ph$. + -/)] +theorem of_principalComponentMk_mem_span_of_forall_componentsGE_mem {ι' : Type*} [Finite ι'] + {q : ι' → MvPolynomial ι K} {c : ι' → NatOrdinal} + (hq : ∀ j, IsWeightedHomogeneous wt (q j) (c j)) (hc : ∀ j, (c j).constantCoeff = 0) + {τ : NatOrdinal} (hτ : τ + 1 < α) {u : Series K} (hu : ordinalValue u < ω^ (τ + 1 + 1)) + {ε : ℝ} (hε : 0 < ε) + (hdrop : ∀ δ : ℝ, -ε < δ → δ < 0 → + ordinalValue (translatedTruncation (u : K⟦ℝ⟧) δ) < ω^ (τ + 1)) + (htrunc : ∀ δ : ℝ, -ε < δ → δ < 0 → + componentsGE wt τ (σ.pol hx α (translatedTruncation (u : K⟦ℝ⟧) δ)) ∈ + Ideal.span (Set.range q)) : + DirectSum.of (PrincipalComponent K) (τ + 1) (principalComponentMk (τ + 1) u hu) ∈ + Ideal.span (Set.range fun j ↦ aeval x (q j)) := by + classical + have hα1 : 0 < (τ + 1).constantCoeff := constantCoeff_add_one_pos τ + have hrem : (τ + 1).removeNat 1 = τ := removeNat_one_add_one τ + have hτα : τ < α := (lt_add_one τ).trans hτ + have hq' : ∀ j, aeval x (q j) ∈ principalGrading K (c j) := + fun j ↦ aeval_mem_of_forall_mem hx.mem (hq j) + -- the derivative of the class of `u`, as a function at `0⁻` + let f : ℝ → PrincipalSubring K := fun δ ↦ + if -ε < δ ∧ δ < 0 then + DirectSum.of (PrincipalComponent K) ((τ + 1).removeNat 1) (derivAt (τ + 1) u δ) + else 0 + have hΔ : principalSubringDerivation K + (DirectSum.of (PrincipalComponent K) (τ + 1) (principalComponentMk (τ + 1) u hu)) = + (f : FunAtZeroMinus (PrincipalSubring K)) := by + rw [principalSubringDerivation_of, principalComponentDerivation_principalComponentMk hα1] + exact (funAtZeroMinus_coe_eq_iff_exists _ _).mpr ⟨ε, hε, fun δ h1 h2 ↦ by + simp only [f, ite_eq_left (And.intro h1 h2)]⟩ + have hf : ∀ δ, f δ ∈ Ideal.span (Set.range fun j ↦ aeval x (q j)) := by + intro δ + by_cases h : -ε < δ ∧ δ < 0 + · simp only [f, ite_eq_left h] + have hδ : ordinalValue (translatedTruncation (u : K⟦ℝ⟧) δ) < + ω^ ((τ + 1).removeNat 1 + 1) := by + rw [hrem]; exact hdrop δ h.1 h.2 + rw [derivAt_eq (τ + 1) u δ hδ, of_principalComponentMk_congr hrem _ hδ (by + rw [← hrem]; exact hδ)] + have hrep := σ.represents_aeval_weightedHomogeneousComponent_pol hx hinj hτα + (hdrop δ h.1 h.2) + rw [hrep.of_principalComponentMk] + exact aeval_mem_span_range_of_mem_span + (weightedHomogeneousComponent_mem_span_of_componentsGE_mem wt hq (htrunc δ h.1 h.2) le_rfl) + · simp only [f, ite_eq_right h] + exact Ideal.zero_mem _ + exact mem_span_of_principalSubringDerivation_eq_coe hq' hc hα1 (of_mem_principalGrading _ _) hf hΔ + +end Lifts + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/UnboundedTruncations.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/UnboundedTruncations.lean new file mode 100644 index 0000000000..a8fb04b4b5 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/AlgebraicIndependence/UnboundedTruncations.lean @@ -0,0 +1,260 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Truncation +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValue +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.StableInterval +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValueFinalSegment +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValueImage +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.TruncationDrop +import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.SetOrderType +import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.AdditivelyPrincipal +import Mathlib.Topology.Instances.Real.Lemmas + +/-! +# Translated truncations of a series of ordinal value `ω^β` reach every `ω^ρ`, `ρ < β` + +If `v_J(u) = ω^β` and `ρ < β`, then for every real `θ < 0` there is a cutoff `θ < γ < 0` with +`v_J(u^{|γ}) = ω^ρ` exactly: take an interval `(η, 0)` with `η > θ` on which +`ot(supp u ∩ (γ', 0)) = v_J(u)` for all `γ' ∈ [η, 0)`, the initial segment `S` of +`supp u ∩ (η, 0)` of order type `ω^ρ`, and `γ := sup S`. Every point of `supp u ∩ (η, 0)` below +`γ` lies in `S`, so the support of `u^{|γ}` on some interval `(η', 0]` is a translate of a final +segment of `S`, of order type `ω^ρ` by additive indecomposability (for `ρ = 0`, `S` is a single +support point and `u^{|γ}` has a nonzero constant term and a gap below `0`). This is the +same support-tail phenomenon as Berarducci [Ber00, Lem. 6.8], at every degree below the ordinal +value. The case `β = α + 1`, `ρ = α` gives the injectivity of the lowering derivation on +`P_{α+1}`. +-/ + +universe v + +open Ordinal Set +open scoped NatOrdinal + +public noncomputable section + +namespace Berarducci + +open Berarducci HahnSeries + +variable {K : Type v} [Field K] + +/-- A translated truncation at a support point is not in `J`. -/ +private theorem translatedTruncation_not_mem_negativeMonomialIdeal_of_mem_support + (u : Series K) {γ : ℝ} (hγ : γ ∈ (u : K⟦ℝ⟧).support) : + translatedTruncation (u : K⟦ℝ⟧) γ ∉ HahnSeries.Nonpositive.negativeMonomialIdeal K := by + intro hJ + rw [HahnSeries.Nonpositive.mem_negativeMonomialIdeal_iff_supportSup_lt_zero] at hJ + have hzero : (0 : ℝ) ∈ ((translatedTruncation (u : K⟦ℝ⟧) γ : Series K) : K⟦ℝ⟧).support := by + rw [HahnSeries.mem_support, coeff_translatedTruncation] + simpa using hγ + have hne : translatedTruncation (u : K⟦ℝ⟧) γ ≠ 0 := by + intro h + rw [h] at hzero + simp at hzero + rw [HahnSeries.Nonpositive.supportSup_of_ne hne] at hJ + exact absurd (le_csSup (HahnSeries.Nonpositive.bddAbove_support _) hzero) + (not_le.mpr (WithBot.coe_lt_coe.mp hJ)) + +/-- If `v_J(u) = ω^β`, `ρ < β` and `θ < 0`, there is a cutoff `θ < γ < 0` with `v_J(u^{|γ}) = ω^ρ` +(cf. [Ber00, Lem. 6.8]). -/ +@[blueprint "lem:truncation-values" + (phase := "Limit ordinals in the degree induction") + (title := "Realisation of lower ordinal values by translated truncations") + (statement := /-- + Let $K$ be a field and let + $u\in K((\mathbb R^{\le0}))$. If + \[ + v_J(u)=\omega^\beta + \qquad\text{and}\qquad + \rho<\beta, + \] + then, for every $\theta<0$, there is a $\gamma$ such that + \[ + \theta<\gamma<0 + \qquad\text{and}\qquad + v_J(u^{|\gamma})=\omega^\rho. + \] + -/) + (proof := /-- + Since $\rho<\beta$, the ordinal value of $u$ is greater than $1$. By + \ref{fact:ordinal-value-support-tail}, choose $\eta>\theta$ such that the + negative support tail + \[ + B=\operatorname{supp}(u)\cap(\eta,0) + \] + has order type $\omega^\beta$. Let $S$ be the initial segment of $B$ of + order type $\omega^\rho$, and put $\gamma=\sup S$. Then + $\theta<\gamma<0$. + + If $\rho=0$, the set $S$ is a singleton. Thus $\gamma$ is a support point + with a gap immediately below it. The translated truncation $u^{|\gamma}$ + has a nonzero constant term and ordinal value at most $1$, hence ordinal + value exactly $1=\omega^0$. + + Suppose $\rho>0$. Then $\omega^\rho$ is an additively principal limit + ordinal, so $S$ has no largest element. The set $S$ is a final segment of + the support strictly below $\gamma$, which gives + $v_J(u^{|\gamma})\le\omega^\rho$. Conversely, every interval immediately + below $\gamma$ contains a nonempty final segment of $S$, and every such + final segment still has order type $\omega^\rho$. The support-tail + characterisation of $v_J$ therefore gives the reverse inequality. + -/)] +theorem exists_ordinalValue_translatedTruncation_eq_wpow_of_lt + {beta rho : NatOrdinal} (hrho : rho < beta) (u : Series K) (hu : ordinalValue u = ω^ beta) + {θ : ℝ} (hθ : θ < 0) : + ∃ γ : ℝ, θ < γ ∧ γ < 0 ∧ ordinalValue (translatedTruncation (u : K⟦ℝ⟧) γ) = ω^ rho := by + have hbeta0 : beta ≠ 0 := (pos_of_gt hrho).ne' + have hone : 1 < ordinalValue u := by + rw [hu, ← NatOrdinal.wpow_zero] + exact NatOrdinal.wpow_lt_wpow.mpr (pos_iff_ne_zero.mpr hbeta0) + -- `B = supp(u) ∩ (η, 0)` with `η > θ`, on which the order type of the support is `v_J(u)`. + obtain ⟨η₀, hη₀, hstable⟩ := + exists_forall_later_negativeSupportTail_orderType_eq_ordinalValue u hone + set η : ℝ := max (η₀ / 2) (θ / 2) with hηdef + have hη₀η : η₀ < η := lt_max_of_lt_left (by linarith) + have hθη : θ < η := lt_max_of_lt_right (by linarith) + have hη : η < 0 := max_lt (by linarith) (by linarith) + set B : Set ℝ := negativeSupportTail u η with hBdef + have hBsupp : B ⊆ (u : K⟦ℝ⟧).support := negativeSupportTail_subset_support u η + have hBpwo : B.IsPWO := (u : K⟦ℝ⟧).isPWO_support.mono hBsupp + set ρ : Ordinal := omega0 ^ rho.val with hρdef + have hρpos : 0 < ρ := opow_pos _ omega0_pos + have hBtype : hBpwo.orderType = omega0 ^ beta.val := by + rw [Set.IsPWO.orderType_proof_irrel hBpwo + ((u : K⟦ℝ⟧).isPWO_support.mono (negativeSupportTail_subset_support u η)), + hstable η hη₀η hη, hu, NatOrdinal.val_wpow] + -- The point `y` of index `ρ`; the initial segment `S = B ∩ (-∞, y)`. + have hρlt : ρ < hBpwo.orderType := by + rw [hBtype, hρdef] + exact (opow_lt_opow_iff_right one_lt_omega0).mpr hrho + obtain ⟨y, hyB, hyIdx⟩ := hBpwo.exists_orderType_inter_Iio_eq hρlt + set S : Set ℝ := B ∩ Set.Iio y with hSdef + have hSpwo : S.IsPWO := hBpwo.mono Set.inter_subset_left + have hStype : hSpwo.orderType = ρ := hyIdx + have hSne : S.Nonempty := by + rw [Set.nonempty_iff_ne_empty] + intro hempty + have := (hSpwo.orderType_eq_zero).mpr hempty + rw [hStype] at this + exact hρpos.ne' this + have hSbdd : BddAbove S := ⟨y, fun x hx ↦ hx.2.le⟩ + set γ : ℝ := sSup S with hγdef + have hSγ : ∀ x ∈ S, x ≤ γ := fun x hx ↦ le_csSup hSbdd hx + have hγy : γ ≤ y := csSup_le hSne fun x hx ↦ hx.2.le + have hy0 : y < 0 := (mem_negativeSupportTail_iff.mp hyB).2.2 + have hγ0 : γ < 0 := hγy.trans_lt hy0 + have hθγ : θ < γ := by + obtain ⟨s, hs⟩ := hSne + exact (hθη.trans (mem_negativeSupportTail_iff.mp hs.1).2.1).trans_le (hSγ s hs) + -- Every point of `B` below `γ` lies in `S`. + have hbelow : ∀ x ∈ B, x < γ → x ∈ S := by + intro x hxB hxγ + obtain ⟨s, hs, hxs⟩ := exists_lt_of_lt_csSup hSne hxγ + exact ⟨hxB, hxs.trans hs.2⟩ + have hsuppBelow : ∀ x ∈ (u : K⟦ℝ⟧).support, η < x → x < γ → x ∈ S := fun x hx hηx hxγ ↦ + hbelow x (mem_negativeSupportTail_iff.mpr ⟨hx, hηx, hxγ.trans hγ0⟩) hxγ + refine ⟨γ, hθγ, hγ0, ?_⟩ + rcases eq_or_ne rho 0 with rfl | hrho0 + · -- `ρ = 0`: `S` is a single support point `γ`. + have hρone : ρ = 1 := by simp [hρdef] + have hSmin : ∀ x ∈ S, ∀ x' ∈ S, x' ≤ x → x' = x := by + intro x hx x' hx' hle + by_contra hne + have hlt : x' < x := lt_of_le_of_ne hle hne + have hbelow := hSpwo.orderType_inter_Iio_lt hx + rw [hStype, hρone, Order.lt_one_iff, Set.IsPWO.orderType_eq_zero] at hbelow + have : x' ∈ S ∩ Set.Iio x := ⟨hx', hlt⟩ + rw [hbelow] at this + exact this + obtain ⟨m, hm⟩ := hSne + have hSeq : S = {m} := by + ext x + constructor + · intro hx + rcases le_total x m with hxm | hmx + · exact hSmin m hm x hx hxm + · exact (hSmin x hx m hm hmx).symm + · rintro rfl + exact hm + have hγm : γ = m := by rw [hγdef, hSeq, csSup_singleton] + have hγS : γ ∈ S := hγm ▸ hm + have hγsupp : γ ∈ (u : K⟦ℝ⟧).support := hBsupp hγS.1 + have hgap : (u : K⟦ℝ⟧).support ∩ Set.Ioo η γ = ∅ := by + rw [Set.eq_empty_iff_forall_notMem] + rintro x ⟨hx, hηx, hxγ⟩ + have hxS := hsuppBelow x hx hηx hxγ + rw [hSeq] at hxS + exact hxγ.ne (hxS.trans hγm.symm) + have hηγ : η < γ := (mem_negativeSupportTail_iff.mp hγS.1).2.1 + have hle := ordinalValue_translatedTruncation_le_one_of_eq_empty u hηγ hgap + have hne : ordinalValue (translatedTruncation (u : K⟦ℝ⟧) γ) ≠ 0 := by + rw [Ne, ordinalValue_eq_zero_iff] + exact translatedTruncation_not_mem_negativeMonomialIdeal_of_mem_support u hγsupp + rw [NatOrdinal.wpow_zero] + rcases Order.le_one_iff.mp hle with hzero | hone' + · exact absurd hzero hne + · exact hone' + · -- `ρ ≥ 1`: `ω^ρ` is an additively indecomposable limit. + have hρprin : IsAdditivelyPrincipal ρ := isAdditivelyPrincipal_omega0_opow _ + have hρone : 1 < ρ := by + have : ω^ (0 : NatOrdinal) < ω^ rho := + NatOrdinal.wpow_lt_wpow.mpr (pos_iff_ne_zero.mpr hrho0) + rw [NatOrdinal.wpow_zero] at this + have hval : (1 : NatOrdinal).val < (ω^ rho).val := this + simpa [hρdef] using hval + have hlimit : Order.IsSuccLimit hSpwo.orderType := by + rw [hStype] + exact hρprin.isSuccLimit_of_one_lt hρone + have hprincipal : IsPrincipal (fun a b : Ordinal ↦ a + b) hSpwo.orderType := by + rw [hStype] + exact (isAdditivelyPrincipal_iff_ne_zero_and_isPrincipal_add.mp hρprin).2 + -- `S` has no largest element, so every point of `S` lies strictly below `γ`. + have hSlt : ∀ x ∈ S, x < γ := by + intro x hx + obtain ⟨x', hx', hxx'⟩ := hSpwo.exists_gt_of_isSuccLimit_orderType hlimit hx + exact hxx'.trans_le (hSγ x' hx') + -- Upper bound: `S` is a nonempty final segment of the support strictly below `γ`. + have hSupper : IsRelUpperSet S (· ∈ (u : K⟦ℝ⟧).support ∩ Set.Iio γ) := by + intro x hx + refine ⟨⟨hBsupp hx.1, hSlt x hx⟩, fun y' hxy' hy' ↦ ?_⟩ + exact hsuppBelow y' hy'.1 ((mem_negativeSupportTail_iff.mp hx.1).2.1.trans_le hxy') hy'.2 + have hupper := ordinalValue_translatedTruncation_le_orderType_of_isRelUpperSet_supportBelow + (u : K⟦ℝ⟧) γ hSupper hSne + rw [Set.IsPWO.orderType_proof_irrel _ hSpwo, hStype] at hupper + -- Lower bound: every interval `(θ', γ)` contains a nonempty final segment of `S`. + have hlower : NatOrdinal.of ρ ≤ ordinalValue (translatedTruncation (u : K⟦ℝ⟧) γ) := by + apply le_ordinalValue_translatedTruncation_of_forall_le_orderType + intro θ' hθ'γ + obtain ⟨s, hs, hθ's⟩ := exists_lt_of_lt_csSup hSne hθ'γ + have hfinal := hSpwo.orderType_inter_Ioi_eq_of_isPrincipal hprincipal ⟨s, hs, hθ's⟩ + rw [hStype] at hfinal + rw [← hfinal] + apply Set.IsPWO.orderType_mono + intro x hx + exact ⟨hBsupp hx.1.1, hx.2, hSlt x hx.1⟩ + rw [NatOrdinal.val_eq_iff.mp (le_antisymm hupper (NatOrdinal.of_le_iff.mp hlower)), hρdef, + ← NatOrdinal.val_wpow, NatOrdinal.of_val] + +/-- If `v_J(u) = ω^β` and `ρ < β`, then `v_J(u^{|γ}) = ω^ρ` for cutoffs `γ < 0` arbitrarily close +to `0`. -/ +theorem frequently_ordinalValue_translatedTruncation_eq_wpow_of_lt + {beta rho : NatOrdinal} (hrho : rho < beta) (u : Series K) (hu : ordinalValue u = ω^ beta) : + ∃ᶠ γ in nhdsWithin (0 : ℝ) (Set.Iio 0), + ordinalValue (translatedTruncation (u : K⟦ℝ⟧) γ) = ω^ rho := by + rw [Filter.frequently_iff] + intro U hU + obtain ⟨ε, hε, hεU⟩ := Metric.mem_nhdsWithin_iff.mp hU + obtain ⟨γ, hθγ, hγ0, hγ⟩ := exists_ordinalValue_translatedTruncation_eq_wpow_of_lt hrho u hu + (neg_neg_of_pos hε : -ε < 0) + refine ⟨γ, hεU ⟨?_, hγ0⟩, hγ⟩ + rw [Metric.mem_ball, Real.dist_eq, abs_lt] + constructor <;> linarith + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/CoefficientMap.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/CoefficientMap.lean new file mode 100644 index 0000000000..e6de795a10 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/CoefficientMap.lean @@ -0,0 +1,38 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValueSupport +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.NonpositiveCoefficientMap + +/-! +# Ordinal value under coefficient extension + +An embedding of coefficient fields preserves the support and hence the ordinal value of a +nonpositive Hahn series. +-/ + +universe v w + +open scoped HahnSeries + +namespace Berarducci + +open HahnSeries.Nonpositive + +public section + +/-- Coefficient extension along a field embedding preserves the ordinal value. -/ +theorem ordinalValue_nonpositiveCoefficientMap {K : Type v} {E : Type w} + [Field K] [Field E] (f : K →+* E) (u : HahnSeries.Nonpositive ℝ K) : + ordinalValue (nonpositiveCoefficientMap f u) = ordinalValue u := + le_antisymm + (ordinalValue_le_of_support_subset _ _ (support_nonpositiveCoefficientMap f u).subset) + (ordinalValue_le_of_support_subset _ _ (support_nonpositiveCoefficientMap f u).superset) + +end + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/ComplexityDecrease.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/ComplexityDecrease.lean new file mode 100644 index 0000000000..6cc8abb28c --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/ComplexityDecrease.lean @@ -0,0 +1,248 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.FormalExpression +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.ResidualPoint + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.ResidualPointValue + +/-! +# The complexity drop of Berarducci's reduction step + +Berarducci, Lemma 9.5: replacing the selected factor of a formal expression by one truncation +`b₀^{|γ}` and one fewer copy of `b₀`, while doubling every other exponent, strictly decreases +the complexity, provided `γ` is a residual point of `b₀` close enough to zero. + +Only two properties of the truncation are used, both supplied by the residual-point remarks of +Section 6 and Section 9: its ordinal value is strictly below `v_J(b₀)`, and its principal value is +at least `v_J^p(b₀)`. The combinatorial step is therefore stated for an arbitrary multiset of +factors having those two properties, which also accommodates the source's convention of omitting +the truncation when its value is one. +-/ + +universe v + +public noncomputable section + +open HahnSeries Ordinal + +namespace Berarducci + +variable {K : Type v} [Field K] + +namespace FormalExpression + +open Classical in +/-- The factors of `w` other than the selected one. -/ +noncomputable def unselected (w : FormalExpression K) (hw : w ≠ 0) : FormalExpression K := + w.filter (· ≠ selected w hw) + +open Classical in +theorem unselected_eq (w : FormalExpression K) (hw : w ≠ 0) : + unselected w hw = w.filter (· ≠ selected w hw) := (rfl) + +open Classical in +theorem mem_unselected {w : FormalExpression K} {hw : w ≠ 0} + {y : SeriesWithOrdinalValueAboveOne K} : + y ∈ unselected w hw ↔ y ∈ w ∧ y ≠ selected w hw := by + rw [unselected] + exact Multiset.mem_filter + +open Classical in +/-- Berarducci, Lemma 9.5: the expression +`b₀^{|γ} b₀^{k - 1} b₁^{2 k₁} ⋯ bₙ^{2 kₙ}` obtained from `w` by reducing the selected +exponent, doubling the others, and adjoining the truncation factors `t`. -/ +noncomputable def reduced (w : FormalExpression K) (hw : w ≠ 0) (t : FormalExpression K) : + FormalExpression K := + t + Multiset.replicate (selectedExponent w hw - 1) (selected w hw) + + (unselected w hw + unselected w hw) + +theorem reduced_eq (w : FormalExpression K) (hw : w ≠ 0) (t : FormalExpression K) : + reduced w hw t = t + Multiset.replicate (selectedExponent w hw - 1) (selected w hw) + + (unselected w hw + unselected w hw) := (rfl) + +theorem mem_reduced {w : FormalExpression K} {hw : w ≠ 0} {t : FormalExpression K} + {y : SeriesWithOrdinalValueAboveOne K} : + y ∈ reduced w hw t ↔ y ∈ t ∨ (selectedExponent w hw - 1 ≠ 0 ∧ y = selected w hw) ∨ + (y ∈ w ∧ y ≠ selected w hw) := by + rw [reduced] + simp only [Multiset.mem_add, Multiset.mem_replicate, mem_unselected, or_self, or_assoc] + +theorem one_le_selectedExponent (w : FormalExpression K) (hw : w ≠ 0) : + 1 ≤ selectedExponent w hw := by + classical + rw [selectedExponent_eq_count] + exact Multiset.count_pos.mpr (isSelected_selected w hw).mem + +open Classical in +/-- The reduction removes one copy of the selected factor. -/ +theorem count_selected_reduced {w : FormalExpression K} {hw : w ≠ 0} {t : FormalExpression K} + (ht : selected w hw ∉ t) : + Multiset.count (selected w hw) (reduced w hw t) = selectedExponent w hw - 1 := by + rw [reduced] + simp only [Multiset.count_add, Multiset.count_replicate_self] + rw [Multiset.count_eq_zero.mpr ht, + Multiset.count_eq_zero.mpr fun h ↦ (mem_unselected.mp h).2 rfl] + omega + +open Classical in +/-- The reduction doubles the exponent of every other factor. -/ +theorem count_reduced_of_ne {w : FormalExpression K} {hw : w ≠ 0} {t : FormalExpression K} + {y : SeriesWithOrdinalValueAboveOne K} (hy : y ≠ selected w hw) (hyt : y ∉ t) : + Multiset.count y (reduced w hw t) = 2 * Multiset.count y w := by + rw [reduced, unselected] + simp only [Multiset.count_add, Multiset.count_replicate, Multiset.count_filter, + ite_eq_right (Ne.symm hy), ite_eq_left hy, Multiset.count_eq_zero.mpr hyt] + omega + +/-- The selected factor survives the reduction exactly when its exponent exceeds one. -/ +theorem selected_mem_reduced {w : FormalExpression K} {hw : w ≠ 0} {t : FormalExpression K} + (hk : 1 < selectedExponent w hw) : selected w hw ∈ reduced w hw t := + mem_reduced.mpr (Or.inr (Or.inl ⟨by omega, rfl⟩)) + +theorem selectedExponent_lt_of_isSelected {w : FormalExpression K} {hw : w ≠ 0} + {t : FormalExpression K} (hw₂ : reduced w hw t ≠ 0) + (ht : selected w hw ∉ t) (hsel : selected (reduced w hw t) hw₂ = selected w hw) : + selectedExponent (reduced w hw t) hw₂ < selectedExponent w hw := by + rw [selectedExponent_eq_count, hsel, count_selected_reduced ht] + have := one_le_selectedExponent w hw + omega + +/-- Case 1 of Berarducci, Lemma 9.5: when the selected exponent exceeds one, the selected factor +of the reduced expression is unchanged. -/ +theorem isSelected_reduced (w : FormalExpression K) (hw : w ≠ 0) (t : FormalExpression K) + (ht : ∀ u ∈ t, ordinalValue u.1 < ordinalValue (selected w hw).1) + (htp : ∀ u ∈ t, (selected w hw).principalValue ≤ u.principalValue) + (hk : 1 < selectedExponent w hw) : + IsSelected (reduced w hw t) (selected w hw) := by + have hsel := isSelected_selected w hw + refine ⟨mem_reduced.mpr (Or.inr (Or.inl ⟨by omega, rfl⟩)), ?_, ?_, ?_⟩ + · intro y hy + rcases mem_reduced.mp hy with h | ⟨-, rfl⟩ | ⟨hyw, -⟩ + · exact htp y h + · exact le_rfl + · exact hsel.min_principalValue y hyw + · intro y hy hyp + rcases mem_reduced.mp hy with h | ⟨-, rfl⟩ | ⟨hyw, -⟩ + · exact (ht y h).le + · exact le_rfl + · exact hsel.max_ordinalValue y hyw hyp + · intro y hy hyp hyo + rcases mem_reduced.mp hy with h | ⟨-, rfl⟩ | ⟨hyw, -⟩ + · exact absurd hyo (ht y h).ne + · exact irrefl_of (WellOrderingRel : SeriesWithOrdinalValueAboveOne K → _ → Prop) _ + · exact hsel.least y hyw hyp hyo + +/-- The Dershowitz-Manna step behind the second case of Berarducci, Lemma 9.5: an expression each +of whose factors is either of strictly smaller ordinal value than the selected factor of `w`, or a +factor of `w` other than that one, has strictly smaller complexity. The selected factor of the +smaller expression never has to be identified. -/ +theorem complexityLT_of_forall_lt_or_mem {w w' : FormalExpression K} (hw : w ≠ 0) (hw' : w' ≠ 0) + (h : ∀ u ∈ w', ordinalValue u.1 < ordinalValue (selected w hw).1 ∨ + (u ∈ w ∧ u ≠ selected w hw)) : + ComplexityLT (complexity w' hw') (complexity w hw) := by + classical + set f : SeriesWithOrdinalValueAboveOne K → Ordinal := fun y ↦ (ordinalValue y.1).val with hf + set S : Finset (SeriesWithOrdinalValueAboveOne K) := w'.toFinset.filter + (fun y ↦ ordinalValue (selected w' hw').1 ≤ ordinalValue y.1) with hS + set T : Finset (SeriesWithOrdinalValueAboveOne K) := + w.toFinset.filter (fun y ↦ ordinalValue (selected w hw).1 ≤ ordinalValue y.1) with hT + have hxT : selected w hw ∈ T := + Finset.mem_filter.mpr ⟨Multiset.mem_toFinset.mpr (isSelected_selected w hw).mem, le_rfl⟩ + set R : Finset (SeriesWithOrdinalValueAboveOne K) := T.erase (selected w hw) with hR + have hkey : ∀ u ∈ S, u ∉ R → ordinalValue u.1 < ordinalValue (selected w hw).1 := by + intro u hu huR + have humem : u ∈ w' := Multiset.mem_toFinset.mp (Finset.mem_filter.mp hu).1 + rcases h u humem with hlt | ⟨huw, hux⟩ + · exact hlt + · rw [hR, Finset.mem_erase] at huR + have hTu : u ∉ T := fun hmem ↦ huR ⟨hux, hmem⟩ + refine lt_of_not_ge fun hle ↦ hTu ?_ + rw [hT] + exact Finset.mem_filter.mpr ⟨Multiset.mem_toFinset.mpr huw, hle⟩ + have hsplit : ∀ A B : Finset (SeriesWithOrdinalValueAboveOne K), + A.val = (A ∩ B).val + (A \ B).val := by + intro A B + rw [← Finset.filter_mem_eq_inter, Finset.sdiff_eq_filter, Finset.filter_val, + Finset.filter_val] + exact (Multiset.filter_add_not _ _).symm + refine complexityLT_of_relevantValues (X := (S ∩ R).val.map f) (Y := (S \ R).val.map f) + (Z := f (selected w hw) ::ₘ (R \ S).val.map f) (by simp) ?_ ?_ ?_ + · rw [relevantValues_eq_map, ← hS, hsplit S R, Multiset.map_add] + · rw [relevantValues_eq_map, ← hT, ← Multiset.cons_erase (s := T.val) hxT, + ← Finset.erase_val, ← hR, Multiset.map_cons, hsplit R S, Multiset.map_add, + Finset.inter_comm, Multiset.add_cons] + · intro y hy + obtain ⟨u, hu, rfl⟩ := Multiset.mem_map.mp hy + rw [Finset.mem_val, Finset.mem_sdiff] at hu + exact ⟨f (selected w hw), Multiset.mem_cons_self _ _, + NatOrdinal.val.lt_iff_lt.mpr (hkey u hu.1 hu.2)⟩ + +/-- The factors other than the selected one form an expression of strictly smaller complexity. -/ +theorem complexityLT_unselected {w : FormalExpression K} (hw : w ≠ 0) + (hr : unselected w hw ≠ 0) : + ComplexityLT (complexity (unselected w hw) hr) (complexity w hw) := + complexityLT_of_forall_lt_or_mem hw hr fun _ hu ↦ Or.inr (mem_unselected.mp hu) + +/-- Berarducci, Lemma 9.5: the reduction step strictly decreases the complexity. The adjoined +factors are only required to have strictly smaller ordinal value and no smaller principal value +than the selected factor. -/ +theorem complexityLT_reduced (w : FormalExpression K) (hw : w ≠ 0) (t : FormalExpression K) + (ht : ∀ u ∈ t, ordinalValue u.1 < ordinalValue (selected w hw).1) + (htp : ∀ u ∈ t, (selected w hw).principalValue ≤ u.principalValue) + (hw₂ : reduced w hw t ≠ 0) : + ComplexityLT (complexity (reduced w hw t) hw₂) (complexity w hw) := by + classical + have htmem : selected w hw ∉ t := fun h ↦ absurd (ht _ h) (lt_irrefl _) + rcases lt_or_ge 1 (selectedExponent w hw) with hk | hk + · -- Case 1: the selected factor survives, so only its exponent moves. + have hsel : selected (reduced w hw t) hw₂ = selected w hw := + (eq_selected_of_isSelected hw₂ (isSelected_reduced w hw t ht htp hk)).symm + refine complexityLT_of_selectedExponent ?_ (selectedExponent_lt_of_isSelected hw₂ htmem hsel) + refine relevantValues_congr hw₂ hw hsel fun y hy ↦ ?_ + rw [hsel] at hy + constructor + · intro hmem + rcases mem_reduced.mp hmem with hmem | ⟨-, rfl⟩ | ⟨hmem, -⟩ + · exact absurd hy (not_le.mpr (ht y hmem)) + · exact (isSelected_selected w hw).mem + · exact hmem + · intro hmem + by_cases hyx : y = selected w hw + · exact mem_reduced.mpr (Or.inr (Or.inl ⟨by omega, hyx⟩)) + · exact mem_reduced.mpr (Or.inr (Or.inr ⟨hmem, hyx⟩)) + · -- Case 2: the selected factor disappears, and its value is replaced by smaller ones. + have hk1 : selectedExponent w hw - 1 = 0 := by + have := one_le_selectedExponent w hw + omega + refine complexityLT_of_forall_lt_or_mem hw hw₂ fun u hu ↦ ?_ + rcases mem_reduced.mp hu with hmem | ⟨hne, -⟩ | hmem + · exact Or.inl (ht u hmem) + · exact absurd hk1 hne + · exact Or.inr hmem + +end FormalExpression + +/-- Berarducci, Lemma 9.5: for residual points of the selected factor close enough to zero, the +reduction step strictly decreases the complexity. -/ +theorem exists_complexityLT_reduced (w : FormalExpression K) (hw : w ≠ 0) : + ∃ η < (0 : ℝ), ∀ γ : ℝ, η < γ → γ < 0 → + γ ∈ residualPointSet (FormalExpression.selected w hw) → + ∀ t : FormalExpression K, + (∀ u ∈ t, u.1 = translatedTruncation ((FormalExpression.selected w hw).1 : K⟦ℝ⟧) γ) → + ∀ hw₂ : FormalExpression.reduced w hw t ≠ 0, + FormalExpression.ComplexityLT (FormalExpression.complexity _ hw₂) + (FormalExpression.complexity w hw) := by + obtain ⟨η, hη, hcut⟩ := exists_ordinalValue_translatedTruncation_lt (FormalExpression.selected w + hw) + refine ⟨η, hη, fun γ hlow hhigh hγ t htu hw₂ ↦ ?_⟩ + refine FormalExpression.complexityLT_reduced w hw t (fun u hu ↦ ?_) (fun u hu ↦ ?_) hw₂ + · rw [htu u hu] + exact hcut γ hlow hhigh + · exact principalValue_le_of_mem_residualPointSet _ u hγ (htu u hu) + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Convolution.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Convolution.lean new file mode 100644 index 0000000000..e2763945f6 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Convolution.lean @@ -0,0 +1,179 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Truncation +public import Mathlib.Topology.MetricSpace.Pseudo.Defs + +import LeanPool.ConwayRefinement.ConwayRefinement.Topology.Order.PWOSumset +import Mathlib.Topology.Instances.Real.Lemmas + +/-! +# Berarducci's convolution formula for germs + +Berarducci, Lemma 7.5(2): the germ of a product at `γ` is the finite sum of the products of the +germs of the factors over all pairs of exponents summing to `γ`. The index set +`Berarducci.convolutionIndex` is the finite set of first coordinates of points of the two closed +supports on the line of sum `γ`; it is finite by the well-ordering estimate proved with the +sumset lemmas. + +The proof has two halves. `coeff_translatedTruncation_mul` reindexes the coefficient of a product + of two +germ truncations as a sum over the pairs of the original supports on the line of sum `β + ξ + δ` +that lie weakly below `(β, ξ)`; this is a translation bijection and needs no hypotheses. The +remaining half is Berarducci, Lemma 7.4: for `γ + δ` below and sufficiently close to `γ`, each +such pair is dominated by exactly one index, so summing the reindexed coefficients over the index +set recovers the full antidiagonal sum, which is the coefficient of the product. + +Equality of germs is equality on some interval `(η, γ]`; `η` is exactly the cutoff supplied by +Lemma 7.4. +-/ + +universe v + +public noncomputable section + +open HahnSeries Filter Topology + +namespace Berarducci + +variable {K : Type v} [Field K] + +private theorem mem_support_translatedTruncation {b : K⟦ℝ⟧} {β u : ℝ} : + u ∈ ((translatedTruncation b β : Series K) : K⟦ℝ⟧).support ↔ + u ≤ 0 ∧ β + u ∈ b.support := by + rw [HahnSeries.mem_support, coeff_translatedTruncation] + by_cases hu : u ≤ 0 + · simp [hu, HahnSeries.mem_support] + · simp [hu] + +theorem coeff_translatedTruncation_mul (b c : K⟦ℝ⟧) (β ξ δ : ℝ) : + ((translatedTruncation b β * translatedTruncation c ξ : Series K) : K⟦ℝ⟧).coeff δ = + ∑ pq ∈ (Finset.antidiagonal b.isPWO_support c.isPWO_support (β + ξ + δ)).filter + (fun pq ↦ pq.1 ≤ β ∧ pq.2 ≤ ξ), b.coeff pq.1 * c.coeff pq.2 := by + rw [Subring.coe_mul, HahnSeries.coeff_mul] + refine Finset.sum_nbij' (i := fun uv ↦ (β + uv.1, ξ + uv.2)) + (j := fun pq ↦ (pq.1 - β, pq.2 - ξ)) ?_ ?_ ?_ ?_ ?_ + · rintro ⟨u, v⟩ huv + rw [Finset.mem_antidiagonal] at huv + obtain ⟨hu, hv, huv⟩ := huv + rw [mem_support_translatedTruncation] at hu + rw [mem_support_translatedTruncation] at hv + simp only [Finset.mem_filter, Finset.mem_antidiagonal] + refine ⟨⟨hu.2, hv.2, by linarith⟩, by linarith [hu.1], by linarith [hv.1]⟩ + · rintro ⟨p, q⟩ hpq + simp only [Finset.mem_filter, Finset.mem_antidiagonal] at hpq + obtain ⟨⟨hp, hq, hsum⟩, hpβ, hqξ⟩ := hpq + rw [Finset.mem_antidiagonal] + refine ⟨?_, ?_, by linarith⟩ + · rw [mem_support_translatedTruncation] + exact ⟨by linarith, by simpa using hp⟩ + · rw [mem_support_translatedTruncation] + exact ⟨by linarith, by simpa using hq⟩ + · rintro ⟨u, v⟩ _ + simp + · rintro ⟨p, q⟩ _ + simp + · rintro ⟨u, v⟩ huv + rw [Finset.mem_antidiagonal] at huv + obtain ⟨hu, hv, -⟩ := huv + rw [mem_support_translatedTruncation] at hu + rw [mem_support_translatedTruncation] at hv + rw [coeff_translatedTruncation, coeff_translatedTruncation, ite_eq_left hu.1, ite_eq_left hv.1] + +/-- The finite index set of Berarducci's convolution formula: the first coordinates of the points +of the closed supports lying on the line of sum `γ`. -/ +def convolutionIndex (b c : K⟦ℝ⟧) (γ : ℝ) : Finset ℝ := + (Set.IsPWO.finite_sub_mem (Set.isPWO_closure b.isPWO_support) + (Set.isPWO_closure c.isPWO_support) γ).toFinset + +@[simp] +theorem mem_convolutionIndex {b c : K⟦ℝ⟧} {γ β : ℝ} : + β ∈ convolutionIndex b c γ ↔ + β ∈ closure b.support ∧ γ - β ∈ closure c.support := by + simp [convolutionIndex] + +/-- The convolution formula for germs of a product, valid at every real cutoff. -/ +@[blueprint "lem:convolution-formula" + (phase := "Ordinal value and degree") + (title := "Convolution formula for translated truncations") + (statement := /-- + Let $K$ be a field. For $b,c\in K((\mathbb R))$ and $\gamma\in\mathbb R$, + \[ + \trunc{(bc)}\gamma\equiv\sum_{\xi+\zeta=\gamma}\trunc b\xi\trunc c\zeta + \bmod J . + \] + -/) + (proof := /-- + For a cutoff $\gamma$, only finitely many pairs of points in the two closed + supports can sum to $\gamma$. Below a sufficiently small neighbourhood of + zero, every support pair contributing to the coefficient of $bc$ is dominated + by a unique such boundary pair. Regrouping the convolution product by that pair + identifies the coefficients of $(bc)^{|\gamma}$ with the finite sum of + $b^{|\xi}c^{|\zeta}$; equality near zero is precisely congruence modulo $J$. + This is the proof of \cite[Lemma~7.5(2)]{Ber00}; its argument does not use + $\gamma\le 0$, so it gives the displayed formula at every real cutoff. + -/)] +theorem germAt_mul (b c : K⟦ℝ⟧) (γ : ℝ) : + germAt (b * c) γ = ∑ β ∈ convolutionIndex b c γ, germAt b β * germAt c (γ - β) := by + classical + have hB := Set.isPWO_closure b.isPWO_support + have hC := Set.isPWO_closure c.isPWO_support + have hev := Set.IsPWO.eventually_existsUnique_dominating hB hC + isClosed_closure isClosed_closure γ + obtain ⟨η₀, hη₀, hsub⟩ := mem_nhdsLE_iff_exists_Ioc_subset.mp hev + rw [Set.mem_Iio] at hη₀ + have hRHS : ∑ β ∈ convolutionIndex b c γ, germAt b β * germAt c (γ - β) = + toGerm (∑ β ∈ convolutionIndex b c γ, + translatedTruncation b β * translatedTruncation c (γ - β)) := by + rw [map_sum] + simp only [germAt_apply, map_mul] + rw [germAt_apply, hRHS, toGerm_eq_toGerm_iff_exists_coeff_eq] + refine ⟨η₀ - γ, by linarith, fun δ hδlow hδ0 ↦ ?_⟩ + have hγδ : γ + δ ∈ Set.Ioc η₀ γ := ⟨by linarith, by linarith⟩ + have hunique := hsub hγδ + rw [coeff_translatedTruncation, ite_eq_left hδ0] + set A := Finset.antidiagonal b.isPWO_support c.isPWO_support (γ + δ) with hA + rw [HahnSeries.coeff_mul] + have hcoeSum : ((∑ β ∈ convolutionIndex b c γ, + translatedTruncation b β * translatedTruncation c (γ - β) : Series K) : K⟦ℝ⟧).coeff δ = + ∑ β ∈ convolutionIndex b c γ, + ((translatedTruncation b β * translatedTruncation c (γ - β) : Series K) : K⟦ℝ⟧).coeff δ := + by + rw [AddSubmonoidClass.coe_finsetSum, HahnSeries.coeff_sum] + rw [hcoeSum] + have hterm : ∀ β ∈ convolutionIndex b c γ, + ((translatedTruncation b β * translatedTruncation c (γ - β) : Series K) : K⟦ℝ⟧).coeff δ = + ∑ pq ∈ A.filter (fun pq ↦ pq.1 ≤ β ∧ pq.2 ≤ γ - β), + b.coeff pq.1 * c.coeff pq.2 := by + intro β _ + have hidx : β + (γ - β) + δ = γ + δ := by ring + rw [coeff_translatedTruncation_mul b c β (γ - β) δ, hidx, ← hA] + rw [Finset.sum_congr rfl hterm] + simp only [Finset.sum_filter] + rw [Finset.sum_comm] + refine (Finset.sum_congr rfl fun pq hpq ↦ ?_).symm + rw [Finset.mem_antidiagonal] at hpq + obtain ⟨hp, hq, hsum⟩ := hpq + obtain ⟨β₀, hβ₀, hβ₀uniq⟩ := + hunique pq.1 (subset_closure hp) pq.2 (subset_closure hq) hsum + refine (Finset.sum_eq_single β₀ ?_ ?_).trans ?_ + · intro β hβ hne + refine ite_eq_right fun hdom ↦ hne ?_ + exact hβ₀uniq β ⟨(mem_convolutionIndex.mp hβ).1, (mem_convolutionIndex.mp hβ).2, + hdom.1, hdom.2⟩ + · intro hnot + exact absurd (mem_convolutionIndex.mpr ⟨hβ₀.1, hβ₀.2.1⟩) hnot + · exact ite_eq_left ⟨hβ₀.2.2.1, hβ₀.2.2.2⟩ + +/-- Berarducci, Lemma 7.5(2), the convolution formula at a nonpositive cutoff. -/ +theorem germAt_mul_of_nonpos (b c : K⟦ℝ⟧) (γ : ℝ) (_hγ : γ ≤ 0) : + germAt (b * c) γ = ∑ β ∈ convolutionIndex b c γ, germAt b β * germAt c (γ - β) := + germAt_mul b c γ + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/ConvolutionList.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/ConvolutionList.lean new file mode 100644 index 0000000000..8d58b1b608 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/ConvolutionList.lean @@ -0,0 +1,146 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Convolution + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.ResidualPointWellOrdered +import Mathlib.Topology.Instances.Real.Lemmas + +/-! +# The multi-factor convolution formula + +Berarducci, Remark 7.6: the two-factor convolution formula extends by induction to a product of +finitely many series. The germ of the product of a list of series at a cutoff is the finite sum, +over the exponent lists summing to that cutoff, of the products of the germs of the factors at +those exponents. + +The index set is built by the same recursion as the formula. At a cons the two-factor index set +selects the exponent of the head, and the exponent lists of the tail are taken at the shifted +cutoff; the resulting families are pairwise disjoint because they have distinct heads, and the +cons map is injective, so the double sum collapses to a single sum. The empty list contributes the +unit exactly at cutoff zero, since the support of one is the single exponent zero and its germ +vanishes elsewhere. +-/ + +universe v + +public noncomputable section + +open HahnSeries + +namespace Berarducci + +variable {K : Type v} [Field K] + +/-- The product of the germs of a list of series at a list of exponents. -/ +def germListProd : List K⟦ℝ⟧ → List ℝ → Germ K + | [], [] => 1 + | b :: l, β :: f => germAt b β * germListProd l f + | _, _ => 0 + +@[simp] +theorem germListProd_nil : germListProd ([] : List K⟦ℝ⟧) [] = 1 := + (rfl) + +@[simp] +theorem germListProd_cons (b : K⟦ℝ⟧) (l : List K⟦ℝ⟧) (β : ℝ) (f : List ℝ) : + germListProd (b :: l) (β :: f) = germAt b β * germListProd l f := + (rfl) + +/-- The finite index set of the multi-factor convolution formula. -/ +def convolutionIndexList : List K⟦ℝ⟧ → ℝ → Finset (List ℝ) + | [], γ => if γ = 0 then {[]} else ∅ + | b :: l, γ => + (convolutionIndex b l.prod γ).biUnion + fun β ↦ (convolutionIndexList l (γ - β)).image (β :: ·) + +@[simp] +theorem convolutionIndexList_nil (γ : ℝ) : + convolutionIndexList ([] : List K⟦ℝ⟧) γ = if γ = 0 then {[]} else ∅ := + (rfl) + +@[simp] +theorem convolutionIndexList_cons (b : K⟦ℝ⟧) (l : List K⟦ℝ⟧) (γ : ℝ) : + convolutionIndexList (b :: l) γ = + (convolutionIndex b l.prod γ).biUnion + fun β ↦ (convolutionIndexList l (γ - β)).image (β :: ·) := + (rfl) + +theorem length_of_mem_convolutionIndexList : + ∀ (l : List K⟦ℝ⟧) (γ : ℝ) {f : List ℝ}, f ∈ convolutionIndexList l γ → + f.length = l.length + | [], γ, f, hf => by + rw [convolutionIndexList_nil] at hf + by_cases hγ : γ = 0 + · rw [ite_eq_left hγ, Finset.mem_singleton] at hf + rw [hf] + rfl + · rw [ite_eq_right hγ] at hf + exact absurd hf (Finset.notMem_empty f) + | b :: t, γ, f, hf => by + rw [convolutionIndexList_cons, Finset.mem_biUnion] at hf + obtain ⟨β, _, hβ⟩ := hf + obtain ⟨g, hg, rfl⟩ := Finset.mem_image.mp hβ + rw [List.length_cons, List.length_cons, + length_of_mem_convolutionIndexList t (γ - β) hg] + +theorem sum_of_mem_convolutionIndexList : + ∀ (l : List K⟦ℝ⟧) (γ : ℝ) {f : List ℝ}, + f ∈ convolutionIndexList l γ → f.sum = γ + | [], γ, f, hf => by + rw [convolutionIndexList_nil] at hf + by_cases hγ : γ = 0 + · rw [ite_eq_left hγ, Finset.mem_singleton] at hf + rw [hf, List.sum_nil, hγ] + · rw [ite_eq_right hγ] at hf + exact absurd hf (Finset.notMem_empty f) + | b :: t, γ, f, hf => by + rw [convolutionIndexList_cons, Finset.mem_biUnion] at hf + obtain ⟨β, _, hβ⟩ := hf + obtain ⟨g, hg, rfl⟩ := Finset.mem_image.mp hβ + rw [List.sum_cons, sum_of_mem_convolutionIndexList t (γ - β) hg] + ring + +private theorem germAt_one_of_ne_zero {γ : ℝ} (hγ : γ ≠ 0) : + germAt (1 : K⟦ℝ⟧) γ = 0 := by + refine germAt_eq_zero_of_not_mem_closure_support ?_ + have hsupp : (1 : K⟦ℝ⟧).support = {(0 : ℝ)} := by + change (HahnSeries.single (0 : ℝ) (1 : K)).support = _ + exact HahnSeries.support_single_of_ne one_ne_zero + rw [hsupp, closure_singleton] + simpa using hγ + +/-- Berarducci, Remark 7.6: the germ of a product of a list of series at a cutoff is the finite +sum, over the exponent lists summing to that cutoff, of the products of the germs of the factors +at those exponents. -/ +theorem germAt_listProd (l : List K⟦ℝ⟧) (γ : ℝ) : + germAt l.prod γ = ∑ f ∈ convolutionIndexList l γ, germListProd l f := by + induction l generalizing γ with + | nil => + rw [List.prod_nil, convolutionIndexList_nil] + by_cases hγ : γ = 0 + · subst hγ + rw [ite_eq_left rfl, Finset.sum_singleton, germListProd_nil] + change germAt ((1 : Series K) : K⟦ℝ⟧) 0 = 1 + rw [germAt_apply, translatedTruncation_zero] + exact map_one toGerm + · rw [ite_eq_right hγ, Finset.sum_empty] + exact germAt_one_of_ne_zero hγ + | cons b t ih => + rw [List.prod_cons, germAt_mul, convolutionIndexList_cons] + rw [Finset.sum_biUnion] + · refine Finset.sum_congr rfl fun β _ ↦ ?_ + rw [Finset.sum_image (fun _ _ _ _ h ↦ (List.cons_inj_right β).mp h), ih (γ - β), + Finset.mul_sum] + exact Finset.sum_congr rfl fun f _ ↦ rfl + · intro x _ y _ hxy + refine Finset.disjoint_left.mpr fun g hg hg' ↦ hxy ?_ + obtain ⟨f, _, rfl⟩ := Finset.mem_image.mp hg + obtain ⟨f', _, hf'⟩ := Finset.mem_image.mp hg' + exact (List.cons.injEq _ _ _ _ ▸ hf').1.symm + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/ConvolutionRemainder.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/ConvolutionRemainder.lean new file mode 100644 index 0000000000..54a19aec98 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/ConvolutionRemainder.lean @@ -0,0 +1,202 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalValue +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Truncation + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Convolution +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.GermValueCut +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.ResidualPointWellOrdered +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValueDegree +import Mathlib.Topology.Instances.Real.Lemmas +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValueSubmultiplicative +import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.NaturalPrincipal + +/-! +# The convolution remainder estimate + +Berarducci, Lemma 7.7: when `v_J^p(b) ≤ v_J^p(c)`, the germ of `b * c` at a sufficiently high +negative cutoff differs from `b^{|γ} c + b c^{|γ}` by a germ of ordinal value strictly below +`v_J^r(b) ⊙ v_J(c)`. + +The convolution formula expands the germ of the product as a finite sum over the index set. Two +of its terms are the displayed ones: the index `γ` contributes `b^{|γ} c` and the index `0` +contributes `b c^{|γ}`, and when either index is absent from the set the corresponding term is +already zero because a germ at a point outside the closed support vanishes. Every remaining index +`β` satisfies `γ < β < 0` and `γ < γ - β < 0`, so the eventual value cut bounds both factor +values by proper multiples of the two residual values, submultiplicativity bounds the product, and +Berarducci, Fact 3.7 for the natural product collapses the two multipliers strictly below +`v_J^p(c)`. + +The bound uses Hessenberg multiplication throughout; the multipliers supplied by the value cut are +ordinary ordinal products, and the comparison between the two is where `NatOrdinal.omul_le_mul'` +enters. +-/ + +universe u v + +public noncomputable section + +open HahnSeries Filter Topology + +namespace Berarducci + +variable {K : Type v} [Field K] + +@[simp] +theorem germOrdinalValue_zero : germOrdinalValue (0 : Germ K) = 0 := + germOrdinalValue_eq_zero_iff.mpr rfl + +theorem germOrdinalValue_add_le_max (q p : Germ K) : + germOrdinalValue (q + p) ≤ max (germOrdinalValue q) (germOrdinalValue p) := by + obtain ⟨b, rfl⟩ := Ideal.Quotient.mk_surjective q + obtain ⟨c, rfl⟩ := Ideal.Quotient.mk_surjective p + rw [← map_add, germOrdinalValue_mk, germOrdinalValue_mk, germOrdinalValue_mk] + exact ordinalValue_add_le_max b c + +theorem germOrdinalValue_sum_lt {ι : Type u} {s : Finset ι} {f : ι → Germ K} + {X : NatOrdinal} (hX : 0 < X) (h : ∀ i ∈ s, germOrdinalValue (f i) < X) : + germOrdinalValue (∑ i ∈ s, f i) < X := by + classical + induction s using Finset.induction_on with + | empty => simpa using hX + | insert a s ha ih => + rw [Finset.sum_insert ha] + refine (germOrdinalValue_add_le_max _ _).trans_lt (max_lt ?_ ?_) + · exact h a (Finset.mem_insert_self a s) + · exact ih fun i hi ↦ h i (Finset.mem_insert_of_mem hi) + + +theorem exists_germOrdinalValue_convolution_remainder_lt + (b c : SeriesWithOrdinalValueAboveOne K) + (hp : b.principalValue ≤ c.principalValue) : + ∃ η < (0 : ℝ), ∀ γ : ℝ, η < γ → γ < 0 → + germOrdinalValue (germAt ((b.1 * c.1 : Series K) : K⟦ℝ⟧) γ + - germAt (b.1 : K⟦ℝ⟧) γ * toGerm c.1 + - toGerm b.1 * germAt (c.1 : K⟦ℝ⟧) γ) + < b.residualValue * ordinalValue c.1 := by + classical + obtain ⟨ηb, hηb, hcutb⟩ := exists_ordinalValue_translatedTruncation_le b + obtain ⟨ηc, hηc, hcutc⟩ := exists_ordinalValue_translatedTruncation_le c + refine ⟨max ηb ηc, max_lt hηb hηc, fun γ hγlow hγ ↦ ?_⟩ + have hηbγ : ηb < γ := (le_max_left ηb ηc).trans_lt hγlow + have hηcγ : ηc < γ := (le_max_right ηb ηc).trans_lt hγlow + have hclosb : closure (b.1 : K⟦ℝ⟧).support ⊆ Set.Iic 0 := + closure_minimal (HahnSeries.Nonpositive.support_subset b.1) isClosed_Iic + have hclosc : closure (c.1 : K⟦ℝ⟧).support ⊆ Set.Iic 0 := + closure_minimal (HahnSeries.Nonpositive.support_subset c.1) isClosed_Iic + set X : NatOrdinal := b.residualValue * ordinalValue c.1 with hXdef + have hρb : (0 : NatOrdinal) < b.residualValue := + pos_iff_ne_zero.mpr b.residualValue_ne_zero + have hρc : (0 : NatOrdinal) < c.residualValue := + pos_iff_ne_zero.mpr c.residualValue_ne_zero + have hvc : (0 : NatOrdinal) < ordinalValue c.1 := lt_trans zero_lt_one c.2 + have hXpos : 0 < X := mul_pos hρb hvc + set f : ℝ → Germ K := + fun β ↦ germAt (b.1 : K⟦ℝ⟧) β * germAt (c.1 : K⟦ℝ⟧) (γ - β) with hfdef + set T := convolutionIndex (b.1 : K⟦ℝ⟧) (c.1 : K⟦ℝ⟧) γ with hTdef + have hfγ : f γ = germAt (b.1 : K⟦ℝ⟧) γ * toGerm c.1 := by + simp only [hfdef, sub_self, germAt_apply, translatedTruncation_zero] + have hf0 : f 0 = toGerm b.1 * germAt (c.1 : K⟦ℝ⟧) γ := by + simp only [hfdef, sub_zero, germAt_apply, translatedTruncation_zero] + have hfγzero : γ ∉ T → f γ = 0 := by + intro hmem + rw [hTdef, mem_convolutionIndex] at hmem + push Not at hmem + simp only [sub_self] at hmem + simp only [hfdef, sub_self] + by_cases hb : γ ∈ closure (b.1 : K⟦ℝ⟧).support + · rw [germAt_eq_zero_of_not_mem_closure_support (hmem hb), mul_zero] + · rw [germAt_eq_zero_of_not_mem_closure_support hb, zero_mul] + have hf0zero : (0 : ℝ) ∉ T → f 0 = 0 := by + intro hmem + rw [hTdef, mem_convolutionIndex] at hmem + push Not at hmem + simp only [sub_zero] at hmem + simp only [hfdef, sub_zero] + by_cases hb : (0 : ℝ) ∈ closure (b.1 : K⟦ℝ⟧).support + · rw [germAt_eq_zero_of_not_mem_closure_support (hmem hb), mul_zero] + · rw [germAt_eq_zero_of_not_mem_closure_support hb, zero_mul] + have hstep1 : ∑ β ∈ T, f β = f γ + ∑ β ∈ T.erase γ, f β := by + by_cases hmem : γ ∈ T + · exact (Finset.add_sum_erase T f hmem).symm + · rw [Finset.erase_eq_of_notMem hmem, hfγzero hmem, zero_add] + have hmem0 : (0 : ℝ) ∈ T.erase γ ↔ (0 : ℝ) ∈ T := by + rw [Finset.mem_erase] + exact ⟨fun h ↦ h.2, fun h ↦ ⟨(ne_of_lt hγ).symm, h⟩⟩ + have hstep2 : ∑ β ∈ T.erase γ, f β = f 0 + ∑ β ∈ (T.erase γ).erase 0, f β := by + by_cases hmem : (0 : ℝ) ∈ T.erase γ + · exact (Finset.add_sum_erase _ f hmem).symm + · rw [Finset.erase_eq_of_notMem hmem, hf0zero (fun h ↦ hmem (hmem0.mpr h)), zero_add] + have hcoe : ((b.1 * c.1 : Series K) : K⟦ℝ⟧) = (b.1 : K⟦ℝ⟧) * (c.1 : K⟦ℝ⟧) := rfl + have hrewrite : germAt ((b.1 * c.1 : Series K) : K⟦ℝ⟧) γ + - germAt (b.1 : K⟦ℝ⟧) γ * toGerm c.1 + - toGerm b.1 * germAt (c.1 : K⟦ℝ⟧) γ + = ∑ β ∈ (T.erase γ).erase 0, f β := by + rw [hcoe, germAt_mul, ← hTdef, ← hfdef, hstep1, hstep2, ← hfγ, ← hf0] + abel + rw [hrewrite] + refine germOrdinalValue_sum_lt hXpos fun β hβ ↦ ?_ + obtain ⟨hβ0, hβrest⟩ := Finset.mem_erase.mp hβ + obtain ⟨hβγ, hβT⟩ := Finset.mem_erase.mp hβrest + rw [hTdef, mem_convolutionIndex] at hβT + have hβle : β ≤ 0 := hclosb hβT.1 + have hβneg : β < 0 := lt_of_le_of_ne hβle hβ0 + have hγβle : γ - β ≤ 0 := hclosc hβT.2 + have hγβ : γ < β := by + rcases lt_or_eq_of_le (by linarith : γ ≤ β) with h | h + · exact h + · exact absurd h.symm hβγ + obtain ⟨α₁, hα₁, hα₁le⟩ := hcutb β (hηbγ.trans hγβ) hβneg + obtain ⟨α₂, hα₂, hα₂le⟩ := + hcutc (γ - β) (by linarith) (by linarith) + have hgerm : germOrdinalValue (f β) ≤ + ordinalValue (translatedTruncation (b.1 : K⟦ℝ⟧) β) * + ordinalValue (translatedTruncation (c.1 : K⟦ℝ⟧) (γ - β)) := by + simpa only [hfdef, germAt_apply, toGerm_apply, germOrdinalValue_mk] using + germOrdinalValue_mul_le_naturalMul (germAt (b.1 : K⟦ℝ⟧) β) + (germAt (c.1 : K⟦ℝ⟧) (γ - β)) + have hb₁ : ordinalValue (translatedTruncation (b.1 : K⟦ℝ⟧) β) ≤ + NatOrdinal.of (b.residualValue.val * α₁) := by + simpa using NatOrdinal.of.le_iff_le.mpr hα₁le + have hc₁ : ordinalValue (translatedTruncation (c.1 : K⟦ℝ⟧) (γ - β)) ≤ + NatOrdinal.of (c.residualValue.val * α₂) := by + simpa using NatOrdinal.of.le_iff_le.mpr hα₂le + have hfinal : NatOrdinal.of (b.residualValue.val * α₁) * + NatOrdinal.of (c.residualValue.val * α₂) < X := by + have hlt := NatOrdinal.naturalMul_mul_lt_of_lt + (ρ₁ := b.residualValue) (ρ₂ := c.residualValue) + (π₁ := b.principalValue) (π₂ := c.principalValue) + (α₁ := NatOrdinal.of α₁) (α₂ := NatOrdinal.of α₂) + c.principalValue_isMultiplicativelyPrincipal hp + (by simpa using NatOrdinal.of.lt_iff_lt.mpr hα₁) + (by simpa using NatOrdinal.of.lt_iff_lt.mpr hα₂) + (mul_pos hρb hρc) + simpa only [NatOrdinal.val_of, hXdef, mul_assoc, + c.residualValue_mul_principalValue] using hlt + exact ((hgerm.trans (mul_le_mul' hb₁ hc₁)).trans_lt hfinal) + +/-- The convolution-remainder estimate for the actual translated truncation series, with one +left neighbourhood working uniformly for every cutoff in it. -/ +theorem exists_ordinalValue_convolution_remainder_lt + (b c : SeriesWithOrdinalValueAboveOne K) + (hp : b.principalValue ≤ c.principalValue) : + ∃ η < (0 : ℝ), ∀ γ : ℝ, η < γ → γ < 0 → + ordinalValue + (translatedTruncation (((b.1 * c.1 : Series K) : K⟦ℝ⟧)) γ + - translatedTruncation (b.1 : K⟦ℝ⟧) γ * c.1 + - b.1 * translatedTruncation (c.1 : K⟦ℝ⟧) γ) < + b.residualValue * ordinalValue c.1 := by + obtain ⟨η, hη, hrem⟩ := exists_germOrdinalValue_convolution_remainder_lt b c hp + refine ⟨η, hη, fun γ hηγ hγ ↦ ?_⟩ + have hrem' := hrem γ hηγ hγ + simp only [germAt_apply, toGerm_apply] at hrem' + rw [← map_mul, ← map_mul, ← map_sub, ← map_sub, germOrdinalValue_mk] at hrem' + exact hrem' + + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/CriticalPoint.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/CriticalPoint.lean new file mode 100644 index 0000000000..a8bcf80f7c --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/CriticalPoint.lean @@ -0,0 +1,234 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Convolution +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValue + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.ConvolutionRemainder +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.MainLemma +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.ResidualPointWellOrdered +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Statements.ProductValue +import Mathlib.Topology.Instances.Real.Lemmas + +/-! +# Critical points of nonpositive real Hahn series + +For a nonzero series `b`, Berarducci defines its critical point as the least nonpositive exponent +where the ordinal value of a translated truncation is maximal. `IsCriticalPoint b x` states this +characterization directly; existence is the separate content of Berarducci, Lemma 10.1. + +The main result here is Berarducci, Lemma 10.4: at critical points `x` and `y`, the translated +truncation of `b * c` at `x + y` has value equal to the Hessenberg product of the two critical +values. The proof isolates the `(x, y)` term in the finite germ-convolution formula. Minimality +makes every other term strictly smaller, so it cannot cancel the distinguished term. + +## References + +* A. Berarducci, *Factorization in generalized power series*, Trans. Amer. Math. Soc. 352 + (2000), 553–577, cited as [Ber00]. +-/ + +universe v + +open scoped HahnSeries NatOrdinal + +public noncomputable section + +namespace Berarducci + +open HahnSeries + +variable {K : Type v} [Field K] + +/-- `x` is the critical point of `b` when `b` is nonzero, `x ≤ 0`, the value of the translated +truncation at `x` is maximal, and `x` is the least point attaining that value. -/ +def IsCriticalPoint (b : Series K) (x : ℝ) : Prop := + b ≠ 0 ∧ x ≤ 0 ∧ + (∀ y : ℝ, y ≤ 0 → + ordinalValue (translatedTruncation (b : K⟦ℝ⟧) y) ≤ + ordinalValue (translatedTruncation (b : K⟦ℝ⟧) x)) ∧ + ∀ y : ℝ, y ≤ 0 → + ordinalValue (translatedTruncation (b : K⟦ℝ⟧) y) = + ordinalValue (translatedTruncation (b : K⟦ℝ⟧) x) → x ≤ y + +/-- Characterization of the critical-point predicate. -/ +theorem isCriticalPoint_iff {b : Series K} {x : ℝ} : + IsCriticalPoint b x ↔ + b ≠ 0 ∧ x ≤ 0 ∧ + (∀ y : ℝ, y ≤ 0 → + ordinalValue (translatedTruncation (b : K⟦ℝ⟧) y) ≤ + ordinalValue (translatedTruncation (b : K⟦ℝ⟧) x)) ∧ + ∀ y : ℝ, y ≤ 0 → + ordinalValue (translatedTruncation (b : K⟦ℝ⟧) y) = + ordinalValue (translatedTruncation (b : K⟦ℝ⟧) x) → x ≤ y := + (Iff.rfl) + +/-- Eliminate the critical-point predicate through the module boundary. -/ +theorem IsCriticalPoint.elim {b : Series K} {x : ℝ} (hx : IsCriticalPoint b x) : + b ≠ 0 ∧ x ≤ 0 ∧ + (∀ y : ℝ, y ≤ 0 → + ordinalValue (translatedTruncation (b : K⟦ℝ⟧) y) ≤ + ordinalValue (translatedTruncation (b : K⟦ℝ⟧) x)) ∧ + ∀ y : ℝ, y ≤ 0 → + ordinalValue (translatedTruncation (b : K⟦ℝ⟧) y) = + ordinalValue (translatedTruncation (b : K⟦ℝ⟧) x) → x ≤ y := + hx + +/-- A series with a critical point is nonzero. -/ +theorem IsCriticalPoint.ne_zero {b : Series K} {x : ℝ} + (hx : IsCriticalPoint b x) : b ≠ 0 := + hx.elim.1 + +/-- A critical point is nonpositive. -/ +theorem IsCriticalPoint.nonpositive {b : Series K} {x : ℝ} + (hx : IsCriticalPoint b x) : x ≤ 0 := + hx.elim.2.1 + +/-- The translated-truncation value at a critical point is maximal. -/ +theorem IsCriticalPoint.value_le {b : Series K} {x : ℝ} + (hx : IsCriticalPoint b x) (y : ℝ) (hy : y ≤ 0) : + ordinalValue (translatedTruncation (b : K⟦ℝ⟧) y) ≤ + ordinalValue (translatedTruncation (b : K⟦ℝ⟧) x) := + hx.elim.2.2.1 y hy + +/-- A critical point is the least nonpositive point attaining the maximal value. -/ +theorem IsCriticalPoint.le_of_value_eq {b : Series K} {x : ℝ} + (hx : IsCriticalPoint b x) (y : ℝ) (hy : y ≤ 0) + (hvalue : ordinalValue (translatedTruncation (b : K⟦ℝ⟧) y) = + ordinalValue (translatedTruncation (b : K⟦ℝ⟧) x)) : x ≤ y := + hx.elim.2.2.2 y hy hvalue + +/-- Berarducci's ordinal value is multiplicative on the germ quotient once its multiplicativity +on series is known. -/ +theorem germOrdinalValue_mul [CharZero K] (q p : Germ K) : + germOrdinalValue (q * p) = germOrdinalValue q * germOrdinalValue p := by + obtain ⟨b, hb⟩ := Ideal.Quotient.mk_surjective q + obtain ⟨c, hc⟩ := Ideal.Quotient.mk_surjective p + have hb' : toGerm b = q := (toGerm_apply b).trans hb + have hc' : toGerm c = p := (toGerm_apply c).trans hc + rw [← hb', ← hc', ← map_mul] + simp only [toGerm_apply, germOrdinalValue_mk, ordinalValue_mul] + +/-- Adding a germ of strictly smaller value does not change the larger value. -/ +theorem germOrdinalValue_add_eq_left_of_lt {q p : Germ K} + (h : germOrdinalValue p < germOrdinalValue q) : + germOrdinalValue (q + p) = germOrdinalValue q := by + apply le_antisymm + · simpa [max_eq_left h.le] using germOrdinalValue_add_le_max q p + · have hle := germOrdinalValue_add_le_max (q + p) (-p) + rw [add_neg_cancel_right, germOrdinalValue_neg] at hle + by_contra hnot + exact (not_lt_of_ge hle) (max_lt (lt_of_not_ge hnot) h) + +/-- At an exponent in the support, the translated truncation has positive ordinal value. -/ +theorem ordinalValue_translatedTruncation_pos_of_mem_support + {b : K⟦ℝ⟧} {x : ℝ} (hx : x ∈ b.support) : + 0 < ordinalValue (translatedTruncation b x) := by + rw [pos_iff_ne_zero] + intro hzero + have hmem := ordinalValue_eq_zero_iff.mp hzero + have hcoeff := constantCoeff_eq_zero_of_mem_negativeMonomialIdeal hmem + rw [HahnSeries.Nonpositive.constantCoeff_apply, coeff_translatedTruncation] at hcoeff + simp only [le_refl, ite_true, add_zero] at hcoeff + exact (HahnSeries.mem_support _ _).mp hx hcoeff + +/-- The maximal translated-truncation value at a critical point is positive. -/ +theorem IsCriticalPoint.value_pos {b : Series K} {x : ℝ} + (hx : IsCriticalPoint b x) : + 0 < ordinalValue (translatedTruncation (b : K⟦ℝ⟧) x) := by + have hsupport : (b : K⟦ℝ⟧).support.Nonempty := + HahnSeries.support_nonempty_iff.mpr (by simpa using hx.ne_zero) + obtain ⟨y, hy⟩ := hsupport + have hy0 := HahnSeries.Nonpositive.support_subset b hy + exact (ordinalValue_translatedTruncation_pos_of_mem_support hy).trans_le + (hx.value_le y hy0) + +/-- A critical point lies in the closure of the series support. -/ +theorem IsCriticalPoint.mem_closure_support {b : Series K} {x : ℝ} + (hx : IsCriticalPoint b x) : x ∈ closure (b : K⟦ℝ⟧).support := by + by_contra hmem + have hJ := translatedTruncation_mem_negativeMonomialIdeal_of_not_mem_closure_support hmem + rw [← ordinalValue_eq_zero_iff] at hJ + exact hx.value_pos.ne' hJ + +/-- Berarducci, Lemma 10.4: the value of a product truncated at the sum of the factors' critical +points is the Hessenberg product of their critical values. -/ +theorem criticalPoint_product_value [CharZero K] + {b c : Series K} {x y : ℝ} + (hx : IsCriticalPoint b x) (hy : IsCriticalPoint c y) : + ordinalValue (translatedTruncation (((b * c : Series K) : K⟦ℝ⟧)) (x + y)) = + ordinalValue (translatedTruncation (b : K⟦ℝ⟧) x) * + ordinalValue (translatedTruncation (c : K⟦ℝ⟧) y) := by + classical + let gamma := x + y + let s := convolutionIndex (b : K⟦ℝ⟧) (c : K⟦ℝ⟧) gamma + let f : ℝ → Germ K := fun beta ↦ + germAt (b : K⟦ℝ⟧) beta * germAt (c : K⟦ℝ⟧) (gamma - beta) + let X := ordinalValue (translatedTruncation (b : K⟦ℝ⟧) x) * + ordinalValue (translatedTruncation (c : K⟦ℝ⟧) y) + have hxs : x ∈ s := by + rw [mem_convolutionIndex] + refine ⟨hx.mem_closure_support, ?_⟩ + simpa [gamma] using hy.mem_closure_support + have hXpos : 0 < X := mul_pos hx.value_pos hy.value_pos + have hfx : germOrdinalValue (f x) = X := by + dsimp only [f] + rw [germOrdinalValue_mul] + simp only [germAt_apply, toGerm_apply, germOrdinalValue_mk] + congr 1 + simp [gamma] + have hterm : ∀ beta ∈ s.erase x, germOrdinalValue (f beta) < X := by + intro beta hbeta + have hbetaS := (Finset.mem_erase.mp hbeta).2 + have hbetaNe := (Finset.mem_erase.mp hbeta).1 + obtain ⟨hbetaClosure, hdeltaClosure⟩ := mem_convolutionIndex.mp hbetaS + have hclosureB : closure (b : K⟦ℝ⟧).support ⊆ Set.Iic 0 := + closure_minimal (HahnSeries.Nonpositive.support_subset b) isClosed_Iic + have hclosureC : closure (c : K⟦ℝ⟧).support ⊆ Set.Iic 0 := + closure_minimal (HahnSeries.Nonpositive.support_subset c) isClosed_Iic + have hbeta0 : beta ≤ 0 := hclosureB hbetaClosure + have hdelta0 : gamma - beta ≤ 0 := hclosureC hdeltaClosure + have hbLe := hx.value_le beta hbeta0 + have hcLe := hy.value_le (gamma - beta) hdelta0 + dsimp only [f] + rw [germOrdinalValue_mul] + simp only [germAt_apply, toGerm_apply, germOrdinalValue_mk] + change ordinalValue (translatedTruncation (b : K⟦ℝ⟧) beta) * + ordinalValue (translatedTruncation (c : K⟦ℝ⟧) (gamma - beta)) < X + dsimp only [X] + rcases hbLe.eq_or_lt with hbEq | hbLt + · have hxbeta : x ≤ beta := hx.le_of_value_eq beta hbeta0 hbEq + have hdeltaLt : gamma - beta < y := by + dsimp [gamma] + rcases hxbeta.eq_or_lt with h | h + · exact (hbetaNe h.symm).elim + · linarith + have hcLt : ordinalValue (translatedTruncation (c : K⟦ℝ⟧) (gamma - beta)) < + ordinalValue (translatedTruncation (c : K⟦ℝ⟧) y) := by + exact lt_of_le_of_ne hcLe fun heq ↦ + (not_le_of_gt hdeltaLt) (hy.le_of_value_eq (gamma - beta) hdelta0 heq) + rw [hbEq] + exact mul_lt_mul_of_pos_left hcLt hx.value_pos + · exact (mul_le_mul_right hcLe _).trans_lt + (mul_lt_mul_of_pos_right hbLt hy.value_pos) + have hrest : germOrdinalValue (∑ beta ∈ s.erase x, f beta) < X := + germOrdinalValue_sum_lt hXpos hterm + have hsum : germOrdinalValue (∑ beta ∈ s, f beta) = X := by + rw [← s.add_sum_erase f hxs] + rw [germOrdinalValue_add_eq_left_of_lt] + · exact hfx + · rwa [hfx] + have hconv := germAt_mul (b : K⟦ℝ⟧) (c : K⟦ℝ⟧) gamma + change ordinalValue (translatedTruncation (((b * c : Series K) : K⟦ℝ⟧)) gamma) = X + calc + _ = germOrdinalValue (germAt (((b * c : Series K) : K⟦ℝ⟧)) gamma) := by + rw [germAt_apply, toGerm_apply, germOrdinalValue_mk] + _ = germOrdinalValue + (germAt ((b : K⟦ℝ⟧) * (c : K⟦ℝ⟧)) gamma) := by rfl + _ = X := by rw [hconv]; exact hsum + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/CriticalPointExistence.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/CriticalPointExistence.lean new file mode 100644 index 0000000000..ab6c1b8089 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/CriticalPointExistence.lean @@ -0,0 +1,250 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.CriticalPoint + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.NormalForm +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.PrincipalAddition +import LeanPool.ConwayRefinement.ConwayRefinement.Topology.Order.PWOSumset +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.GermDegree +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.MainLemma +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalComponentDegree +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.ResidualPointWellOrdered +import Mathlib.Tactic.Linarith + +/-! +# Existence of Berarducci critical points + +Berarducci, Lemma 10.1 proves that the ordinal values of all translated truncations of a nonzero +nonpositive real Hahn series have a maximum. Definition 10.2 chooses the least nonpositive cutoff +where that maximum occurs. + +The proof realizes the maximum through the LM24 normal form. Its principal head has the same +degree as the full series. Truncating at the head exponent recovers that principal coefficient up +to a constant, so its ordinal-value degree reaches the upper bound for every translated truncation. +The maximizers lie in the closed support, which is partially well ordered, and therefore have a +least element. + +## References + +* A. Berarducci, *Factorization in generalized power series*, Trans. Amer. Math. Soc. 352 + (2000), 553–577, cited as [Ber00]. +-/ + +universe v + +open scoped HahnSeries NatOrdinal + +public noncomputable section + +namespace Berarducci + +open HahnSeries + +variable {K : Type v} [Field K] + +private theorem translatedTruncation_translate_self + (p : Series K) (x : ℝ) : + translatedTruncation (HahnSeries.translate x (p : K⟦ℝ⟧)) x = p := by + apply Subtype.ext + rw [coe_translatedTruncation, HahnSeries.truncLE_translate] + simp only [sub_self] + rw [HahnSeries.truncLE_eq_self_of_support_subset_Iic + (HahnSeries.Nonpositive.support_subset p), HahnSeries.translate_add_apply] + simp + +private theorem translatedTruncation_eq_C_of_support_subset_Ici + (b : Series K) (x : ℝ) + (hb : (b : K⟦ℝ⟧).support ⊆ Set.Ici x) : + translatedTruncation (b : K⟦ℝ⟧) x = + HahnSeries.Nonpositive.C ((b : K⟦ℝ⟧).coeff x) := by + apply Subtype.ext + ext δ + rw [coeff_translatedTruncation, HahnSeries.Nonpositive.coe_C] + rcases lt_trichotomy δ 0 with hδ | rfl | hδ + · rw [ite_eq_left hδ.le, HahnSeries.C_apply, + HahnSeries.coeff_single_of_ne hδ.ne] + apply not_ne_iff.mp + rw [← HahnSeries.mem_support] + intro hmem + exact (not_le_of_gt (by linarith : x + δ < x)) (hb hmem) + · simp + · rw [ite_eq_right (not_le_of_gt hδ), HahnSeries.C_apply, + HahnSeries.coeff_single_of_ne hδ.ne'] + +private theorem principalHeadExponent_nonpositive + {b p r : Series K} {x : ℝ} + (hb : (b : K⟦ℝ⟧) = + HahnSeries.translate x (p : K⟦ℝ⟧) + (r : K⟦ℝ⟧)) + (hp : HahnSeries.Nonpositive.IsPrincipal p) : x ≤ 0 := by + by_contra hx + have hxpos : 0 < x := lt_of_not_ge hx + have hheadNe : HahnSeries.translate x (p : K⟦ℝ⟧) ≠ 0 := + fun hzero ↦ hp.ne_zero (Subtype.ext + ((HahnSeries.translate x).injective (by simpa using hzero))) + have hpSup : sSup (p : K⟦ℝ⟧).support = 0 := by + have hsup := hp.supportSup_eq_zero + rw [HahnSeries.Nonpositive.supportSup_of_ne hp.ne_zero] at hsup + exact WithBot.coe_eq_coe.mp hsup + have hheadBdd : BddAbove + (HahnSeries.translate x (p : K⟦ℝ⟧)).support := by + refine ⟨x, ?_⟩ + rw [HahnSeries.support_translate] + rintro _ ⟨y, hy, rfl⟩ + have hy0 := HahnSeries.Nonpositive.support_subset p hy + change y ≤ 0 at hy0 + change x + y ≤ x + linarith + have hheadSup : sSup + (HahnSeries.translate x (p : K⟦ℝ⟧)).support = x := by + rw [HahnSeries.csSup_support_translate (by simpa using hp.ne_zero) + (HahnSeries.Nonpositive.bddAbove_support p), hpSup] + simp + have hheadLUB : IsLUB + (HahnSeries.translate x (p : K⟦ℝ⟧)).support x := by + simpa only [hheadSup] using + (isLUB_csSup (HahnSeries.support_nonempty_iff.mpr hheadNe) hheadBdd) + obtain ⟨y, hy, hypos, -⟩ := hheadLUB.exists_between hxpos + have hrCoeff : (r : K⟦ℝ⟧).coeff y = 0 := by + apply not_ne_iff.mp + rw [← HahnSeries.mem_support] + exact fun hmem ↦ (not_le_of_gt hypos) + (HahnSeries.Nonpositive.support_subset r hmem) + have hbCoeff := congrArg (fun q : K⟦ℝ⟧ ↦ q.coeff y) hb + simp only [HahnSeries.coeff_add, hrCoeff, add_zero] at hbCoeff + have hyb : y ∈ (b : K⟦ℝ⟧).support := by + rw [HahnSeries.mem_support, hbCoeff] + exact (HahnSeries.mem_support _ _).mp hy + exact (not_le_of_gt hypos) (HahnSeries.Nonpositive.support_subset b hyb) + +private theorem ordinalValue_add_eq_left_of_lt + {b c : Series K} (h : ordinalValue c < ordinalValue b) : + ordinalValue (b + c) = ordinalValue b := by + apply le_antisymm + · simpa [max_eq_left h.le] using ordinalValue_add_le_max b c + · have hle := ordinalValue_add_le_max (b + c) (-c) + rw [add_neg_cancel_right, ordinalValue_neg] at hle + by_contra hnot + exact (not_lt_of_ge hle) (max_lt (lt_of_not_ge hnot) h) + +private theorem ordinalValue_le_of_ordinalValueDegree_le + {b c : Series K} (h : ordinalValueDegree b ≤ ordinalValueDegree c) : + ordinalValue b ≤ ordinalValue c := by + by_cases hb : ordinalValue b = 0 + · simp [hb] + have hc : ordinalValue c ≠ 0 := by + intro hc + have hcDegree : ordinalValueDegree c = ⊥ := + ordinalValueDegree_eq_bot_iff.mpr (ordinalValue_eq_zero_iff.mp hc) + have hbDegree : ordinalValueDegree b ≠ ⊥ := fun hbot ↦ + hb (ordinalValue_eq_zero_iff.mpr (ordinalValueDegree_eq_bot_iff.mp hbot)) + exact hbDegree (bot_unique (h.trans_eq hcDegree)) + have hbDegreeNe : ordinalValueDegree b ≠ ⊥ := fun hbot ↦ + hb (ordinalValue_eq_zero_iff.mpr (ordinalValueDegree_eq_bot_iff.mp hbot)) + have hcDegreeNe : ordinalValueDegree c ≠ ⊥ := fun hbot ↦ + hc (ordinalValue_eq_zero_iff.mpr (ordinalValueDegree_eq_bot_iff.mp hbot)) + let a := (ordinalValueDegree b).unbot hbDegreeNe + let d := (ordinalValueDegree c).unbot hcDegreeNe + have haDegree : ordinalValueDegree b = (a : WithBot NatOrdinal) := + (WithBot.coe_unbot _ hbDegreeNe).symm + have hdDegree : ordinalValueDegree c = (d : WithBot NatOrdinal) := + (WithBot.coe_unbot _ hcDegreeNe).symm + have haValue : ordinalValue b = ω^ a := + (ordinalValueDegree_eq_coe_iff b a).mp haDegree + have hdValue : ordinalValue c = ω^ d := + (ordinalValueDegree_eq_coe_iff c d).mp hdDegree + rw [haValue, hdValue] + apply NatOrdinal.wpow_le_wpow.mpr + rw [← WithBot.coe_le_coe] + exact haDegree.symm.trans_le (h.trans_eq hdDegree) + +private theorem exists_maximal_translatedTruncation + {b : Series K} (hb : b ≠ 0) : + ∃ x : ℝ, x ≤ 0 ∧ + ∀ y : ℝ, y ≤ 0 → + ordinalValue (translatedTruncation (b : K⟦ℝ⟧) y) ≤ + ordinalValue (translatedTruncation (b : K⟦ℝ⟧) x) := by + obtain ⟨p, x, r, hp, hbpr, hrSupport, hpDegree, -, hrStrict⟩ := + HahnSeries.exists_principal_head_decomposition hb + have hx : x ≤ 0 := principalHeadExponent_nonpositive hbpr hp + let k := (r : K⟦ℝ⟧).coeff x + have hgerm : translatedTruncation (b : K⟦ℝ⟧) x = + p + HahnSeries.Nonpositive.C k := by + rw [← translatedTruncation_translate_self p x, + ← translatedTruncation_eq_C_of_support_subset_Ici r x hrSupport, + ← translatedTruncation_add, hbpr] + have hpDegreeNe : (p : K⟦ℝ⟧).degree ≠ ⊥ := by + intro hbot + exact hp.ne_zero (Subtype.ext (HahnSeries.degree_eq_bot.mp hbot)) + let a := (p : K⟦ℝ⟧).degree.unbot hpDegreeNe + have hpDegree' : (p : K⟦ℝ⟧).degree = + (a : WithBot NatOrdinal) := (WithBot.coe_unbot _ hpDegreeNe).symm + have hpValue : ordinalValue p = ω^ a := + ordinalValue_eq_wpow_of_isPrincipal hp hpDegree' + have hgermValue : ordinalValue (translatedTruncation (b : K⟦ℝ⟧) x) = ω^ a := by + rcases eq_or_ne a 0 with ha | ha + · have hpDegreeZero : (p : K⟦ℝ⟧).degree = 0 := by simpa [ha] using hpDegree' + have hrStrict' := hrStrict (hpDegree.symm.trans hpDegreeZero) + have hk : k = 0 := by + apply not_ne_iff.mp + rw [← HahnSeries.mem_support] + exact fun hmem ↦ (lt_irrefl x) (hrStrict' hmem) + simpa [ha, hgerm, hk] using hpValue + · have haPos : 0 < a := bot_lt_iff_ne_bot.mpr ha + have hconstant : ordinalValue (HahnSeries.Nonpositive.C k : Series K) ≤ 1 := by + by_cases hk : k = 0 + · simp [hk] + · rw [ordinalValue_C_of_ne hk] + rw [hgerm, ordinalValue_add_eq_left_of_lt] + · exact hpValue + · rw [hpValue] + exact hconstant.trans_lt (by + simpa using NatOrdinal.wpow_lt_wpow.mpr haPos) + refine ⟨x, hx, fun y _ ↦ ordinalValue_le_of_ordinalValueDegree_le ?_⟩ + calc + ordinalValueDegree (translatedTruncation (b : K⟦ℝ⟧) y) ≤ + (b : K⟦ℝ⟧).degree := + ordinalValueDegree_translatedTruncation_le_degree (b : K⟦ℝ⟧) y + _ = (p : K⟦ℝ⟧).degree := hpDegree.symm + _ = ordinalValueDegree (translatedTruncation (b : K⟦ℝ⟧) x) := + hpDegree'.trans + ((ordinalValueDegree_eq_coe_iff _ a).mpr hgermValue).symm + +/-- Berarducci, Lemma 10.1 and Definition 10.2: every nonzero nonpositive real Hahn series has +a critical point. -/ +theorem exists_isCriticalPoint {b : Series K} (hb : b ≠ 0) : + ∃ x : ℝ, IsCriticalPoint b x := by + obtain ⟨x, hx0, hxMax⟩ := exists_maximal_translatedTruncation hb + let M : Set ℝ := {y | y ≤ 0 ∧ + ordinalValue (translatedTruncation (b : K⟦ℝ⟧) y) = + ordinalValue (translatedTruncation (b : K⟦ℝ⟧) x)} + have hxM : x ∈ M := ⟨hx0, rfl⟩ + have hxValue : ordinalValue (translatedTruncation (b : K⟦ℝ⟧) x) ≠ 0 := by + have hsupport : (b : K⟦ℝ⟧).support.Nonempty := + HahnSeries.support_nonempty_iff.mpr (by simpa using hb) + obtain ⟨y, hy⟩ := hsupport + exact ne_of_gt ((ordinalValue_translatedTruncation_pos_of_mem_support hy).trans_le + (hxMax y (HahnSeries.Nonpositive.support_subset b hy))) + have hMsub : M ⊆ closure (b : K⟦ℝ⟧).support := by + intro y hy + by_contra hclosure + have hyJ := translatedTruncation_mem_negativeMonomialIdeal_of_not_mem_closure_support hclosure + have hyZero := ordinalValue_of_mem_negativeMonomialIdeal hyJ + exact hxValue (hy.2.symm.trans hyZero) + let hMPWO : M.IsPWO := + (Set.isPWO_closure (b : K⟦ℝ⟧).isPWO_support).mono hMsub + obtain ⟨z, hzMinimal⟩ := hMPWO.exists_minimal ⟨x, hxM⟩ + have hzM : z ∈ M := hzMinimal.1 + refine ⟨z, isCriticalPoint_iff.mpr ⟨hb, hzM.1, ?_, ?_⟩⟩ + · intro y hy + exact (hxMax y hy).trans_eq hzM.2.symm + · intro y hy hvalue + have hyM : y ∈ M := ⟨hy, hvalue.trans hzM.2⟩ + exact le_of_not_gt fun hyz ↦ + (minimal_iff_forall_lt.mp hzMinimal).2 hyz hyM + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/FormalExpression.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/FormalExpression.lean new file mode 100644 index 0000000000..b7df093b33 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/FormalExpression.lean @@ -0,0 +1,237 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalValue +public import Mathlib.SetTheory.Cardinal.Order + +import Mathlib.Data.Multiset.DershowitzManna + +/-! +# Formal expressions and their complexity + +Berarducci, Definitions 9.1 and 9.3. A formal expression is a finite multiset of series of ordinal +value above one; its evaluation is the product of its factors. The selected factor has minimal +principal value, maximal ordinal value among those, and is least for a fixed well order; that rule +determines it uniquely. The relevant factors are those whose ordinal value is at least the selected +factor's, and the complexity records their values together with the multiplicity of the selected +factor. + +The source writes the complexity as the ordinal `ω * [α₀, …, α_m] + k`, where +`[α₀, …, α_m] = ω ^ α₀ ⊕ ⋯ ⊕ ω ^ α_m` is chosen so that it decreases when any +`αᵢ` is replaced by finitely many strictly smaller ordinals. That last property is exactly +Mathlib's Dershowitz–Manna relation on multisets, so the complexity is kept as a pair consisting +of a multiset and a natural number, ordered lexicographically. It carries the same information +and inherits well-foundedness from Mathlib, with no ordinal to construct. +-/ + +universe v + +public noncomputable section + +open HahnSeries Ordinal + +namespace Berarducci + +variable {K : Type v} [Field K] + +/-- Berarducci, Definition 9.1: a formal expression is a finite multiset of series of ordinal +value above one. -/ +abbrev FormalExpression (K : Type v) [Field K] := Multiset (SeriesWithOrdinalValueAboveOne K) + +namespace FormalExpression + +/-- The product of the factors of a formal expression. -/ +def eval (w : FormalExpression K) : Series K := (w.map (·.1)).prod + +theorem eval_eq (w : FormalExpression K) : eval w = (w.map (·.1)).prod := (rfl) + +theorem eval_zero : (0 : FormalExpression K).eval = 1 := (rfl) + +theorem eval_cons (x : SeriesWithOrdinalValueAboveOne K) (w : FormalExpression K) : + eval (x ::ₘ w) = x.1 * eval w := by + rw [eval, eval, Multiset.map_cons, Multiset.prod_cons] + +/-- Berarducci, Definition 9.3: `x` is the selected factor of `w`. Among the factors of minimal +principal value it has maximal ordinal value, and ties are broken by a fixed well order. -/ +structure IsSelected (w : FormalExpression K) (x : SeriesWithOrdinalValueAboveOne K) : Prop where + mem : x ∈ w + min_principalValue : ∀ y ∈ w, x.principalValue ≤ y.principalValue + max_ordinalValue : ∀ y ∈ w, y.principalValue = x.principalValue → + ordinalValue y.1 ≤ ordinalValue x.1 + least : ∀ y ∈ w, y.principalValue = x.principalValue → ordinalValue y.1 = ordinalValue x.1 → + ¬ WellOrderingRel y x + +theorem existsUnique_isSelected {w : FormalExpression K} (hw : w ≠ 0) : + ∃! x, IsSelected w x := by + classical + have hne : w.toFinset.Nonempty := by + rw [Finset.nonempty_iff_ne_empty] + intro h + exact hw (Multiset.toFinset_eq_empty.mp h) + obtain ⟨x₀, hx₀, hx₀min⟩ := + w.toFinset.exists_min_image (fun y ↦ y.principalValue) hne + set A := w.toFinset.filter fun y ↦ y.principalValue = x₀.principalValue with hAdef + have hAne : A.Nonempty := ⟨x₀, by simp [hAdef, hx₀]⟩ + obtain ⟨x₁, hx₁, hx₁max⟩ := A.exists_max_image (fun y ↦ ordinalValue y.1) hAne + set B := A.filter fun y ↦ ordinalValue y.1 = ordinalValue x₁.1 with hBdef + have hBne : (↑B : Set (SeriesWithOrdinalValueAboveOne K)).Nonempty := + ⟨x₁, by simp [hBdef, hx₁]⟩ + have hwf : WellFounded (WellOrderingRel (α := SeriesWithOrdinalValueAboveOne K)) := + (WellOrderingRel.isWellOrder (α := SeriesWithOrdinalValueAboveOne K)).wf + set x := hwf.min _ hBne with hxdef + have hxB : x ∈ B := hwf.min_mem _ hBne + have hxA : x ∈ A := (Finset.mem_filter.mp hxB).1 + have hxw : x ∈ w := Multiset.mem_toFinset.mp (Finset.mem_filter.mp hxA).1 + have hxprin : x.principalValue = x₀.principalValue := (Finset.mem_filter.mp hxA).2 + have hxord : ordinalValue x.1 = ordinalValue x₁.1 := (Finset.mem_filter.mp hxB).2 + refine ⟨x, ⟨hxw, ?_, ?_, ?_⟩, ?_⟩ + · intro y hy + rw [hxprin] + exact hx₀min y (Multiset.mem_toFinset.mpr hy) + · intro y hy hyprin + rw [hxord] + refine hx₁max y ?_ + simp only [hAdef, Finset.mem_filter, Multiset.mem_toFinset] + exact ⟨hy, hyprin.trans hxprin⟩ + · intro y hy hyprin hyord + have hyB : y ∈ (↑B : Set (SeriesWithOrdinalValueAboveOne K)) := by + simp only [hBdef, hAdef, Finset.mem_coe, Finset.mem_filter, Multiset.mem_toFinset] + exact ⟨⟨hy, hyprin.trans hxprin⟩, hyord.trans hxord⟩ + exact hwf.not_lt_min _ hyB + · rintro y hy + have hsel : IsSelected w x := by + refine ⟨hxw, ?_, ?_, ?_⟩ + · intro z hz + rw [hxprin] + exact hx₀min z (Multiset.mem_toFinset.mpr hz) + · intro z hz hzprin + rw [hxord] + refine hx₁max z ?_ + simp only [hAdef, Finset.mem_filter, Multiset.mem_toFinset] + exact ⟨hz, hzprin.trans hxprin⟩ + · intro z hz hzprin hzord + have hzB : z ∈ (↑B : Set (SeriesWithOrdinalValueAboveOne K)) := by + simp only [hBdef, hAdef, Finset.mem_coe, Finset.mem_filter, Multiset.mem_toFinset] + exact ⟨⟨hz, hzprin.trans hxprin⟩, hzord.trans hxord⟩ + exact hwf.not_lt_min _ hzB + have hprin : y.principalValue = x.principalValue := + le_antisymm (hy.min_principalValue x hxw) (hsel.min_principalValue y hy.mem) + have hord : ordinalValue y.1 = ordinalValue x.1 := + le_antisymm (hsel.max_ordinalValue y hy.mem hprin) (hy.max_ordinalValue x hxw hprin.symm) + rcases trichotomous_of + (WellOrderingRel : SeriesWithOrdinalValueAboveOne K → _ → Prop) y x with h | h | h + · exact absurd h (hsel.least y hy.mem hprin hord) + · exact h + · exact absurd h (hy.least x hxw hprin.symm hord.symm) + +/-- The selected factor of a nonempty formal expression. -/ +noncomputable def selected (w : FormalExpression K) (hw : w ≠ 0) : + SeriesWithOrdinalValueAboveOne K := + (existsUnique_isSelected hw).choose + +theorem isSelected_selected (w : FormalExpression K) (hw : w ≠ 0) : + IsSelected w (selected w hw) := + (existsUnique_isSelected hw).choose_spec.1 + +theorem eq_selected_of_isSelected {w : FormalExpression K} (hw : w ≠ 0) + {x : SeriesWithOrdinalValueAboveOne K} (hx : IsSelected w x) : x = selected w hw := + (existsUnique_isSelected hw).choose_spec.2 x hx + +/-- A one-factor expression selects that factor. -/ +theorem selected_singleton (x : SeriesWithOrdinalValueAboveOne K) : + selected {x} (by simp) = x := by + refine (eq_selected_of_isSelected (by simp) ⟨by simp, ?_, ?_, ?_⟩).symm + · intro y hy + rw [Multiset.mem_singleton.mp hy] + · intro y hy _ + rw [Multiset.mem_singleton.mp hy] + · intro y hy _ _ + rw [Multiset.mem_singleton.mp hy] + exact irrefl_of (WellOrderingRel : SeriesWithOrdinalValueAboveOne K → _ → Prop) x + +open Classical in +/-- Berarducci, Definition 9.3: the selected exponent is the multiplicity of the selected +factor. -/ +noncomputable def selectedExponent (w : FormalExpression K) (hw : w ≠ 0) : ℕ := + w.count (selected w hw) + +/-- Adjoining another copy of a factor already present does not change the selected factor. -/ +theorem selected_cons_of_mem {w : FormalExpression K} (hw : w ≠ 0) + {y : SeriesWithOrdinalValueAboveOne K} (hy : y ∈ w) : + selected (y ::ₘ w) Multiset.cons_ne_zero = selected w hw := by + have hmem : ∀ z ∈ y ::ₘ w, z ∈ w := + fun z hz ↦ (Multiset.mem_cons.mp hz).elim (fun h ↦ h ▸ hy) id + have hsel := isSelected_selected w hw + refine (eq_selected_of_isSelected Multiset.cons_ne_zero ⟨Multiset.mem_cons_of_mem hsel.mem, + fun z hz ↦ hsel.min_principalValue z (hmem z hz), + fun z hz ↦ hsel.max_ordinalValue z (hmem z hz), + fun z hz ↦ hsel.least z (hmem z hz)⟩).symm + +open Classical in +theorem selectedExponent_eq_count (w : FormalExpression K) (hw : w ≠ 0) : + selectedExponent w hw = w.count (selected w hw) := (rfl) + +open Classical in +/-- Berarducci, Definition 9.3: the ordinal values of the relevant factors, namely those whose +ordinal value is at least that of the selected factor. The source indexes these by the distinct +factors, so multiplicities are discarded. -/ +noncomputable def relevantValues (w : FormalExpression K) (hw : w ≠ 0) : Multiset Ordinal := + (w.toFinset.filter fun y ↦ ordinalValue (selected w hw).1 ≤ ordinalValue y.1).val.map + fun y ↦ (ordinalValue y.1).val + +open Classical in +theorem relevantValues_eq_map (w : FormalExpression K) (hw : w ≠ 0) : + relevantValues w hw = (w.toFinset.filter fun y ↦ + ordinalValue (selected w hw).1 ≤ ordinalValue y.1).val.map fun y ↦ (ordinalValue y.1).val := + (rfl) + +open Classical in +/-- The relevant values see only the selected factor and which factors of value at least its own +are present, so duplicating or deleting other factors does not change them. -/ +theorem relevantValues_congr {w w' : FormalExpression K} (hw : w ≠ 0) (hw' : w' ≠ 0) + (hsel : selected w hw = selected w' hw') + (hmem : ∀ y, ordinalValue (selected w hw).1 ≤ ordinalValue y.1 → (y ∈ w ↔ y ∈ w')) : + relevantValues w hw = relevantValues w' hw' := by + have hfilter : (w.toFinset.filter fun y ↦ ordinalValue (selected w hw).1 ≤ ordinalValue y.1) + = w'.toFinset.filter fun y ↦ ordinalValue (selected w hw).1 ≤ ordinalValue y.1 := by + ext y + simp only [Finset.mem_filter, Multiset.mem_toFinset] + exact and_congr_left fun h ↦ hmem y h + rw [relevantValues, relevantValues, ← hsel, hfilter] + +/-- Berarducci, Definition 9.3: the complexity of a formal expression, as the pair of the multiset +of relevant-factor values and the selected exponent. -/ +noncomputable def complexity (w : FormalExpression K) (hw : w ≠ 0) : Multiset Ordinal × ℕ := + (relevantValues w hw, selectedExponent w hw) + +/-- The complexity order: the Dershowitz–Manna order on the relevant values, refined by the +selected exponent. This is the order of Berarducci, Definition 9.2. -/ +def ComplexityLT : (Multiset Ordinal × ℕ) → (Multiset Ordinal × ℕ) → Prop := + Prod.Lex Multiset.IsDershowitzMannaLT (· < ·) + +theorem wellFounded_complexityLT : WellFounded (ComplexityLT) := + WellFounded.prod_lex Multiset.wellFounded_isDershowitzMannaLT wellFounded_lt + +/-- A Dershowitz–Manna step on the relevant values, presented by its witnesses: the values of `w'` +are those of `w` with the nonempty part `Z` replaced by members of `Y`, each below some member of +`Z`. -/ +theorem complexityLT_of_relevantValues {w w' : FormalExpression K} {hw : w ≠ 0} {hw' : w' ≠ 0} + {X Y Z : Multiset Ordinal} (hZ : Z ≠ 0) (hw'X : relevantValues w' hw' = X + Y) + (hwX : relevantValues w hw = X + Z) (hYZ : ∀ y ∈ Y, ∃ z ∈ Z, y < z) : + ComplexityLT (complexity w' hw') (complexity w hw) := + Prod.Lex.left _ _ ⟨X, Y, Z, hZ, hw'X, hwX, hYZ⟩ + +theorem complexityLT_of_selectedExponent {w w' : FormalExpression K} {hw : w ≠ 0} {hw' : w' ≠ 0} + (h₁ : relevantValues w' hw' = relevantValues w hw) + (h₂ : selectedExponent w' hw' < selectedExponent w hw) : + ComplexityLT (complexity w' hw') (complexity w hw) := by + rw [complexity, complexity, h₁] + exact Prod.Lex.right _ h₂ + +end FormalExpression + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Germ.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Germ.lean new file mode 100644 index 0000000000..79d71f7d2d --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Germ.lean @@ -0,0 +1,226 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.NegativeMonomialIdeal +public import Mathlib.RingTheory.Ideal.Quotient.Defs + +import Mathlib.Algebra.Group.Subgroup.Lattice + +/-! +# Berarducci germs of nonpositive real Hahn series + +For a field `K`, `Berarducci.Series K` is the ring `K((ℝ⁽≤0⁾))`, and +`Berarducci.Germ K` is its quotient by the ideal `J` generated by the monomials `t^x` for +`x < 0`. This is Berarducci, Definition 5.1. The additive subgroup +`Berarducci.nearConstantSubgroup K` is the subgroup denoted by `J + K` in Berarducci, +Definition 5.2 and LM24, Section 2.7. It is deliberately an `AddSubgroup`, not an ideal. + +The quotient equality certificate proves that two series determine the same germ exactly when +their coefficients agree on an interval `(η, 0]`. The endpoint zero is included: a discrepancy at +zero is a nonzero constant and therefore does not belong to `J`. + +These quotient and subgroup definitions make sense over any field. Results imported from +Berarducci that use characteristic zero will retain that hypothesis in their theorem signatures. +-/ + +universe v + +public noncomputable section + +namespace Berarducci + +open HahnSeries + +variable {K : Type v} [Field K] + +/-- Every element of the negative-monomial ideal has zero constant coefficient. -/ +theorem constantCoeff_eq_zero_of_mem_negativeMonomialIdeal + {b : HahnSeries.Nonpositive ℝ K} + (hb : b ∈ HahnSeries.Nonpositive.negativeMonomialIdeal K) : + HahnSeries.Nonpositive.constantCoeff b = 0 := by + have hsup := + HahnSeries.Nonpositive.mem_negativeMonomialIdeal_iff_supportSup_lt_zero.mp hb + by_contra hcoeff + have hbZero : b ≠ 0 := by + intro hb + subst b + simp at hcoeff + have hzeroSupport : 0 ∈ (b : K⟦ℝ⟧).support := by + rw [HahnSeries.mem_support] + simpa [HahnSeries.Nonpositive.constantCoeff_apply] using hcoeff + rw [HahnSeries.Nonpositive.supportSup_of_ne hbZero] at hsup + apply (not_lt_of_ge _ hsup) + exact WithBot.coe_le_coe.mpr + (le_csSup (HahnSeries.Nonpositive.bddAbove_support b) hzeroSupport) + +/-- Berarducci's ring `K((ℝ⁽≤0⁾))` of nonpositive real Hahn series. -/ +abbrev Series (K : Type v) [Field K] := HahnSeries.Nonpositive ℝ K + +/-- Berarducci's ring of germs `K((ℝ⁽≤0⁾)) / J`. -/ +abbrev Germ (K : Type v) [Field K] := + Series K ⧸ HahnSeries.Nonpositive.negativeMonomialIdeal K + +/-- The quotient map from nonpositive series to Berarducci germs. -/ +def toGerm : Series K →+* Germ K := + Ideal.Quotient.mk (HahnSeries.Nonpositive.negativeMonomialIdeal K) + +/-- Evaluating the germ quotient map is Mathlib's ideal-quotient constructor. -/ +@[simp] +theorem toGerm_apply (b : Series K) : + toGerm b = Ideal.Quotient.mk + (HahnSeries.Nonpositive.negativeMonomialIdeal K) b := + (rfl) + +/-- The additive subgroup of constant series in `Berarducci.Series K`. -/ +def constantSubgroup (K : Type v) [Field K] : AddSubgroup (Series K) := + HahnSeries.Nonpositive.C.toAddMonoidHom.range + +/-- Berarducci's additive subgroup `J + K` of series equal to a constant modulo `J`. -/ +def nearConstantSubgroup (K : Type v) [Field K] : AddSubgroup (Series K) := + (HahnSeries.Nonpositive.negativeMonomialIdeal K).toAddSubgroup ⊔ constantSubgroup K + +/-- Membership in the constant subgroup means equality to a constant Hahn series. -/ +theorem mem_constantSubgroup_iff {b : Series K} : + b ∈ constantSubgroup K ↔ ∃ k : K, HahnSeries.Nonpositive.C k = b := + AddMonoidHom.mem_range + +/-- Membership in `J + K` means being a sum of an element of `J` and a constant series. -/ +theorem mem_nearConstantSubgroup_iff {b : Series K} : + b ∈ nearConstantSubgroup K ↔ + ∃ j ∈ HahnSeries.Nonpositive.negativeMonomialIdeal K, + ∃ k : K, j + HahnSeries.Nonpositive.C k = b := by + rw [nearConstantSubgroup, AddSubgroup.mem_sup] + constructor + · rintro ⟨j, hj, c, hc, rfl⟩ + rw [mem_constantSubgroup_iff] at hc + obtain ⟨k, rfl⟩ := hc + exact ⟨j, hj, k, rfl⟩ + · rintro ⟨j, hj, k, rfl⟩ + exact ⟨j, hj, HahnSeries.Nonpositive.C k, + mem_constantSubgroup_iff.mpr ⟨k, rfl⟩, rfl⟩ + +/-- Two series have the same germ exactly when their difference belongs to `J`. -/ +theorem toGerm_eq_toGerm_iff {b c : Series K} : + toGerm b = toGerm c ↔ + b - c ∈ HahnSeries.Nonpositive.negativeMonomialIdeal K := + Ideal.Quotient.eq + +/-- Two nonpositive series define the same germ exactly when their coefficients agree on some +interval immediately below zero, including the right endpoint. -/ +theorem toGerm_eq_toGerm_iff_exists_coeff_eq {b c : Series K} : + toGerm b = toGerm c ↔ + ∃ η < (0 : ℝ), ∀ δ : ℝ, η < δ → δ ≤ 0 → + (b : K⟦ℝ⟧).coeff δ = (c : K⟦ℝ⟧).coeff δ := by + rw [toGerm_eq_toGerm_iff] + constructor + · intro hbc + have hsup := + HahnSeries.Nonpositive.mem_negativeMonomialIdeal_iff_supportSup_lt_zero.mp hbc + by_cases hd : b - c = 0 + · have hbcEq : b = c := sub_eq_zero.mp hd + exact ⟨-1, by norm_num, fun _ _ _ ↦ by rw [hbcEq]⟩ + · have hsupReal : sSup ((b - c : Series K) : K⟦ℝ⟧).support < 0 := by + rw [HahnSeries.Nonpositive.supportSup_of_ne hd] at hsup + exact WithBot.coe_lt_coe.mp hsup + refine ⟨sSup ((b - c : Series K) : K⟦ℝ⟧).support, hsupReal, + fun δ hδ _ ↦ ?_⟩ + have hnotSupport : δ ∉ ((b - c : Series K) : K⟦ℝ⟧).support := by + intro hδSupport + have hle := le_csSup + (HahnSeries.Nonpositive.bddAbove_support (b - c)) hδSupport + exact (not_lt_of_ge hle) hδ + have hcoeff : (((b - c : Series K) : K⟦ℝ⟧).coeff δ) = 0 := by + rw [← not_ne_iff, ← HahnSeries.mem_support] + exact hnotSupport + simpa using sub_eq_zero.mp hcoeff + · rintro ⟨η, hη, hcoeff⟩ + rw [HahnSeries.Nonpositive.mem_negativeMonomialIdeal_iff_supportSup_lt_zero] + by_cases hd : b - c = 0 + · simp [hd] + · rw [HahnSeries.Nonpositive.supportSup_of_ne hd] + apply WithBot.coe_lt_coe.mpr + refine (csSup_le ?_ ?_).trans_lt hη + · have hd' : (((b - c : Series K) : K⟦ℝ⟧)) ≠ 0 := by + intro h + exact hd (Subtype.ext h) + exact HahnSeries.support_nonempty_iff.mpr hd' + · intro δ hδSupport + apply le_of_not_gt + intro hηδ + have hδ0 := HahnSeries.Nonpositive.support_subset (b - c) hδSupport + have heq := hcoeff δ hηδ hδ0 + have hzero : (((b - c : Series K) : K⟦ℝ⟧).coeff δ) = 0 := by + simpa using sub_eq_zero.mpr heq + exact (HahnSeries.mem_support _ _).mp hδSupport hzero + +/-- A series belongs to `J + K` exactly when subtracting its own constant coefficient leaves an +element of `J`. -/ +theorem mem_nearConstantSubgroup_iff_sub_C_constantCoeff_mem {b : Series K} : + b ∈ nearConstantSubgroup K ↔ + b - HahnSeries.Nonpositive.C (HahnSeries.Nonpositive.constantCoeff b) ∈ + HahnSeries.Nonpositive.negativeMonomialIdeal K := by + constructor + · intro hb + obtain ⟨j, hj, k, hsum⟩ := mem_nearConstantSubgroup_iff.mp hb + have hcoeff : HahnSeries.Nonpositive.constantCoeff b = k := by + rw [← hsum, map_add, + constantCoeff_eq_zero_of_mem_negativeMonomialIdeal hj] + simp + rw [hcoeff, ← hsum, add_sub_cancel_right] + exact hj + · intro hb + apply mem_nearConstantSubgroup_iff.mpr + refine ⟨b - HahnSeries.Nonpositive.C + (HahnSeries.Nonpositive.constantCoeff b), hb, + HahnSeries.Nonpositive.constantCoeff b, ?_⟩ + exact sub_add_cancel _ _ + +/-- A series belongs to `J + K` exactly when its germ is represented by a constant series. -/ +theorem mem_nearConstantSubgroup_iff_exists_germ_eq_constant {b : Series K} : + b ∈ nearConstantSubgroup K ↔ + ∃ k : K, toGerm b = toGerm (HahnSeries.Nonpositive.C k) := by + rw [mem_nearConstantSubgroup_iff_sub_C_constantCoeff_mem, ← toGerm_eq_toGerm_iff] + constructor + · exact fun h ↦ ⟨HahnSeries.Nonpositive.constantCoeff b, h⟩ + · rintro ⟨k, hk⟩ + rw [toGerm_eq_toGerm_iff] at hk ⊢ + have hcoeff : HahnSeries.Nonpositive.constantCoeff b = k := by + have hzero := constantCoeff_eq_zero_of_mem_negativeMonomialIdeal hk + have hzero' : HahnSeries.Nonpositive.constantCoeff b - k = 0 := by + simpa using hzero + exact sub_eq_zero.mp hzero' + simpa [hcoeff] using hk + +/-- The negative-monomial ideal, regarded as an additive subgroup, is contained in `J + K`. -/ +theorem negativeMonomialIdeal_le_nearConstantSubgroup : + (HahnSeries.Nonpositive.negativeMonomialIdeal K).toAddSubgroup ≤ + nearConstantSubgroup K := by + intro b hb + apply AddSubgroup.mem_sup.mpr + exact ⟨b, hb, 0, (constantSubgroup K).zero_mem, add_zero b⟩ + +/-- Series congruent modulo `J + K` have equal coefficients on some interval `(η, 0)`. The right +endpoint is excluded: a constant summand changes exactly the coefficient at zero. -/ +theorem exists_coeff_eq_of_sub_mem_nearConstantSubgroup + {b c : Series K} (hbc : b - c ∈ nearConstantSubgroup K) : + ∃ η < (0 : ℝ), ∀ δ : ℝ, η < δ → δ < 0 → + (b : K⟦ℝ⟧).coeff δ = (c : K⟦ℝ⟧).coeff δ := by + have hq := mem_nearConstantSubgroup_iff_sub_C_constantCoeff_mem.mp hbc + have hgerm : toGerm + (b - c - HahnSeries.Nonpositive.C + (HahnSeries.Nonpositive.constantCoeff (b - c))) = toGerm 0 := by + rw [toGerm_eq_toGerm_iff] + simpa using hq + obtain ⟨η, hη, hcoeff⟩ := + toGerm_eq_toGerm_iff_exists_coeff_eq.mp hgerm + refine ⟨η, hη, fun δ hηδ hδ ↦ ?_⟩ + have heq := hcoeff δ hηδ hδ.le + have hzero : (b : K⟦ℝ⟧).coeff δ - (c : K⟦ℝ⟧).coeff δ = 0 := by + simpa [hδ.ne] using heq + exact sub_eq_zero.mp hzero + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/GermDegree.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/GermDegree.lean new file mode 100644 index 0000000000..f46909572d --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/GermDegree.lean @@ -0,0 +1,44 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValueDegree +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Truncation + +/-! +# Degree bounds for translated truncations + +Translated closed truncation at a real exponent does not increase Hahn-series degree. Since +Berarducci's ordinal-value degree is bounded by Hahn-series degree, the same bound holds for the +ordinal-value degree of every translated truncation. +-/ + +open scoped HahnSeries + +universe v + +public noncomputable section + +namespace Berarducci + +open HahnSeries + +variable {K : Type v} [Field K] + +/-- Translated closed truncation does not increase Hahn-series degree. -/ +theorem degree_translatedTruncation_le (b : K⟦ℝ⟧) (γ : ℝ) : + ((translatedTruncation b γ : Series K) : K⟦ℝ⟧).degree ≤ b.degree := by + rw [coe_translatedTruncation, HahnSeries.degree_translate] + exact HahnSeries.degree_truncLE_le γ b + +/-- The ordinal-value degree of a translated closed truncation is bounded by the degree of the +original Hahn series. -/ +theorem ordinalValueDegree_translatedTruncation_le_degree (b : K⟦ℝ⟧) (γ : ℝ) : + ordinalValueDegree (translatedTruncation b γ) ≤ b.degree := + (ordinalValueDegree_le_degree (translatedTruncation b γ)).trans + (degree_translatedTruncation_le b γ) + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/GermValueCut.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/GermValueCut.lean new file mode 100644 index 0000000000..fcfbd55e5f --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/GermValueCut.lean @@ -0,0 +1,111 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalValue +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Truncation + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValueFinalSegment +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.StableInterval + +/-! +# The eventual value cut for translated truncations + +For a series of ordinal value above one, every sufficiently high translated truncation has +ordinal value at most `v_J^r(b) * α` for some `α < v_J^p(b)`, with ordinary ordinal +multiplication. This is the upper half of Berarducci, Lemma 6.8, in the quantitative form used by +the value estimates of Berarducci, Lemma 7.7 and Lemma 8.2, and it is the statement that lets a +truncation value be absorbed strictly below `v_J(b)`. + +On a stable tail the ordinary order type is exactly `v_J(b) = v_J^r(b) * v_J^p(b)`. Cutting at `γ` +leaves a relative upper set of the support below `γ` whose order type is bounded by that of a +proper initial segment of the tail, hence strictly below `v_J(b)`; continuity of ordinary ordinal +multiplication in its second argument at the successor-limit `v_J^p(b)` then supplies `α`. + +When the support has no point in `(η, γ)` the truncation is a constant modulo `J`, its value is at +most one, and `α = 1` works because the residual value is at least one and the principal value is +above one. +-/ + +universe v + +public noncomputable section + +open HahnSeries + +namespace Berarducci + +variable {K : Type v} [Field K] + +theorem exists_ordinalValue_translatedTruncation_le (b : SeriesWithOrdinalValueAboveOne K) : + ∃ η < (0 : ℝ), ∀ γ : ℝ, η < γ → γ < 0 → + ∃ α < b.principalValue.val, + (ordinalValue (translatedTruncation (b.1 : K⟦ℝ⟧) γ)).val ≤ b.residualValue.val * α := by + obtain ⟨η, hη, hstable⟩ := + exists_forall_later_negativeSupportTail_orderType_eq_ordinalValue b.1 b.2 + obtain ⟨η', hηη', hη'0⟩ := exists_between hη + have hone : (1 : Ordinal) < b.principalValue.val := by + simpa using NatOrdinal.val.lt_iff_lt.mpr b.one_lt_principalValue + have hρ : (1 : Ordinal) ≤ b.residualValue.val := by + rw [Order.one_le_iff_ne_zero] + intro h + exact b.residualValue_ne_zero (NatOrdinal.val.injective (by simpa using h)) + refine ⟨η', hη'0, fun γ hη'γ hγ ↦ ?_⟩ + by_cases hne : ((b.1 : K⟦ℝ⟧).support ∩ Set.Ioo η' γ).Nonempty + · set C := (b.1 : K⟦ℝ⟧).support ∩ Set.Ioo η' γ with hCdef + have hC : IsRelUpperSet C (· ∈ (b.1 : K⟦ℝ⟧).support ∩ Set.Iio γ) := by + rintro a ⟨haSupport, haLow, haHigh⟩ + refine ⟨⟨haSupport, haHigh⟩, ?_⟩ + rintro d had ⟨hdSupport, hdHigh⟩ + exact ⟨hdSupport, lt_of_lt_of_le haLow had, hdHigh⟩ + have hbound := + ordinalValue_translatedTruncation_le_orderType_of_isRelUpperSet_supportBelow + (b.1 : K⟦ℝ⟧) γ hC hne + have htailLUB := + isLUB_negativeSupportTail_zero_of_one_lt_ordinalValue b.1 b.2 hη'0 + obtain ⟨x, hxTail, hγx, _⟩ := htailLUB.exists_between hγ + have htailPWO : (negativeSupportTail b.1 η').IsPWO := + (b.1 : K⟦ℝ⟧).isPWO_support.mono (negativeSupportTail_subset_support b.1 η') + have hsub : C ⊆ negativeSupportTail b.1 η' ∩ Set.Iio x := by + rintro y ⟨hySupport, hyLow, hyHigh⟩ + exact ⟨mem_negativeSupportTail_iff.mpr ⟨hySupport, hyLow, hyHigh.trans hγ⟩, + hyHigh.trans hγx⟩ + have hlt : ((b.1 : K⟦ℝ⟧).isPWO_support.mono fun _ hx ↦ (hC hx).1.1).orderType < + (ordinalValue b.1).val := by + calc + ((b.1 : K⟦ℝ⟧).isPWO_support.mono fun _ hx ↦ (hC hx).1.1).orderType + ≤ (htailPWO.mono (s := negativeSupportTail b.1 η' ∩ Set.Iio x) + Set.inter_subset_left).orderType := + Set.IsPWO.orderType_mono _ _ hsub + _ < htailPWO.orderType := htailPWO.orderType_inter_Iio_lt hxTail + _ = (ordinalValue b.1).val := hstable η' hηη' hη'0 + rw [← b.residualValue_val_mul_principalValue_val] at hlt + obtain ⟨α, hα, hαlt⟩ := + (Ordinal.lt_mul_iff_of_isSuccLimit + b.principalValue_isInfiniteMultiplicativelyPrincipal.isSuccLimit).mp hlt + exact ⟨α, hα, hbound.trans hαlt.le⟩ + · refine ⟨1, hone, ?_⟩ + rw [mul_one] + rw [Set.not_nonempty_iff_eq_empty] at hne + have hmem : translatedTruncation (b.1 : K⟦ℝ⟧) γ ∈ nearConstantSubgroup K := by + refine mem_nearConstantSubgroup_iff_exists_germ_eq_constant.mpr + ⟨(b.1 : K⟦ℝ⟧).coeff γ, ?_⟩ + refine toGerm_eq_toGerm_iff_exists_coeff_eq.mpr + ⟨η' - γ, by linarith, fun δ hδlow hδ0 ↦ ?_⟩ + rw [coeff_translatedTruncation, ite_eq_left hδ0, HahnSeries.Nonpositive.coe_C] + rcases hδ0.eq_or_lt with rfl | hδneg + · simp + · rw [HahnSeries.C_apply, HahnSeries.coeff_single_of_ne (by linarith : δ ≠ (0 : ℝ))] + by_contra hcoeff + have hmemSupport : γ + δ ∈ (b.1 : K⟦ℝ⟧).support ∩ Set.Ioo η' γ := + ⟨(HahnSeries.mem_support _ _).mpr hcoeff, by linarith, by linarith⟩ + rw [hne] at hmemSupport + exact hmemSupport + have hle : ordinalValue (translatedTruncation (b.1 : K⟦ℝ⟧) γ) ≤ 1 := + le_of_not_gt fun h ↦ (one_lt_ordinalValue_iff.mp h) hmem + exact (NatOrdinal.val.monotone hle).trans hρ + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Irreducibility.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Irreducibility.lean new file mode 100644 index 0000000000..f8a0098a9f --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Irreducibility.lean @@ -0,0 +1,336 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrderTypeMultiplicativity + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Monomial +import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.NaturalPrincipal +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.CriticalPointExistence +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.MainLemma +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValueFinalSegment +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Statements.ProductValue +import Mathlib.Tactic.Linarith +import Mathlib.Tactic.Ring + +/-! +# Irreducibility at multiplicatively principal support order types + +Berarducci, Theorem 10.5 proves that a nonpositive real Hahn series with support order type `ω` +or `ω ^ (ω ^ β)` is irreducible, as is its sum with one, provided no strictly negative monomial +divides it. + +The proof combines multiplicativity of the ordinal value with critical points. In a nontrivial +factorisation, multiplicative principality forces one factor to have ordinal value one. The two +critical points must sum to zero because every strictly negative translated truncation has smaller +ordinal value. But a nonunit of ordinal value one has a strictly negative critical point, giving a +contradiction. + +## References + +* A. Berarducci, *Factorization in generalized power series*, Trans. Amer. Math. Soc. 352 + (2000), 553–577, cited as [Ber00]. +-/ + +universe v + +open scoped HahnSeries NatOrdinal + +public noncomputable section + +namespace Berarducci + +open HahnSeries Ordinal + +variable {K : Type v} [Field K] + +private theorem not_mem_negativeMonomialIdeal_of_no_negativeMonomial_dvd + {a : Series K} + (ha : ∀ (gamma : ℝ) (hgamma : gamma < 0), + ¬HahnSeries.Nonpositive.single gamma (1 : K) hgamma.le ∣ a) : + a ∉ HahnSeries.Nonpositive.negativeMonomialIdeal K := by + intro haJ + have hsup := + HahnSeries.Nonpositive.mem_negativeMonomialIdeal_iff_supportSup_lt_zero.mp haJ + by_cases haZero : a = 0 + · have hneg : (-1 : ℝ) < 0 := by norm_num + apply ha (-1) hneg + refine ⟨0, ?_⟩ + simp [haZero] + · rw [HahnSeries.Nonpositive.supportSup_of_ne haZero] at hsup + have hsupReal : sSup (a : K⟦ℝ⟧).support < 0 := WithBot.coe_lt_coe.mp hsup + apply ha (sSup (a : K⟦ℝ⟧).support) hsupReal + refine ⟨HahnSeries.Nonpositive.normalize a, ?_⟩ + apply Subtype.ext + simpa only [Subring.coe_mul, HahnSeries.Nonpositive.coe_single, + HahnSeries.single_one_mul_eq_translate] using + (HahnSeries.Nonpositive.translate_csSup_normalize a).symm + +private theorem ordinalValue_eq_one_of_isUnit {b : Series K} (hb : IsUnit b) : + ordinalValue b = 1 := by + have hbConstant := HahnSeries.Nonpositive.eq_C_constantCoeff_of_isUnit hb + have hcoeff : HahnSeries.Nonpositive.constantCoeff b ≠ 0 := by + intro hzero + have hbZero : b = 0 := by simpa [hzero] using hbConstant + exact hb.ne_zero hbZero + rw [hbConstant, ordinalValue_C_of_ne hcoeff] + +private theorem exists_negative_support_of_ordinalValue_eq_one_of_not_isUnit + {b : Series K} (hbValue : ordinalValue b = 1) (hbUnit : ¬IsUnit b) : + ∃ gamma ∈ (b : K⟦ℝ⟧).support, gamma < 0 := by + have hbNear := (ordinalValue_eq_one_iff.mp hbValue).1 + have hbJ := (ordinalValue_eq_one_iff.mp hbValue).2 + have hbCoeff : HahnSeries.Nonpositive.constantCoeff b ≠ 0 := by + intro hzero + apply hbJ + have hsub := mem_nearConstantSubgroup_iff_sub_C_constantCoeff_mem.mp hbNear + simpa [hzero] using hsub + have hzeroSupport : (0 : ℝ) ∈ (b : K⟦ℝ⟧).support := by + rw [HahnSeries.mem_support, ← HahnSeries.Nonpositive.constantCoeff_apply] + exact hbCoeff + by_contra hnegative + have hsupport : (b : K⟦ℝ⟧).support = {0} := by + apply Set.Subset.antisymm + · intro gamma hgamma + rw [Set.mem_singleton_iff] + have hnonpositive := HahnSeries.Nonpositive.support_subset b hgamma + exact le_antisymm hnonpositive (le_of_not_gt fun hgammaNeg ↦ + hnegative ⟨gamma, hgamma, hgammaNeg⟩) + · exact Set.singleton_subset_iff.mpr hzeroSupport + apply hbUnit + have hbConstant : b = HahnSeries.Nonpositive.C + (HahnSeries.Nonpositive.constantCoeff b) := by + apply Subtype.ext + apply HahnSeries.coeff_injective + funext gamma + by_cases hgamma : gamma = 0 + · subst gamma + simp [HahnSeries.Nonpositive.constantCoeff_apply] + · have hgammaSupport : gamma ∉ (b : K⟦ℝ⟧).support := by + rw [hsupport] + simpa using hgamma + rw [HahnSeries.mem_support, not_ne_iff] at hgammaSupport + simp [hgamma, hgammaSupport] + rw [hbConstant] + exact (isUnit_iff_ne_zero.mpr hbCoeff).map HahnSeries.Nonpositive.C + +private theorem criticalPoint_lt_zero_of_ordinalValue_eq_one_of_not_isUnit + {b : Series K} {x : ℝ} (hbValue : ordinalValue b = 1) + (hbUnit : ¬IsUnit b) (hx : IsCriticalPoint b x) : x < 0 := by + obtain ⟨gamma, hgammaSupport, hgamma⟩ := + exists_negative_support_of_ordinalValue_eq_one_of_not_isUnit hbValue hbUnit + apply lt_of_le_of_ne hx.nonpositive + intro hxZero + have hxValue : ordinalValue (translatedTruncation (b : K⟦ℝ⟧) x) = 1 := by + rw [hxZero, translatedTruncation_zero, hbValue] + have hgammaPos : 0 < ordinalValue (translatedTruncation (b : K⟦ℝ⟧) gamma) := + ordinalValue_translatedTruncation_pos_of_mem_support hgammaSupport + have hgammaValue : ordinalValue (translatedTruncation (b : K⟦ℝ⟧) gamma) = 1 := by + apply le_antisymm + · exact (hx.value_le gamma hgamma.le).trans_eq hxValue + · exact Order.one_le_iff_pos.mpr hgammaPos + have hxLeGamma := hx.le_of_value_eq gamma hgamma.le (hgammaValue.trans hxValue.symm) + exact (not_le_of_gt hgamma) (hxZero ▸ hxLeGamma) + +private theorem factor_ordinalValue_eq_one_of_mul_eq_infiniteMultiplicativelyPrincipal + {b c rho : NatOrdinal} + (hrho : Ordinal.IsInfiniteMultiplicativelyPrincipal rho.val) + (hmul : b * c = rho) : b = 1 ∨ c = 1 := by + have hrhoPos : 0 < rho := by + rw [← NatOrdinal.val.lt_iff_lt] + exact hrho.isSuccLimit.bot_lt + have hbNe : b ≠ 0 := by + intro hb + rw [hb, zero_mul] at hmul + exact hrhoPos.ne' hmul.symm + have hcNe : c ≠ 0 := by + intro hc + rw [hc, mul_zero] at hmul + exact hrhoPos.ne' hmul.symm + by_cases hb : b = 1 + · exact Or.inl hb + by_cases hc : c = 1 + · exact Or.inr hc + exfalso + have hbOne : 1 < b := lt_of_le_of_ne (Order.one_le_iff_pos.mpr (pos_iff_ne_zero.mpr hbNe)) + (Ne.symm hb) + have hcOne : 1 < c := lt_of_le_of_ne (Order.one_le_iff_pos.mpr (pos_iff_ne_zero.mpr hcNe)) + (Ne.symm hc) + have hbLt : b < rho := by + rw [← hmul] + simpa only [mul_one] using mul_lt_mul_of_pos_left hcOne (pos_iff_ne_zero.mpr hbNe) + have hcLt : c < rho := by + rw [← hmul] + simpa only [one_mul] using mul_lt_mul_of_pos_right hbOne (pos_iff_ne_zero.mpr hcNe) + have hlt := NatOrdinal.mul_lt_of_isMultiplicativelyPrincipal + (Ordinal.isInfiniteMultiplicativelyPrincipal_iff_two_lt_and_isMultiplicativelyPrincipal.mp + hrho).2 hbLt hcLt + rw [hmul] at hlt + exact (lt_irrefl _) hlt + +private theorem irreducible_of_infiniteMultiplicativelyPrincipal_ordinalValue + [CharZero K] {a : Series K} + (haPrincipal : Ordinal.IsInfiniteMultiplicativelyPrincipal (ordinalValue a).val) + (haNegative : ∀ u : ℝ, u < 0 → + ordinalValue (translatedTruncation (a : K⟦ℝ⟧) u) < ordinalValue a) : + Irreducible a := by + have haOne : 1 < ordinalValue a := by + rw [← NatOrdinal.val.lt_iff_lt] + exact (show (1 : Ordinal) < 2 by norm_num).trans + (Ordinal.isInfiniteMultiplicativelyPrincipal_iff_two_lt_and_isMultiplicativelyPrincipal.mp + haPrincipal).1 + rw [irreducible_iff] + refine ⟨fun haUnit ↦ haOne.ne' (ordinalValue_eq_one_of_isUnit haUnit), ?_⟩ + intro b c habc + by_cases hbUnit : IsUnit b + · exact Or.inl hbUnit + by_cases hcUnit : IsUnit c + · exact Or.inr hcUnit + exfalso + have hmul : ordinalValue b * ordinalValue c = ordinalValue a := by + rw [← ordinalValue_mul, ← habc] + have hfactor := + factor_ordinalValue_eq_one_of_mul_eq_infiniteMultiplicativelyPrincipal haPrincipal hmul + have haNe : a ≠ 0 := by + intro haZero + rw [haZero, ordinalValue_zero] at haOne + exact (not_lt_of_ge zero_le_one) haOne + have hbNe : b ≠ 0 := by + intro hbZero + apply haNe + rw [habc, hbZero, zero_mul] + have hcNe : c ≠ 0 := by + intro hcZero + apply haNe + rw [habc, hcZero, mul_zero] + obtain ⟨x, hx⟩ := exists_isCriticalPoint hbNe + obtain ⟨y, hy⟩ := exists_isCriticalPoint hcNe + have hbLe : ordinalValue b ≤ ordinalValue (translatedTruncation (b : K⟦ℝ⟧) x) := by + simpa using hx.value_le 0 le_rfl + have hcLe : ordinalValue c ≤ ordinalValue (translatedTruncation (c : K⟦ℝ⟧) y) := by + simpa using hy.value_le 0 le_rfl + have hcriticalLower : ordinalValue a ≤ + ordinalValue (translatedTruncation (a : K⟦ℝ⟧) (x + y)) := by + calc + ordinalValue a = ordinalValue b * ordinalValue c := hmul.symm + _ ≤ ordinalValue (translatedTruncation (b : K⟦ℝ⟧) x) * + ordinalValue (translatedTruncation (c : K⟦ℝ⟧) y) := + mul_le_mul hbLe hcLe bot_le bot_le + _ = ordinalValue (translatedTruncation (((b * c : Series K) : K⟦ℝ⟧)) (x + y)) := + (criticalPoint_product_value hx hy).symm + _ = ordinalValue (translatedTruncation (a : K⟦ℝ⟧) (x + y)) := by rw [habc] + have hsum : x + y = 0 := by + apply le_antisymm (add_nonpos hx.nonpositive hy.nonpositive) + apply le_of_not_gt + intro hnegative + exact (not_lt_of_ge hcriticalLower) (haNegative (x + y) hnegative) + rcases hfactor with hbValue | hcValue + · have hxNegative := + criticalPoint_lt_zero_of_ordinalValue_eq_one_of_not_isUnit hbValue hbUnit hx + linarith [hy.nonpositive] + · have hyNegative := + criticalPoint_lt_zero_of_ordinalValue_eq_one_of_not_isUnit hcValue hcUnit hy + linarith [hx.nonpositive] + +private theorem translatedTruncation_one_eq_zero_of_neg {u : ℝ} (hu : u < 0) : + translatedTruncation (1 : K⟦ℝ⟧) u = 0 := by + apply Subtype.ext + apply HahnSeries.coeff_injective + funext delta + rw [coeff_translatedTruncation] + by_cases hdelta : delta ≤ 0 + · rw [ite_eq_left hdelta] + have hsum : u + delta ≠ 0 := ne_of_lt (add_neg_of_neg_of_nonpos hu hdelta) + simp [hsum] + · rw [ite_eq_right hdelta] + rfl + +private theorem ordinalValue_add_one_eq_of_one_lt + {a : Series K} (ha : 1 < ordinalValue a) : ordinalValue (a + 1) = ordinalValue a := by + apply le_antisymm + · simpa [ordinalValue_one, max_eq_left ha.le] using ordinalValue_add_le_max a 1 + · have h := ordinalValue_add_le_max (a + 1) (-1) + have hsum : (a + 1) + (-1) = a := by ring + rw [hsum, ordinalValue_neg, ordinalValue_one] at h + exact (le_max_iff.mp h).resolve_right (not_le_of_gt ha) + +private theorem ordinalValue_translatedTruncation_lt_of_supportOrderType_eq_ordinalValue + {a : Series K} + (haValue : (a : K⟦ℝ⟧).supportOrderType = (ordinalValue a).val) + (haZero : ordinalValue a ≠ 0) {u : ℝ} (hu : u < 0) : + ordinalValue (translatedTruncation (a : K⟦ℝ⟧) u) < ordinalValue a := by + have hLUB := isLUB_support_zero_of_ordinalValue_ne_zero haZero + obtain ⟨gamma, hgammaSupport, hugamma, -⟩ := hLUB.exists_between hu + have htruncNe : HahnSeries.truncLE u (a : K⟦ℝ⟧) ≠ (a : K⟦ℝ⟧) := by + intro htrunc + have hgammaTrunc : gamma ∈ (HahnSeries.truncLE u (a : K⟦ℝ⟧)).support := by + rw [htrunc] + exact hgammaSupport + rw [HahnSeries.support_truncLE] at hgammaTrunc + exact (not_le_of_gt hugamma) hgammaTrunc.2 + calc + ordinalValue (translatedTruncation (a : K⟦ℝ⟧) u) ≤ + NatOrdinal.of + ((translatedTruncation (a : K⟦ℝ⟧) u : Series K) : K⟦ℝ⟧).supportOrderType := + ordinalValue_le_supportOrderType _ + _ = NatOrdinal.of (HahnSeries.truncLE u (a : K⟦ℝ⟧)).supportOrderType := by + rw [coe_translatedTruncation, HahnSeries.supportOrderType_translate] + _ < NatOrdinal.of (a : K⟦ℝ⟧).supportOrderType := + NatOrdinal.of.lt_iff_lt.mpr (HahnSeries.supportOrderType_truncLE_lt u htruncNe) + _ = ordinalValue a := by rw [haValue, NatOrdinal.of_val] + +/-- Berarducci, Theorem 10.5: a nonpositive real Hahn series not divisible by a strictly +negative monomial is irreducible, as is its sum with one, when its support has order type `ω` or +`ω ^ (ω ^ beta)`. -/ +theorem irreducible_and_add_one_of_supportOrderType + [CharZero K] {a : Series K} + (haMonomial : ∀ (gamma : ℝ) (hgamma : gamma < 0), + ¬HahnSeries.Nonpositive.single gamma (1 : K) hgamma.le ∣ a) + (haType : (a : K⟦ℝ⟧).supportOrderType = Ordinal.omega0 ∨ + ∃ beta : Ordinal, (a : K⟦ℝ⟧).supportOrderType = + Ordinal.omega0 ^ Ordinal.omega0 ^ beta) : + Irreducible a ∧ Irreducible (a + 1) := by + have haJ := not_mem_negativeMonomialIdeal_of_no_negativeMonomial_dvd haMonomial + have haPrincipal : Ordinal.IsInfiniteMultiplicativelyPrincipal + (a : K⟦ℝ⟧).supportOrderType := by + rcases haType with haOmega | ⟨beta, haBeta⟩ + · rw [haOmega] + simpa using Ordinal.isInfiniteMultiplicativelyPrincipal_omega0_opow_opow 0 + · rw [haBeta] + exact Ordinal.isInfiniteMultiplicativelyPrincipal_omega0_opow_opow beta + have haWeak : HahnSeries.IsWeaklyPrincipal (a : K⟦ℝ⟧) := by + rw [HahnSeries.isWeaklyPrincipal_iff] + exact haPrincipal.isAdditivelyPrincipal + have haValue := supportOrderType_eq_ordinalValue_of_isWeaklyPrincipal haWeak haJ + have haOrderPrincipal : Ordinal.IsInfiniteMultiplicativelyPrincipal (ordinalValue a).val := by + rw [← haValue] + exact haPrincipal + have haOne : 1 < ordinalValue a := by + rw [← NatOrdinal.val.lt_iff_lt] + exact (show (1 : Ordinal) < 2 by norm_num).trans + (Ordinal.isInfiniteMultiplicativelyPrincipal_iff_two_lt_and_isMultiplicativelyPrincipal.mp + haOrderPrincipal).1 + have haNegative : ∀ u : ℝ, u < 0 → + ordinalValue (translatedTruncation (a : K⟦ℝ⟧) u) < ordinalValue a := + fun _ hu ↦ ordinalValue_translatedTruncation_lt_of_supportOrderType_eq_ordinalValue + haValue (zero_lt_one.trans haOne).ne' hu + refine ⟨irreducible_of_infiniteMultiplicativelyPrincipal_ordinalValue + haOrderPrincipal haNegative, ?_⟩ + have haAddValue := ordinalValue_add_one_eq_of_one_lt haOne + have haAddPrincipal : + Ordinal.IsInfiniteMultiplicativelyPrincipal (ordinalValue (a + 1)).val := by + rw [haAddValue] + exact haOrderPrincipal + apply irreducible_of_infiniteMultiplicativelyPrincipal_ordinalValue haAddPrincipal + intro u hu + have hgerm : translatedTruncation (((a + 1 : Series K) : K⟦ℝ⟧)) u = + translatedTruncation (a : K⟦ℝ⟧) u := by + rw [show (((a + 1 : Series K) : K⟦ℝ⟧)) = (a : K⟦ℝ⟧) + 1 from rfl, + translatedTruncation_add, translatedTruncation_one_eq_zero_of_neg hu, add_zero] + rw [hgerm, haAddValue] + exact haNegative u hu + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/LeibnizRemainder.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/LeibnizRemainder.lean new file mode 100644 index 0000000000..b6060535a3 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/LeibnizRemainder.lean @@ -0,0 +1,192 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.TruncationDrop +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Convolution +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.FinitePart + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValueSubmultiplicative +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValueImage +import Mathlib.Topology.Instances.Real.Lemmas + +/-! +# The Leibniz remainder of a product near zero + +Berarducci, Lemma 7.7 (Fornasiero, Lavi, L'Innocente and Mantova, Proposition 2.10): for +`u ∈ J_{ω^(α+1)}` and `v ∈ J_{ω^(β+1)}` with `α` a successor, Berarducci's convolution formula +writes `(uv)^{|γ}` modulo `J` as the finite sum of the products `u^{|ξ} v^{|ζ}` over `ξ + ζ = γ`. +The pairs `(γ, 0)` and `(0, γ)` contribute `u^{|γ} v` and `u v^{|γ}`; every other pair has +`ξ, ζ ∈ (γ, 0)`, and for `γ` close to zero the truncation drop gives `v_J(u^{|ξ}) ≤ ω^{α⁻}` and +`v_J(v^{|ζ}) < ω^β`, so by submultiplicativity the product has ordinal value below +`ω^{α⁻ + β}`. Hence + +`(uv)^{|γ} ≡ u^{|γ} v + u v^{|γ} (mod J_{ω^{α⁻ + β}})` + +for all `γ < 0` close to zero. Here `α⁻ + β` is `deg_J^r(u) ⊕ deg_J(v)` when `u` and `v` have +ordinal values `ω^α` and `ω^β`, which is the bound printed in the source. +-/ + +open Filter Topology +open scoped HahnSeries NatOrdinal + +universe v + +public noncomputable section + +namespace Berarducci + +open HahnSeries + +variable {K : Type v} [Field K] + +/-- A finite sum of series of ordinal value below `ρ > 0` has ordinal value below `ρ`. -/ +private theorem ordinalValue_finset_sum_lt {ι : Type*} (s : Finset ι) (f : ι → Series K) + {ρ : NatOrdinal} (hρ : 0 < ρ) (h : ∀ i ∈ s, ordinalValue (f i) < ρ) : + ordinalValue (∑ i ∈ s, f i) < ρ := by + classical + induction s using Finset.induction_on with + | empty => simpa using hρ + | insert a s ha ih => + rw [Finset.sum_insert ha] + exact (ordinalValue_add_le_max _ _).trans_lt + (max_lt (h a (Finset.mem_insert_self a s)) + (ih fun i hi ↦ h i (Finset.mem_insert_of_mem hi))) + +/-- `ω^a ⊙ y < ω^(a + b)` whenever `y < ω^b`. -/ +private theorem wpow_mul_lt_wpow_add_of_lt {a b y : NatOrdinal} (hy : y < ω^ b) : + ω^ a * y < ω^ (a + b) := by + rcases eq_or_ne y 0 with rfl | hy0 + · simp + have hb : b ≠ 0 := by + rintro rfl + rw [NatOrdinal.wpow_zero] at hy + exact hy0 (le_antisymm (Order.lt_one_iff.mp hy).le bot_le) + obtain ⟨z, hz, n, hn⟩ := (NatOrdinal.lt_wpow_iff hb).mp hy + calc ω^ a * y ≤ ω^ a * (ω^ z * n) := mul_le_mul_right hn.le _ + _ = ω^ (a + z) * n := by rw [← mul_assoc, ← NatOrdinal.wpow_add] + _ < ω^ (a + b) := NatOrdinal.wpow_mul_natCast_lt (add_lt_add_right hz a) n + +/-- **Convolution remainder.** For `u ∈ J_{ω^(α+1)}`, `v ∈ J_{ω^(β+1)}` and `α` a successor, +`(uv)^{|γ} - u^{|γ} v - u v^{|γ}` has ordinal value below `ω^{α⁻ + β}` for all `γ < 0` close to +zero. -/ +theorem eventually_ordinalValue_leibnizRemainder_lt + {alpha beta : NatOrdinal} (halpha : 0 < alpha.constantCoeff) + (u v : Series K) (hu : ordinalValue u < ω^ (alpha + 1)) (hv : ordinalValue v < ω^ (beta + 1)) : + ∀ᶠ γ in 𝓝[<] (0 : ℝ), + ordinalValue (translatedTruncation ((u * v : Series K) : K⟦ℝ⟧) γ - + translatedTruncation (u : K⟦ℝ⟧) γ * v - u * translatedTruncation (v : K⟦ℝ⟧) γ) < + ω^ (alpha.removeNat 1 + beta) := by + classical + obtain ⟨ηu, hηu, hu'⟩ := eventually_nhdsLT_iff_exists.mp + (eventually_ordinalValue_translatedTruncation_lt_wpow_of_ordinalValue_lt_wpow_add_one alpha u + hu) + obtain ⟨ηv, hηv, hv'⟩ := eventually_nhdsLT_iff_exists.mp + (eventually_ordinalValue_translatedTruncation_lt_wpow_of_ordinalValue_lt_wpow_add_one beta v hv) + rw [eventually_nhdsLT_iff_exists] + refine ⟨max ηu ηv, max_lt hηu hηv, fun γ hηγ hγ ↦ ?_⟩ + have hαpred : alpha.removeNat 1 + 1 = alpha := by + simpa using NatOrdinal.removeNat_add_natCast halpha + -- The terms of the convolution sum with `ξ ∈ (γ, 0)` have small ordinal value. + have hterm : ∀ ξ : ℝ, γ < ξ → ξ < 0 → + ordinalValue (translatedTruncation (u : K⟦ℝ⟧) ξ * translatedTruncation (v : K⟦ℝ⟧) (γ - ξ)) < + ω^ (alpha.removeNat 1 + beta) := by + intro ξ hγξ hξ + have hξu : ordinalValue (translatedTruncation (u : K⟦ℝ⟧) ξ) < ω^ alpha := + hu' ξ ((le_max_left _ _).trans_lt (hηγ.trans hγξ)) hξ + have hξv : ordinalValue (translatedTruncation (v : K⟦ℝ⟧) (γ - ξ)) < ω^ beta := + hv' (γ - ξ) (by linarith [le_max_right ηu ηv]) (by linarith) + have hξu' : ordinalValue (translatedTruncation (u : K⟦ℝ⟧) ξ) ≤ ω^ (alpha.removeNat 1) := by + rcases ordinalValue_eq_zero_or_isAdditivelyPrincipal (translatedTruncation (u : K⟦ℝ⟧) ξ) with + hzero | hprin + · rw [hzero]; exact bot_le + · have hxi := Ordinal.natOrdinal_of_eq_wpow_log hprin + rw [NatOrdinal.of_val] at hxi + rw [hxi] at hξu ⊢ + rw [← hαpred] at hξu + exact NatOrdinal.wpow_le_wpow.mpr (Order.lt_add_one_iff.mp (NatOrdinal.wpow_lt_wpow.mp hξu)) + calc ordinalValue (translatedTruncation (u : K⟦ℝ⟧) ξ * translatedTruncation (v : K⟦ℝ⟧) (γ - ξ)) + ≤ + ordinalValue (translatedTruncation (u : K⟦ℝ⟧) ξ) * ordinalValue (translatedTruncation (v + : K⟦ℝ⟧) (γ - ξ)) := + ordinalValue_mul_le_naturalMul _ _ + _ ≤ ω^ (alpha.removeNat 1) * ordinalValue (translatedTruncation (v : K⟦ℝ⟧) (γ - ξ)) := + mul_le_mul_left hξu' _ + _ < ω^ (alpha.removeNat 1 + beta) := wpow_mul_lt_wpow_add_of_lt hξv + -- Berarducci's convolution formula, with the endpoint pairs added to the index set. + set I : Finset ℝ := convolutionIndex (u : K⟦ℝ⟧) (v : K⟦ℝ⟧) γ with hIdef + set I' : Finset ℝ := insert γ (insert 0 I) with hI'def + set F : ℝ → Series K := fun ξ ↦ translatedTruncation (u : K⟦ℝ⟧) ξ * translatedTruncation (v : + K⟦ℝ⟧) (γ - ξ) + with hFdef + have hJ : ∀ ξ, ξ ∉ I → F ξ ∈ HahnSeries.Nonpositive.negativeMonomialIdeal K := by + intro ξ hξ + rw [hIdef, mem_convolutionIndex, not_and_or] at hξ + rcases hξ with hξ | hξ + · exact Ideal.mul_mem_right _ _ + (translatedTruncation_mem_negativeMonomialIdeal_of_not_mem_closure_support hξ) + · exact Ideal.mul_mem_left _ _ + (translatedTruncation_mem_negativeMonomialIdeal_of_not_mem_closure_support hξ) + have hsumI : ∑ ξ ∈ I', F ξ - ∑ ξ ∈ I, F ξ ∈ HahnSeries.Nonpositive.negativeMonomialIdeal K := by + have hsub : I ⊆ I' := fun ξ hξ ↦ Finset.mem_insert_of_mem (Finset.mem_insert_of_mem hξ) + rw [← Finset.sum_sdiff hsub, add_sub_cancel_right] + exact Submodule.sum_mem _ fun ξ hξ ↦ hJ ξ (Finset.mem_sdiff.mp hξ).2 + have hconv : translatedTruncation ((u * v : Series K) : K⟦ℝ⟧) γ - ∑ ξ ∈ I', F ξ ∈ + HahnSeries.Nonpositive.negativeMonomialIdeal K := by + have hformula := germAt_mul (u : K⟦ℝ⟧) (v : K⟦ℝ⟧) γ + simp only [germAt_apply, ← map_mul, ← map_sum] at hformula + have hI : translatedTruncation ((u * v : Series K) : K⟦ℝ⟧) γ - ∑ ξ ∈ I, F ξ ∈ + HahnSeries.Nonpositive.negativeMonomialIdeal K := by + rw [← toGerm_eq_toGerm_iff, Subring.coe_mul] + exact hformula + have := Ideal.sub_mem _ hI hsumI + rwa [sub_sub_sub_cancel_right] at this + -- Split off the endpoint pairs `ξ = γ` and `ξ = 0`. + set R : Finset ℝ := (I'.erase γ).erase 0 with hRdef + have hγI' : γ ∈ I' := Finset.mem_insert_self γ _ + have h0I' : (0 : ℝ) ∈ I'.erase γ := + Finset.mem_erase.mpr ⟨hγ.ne', Finset.mem_insert_of_mem (Finset.mem_insert_self 0 I)⟩ + have hsplit : ∑ ξ ∈ I', F ξ = F γ + (F 0 + ∑ ξ ∈ R, F ξ) := by + rw [Finset.add_sum_erase _ _ h0I', Finset.add_sum_erase _ _ hγI'] + have hFγ : F γ = translatedTruncation (u : K⟦ℝ⟧) γ * v := by + simp only [hFdef, sub_self, translatedTruncation_zero] + have hF0 : F 0 = u * translatedTruncation (v : K⟦ℝ⟧) γ := by + simp only [hFdef, sub_zero, translatedTruncation_zero] + -- The remainder is congruent modulo `J` to the sum over `R`. + have hrem : translatedTruncation ((u * v : Series K) : K⟦ℝ⟧) γ - translatedTruncation (u : K⟦ℝ⟧) + γ * v - + u * translatedTruncation (v : K⟦ℝ⟧) γ - ∑ ξ ∈ R, F ξ ∈ + HahnSeries.Nonpositive.negativeMonomialIdeal K := by + have : translatedTruncation ((u * v : Series K) : K⟦ℝ⟧) γ - translatedTruncation (u : K⟦ℝ⟧) γ * + v - + u * translatedTruncation (v : K⟦ℝ⟧) γ - ∑ ξ ∈ R, F ξ = + translatedTruncation ((u * v : Series K) : K⟦ℝ⟧) γ - ∑ ξ ∈ I', F ξ := by + rw [hsplit, hFγ, hF0] + abel + rw [this] + exact hconv + rw [ordinalValue_eq_of_sub_mem_negativeMonomialIdeal hrem] + apply ordinalValue_finset_sum_lt _ _ (NatOrdinal.wpow_pos _) + intro ξ hξ + have hξ0 : ξ ≠ 0 := (Finset.mem_erase.mp hξ).1 + have hξγ : ξ ≠ γ := (Finset.mem_erase.mp (Finset.mem_erase.mp hξ).2).1 + have hξI : ξ ∈ I := by + have hmem := (Finset.mem_erase.mp (Finset.mem_erase.mp hξ).2).2 + rw [hI'def, Finset.mem_insert, Finset.mem_insert] at hmem + rcases hmem with h | h | h + · exact absurd h hξγ + · exact absurd h hξ0 + · exact h + rw [hIdef, mem_convolutionIndex] at hξI + have hclosure : ∀ b : Series K, closure (b : K⟦ℝ⟧).support ⊆ Set.Iic 0 := fun b ↦ + closure_minimal (HahnSeries.Nonpositive.support_subset b) isClosed_Iic + have hξle : ξ ≤ 0 := hclosure u hξI.1 + have hγξle : γ - ξ ≤ 0 := hclosure v hξI.2 + exact hterm ξ (lt_of_le_of_ne (by linarith) (Ne.symm hξγ)) (lt_of_le_of_ne hξle hξ0) + +end Berarducci + +end diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/MainLemma.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/MainLemma.lean new file mode 100644 index 0000000000..a41647e275 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/MainLemma.lean @@ -0,0 +1,209 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PurePowerRemainder + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValueConstantMul +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValueImage + +/-! +# Ingredients of Berarducci's main lemma + +The proof of Berarducci, Lemma 8.2 rewrites the expected value `⊙^k v_J(b) ⊙ v_J(c)` as the +ordinary product `[⊙^{k-1} v_J(b) ⊙ v_J^r(b) ⊙ v_J(c)] * v_J^p(b)`, so that ordinal +multiplication is continuous in its second argument there; the Hessenberg product is not. The +conversion is justified by the criterion on Cantor terms, and the hypothesis +`v_J^p(b) ≤ v_J^p(c)` is exactly what supplies it: every canonical multiplicative factor of an +ordinal value or of a residual value is at least the corresponding principal value. + +The remaining ingredients are the invariance of the ordinal value under negation and under a +nonzero natural-number scalar. The second is the only place where the characteristic-zero +hypothesis of the source is used: in characteristic `p` the coefficient `k` of the surviving term +could annihilate it. +-/ + +universe v + +public noncomputable section + +open HahnSeries Ordinal + +namespace Berarducci + +variable {K : Type v} [Field K] + +/-- `Y` is additive principal and each of its canonical multiplicative factors is at least +`ω ^ w`. -/ +private def GoodAt (w : Ordinal) (Y : NatOrdinal) : Prop := + IsAdditivelyPrincipal Y.val ∧ + ∀ t ∈ (log omega0 Y.val).additivePrincipalTerms, w ≤ t + +private theorem GoodAt.one (w : Ordinal) : GoodAt w 1 := by + refine ⟨isAdditivelyPrincipal_iff.mpr ⟨0, by simp⟩, fun t ht ↦ ?_⟩ + rw [show ((1 : NatOrdinal).val) = 1 from rfl, log_one_right, + additivePrincipalTerms_zero] at ht + exact absurd ht (List.not_mem_nil) + +private theorem GoodAt.mul {w : Ordinal} {Y Z : NatOrdinal} + (hY : GoodAt w Y) (hZ : GoodAt w Z) : GoodAt w (Y * Z) := by + have hYval : NatOrdinal.of Y.val = Y := NatOrdinal.of_val Y + have hZval : NatOrdinal.of Z.val = Z := NatOrdinal.of_val Z + have hprod : (NatOrdinal.of Y.val * NatOrdinal.of Z.val).val = (Y * Z).val := by + rw [hYval, hZval] + constructor + · obtain ⟨e, he⟩ := isAdditivelyPrincipal_iff.mp hY.1 + obtain ⟨f, hf⟩ := isAdditivelyPrincipal_iff.mp hZ.1 + refine isAdditivelyPrincipal_iff.mpr + ⟨(NatOrdinal.of e + NatOrdinal.of f).val, ?_⟩ + rw [← hprod, he, hf, NatOrdinal.of_omega0_opow, NatOrdinal.of_omega0_opow, + ← NatOrdinal.wpow_add, NatOrdinal.val_wpow] + · intro t ht + rw [← hprod] at ht + rcases mem_additivePrincipalTerms_log_natMul hY.1 hZ.1 ht with h | h + · exact hY.2 t h + · exact hZ.2 t h + +private theorem GoodAt.pow {w : Ordinal} {Y : NatOrdinal} (hY : GoodAt w Y) (n : ℕ) : + GoodAt w (Y ^ n) := by + induction n with + | zero => simpa using GoodAt.one w + | succ n ih => rw [pow_succ]; exact ih.mul hY + +private theorem goodAt_principalValue (b : SeriesWithOrdinalValueAboveOne K) : + GoodAt (log omega0 b.principalValue.val) b.principalValue := by + refine ⟨b.principalValue_isInfiniteMultiplicativelyPrincipal.isAdditivelyPrincipal, + fun t ht ↦ ?_⟩ + rw [additivePrincipalTerms_of_isAdditivelyPrincipal + b.isAdditivelyPrincipal_log_principalValue, List.mem_singleton] at ht + exact ht.ge + +private theorem goodAt_residualValue (b : SeriesWithOrdinalValueAboveOne K) : + GoodAt (log omega0 b.principalValue.val) b.residualValue := + ⟨b.residualValue_isAdditivelyPrincipal, + fun _ ht ↦ b.log_principalValue_le_of_mem_terms_residualValue ht⟩ + +private theorem goodAt_ordinalValue (b : SeriesWithOrdinalValueAboveOne K) : + GoodAt (log omega0 b.principalValue.val) (ordinalValue b.1) := + ⟨ordinalValue_isAdditivelyPrincipal_of_one_lt b.2, + fun _ ht ↦ b.log_principalValue_le_of_mem_terms_ordinalValue ht⟩ + +private theorem GoodAt.mono {w w' : Ordinal} {Y : NatOrdinal} (hY : GoodAt w Y) + (hw : w' ≤ w) : GoodAt w' Y := + ⟨hY.1, fun t ht ↦ hw.trans (hY.2 t ht)⟩ + +private theorem log_principalValue_mono {b c : SeriesWithOrdinalValueAboveOne K} + (hp : b.principalValue ≤ c.principalValue) : + log omega0 b.principalValue.val ≤ log omega0 c.principalValue.val := by + have hle : b.principalValue.val ≤ c.principalValue.val := NatOrdinal.val.monotone hp + rw [← b.principalValue_val_eq_opow_log, ← c.principalValue_val_eq_opow_log] at hle + exact (opow_le_opow_iff_right one_lt_omega0).mp hle + +private theorem goodAt_powerRemainderBound (b c : SeriesWithOrdinalValueAboveOne K) + (hp : b.principalValue ≤ c.principalValue) (m : ℕ) : + GoodAt (log omega0 b.principalValue.val) (powerRemainderBound b c m) := by + rw [powerRemainderBound_eq] + exact (((goodAt_ordinalValue b).pow m).mul (goodAt_residualValue b)).mul + ((goodAt_ordinalValue c).mono (log_principalValue_mono hp)) + +/-- The remainder bound is additive principal. -/ +theorem isAdditivelyPrincipal_powerRemainderBound (b c : SeriesWithOrdinalValueAboveOne K) + (hp : b.principalValue ≤ c.principalValue) (m : ℕ) : + IsAdditivelyPrincipal (powerRemainderBound b c m).val := + (goodAt_powerRemainderBound b c hp m).1 + +/-- The Hessenberg-to-ordinary conversion described above, at the expected value. -/ +theorem powerRemainderBound_mul_principalValue_val + (b c : SeriesWithOrdinalValueAboveOne K) (hp : b.principalValue ≤ c.principalValue) (m : ℕ) : + (powerRemainderBound b c m * b.principalValue).val + = (powerRemainderBound b c m).val * b.principalValue.val := by + have hX := goodAt_powerRemainderBound b c hp m + have h := natOrdinal_of_mul_wpow_eq_mul_of_log_terms + b.isAdditivelyPrincipal_log_principalValue hX.1 hX.2 + rw [b.principalValue_val_eq_opow_log, NatOrdinal.of_val, NatOrdinal.of_val] at h + exact (congrArg NatOrdinal.val h).symm + +private theorem goodAt_powerRemainderBoundOne (b : SeriesWithOrdinalValueAboveOne K) (m : ℕ) : + GoodAt (log omega0 b.principalValue.val) (powerRemainderBoundOne b m) := by + rw [powerRemainderBoundOne_eq] + exact ((goodAt_ordinalValue b).pow m).mul (goodAt_residualValue b) + +/-- The pure-power remainder bound is additive principal. -/ +theorem isAdditivelyPrincipal_powerRemainderBoundOne (b : SeriesWithOrdinalValueAboveOne K) + (m : ℕ) : IsAdditivelyPrincipal (powerRemainderBoundOne b m).val := + (goodAt_powerRemainderBoundOne b m).1 + +/-- The Hessenberg-to-ordinary conversion for a pure power. No comparison of principal values is +needed: both factors of the bound come from `b` itself. -/ +theorem powerRemainderBoundOne_mul_principalValue_val (b : SeriesWithOrdinalValueAboveOne K) + (m : ℕ) : (powerRemainderBoundOne b m * b.principalValue).val + = (powerRemainderBoundOne b m).val * b.principalValue.val := by + have hX := goodAt_powerRemainderBoundOne b m + have h := natOrdinal_of_mul_wpow_eq_mul_of_log_terms + b.isAdditivelyPrincipal_log_principalValue hX.1 hX.2 + rw [b.principalValue_val_eq_opow_log, NatOrdinal.of_val, NatOrdinal.of_val] at h + exact (congrArg NatOrdinal.val h).symm + +/-- Berarducci, Lemma 8.2: a value strictly below the expected one is bounded by a proper +ordinary multiple of the remainder bound. -/ +theorem exists_le_mul_of_lt_powerRemainderBound_mul + (b c : SeriesWithOrdinalValueAboveOne K) (hp : b.principalValue ≤ c.principalValue) (m : ℕ) + {u : NatOrdinal} (hu : u < powerRemainderBound b c m * b.principalValue) : + ∃ α < b.principalValue.val, u.val ≤ (powerRemainderBound b c m).val * α := by + have hlt : u.val < (powerRemainderBound b c m).val * b.principalValue.val := by + rw [← powerRemainderBound_mul_principalValue_val b c hp m] + exact NatOrdinal.val.lt_iff_lt.mpr hu + obtain ⟨α, hα, hlt'⟩ := + (Ordinal.lt_mul_iff_of_isSuccLimit + b.principalValue_isInfiniteMultiplicativelyPrincipal.isSuccLimit).mp hlt + exact ⟨α, hα, hlt'.le⟩ + +private theorem goodAt_prod {w : Ordinal} (l : Multiset (SeriesWithOrdinalValueAboveOne K)) + (hl : ∀ y ∈ l, GoodAt w (ordinalValue y.1)) : + GoodAt w (l.map fun y ↦ ordinalValue y.1).prod := by + induction l using Multiset.induction with + | empty => simpa using GoodAt.one w + | cons a s ih => + rw [Multiset.map_cons, Multiset.prod_cons] + exact (hl a (Multiset.mem_cons_self a s)).mul + (ih fun y hy ↦ hl y (Multiset.mem_cons_of_mem hy)) + +/-- If every factor of a product has principal value at least that of `b`, then so does the +product. This supplies the hypothesis of Lemma 8.2 when the second factor is itself a product. -/ +theorem principalValue_le_of_forall_mem (b c : SeriesWithOrdinalValueAboveOne K) + (l : Multiset (SeriesWithOrdinalValueAboveOne K)) + (hl : ∀ y ∈ l, b.principalValue ≤ y.principalValue) + (hc : ordinalValue c.1 = (l.map fun y ↦ ordinalValue y.1).prod) : + b.principalValue ≤ c.principalValue := by + have hgood := goodAt_prod (w := log omega0 b.principalValue.val) l + fun y hy ↦ (goodAt_ordinalValue y).mono (log_principalValue_mono (hl y hy)) + rw [← hc] at hgood + exact b.le_principalValue_of_forall_mem_terms c fun t ht ↦ hgood.2 t ht + +theorem ordinalValue_neg (x : Series K) : ordinalValue (-x) = ordinalValue x := by + have hx : -x = HahnSeries.Nonpositive.C (-1 : K) * x := by + rw [map_neg, map_one, neg_one_mul] + rw [hx, ordinalValue_C_mul (neg_ne_zero.mpr one_ne_zero)] + +theorem germOrdinalValue_neg (q : Germ K) : germOrdinalValue (-q) = germOrdinalValue q := by + obtain ⟨x, rfl⟩ := Ideal.Quotient.mk_surjective q + rw [← map_neg, germOrdinalValue_mk, germOrdinalValue_mk, ordinalValue_neg] + +/-- A nonzero natural-number scalar does not change the ordinal value. This is the only place +where the characteristic-zero hypothesis is used. -/ +theorem ordinalValue_nsmul {n : ℕ} (hn : (n : K) ≠ 0) (x : Series K) : + ordinalValue (n • x) = ordinalValue x := by + have hns : (n • x : Series K) = HahnSeries.Nonpositive.C ((n : K)) * x := by + rw [map_natCast HahnSeries.Nonpositive.C n] + exact nsmul_eq_mul _ _ + rw [hns, ordinalValue_C_mul hn] + +theorem germOrdinalValue_nsmul {n : ℕ} (hn : (n : K) ≠ 0) (q : Germ K) : + germOrdinalValue (n • q) = germOrdinalValue q := by + obtain ⟨x, rfl⟩ := Ideal.Quotient.mk_surjective q + rw [← map_nsmul, germOrdinalValue_mk, germOrdinalValue_mk, ordinalValue_nsmul hn] + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/OneRow.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/OneRow.lean new file mode 100644 index 0000000000..c2e45b5ee2 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/OneRow.lean @@ -0,0 +1,262 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Irreducibility +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.NonpositiveCoefficientMap + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Domain + +/-! +# The one-row irreducibles + +The series + +`a = Σ n : ℕ, t ^ (-1 / (n + 1))` + +has support order type `ω`, with supremum zero approached from below. Berarducci, Theorem 10.5 +therefore proves that both `a` and `a + 1` are irreducible over every characteristic-zero +coefficient field. The second series is the signed Hahn-series form of Conway's one-row omnific +integer `1 + Σ n, ω ^ (1 / (n + 1))`, discussed in LM24, Example 9.2.8. + +## References + +* A. Berarducci, *Factorization in generalized power series*, Trans. Amer. Math. Soc. 352 + (2000), 553–577, cited as [Ber00]. +* S. L'Innocente, V. Mantova, *A factorisation theory for generalised power series and omnific + integers*, Adv. Math. 442 (2024) 109513, cited as [LM24]. +-/ + +universe v w + +open scoped HahnSeries + +public noncomputable section + +namespace Berarducci.OneRow + +variable {K : Type v} [Field K] + +/-- The `n`-th exponent in the one-row series approaching zero from below. -/ +def exponent (n : ℕ) : ℝ := + -(1 / (n + 1 : ℝ)) + +@[simp] +theorem exponent_apply (n : ℕ) : exponent n = -(1 / (n + 1 : ℝ)) := + (rfl) + +private theorem exponent_strictMono : StrictMono exponent := + strictMono_nat_of_lt_succ fun n ↦ by + rw [exponent_apply, exponent_apply] + apply neg_lt_neg + apply one_div_lt_one_div_of_lt + · positivity + · norm_num + +/-- The order embedding enumerating the support of the one-row series. -/ +def exponentEmbedding : ℕ ↪o ℝ := + OrderEmbedding.ofStrictMono exponent exponent_strictMono + +@[simp] +theorem exponentEmbedding_apply (n : ℕ) : exponentEmbedding n = exponent n := + (rfl) + +private def coefficientOne : K⟦ℕ⟧ where + coeff _ := 1 + isPWO_support' := by + simpa [Function.support] using Set.IsPWO.of_linearOrder (Set.univ : Set ℕ) + +private theorem coefficientOne_support : (coefficientOne (K := K)).support = Set.univ := by + ext n + simp [coefficientOne] + +/-- The coefficient-one nonpositive Hahn series `Σ n, t ^ (-1 / (n + 1))`. -/ +def withoutConstant : Series K := + ⟨HahnSeries.embDomain exponentEmbedding (coefficientOne (K := K)), by + rw [HahnSeries.mem_nonpositiveSubring, + HahnSeries.support_embDomain, coefficientOne_support, Set.image_univ] + rintro _ ⟨n, rfl⟩ + rw [exponentEmbedding_apply, exponent_apply] + exact neg_nonpos.mpr (show 0 ≤ 1 / (n + 1 : ℝ) by positivity)⟩ + +/-- Every exponent displayed in the one-row series has coefficient one. -/ +theorem withoutConstant_coeff_exponent (n : ℕ) : + (withoutConstant (K := K) : K⟦ℝ⟧).coeff (exponent n) = 1 := by + rw [withoutConstant, ← exponentEmbedding_apply, HahnSeries.embDomain_coeff] + rfl + +/-- The support of the one-row series is exactly its displayed exponent sequence. -/ +theorem withoutConstant_support : + (withoutConstant (K := K) : K⟦ℝ⟧).support = Set.range exponentEmbedding := by + rw [withoutConstant, HahnSeries.support_embDomain, + coefficientOne_support, Set.image_univ] + +/-- Coefficient extension preserves the coefficient-one row. -/ +theorem nonpositiveCoefficientMap_withoutConstant + {E : Type w} [Field E] (f : K →+* E) : + HahnSeries.Nonpositive.nonpositiveCoefficientMap f + (withoutConstant (K := K)) = + withoutConstant (K := E) := by + apply Subtype.ext + apply HahnSeries.coeff_injective + funext x + by_cases hx : x ∈ Set.range exponentEmbedding + · obtain ⟨n, rfl⟩ := hx + rw [HahnSeries.Nonpositive.coe_nonpositiveCoefficientMap] + simp only [exponentEmbedding_apply, withoutConstant_coeff_exponent, map_one] + · have hK : (withoutConstant (K := K) : K⟦ℝ⟧).coeff x = 0 := by + rw [← not_ne_iff, ← HahnSeries.mem_support, withoutConstant_support] + exact hx + have hE : (withoutConstant (K := E) : E⟦ℝ⟧).coeff x = 0 := by + rw [← not_ne_iff, ← HahnSeries.mem_support, withoutConstant_support] + exact hx + rw [HahnSeries.Nonpositive.coe_nonpositiveCoefficientMap, hK, map_zero, hE] + +@[simp] +theorem withoutConstant_coeff_zero : + (withoutConstant (K := K) : K⟦ℝ⟧).coeff 0 = 0 := by + rw [← not_ne_iff, ← HahnSeries.mem_support, withoutConstant_support] + rintro ⟨n, hn⟩ + have hneg : exponentEmbedding n < 0 := by + rw [exponentEmbedding_apply, exponent_apply] + exact neg_lt_zero.mpr (by positivity) + exact hneg.ne hn + +/-- The support of the one-row series has order type `ω`. -/ +theorem withoutConstant_supportOrderType : + (withoutConstant (K := K) : K⟦ℝ⟧).supportOrderType = Ordinal.omega0 := by + rw [HahnSeries.supportOrderType_eq_setOrderType] + have e : (withoutConstant (K := K) : K⟦ℝ⟧).support ≃o ℕ := + (Set.orderIsoOfEq _ (Set.range exponentEmbedding) + (withoutConstant_support (K := K))).trans exponentEmbedding.orderIso.symm + exact (withoutConstant (K := K) : K⟦ℝ⟧).isPWO_support + |>.orderType_eq_typeLT_of_orderIso e |>.trans Ordinal.type_nat_lt + +private theorem withoutConstant_isLUB : + IsLUB (withoutConstant (K := K) : K⟦ℝ⟧).support 0 := by + rw [withoutConstant_support] + constructor + · rintro _ ⟨n, rfl⟩ + rw [exponentEmbedding_apply, exponent_apply] + exact neg_nonpos.mpr (by positivity) + · intro a ha + by_contra hnot + have haNeg : a < 0 := lt_of_not_ge hnot + obtain ⟨n, hn⟩ := exists_nat_one_div_lt (neg_pos.mpr haNeg) + have hle := ha (Set.mem_range_self n) + rw [exponentEmbedding_apply, exponent_apply] at hle + linarith + +/-- The support supremum is zero and is not attained. -/ +theorem withoutConstant_supportSup : + HahnSeries.Nonpositive.supportSup (withoutConstant (K := K)) = 0 := by + apply HahnSeries.Nonpositive.supportSup_eq_coe_iff.mpr + refine ⟨?_, withoutConstant_isLUB (K := K)⟩ + intro hzero + have hcoeff := withoutConstant_coeff_exponent (K := K) 0 + rw [hzero] at hcoeff + change (0 : K) = 1 at hcoeff + exact zero_ne_one hcoeff + +/-- No strictly negative monomial divides the one-row series. -/ +theorem negative_single_not_dvd_withoutConstant + (gamma : ℝ) (hgamma : gamma < 0) : + ¬ HahnSeries.Nonpositive.single gamma (1 : K) hgamma.le ∣ + withoutConstant (K := K) := by + have hnotJ : withoutConstant (K := K) ∉ + HahnSeries.Nonpositive.negativeMonomialIdeal K := by + rw [HahnSeries.Nonpositive.mem_negativeMonomialIdeal_iff_supportSup_lt_zero, + withoutConstant_supportSup] + exact lt_irrefl 0 + intro hdvd + obtain ⟨c, hc⟩ := hdvd + apply hnotJ + rw [hc] + apply Ideal.mul_mem_right c + rw [HahnSeries.Nonpositive.mem_negativeMonomialIdeal_iff_supportSup_lt_zero, + HahnSeries.Nonpositive.supportSup_single one_ne_zero] + exact_mod_cast hgamma + +/-- The one-row series with its final constant coefficient one. -/ +def withConstant : Series K := + withoutConstant (K := K) + 1 + +/-- Coefficient extension preserves the constant-capped coefficient-one row. -/ +theorem nonpositiveCoefficientMap_withConstant + {E : Type w} [Field E] (f : K →+* E) : + HahnSeries.Nonpositive.nonpositiveCoefficientMap f + (withConstant (K := K)) = + withConstant (K := E) := by + rw [withConstant, withConstant, map_add, map_one, + nonpositiveCoefficientMap_withoutConstant] + +theorem withConstant_coeff_exponent (n : ℕ) : + (withConstant (K := K) : K⟦ℝ⟧).coeff (exponent n) = 1 := by + rw [withConstant, Subring.coe_add, HahnSeries.coeff_add, + withoutConstant_coeff_exponent, show ((1 : Series K) : K⟦ℝ⟧) = 1 from rfl] + have hne : exponent n ≠ 0 := by + rw [exponent_apply] + exact (neg_lt_zero.mpr (by positivity)).ne + rw [HahnSeries.coeff_one, ite_eq_right hne, add_zero] + +@[simp] +theorem withConstant_coeff_zero : + (withConstant (K := K) : K⟦ℝ⟧).coeff 0 = 1 := by + rw [withConstant, Subring.coe_add, HahnSeries.coeff_add, + withoutConstant_coeff_zero] + simp + +/-- The constant coefficient of the capped row is one. -/ +theorem withConstant_constantCoeff : + HahnSeries.Nonpositive.constantCoeff (withConstant (K := K)) = 1 := by + rw [HahnSeries.Nonpositive.constantCoeff_apply, withConstant_coeff_zero] + +/-- The support of the constant-capped series is the one-row sequence followed by zero. -/ +theorem withConstant_support : + (withConstant (K := K) : K⟦ℝ⟧).support = Set.range exponentEmbedding ∪ {0} := by + ext x + by_cases hx : x = 0 + · subst x + simp [withConstant_coeff_zero] + · have hone : (1 : K⟦ℝ⟧).coeff x = 0 := by + rw [HahnSeries.coeff_one, ite_eq_right hx] + rw [HahnSeries.mem_support, withConstant, Subring.coe_add, + HahnSeries.coeff_add, show ((1 : Series K) : K⟦ℝ⟧) = 1 from rfl, + hone, add_zero, ← HahnSeries.mem_support, withoutConstant_support] + simp [hx] + +private theorem withoutConstant_supportBelow_one : + HahnSeries.SupportBelow (withoutConstant (K := K) : K⟦ℝ⟧) 1 := by + rw [HahnSeries.supportBelow_iff] + intro i hi j hj + rw [withoutConstant_support] at hi + obtain ⟨n, rfl⟩ := hi + have hj0 : j = 0 := by + simpa [HahnSeries.support_one] using hj + subst j + rw [exponentEmbedding_apply, exponent_apply] + exact neg_lt_zero.mpr (by positivity) + +/-- The support of the constant-capped one-row series has order type `ω + 1`. -/ +theorem withConstant_supportOrderType : + (withConstant (K := K) : K⟦ℝ⟧).supportOrderType = Ordinal.omega0 + 1 := by + apply (HahnSeries.supportOrderType_eq_add_iff _ _ _).mpr + refine ⟨(withoutConstant (K := K) : K⟦ℝ⟧), 1, + withoutConstant_supportBelow_one (K := K), + withoutConstant_supportOrderType (K := K), ?_, ?_⟩ + · change (HahnSeries.C (1 : K)).supportOrderType = 1 + rw [HahnSeries.C_apply, HahnSeries.supportOrderType_single one_ne_zero] + · rfl + +/-- Berarducci's theorem makes both the one-row series and its constant-capped form irreducible. -/ +theorem irreducible_withoutConstant_and_withConstant [CharZero K] : + Irreducible (withoutConstant (K := K)) ∧ + Irreducible (withConstant (K := K)) := by + apply Berarducci.irreducible_and_add_one_of_supportOrderType + · exact negative_single_not_dvd_withoutConstant + · exact Or.inl withoutConstant_supportOrderType + +end Berarducci.OneRow diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/OrderTypeMultiplicativity.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/OrderTypeMultiplicativity.lean new file mode 100644 index 0000000000..b39ae46582 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/OrderTypeMultiplicativity.lean @@ -0,0 +1,214 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Multiplicativity +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValue + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValueFinalSegment +import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.Sumset +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Statements.ProductValue + +/-! +# Multiplicativity of the support order type + +Berarducci, Corollary 9.9, imported by LM24 as Fact 3.4.1: the support order type is +multiplicative for the Hessenberg product on series whose order types are additively principal. + +The ordinal value is bounded above by the support order type, and on a series outside `J` whose +order type is additively principal the two agree: a representative modulo `J + K` shares a final +segment of the support, and a nonempty final segment of an additively principal order type has +the full order type. The order type of a product is bounded above by the Hessenberg product of +the order types, because the support of a product lies in the sumset of the supports. Theorem 9.7 +supplies the matching lower bound, and the two squeeze. +-/ + +universe v + +public noncomputable section + +open HahnSeries Ordinal + +namespace Berarducci + +variable {K : Type v} [Field K] + +/-- Berarducci, Remark 5.4: the support order type of a product is at most the Hessenberg product +of the support order types. -/ +theorem supportOrderType_mul_le_naturalMul (b c : K⟦ℝ⟧) : + (b * c).supportOrderType + ≤ (NatOrdinal.of b.supportOrderType * NatOrdinal.of c.supportOrderType).val := by + rw [supportOrderType_eq_setOrderType, supportOrderType_eq_setOrderType, + supportOrderType_eq_setOrderType] + exact ((b * c).isPWO_support.orderType_mono (b.isPWO_support.add c.isPWO_support) + HahnSeries.support_mul_subset).trans + (Set.IsPWO.orderType_add_le_naturalMul b.isPWO_support c.isPWO_support) + +/-- A series outside `J` has support points arbitrarily close to zero. -/ +private theorem exists_mem_support_gt {b : Series K} + (hbJ : b ∉ HahnSeries.Nonpositive.negativeMonomialIdeal K) {η : ℝ} (hη : η < 0) : + ∃ y ∈ (b : K⟦ℝ⟧).support, η < y := by + have hlub := isLUB_support_zero_of_ordinalValue_ne_zero + (b := b) (fun h ↦ hbJ (ordinalValue_eq_zero_iff.mp h)) + by_contra hcon + exact absurd (hlub.2 fun y hy ↦ le_of_not_gt fun hgt ↦ hcon ⟨y, hy, hgt⟩) (not_le.mpr hη) + +/-- Above order type one an additively principal order type is a limit, so the support has no +maximum and in particular misses the origin. -/ +private theorem notMem_support_zero_of_ne_one {b : Series K} + (hb : IsWeaklyPrincipal (b : K⟦ℝ⟧)) (h1 : (b : K⟦ℝ⟧).supportOrderType ≠ 1) : + (0 : ℝ) ∉ (b : K⟦ℝ⟧).support := by + obtain ⟨e, he⟩ := isAdditivelyPrincipal_iff.mp (isWeaklyPrincipal_iff.mp hb) + have hene : e ≠ 0 := by + rintro rfl + exact h1 (by simpa using he) + have hlim : Order.IsSuccLimit (b : K⟦ℝ⟧).supportOrderType := by + rw [he] + exact Ordinal.isSuccLimit_opow_left Ordinal.isSuccLimit_omega0 hene + intro h0 + obtain ⟨y, hy, hy0⟩ := (b : K⟦ℝ⟧).isPWO_support.exists_gt_of_isSuccLimit_orderType + (by rwa [← supportOrderType_eq_setOrderType]) h0 + exact absurd ((HahnSeries.mem_nonpositiveSubring (Γ := ℝ) (R := K)).mp b.2 hy) (not_le.mpr hy0) + +/-- A representative modulo `J + K` of a series outside `J` whose order type is additively +principal has at least that order type. Above one the order type is a limit, so the support has no +maximum and in particular misses the origin, where a constant summand could have changed it; the +two supports then share a final segment, which carries the whole order type. -/ +private theorem supportOrderType_le_of_sub_mem_nearConstantSubgroup {b c : Series K} + (hb : IsWeaklyPrincipal (b : K⟦ℝ⟧)) + (hbJ : b ∉ HahnSeries.Nonpositive.negativeMonomialIdeal K) + (hbc : b - c ∈ nearConstantSubgroup K) (hc : c ≠ 0) : + (b : K⟦ℝ⟧).supportOrderType ≤ (c : K⟦ℝ⟧).supportOrderType := by + have hbsupp : (b : K⟦ℝ⟧).support ⊆ Set.Iic (0 : ℝ) := + (HahnSeries.mem_nonpositiveSubring (Γ := ℝ) (R := K)).mp b.2 + rcases eq_or_ne (b : K⟦ℝ⟧).supportOrderType 1 with h1 | h1 + · rw [h1] + refine Order.one_le_iff_ne_zero.mpr fun h0 ↦ hc ?_ + rw [supportOrderType_eq_setOrderType, Set.IsPWO.orderType_eq_zero] at h0 + exact Subtype.ext (HahnSeries.support_eq_empty_iff.mp h0) + · have hzero := notMem_support_zero_of_ne_one hb h1 + obtain ⟨η, hη, hcoeff⟩ := exists_coeff_eq_of_sub_mem_nearConstantSubgroup hbc + have hprin : + Ordinal.IsPrincipal (fun a b ↦ a + b) (b : K⟦ℝ⟧).isPWO_support.orderType := by + rw [← supportOrderType_eq_setOrderType] + exact (isAdditivelyPrincipal_iff_ne_zero_and_isPrincipal_add.mp + (isWeaklyPrincipal_iff.mp hb)).2 + have hseg := (b : K⟦ℝ⟧).isPWO_support.orderType_inter_Ioi_eq_of_isPrincipal hprin + (exists_mem_support_gt hbJ hη) + have hsub : (b : K⟦ℝ⟧).support ∩ Set.Ioi η ⊆ (c : K⟦ℝ⟧).support := by + intro y hy + have hy0 : y < 0 := lt_of_le_of_ne (hbsupp hy.1) fun h ↦ hzero (h ▸ hy.1) + rw [HahnSeries.mem_support, ← hcoeff y hy.2 hy0] + exact (HahnSeries.mem_support _ _).mp hy.1 + rw [supportOrderType_eq_setOrderType, ← hseg, supportOrderType_eq_setOrderType] + exact Set.IsPWO.orderType_mono _ _ hsub + +/-- On a series outside `J` whose order type is additively principal, the support order type and +the ordinal value agree. -/ +theorem supportOrderType_eq_ordinalValue_of_isWeaklyPrincipal {b : Series K} + (hb : IsWeaklyPrincipal (b : K⟦ℝ⟧)) + (hbJ : b ∉ HahnSeries.Nonpositive.negativeMonomialIdeal K) : + (b : K⟦ℝ⟧).supportOrderType = (ordinalValue b).val := by + refine le_antisymm ?_ (NatOrdinal.val.monotone (ordinalValue_le_supportOrderType b)) + by_cases hbNear : b ∈ nearConstantSubgroup K + · rw [ordinalValue_of_mem_nearConstantSubgroup_of_not_mem_negativeMonomialIdeal hbNear hbJ] + rcases eq_or_ne (b : K⟦ℝ⟧).supportOrderType 1 with h1 | h1 + · rw [h1] + simp + · refine absurd ?_ hbJ + have hcc : HahnSeries.Nonpositive.constantCoeff b = 0 := by + by_contra hne + exact notMem_support_zero_of_ne_one hb h1 ((HahnSeries.mem_support _ _).mpr + (by rwa [HahnSeries.Nonpositive.constantCoeff_apply] at hne)) + have hsub := mem_nearConstantSubgroup_iff_sub_C_constantCoeff_mem.mp hbNear + rwa [hcc, map_zero, _root_.sub_zero] at hsub + · obtain ⟨hmem, -⟩ := ordinalValue_isLeast_representativeOrderTypes hbNear + obtain ⟨d, hd, hdeq⟩ := mem_representativeOrderTypes_iff.mp hmem + have hdne : d ≠ 0 := by + rintro rfl + rw [_root_.sub_zero] at hd + exact hbNear hd + rw [← hdeq, NatOrdinal.val_of] + exact supportOrderType_le_of_sub_mem_nearConstantSubgroup hb hbJ hd hdne + +/-- Berarducci, Corollary 9.9 for series outside `J`: the ordinal value and the support order +type coincide there, and Theorem 9.7 supplies the lower bound that meets Remark 5.4. -/ +private theorem supportOrderType_mul_of_notMem_negativeMonomialIdeal [CharZero K] {b c : Series K} + (hb : IsWeaklyPrincipal (b : K⟦ℝ⟧)) (hc : IsWeaklyPrincipal (c : K⟦ℝ⟧)) + (hbJ : b ∉ HahnSeries.Nonpositive.negativeMonomialIdeal K) + (hcJ : c ∉ HahnSeries.Nonpositive.negativeMonomialIdeal K) : + ((b * c : Series K) : K⟦ℝ⟧).supportOrderType + = (NatOrdinal.of (b : K⟦ℝ⟧).supportOrderType * + NatOrdinal.of (c : K⟦ℝ⟧).supportOrderType).val := by + refine le_antisymm ?_ ?_ + · rw [show ((b * c : Series K) : K⟦ℝ⟧) = (b : K⟦ℝ⟧) * (c : K⟦ℝ⟧) from rfl] + exact supportOrderType_mul_le_naturalMul _ _ + · rw [supportOrderType_eq_ordinalValue_of_isWeaklyPrincipal hb hbJ, + supportOrderType_eq_ordinalValue_of_isWeaklyPrincipal hc hcJ, NatOrdinal.of_val, + NatOrdinal.of_val, ← ordinalValue_mul b c] + exact NatOrdinal.val.monotone (ordinalValue_le_supportOrderType (b * c)) + +end Berarducci + +namespace HahnSeries.Nonpositive + +variable {K : Type v} [Field K] + +/-- Berarducci, Corollary 9.9, imported by LM24 as Fact 3.4.1. Normalizing each factor moves it +out of `J` without changing any order type, since translation is an order isomorphism of the +exponents and the product of two translates is a translate of the product. -/ +@[blueprint "fact:weakly-principal-order-type-multiplicativity" + (phase := "Ordinal value and degree") + (title := "Multiplicativity of order type for weakly principal series \ + (Ber00, Corollary 9.9; LM24, Fact 3.4.1)") + (statement := /-- + Let $K$ be a field of characteristic zero. If + $b,c\in K((\mathbb R^{\le 0}))$ are weakly principal, then + \[ + \operatorname{ot}(bc)= + \operatorname{ot}(b)\odot\operatorname{ot}(c). + \] + -/) + (proof := /-- + Translate each factor so that the supremum of its support is zero. Translation + preserves the three support order types and places both factors outside $J$. + For a weakly principal series outside $J$, its support order type equals its + ordinal value. \ref{fact:ordinal-value-multiplicativity} gives the lower bound for + the product, while containment of its support in the sum of the two supports + gives the reverse bound. + -/)] +theorem orderTypeMultiplicativeOnWeaklyPrincipal [CharZero K] : + OrderTypeMultiplicativeOnWeaklyPrincipal K := by + refine orderTypeMultiplicativeOnWeaklyPrincipal_iff.mpr fun b c hb hc ↦ ?_ + have hne : ∀ x : Berarducci.Series K, IsWeaklyPrincipal (x : K⟦ℝ⟧) → x ≠ 0 := by + rintro x hx rfl + exact (isAdditivelyPrincipal_iff_ne_zero_and_isPrincipal_add.mp + (isWeaklyPrincipal_iff.mp hx)).1 (by + rw [HahnSeries.supportOrderType_eq_setOrderType, Set.IsPWO.orderType_eq_zero] + simp) + set sb := sSup (b : K⟦ℝ⟧).support with hsb + set sc := sSup (c : K⟦ℝ⟧).support with hsc + have hbot : (normalize b : K⟦ℝ⟧).supportOrderType = (b : K⟦ℝ⟧).supportOrderType := + supportOrderType_normalize b + have hcot : (normalize c : K⟦ℝ⟧).supportOrderType = (c : K⟦ℝ⟧).supportOrderType := + supportOrderType_normalize c + have hmul : (b : K⟦ℝ⟧) * (c : K⟦ℝ⟧) + = HahnSeries.translate (sb + sc) + ((normalize b : K⟦ℝ⟧) * (normalize c : K⟦ℝ⟧)) := by + have h := HahnSeries.translate_mul_translate sb sc + (normalize b : K⟦ℝ⟧) (normalize c : K⟦ℝ⟧) + rwa [translate_csSup_normalize b, translate_csSup_normalize c] at h + rw [show ((b * c : Berarducci.Series K) : K⟦ℝ⟧) = + (b : K⟦ℝ⟧) * (c : K⟦ℝ⟧) from rfl, + hmul, HahnSeries.supportOrderType_translate, ← hbot, ← hcot] + exact Berarducci.supportOrderType_mul_of_notMem_negativeMonomialIdeal + (by rwa [isWeaklyPrincipal_iff, hbot, ← isWeaklyPrincipal_iff]) + (by rwa [isWeaklyPrincipal_iff, hcot, ← isWeaklyPrincipal_iff]) + (not_mem_negativeMonomialIdeal_of_supportSup_eq_zero (supportSup_normalize (hne b hb))) + (not_mem_negativeMonomialIdeal_of_supportSup_eq_zero (supportSup_normalize (hne c hc))) + +end HahnSeries.Nonpositive diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/OrdinalValue.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/OrdinalValue.lean new file mode 100644 index 0000000000..97bd0ef510 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/OrdinalValue.lean @@ -0,0 +1,422 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Germ +public import LeanPool.ConwayRefinement.CombinatorialGames.NatOrdinal.Basic + +import Mathlib.Tactic.Abel + +/-! +# Berarducci's ordinal value + +This module defines the ordinal value `Berarducci.ordinalValue` by the three disjoint clauses in +Berarducci, Definition 5.2 and LM24, Section 2.7: + +* it is zero on the negative-monomial ideal `J`; +* it is one on `(J + K) \ J`; +* otherwise it is the least support order type among representatives congruent modulo `J + K`. + +`NatOrdinal` is a type synonym for ordinals equipped with Hessenberg addition and multiplication; +its underlying order is the ordinary ordinal order. Using it here preserves the source value while +making the later multiplicative statement type-correct without introducing parallel operations. + +The third branch is not postulated to have a minimum. Its candidate set contains the original +series, and the well-order of `NatOrdinal` proves that its infimum is a member and is least. The +characteristic theorems prove the exact zero and one fibers, invariance modulo `J`, and the induced +separated value on the germ quotient. No additive or multiplicative law is asserted in this file. + +The definition and these order-theoretic properties make sense over any field. Berarducci's +additive and multiplicative theorems retain the source's characteristic-zero hypothesis. +-/ + +universe v + +public noncomputable section + +namespace Berarducci + +open HahnSeries + +variable {K : Type v} [Field K] + +/-- The support order types of series congruent to `b` modulo Berarducci's subgroup `J + K`. -/ +def representativeOrderTypes (b : Series K) : Set NatOrdinal := + {o | ∃ c : Series K, + b - c ∈ nearConstantSubgroup K ∧ + NatOrdinal.of (c : K⟦ℝ⟧).supportOrderType = o} + +/-- Membership in the set of support order types of representatives congruent to `b`. -/ +theorem mem_representativeOrderTypes_iff {b : Series K} {o : NatOrdinal} : + o ∈ representativeOrderTypes b ↔ + ∃ c : Series K, + b - c ∈ nearConstantSubgroup K ∧ + NatOrdinal.of (c : K⟦ℝ⟧).supportOrderType = o := by + rfl + +/-- The candidate set for the third branch of the ordinal value is nonempty. -/ +theorem representativeOrderTypes_nonempty (b : Series K) : + (representativeOrderTypes b).Nonempty := by + refine ⟨NatOrdinal.of (b : K⟦ℝ⟧).supportOrderType, b, ?_, rfl⟩ + simp + +/-- Berarducci's ordinal value on nonpositive real Hahn series. -/ +noncomputable def ordinalValue (b : Series K) : NatOrdinal := by + classical + exact if b ∈ HahnSeries.Nonpositive.negativeMonomialIdeal K then 0 + else if b ∈ nearConstantSubgroup K then 1 + else sInf (representativeOrderTypes b) + +/-- The first defining clause of the ordinal value. -/ +theorem ordinalValue_of_mem_negativeMonomialIdeal {b : Series K} + (hb : b ∈ HahnSeries.Nonpositive.negativeMonomialIdeal K) : + ordinalValue b = 0 := by + simp [ordinalValue, hb] + +/-- The second defining clause of the ordinal value. -/ +theorem ordinalValue_of_mem_nearConstantSubgroup_of_not_mem_negativeMonomialIdeal + {b : Series K} (hbNear : b ∈ nearConstantSubgroup K) + (hbJ : b ∉ HahnSeries.Nonpositive.negativeMonomialIdeal K) : + ordinalValue b = 1 := by + simp [ordinalValue, hbJ, hbNear] + +/-- The third defining clause of the ordinal value. -/ +theorem ordinalValue_of_not_mem_nearConstantSubgroup {b : Series K} + (hb : b ∉ nearConstantSubgroup K) : + ordinalValue b = sInf (representativeOrderTypes b) := by + have hbJ : b ∉ HahnSeries.Nonpositive.negativeMonomialIdeal K := + fun hbJ ↦ hb (negativeMonomialIdeal_le_nearConstantSubgroup hbJ) + simp [ordinalValue, hbJ, hb] + +/-- Outside `J + K`, the ordinal value is attained by a congruent representative. -/ +theorem ordinalValue_mem_representativeOrderTypes_of_not_mem_nearConstantSubgroup + {b : Series K} + (hb : b ∉ nearConstantSubgroup K) : + ordinalValue b ∈ representativeOrderTypes b := by + rw [ordinalValue_of_not_mem_nearConstantSubgroup hb] + exact csInf_mem (representativeOrderTypes_nonempty b) + +/-- The support order type of a nonzero constant series is one. -/ +private theorem supportOrderType_C_eq_one {k : K} (hk : k ≠ 0) : + ((HahnSeries.Nonpositive.C k : Series K) : K⟦ℝ⟧).supportOrderType = 1 := by + rw [HahnSeries.Nonpositive.coe_C, HahnSeries.C_apply] + exact HahnSeries.supportOrderType_single hk + +/-- In every branch of its definition, the ordinal value is attained by a representative +congruent modulo `J + K`. -/ +theorem ordinalValue_mem_representativeOrderTypes (b : Series K) : + ordinalValue b ∈ representativeOrderTypes b := by + by_cases hbJ : b ∈ HahnSeries.Nonpositive.negativeMonomialIdeal K + · rw [ordinalValue_of_mem_negativeMonomialIdeal hbJ] + apply mem_representativeOrderTypes_iff.mpr + refine ⟨0, ?_, by simp⟩ + exact negativeMonomialIdeal_le_nearConstantSubgroup (by simpa using hbJ) + by_cases hbNear : b ∈ nearConstantSubgroup K + · rw [ordinalValue_of_mem_nearConstantSubgroup_of_not_mem_negativeMonomialIdeal + hbNear hbJ] + let k := HahnSeries.Nonpositive.constantCoeff b + have hk : k ≠ 0 := by + intro hk + apply hbJ + have hsub := mem_nearConstantSubgroup_iff_sub_C_constantCoeff_mem.mp hbNear + simpa [k, hk] using hsub + apply mem_representativeOrderTypes_iff.mpr + refine ⟨HahnSeries.Nonpositive.C k, ?_, ?_⟩ + · exact negativeMonomialIdeal_le_nearConstantSubgroup + (mem_nearConstantSubgroup_iff_sub_C_constantCoeff_mem.mp hbNear) + · rw [supportOrderType_C_eq_one hk] + simp + · exact ordinalValue_mem_representativeOrderTypes_of_not_mem_nearConstantSubgroup hbNear + +/-- A common lower bound for all representative support order types is a lower bound for the +ordinal value. -/ +theorem le_ordinalValue_of_forall_mem_representativeOrderTypes + {b : Series K} {o : NatOrdinal} + (h : ∀ p ∈ representativeOrderTypes b, o ≤ p) : + o ≤ ordinalValue b := + h _ (ordinalValue_mem_representativeOrderTypes b) + +/-- Outside `J + K`, the ordinal value is the least candidate support order type. -/ +theorem ordinalValue_isLeast_representativeOrderTypes {b : Series K} + (hb : b ∉ nearConstantSubgroup K) : + IsLeast (representativeOrderTypes b) (ordinalValue b) := by + refine ⟨ordinalValue_mem_representativeOrderTypes b, ?_⟩ + intro o ho + rw [ordinalValue_of_not_mem_nearConstantSubgroup hb] + exact csInf_le' ho + +private theorem mem_nearConstantSubgroup_of_supportOrderType_le_one + {b : Series K} + (hbType : NatOrdinal.of (b : K⟦ℝ⟧).supportOrderType ≤ 1) : + b ∈ nearConstantSubgroup K := by + rcases Order.le_one_iff.mp hbType with hbZero | hbOne + · have hbTypeZero : (b : K⟦ℝ⟧).supportOrderType = 0 := by + simpa using hbZero + have hb : b = 0 := by + apply Subtype.ext + exact HahnSeries.supportOrderType_eq_zero.mp hbTypeZero + subst b + exact (nearConstantSubgroup K).zero_mem + · have hbTypeOne : (b : K⟦ℝ⟧).supportOrderType = 1 := by + simpa using hbOne + let : WellFoundedLT (b : K⟦ℝ⟧).support := + (b : K⟦ℝ⟧).isWF_support + have htype : Ordinal.type + (fun x y : (b : K⟦ℝ⟧).support ↦ x < y) = 1 := by + rw [← HahnSeries.supportOrderType_eq_typeLT (x := (b : K⟦ℝ⟧)) + (OrderIso.refl (b : K⟦ℝ⟧).support)] + exact hbTypeOne + obtain ⟨hUnique⟩ := Ordinal.type_eq_one_iff_unique.mp htype + let : Unique (b : K⟦ℝ⟧).support := hUnique + let g : (b : K⟦ℝ⟧).support := default + have hsupport : (b : K⟦ℝ⟧).support = {(g : ℝ)} := by + ext x + constructor + · intro hx + have heq : (⟨x, hx⟩ : (b : K⟦ℝ⟧).support) = g := + Subsingleton.elim _ _ + exact Set.mem_singleton_iff.mpr (congrArg Subtype.val heq) + · intro hx + rw [Set.mem_singleton_iff] at hx + subst x + exact g.2 + have hbSingle : (b : K⟦ℝ⟧) = + HahnSeries.single (g : ℝ) ((b : K⟦ℝ⟧).coeff g) := by + ext x + by_cases hx : x = (g : ℝ) + · subst x + simp + · have hxSupport : x ∉ (b : K⟦ℝ⟧).support := by + rw [hsupport] + simpa using hx + have hxCoeff : (b : K⟦ℝ⟧).coeff x = 0 := by + rw [HahnSeries.mem_support] at hxSupport + exact not_ne_iff.mp hxSupport + simp [hx, hxCoeff] + have hgNonpositive : (g : ℝ) ≤ 0 := + HahnSeries.Nonpositive.support_subset b g.2 + rcases hgNonpositive.eq_or_lt with hgZero | hgNegative + · apply mem_nearConstantSubgroup_iff.mpr + refine ⟨0, (HahnSeries.Nonpositive.negativeMonomialIdeal K).zero_mem, + (b : K⟦ℝ⟧).coeff g, ?_⟩ + apply Subtype.ext + simp only [zero_add, HahnSeries.Nonpositive.coe_C] + calc + HahnSeries.C ((b : K⟦ℝ⟧).coeff g) = + HahnSeries.single 0 ((b : K⟦ℝ⟧).coeff g) := rfl + _ = HahnSeries.single (g : ℝ) ((b : K⟦ℝ⟧).coeff g) := by + rw [hgZero] + _ = (b : K⟦ℝ⟧) := hbSingle.symm + · apply negativeMonomialIdeal_le_nearConstantSubgroup + have hgen := HahnSeries.Nonpositive.single_one_mem_negativeMonomialIdeal + (K := K) hgNegative + have hmul := Ideal.mul_mem_left + (HahnSeries.Nonpositive.negativeMonomialIdeal K) + (HahnSeries.Nonpositive.C ((b : K⟦ℝ⟧).coeff g)) hgen + have hproduct : HahnSeries.Nonpositive.C ((b : K⟦ℝ⟧).coeff g) * + HahnSeries.Nonpositive.single (g : ℝ) 1 hgNegative.le = b := by + apply Subtype.ext + simp only [Subring.coe_mul, HahnSeries.Nonpositive.coe_C, + HahnSeries.Nonpositive.coe_single] + change HahnSeries.single 0 ((b : K⟦ℝ⟧).coeff g) * + HahnSeries.single (g : ℝ) 1 = (b : K⟦ℝ⟧) + rw [HahnSeries.single_mul_single, zero_add, mul_one] + exact hbSingle.symm + rwa [hproduct] at hmul + +/-- The zero fiber of the ordinal value is exactly the negative-monomial ideal. -/ +theorem ordinalValue_eq_zero_iff {b : Series K} : + ordinalValue b = 0 ↔ + b ∈ HahnSeries.Nonpositive.negativeMonomialIdeal K := by + constructor + · intro hvalue + by_contra hbJ + by_cases hbNear : b ∈ nearConstantSubgroup K + · rw [ordinalValue_of_mem_nearConstantSubgroup_of_not_mem_negativeMonomialIdeal + hbNear hbJ] at hvalue + exact one_ne_zero hvalue + · obtain ⟨c, hcb, hcType⟩ := + ordinalValue_mem_representativeOrderTypes_of_not_mem_nearConstantSubgroup hbNear + rw [hvalue] at hcType + have hcTypeZero : (c : K⟦ℝ⟧).supportOrderType = 0 := by + simpa using hcType + have hc : c = 0 := by + apply Subtype.ext + exact HahnSeries.supportOrderType_eq_zero.mp hcTypeZero + subst c + exact hbNear (by simpa using hcb) + · exact ordinalValue_of_mem_negativeMonomialIdeal + +/-- The one fiber of the ordinal value is exactly `(J + K) \ J`. -/ +theorem ordinalValue_eq_one_iff {b : Series K} : + ordinalValue b = 1 ↔ + b ∈ nearConstantSubgroup K ∧ + b ∉ HahnSeries.Nonpositive.negativeMonomialIdeal K := by + constructor + · intro hvalue + have hbJ : b ∉ HahnSeries.Nonpositive.negativeMonomialIdeal K := by + intro hbJ + rw [ordinalValue_of_mem_negativeMonomialIdeal hbJ] at hvalue + exact zero_ne_one hvalue + refine ⟨?_, hbJ⟩ + by_contra hbNear + obtain ⟨c, hcb, hcType⟩ := + ordinalValue_mem_representativeOrderTypes_of_not_mem_nearConstantSubgroup hbNear + rw [hvalue] at hcType + have hcNear : c ∈ nearConstantSubgroup K := + mem_nearConstantSubgroup_of_supportOrderType_le_one hcType.le + have hbNear' := (nearConstantSubgroup K).add_mem hcb hcNear + apply hbNear + have heq : (b - c) + c = b := by abel + rwa [heq] at hbNear' + · rintro ⟨hbNear, hbJ⟩ + exact ordinalValue_of_mem_nearConstantSubgroup_of_not_mem_negativeMonomialIdeal + hbNear hbJ + +/-- The third branch consists exactly of the series outside `J + K`. -/ +theorem one_lt_ordinalValue_iff {b : Series K} : + 1 < ordinalValue b ↔ b ∉ nearConstantSubgroup K := by + constructor + · intro hvalue hbNear + by_cases hbJ : b ∈ HahnSeries.Nonpositive.negativeMonomialIdeal K + · rw [ordinalValue_of_mem_negativeMonomialIdeal hbJ] at hvalue + exact (not_lt_of_ge zero_le_one) hvalue + · rw [ordinalValue_of_mem_nearConstantSubgroup_of_not_mem_negativeMonomialIdeal + hbNear hbJ] at hvalue + exact (lt_irrefl 1) hvalue + · intro hbNear + apply lt_of_not_ge + intro hle + rcases Order.le_one_iff.mp hle with hzero | hone + · apply hbNear + exact negativeMonomialIdeal_le_nearConstantSubgroup + (ordinalValue_eq_zero_iff.mp hzero) + · exact hbNear (ordinalValue_eq_one_iff.mp hone).1 + +/-- A series with zero constant coefficient and support supremum zero lies in the third branch of +the ordinal value. -/ +theorem one_lt_ordinalValue_of_constantCoeff_eq_zero_of_supportSup_eq_zero + {b : Series K} (hcoeff : HahnSeries.Nonpositive.constantCoeff b = 0) + (hsup : HahnSeries.Nonpositive.supportSup b = 0) : + 1 < ordinalValue b := by + apply one_lt_ordinalValue_iff.mpr + intro hnear + have hmem := mem_nearConstantSubgroup_iff_sub_C_constantCoeff_mem.mp hnear + have hbJ : b ∈ HahnSeries.Nonpositive.negativeMonomialIdeal K := by + simpa [hcoeff] using hmem + exact + (HahnSeries.Nonpositive.not_mem_negativeMonomialIdeal_of_supportSup_eq_zero hsup) hbJ + +/-- The ordinal value is at most the ordinary order type of the support. -/ +theorem ordinalValue_le_supportOrderType (b : Series K) : + ordinalValue b ≤ NatOrdinal.of (b : K⟦ℝ⟧).supportOrderType := by + by_cases hbJ : b ∈ HahnSeries.Nonpositive.negativeMonomialIdeal K + · rw [ordinalValue_of_mem_negativeMonomialIdeal hbJ] + exact bot_le + by_cases hbNear : b ∈ nearConstantSubgroup K + · rw [ordinalValue_of_mem_nearConstantSubgroup_of_not_mem_negativeMonomialIdeal + hbNear hbJ, Order.one_le_iff_pos] + apply bot_lt_iff_ne_bot.mpr + intro htype + have htypeZero : (b : K⟦ℝ⟧).supportOrderType = 0 := by + simpa using htype + have hbZero : b = 0 := by + apply Subtype.ext + exact HahnSeries.supportOrderType_eq_zero.mp htypeZero + subst b + exact hbJ (HahnSeries.Nonpositive.negativeMonomialIdeal K).zero_mem + · rw [ordinalValue_of_not_mem_nearConstantSubgroup hbNear] + apply csInf_le' + exact ⟨b, by simp, rfl⟩ + +private theorem mem_negativeMonomialIdeal_iff_of_sub_mem + {b c : Series K} + (hbc : b - c ∈ HahnSeries.Nonpositive.negativeMonomialIdeal K) : + b ∈ HahnSeries.Nonpositive.negativeMonomialIdeal K ↔ + c ∈ HahnSeries.Nonpositive.negativeMonomialIdeal K := by + let J := HahnSeries.Nonpositive.negativeMonomialIdeal K + constructor + · intro hb + have hc : b - (b - c) ∈ J := J.sub_mem hb hbc + have heq : b - (b - c) = c := by abel + rwa [heq] at hc + · intro hc + have hb : (b - c) + c ∈ J := J.add_mem hbc hc + have heq : (b - c) + c = b := by abel + rwa [heq] at hb + +private theorem mem_nearConstantSubgroup_iff_of_sub_mem_negativeMonomialIdeal + {b c : Series K} + (hbc : b - c ∈ HahnSeries.Nonpositive.negativeMonomialIdeal K) : + b ∈ nearConstantSubgroup K ↔ c ∈ nearConstantSubgroup K := by + have hbcNear : b - c ∈ nearConstantSubgroup K := + negativeMonomialIdeal_le_nearConstantSubgroup hbc + constructor + · intro hb + have hc := (nearConstantSubgroup K).sub_mem hb hbcNear + have heq : b - (b - c) = c := by abel + rwa [heq] at hc + · intro hc + have hb := (nearConstantSubgroup K).add_mem hbcNear hc + have heq : (b - c) + c = b := by abel + rwa [heq] at hb + +private theorem representativeOrderTypes_eq_of_sub_mem_negativeMonomialIdeal + {b c : Series K} + (hbc : b - c ∈ HahnSeries.Nonpositive.negativeMonomialIdeal K) : + representativeOrderTypes b = representativeOrderTypes c := by + have hbcNear : b - c ∈ nearConstantSubgroup K := + negativeMonomialIdeal_le_nearConstantSubgroup hbc + have hcbNear : c - b ∈ nearConstantSubgroup K := by + have hneg := (nearConstantSubgroup K).neg_mem hbcNear + have heq : -(b - c) = c - b := by abel + rwa [heq] at hneg + ext o + constructor + · rintro ⟨d, hbd, hdType⟩ + refine ⟨d, ?_, hdType⟩ + have hsum := (nearConstantSubgroup K).add_mem hcbNear hbd + have heq : (c - b) + (b - d) = c - d := by abel + rwa [heq] at hsum + · rintro ⟨d, hcd, hdType⟩ + refine ⟨d, ?_, hdType⟩ + have hsum := (nearConstantSubgroup K).add_mem hbcNear hcd + have heq : (b - c) + (c - d) = b - d := by abel + rwa [heq] at hsum + +/-- The ordinal value depends only on the germ modulo the negative-monomial ideal. -/ +theorem ordinalValue_eq_of_sub_mem_negativeMonomialIdeal {b c : Series K} + (hbc : b - c ∈ HahnSeries.Nonpositive.negativeMonomialIdeal K) : + ordinalValue b = ordinalValue c := by + have hbJ := mem_negativeMonomialIdeal_iff_of_sub_mem hbc + have hbNear := mem_nearConstantSubgroup_iff_of_sub_mem_negativeMonomialIdeal hbc + have htypes := representativeOrderTypes_eq_of_sub_mem_negativeMonomialIdeal hbc + classical + unfold ordinalValue + rw [hbJ, hbNear, htypes] + +/-- The ordinal value induced on Berarducci germs. -/ +noncomputable def germOrdinalValue (q : Germ K) : NatOrdinal := + Quotient.liftOn' q ordinalValue fun _ _ h ↦ + ordinalValue_eq_of_sub_mem_negativeMonomialIdeal + (Ideal.Quotient.eq.mp (Quot.sound h)) + +@[simp] +theorem germOrdinalValue_mk (b : Series K) : + germOrdinalValue + (Ideal.Quotient.mk (HahnSeries.Nonpositive.negativeMonomialIdeal K) b) = + ordinalValue b := + (rfl) + +/-- The induced ordinal value is zero exactly at the zero germ. -/ +theorem germOrdinalValue_eq_zero_iff {q : Germ K} : + germOrdinalValue q = 0 ↔ q = 0 := by + obtain ⟨b, rfl⟩ := Ideal.Quotient.mk_surjective q + rw [germOrdinalValue_mk, ordinalValue_eq_zero_iff] + exact (Ideal.Quotient.eq_zero_iff_mem + (I := HahnSeries.Nonpositive.negativeMonomialIdeal K) (a := b)).symm + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/OrdinalValueConstantMul.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/OrdinalValueConstantMul.lean new file mode 100644 index 0000000000..1167d4ff0c --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/OrdinalValueConstantMul.lean @@ -0,0 +1,139 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValue + +/-! +# Invariance of Berarducci's ordinal value under nonzero constant factors + +Multiplication by a nonzero constant series is an automorphism of `Berarducci.Series K` fixing +`J` and `J + K` setwise and preserving supports exactly, so it leaves Berarducci's ordinal value +unchanged. Each defining branch is transported separately, the third by showing that the +candidate set `Berarducci.representativeOrderTypes` is literally the same set. + +The proof of the submultiplicative property in Berarducci, Lemma 5.5(2) uses this invariance for +the cross terms produced by representatives modulo `J + K`. +-/ + +universe v + +public noncomputable section + +namespace Berarducci + +open HahnSeries + +variable {K : Type v} [Field K] + +private theorem coe_C_mul (k : K) (b : Series K) : + ((HahnSeries.Nonpositive.C k * b : Series K) : K⟦ℝ⟧) = k • (b : K⟦ℝ⟧) := by + rw [Subring.coe_mul, HahnSeries.Nonpositive.coe_C, HahnSeries.C_mul_eq_smul] + +/-- A nonzero constant factor leaves the support of a nonpositive series unchanged. -/ +theorem support_C_mul_of_ne_zero {k : K} (hk : k ≠ 0) (b : Series K) : + ((HahnSeries.Nonpositive.C k * b : Series K) : K⟦ℝ⟧).support = + (b : K⟦ℝ⟧).support := by + rw [coe_C_mul] + ext x + simp [HahnSeries.mem_support, hk] + +/-- A nonzero constant factor leaves the ordinary support order type unchanged. -/ +theorem supportOrderType_C_mul_of_ne_zero {k : K} (hk : k ≠ 0) (b : Series K) : + ((HahnSeries.Nonpositive.C k * b : Series K) : K⟦ℝ⟧).supportOrderType = + (b : K⟦ℝ⟧).supportOrderType := + le_antisymm + (HahnSeries.supportOrderType_mono (by rw [support_C_mul_of_ne_zero hk])) + (HahnSeries.supportOrderType_mono (by rw [support_C_mul_of_ne_zero hk])) + +/-- A nonzero constant factor does not change membership in the negative-monomial ideal. -/ +theorem mem_negativeMonomialIdeal_C_mul_iff {k : K} (hk : k ≠ 0) (b : Series K) : + HahnSeries.Nonpositive.C k * b ∈ HahnSeries.Nonpositive.negativeMonomialIdeal K ↔ + b ∈ HahnSeries.Nonpositive.negativeMonomialIdeal K := by + refine ⟨fun h ↦ ?_, fun h ↦ Ideal.mul_mem_left _ _ h⟩ + have hmem := Ideal.mul_mem_left + (HahnSeries.Nonpositive.negativeMonomialIdeal K) (HahnSeries.Nonpositive.C k⁻¹) h + rwa [← mul_assoc, ← map_mul, inv_mul_cancel₀ hk, map_one, one_mul] at hmem + +private theorem C_mul_mem_nearConstantSubgroup (k : K) {b : Series K} + (hb : b ∈ nearConstantSubgroup K) : + HahnSeries.Nonpositive.C k * b ∈ nearConstantSubgroup K := by + obtain ⟨j, hj, c, rfl⟩ := mem_nearConstantSubgroup_iff.mp hb + refine mem_nearConstantSubgroup_iff.mpr + ⟨HahnSeries.Nonpositive.C k * j, Ideal.mul_mem_left _ _ hj, k * c, ?_⟩ + rw [map_mul, mul_add] + +/-- A nonzero constant factor does not change membership in `J + K`. -/ +theorem mem_nearConstantSubgroup_C_mul_iff {k : K} (hk : k ≠ 0) (b : Series K) : + HahnSeries.Nonpositive.C k * b ∈ nearConstantSubgroup K ↔ b ∈ nearConstantSubgroup K := by + refine ⟨fun h ↦ ?_, C_mul_mem_nearConstantSubgroup k⟩ + have hmem := C_mul_mem_nearConstantSubgroup k⁻¹ h + rwa [← mul_assoc, ← map_mul, inv_mul_cancel₀ hk, map_one, one_mul] at hmem + +/-- A nonzero constant factor permutes the representatives modulo `J + K`, so the candidate set of +support order types is unchanged. -/ +theorem representativeOrderTypes_C_mul {k : K} (hk : k ≠ 0) (b : Series K) : + representativeOrderTypes (HahnSeries.Nonpositive.C k * b) = representativeOrderTypes b := by + ext o + rw [mem_representativeOrderTypes_iff, mem_representativeOrderTypes_iff] + constructor + · rintro ⟨d, hd, rfl⟩ + refine ⟨HahnSeries.Nonpositive.C k⁻¹ * d, ?_, ?_⟩ + · have hmem := C_mul_mem_nearConstantSubgroup k⁻¹ hd + rwa [mul_sub, ← mul_assoc, ← map_mul, inv_mul_cancel₀ hk, map_one, one_mul] at hmem + · rw [supportOrderType_C_mul_of_ne_zero (inv_ne_zero hk)] + · rintro ⟨d, hd, rfl⟩ + refine ⟨HahnSeries.Nonpositive.C k * d, ?_, ?_⟩ + · have hmem := C_mul_mem_nearConstantSubgroup k hd + rwa [mul_sub] at hmem + · rw [supportOrderType_C_mul_of_ne_zero hk] + +/-- Berarducci's ordinal value is invariant under multiplication by a nonzero constant series. -/ +theorem ordinalValue_C_mul {k : K} (hk : k ≠ 0) (b : Series K) : + ordinalValue (HahnSeries.Nonpositive.C k * b) = ordinalValue b := by + by_cases hbJ : b ∈ HahnSeries.Nonpositive.negativeMonomialIdeal K + · rw [ordinalValue_of_mem_negativeMonomialIdeal + ((mem_negativeMonomialIdeal_C_mul_iff hk b).mpr hbJ), + ordinalValue_of_mem_negativeMonomialIdeal hbJ] + by_cases hbNear : b ∈ nearConstantSubgroup K + · rw [ordinalValue_of_mem_nearConstantSubgroup_of_not_mem_negativeMonomialIdeal + ((mem_nearConstantSubgroup_C_mul_iff hk b).mpr hbNear) + (fun h ↦ hbJ ((mem_negativeMonomialIdeal_C_mul_iff hk b).mp h)), + ordinalValue_of_mem_nearConstantSubgroup_of_not_mem_negativeMonomialIdeal hbNear hbJ] + · rw [ordinalValue_of_not_mem_nearConstantSubgroup + (fun h ↦ hbNear ((mem_nearConstantSubgroup_C_mul_iff hk b).mp h)), + ordinalValue_of_not_mem_nearConstantSubgroup hbNear, + representativeOrderTypes_C_mul hk] + +@[simp] +theorem ordinalValue_one : ordinalValue (1 : Series K) = 1 := by + rw [ordinalValue_eq_one_iff] + refine ⟨mem_nearConstantSubgroup_iff.mpr ⟨0, Submodule.zero_mem _, 1, by simp⟩, + fun h ↦ ?_⟩ + have hc := constantCoeff_eq_zero_of_mem_negativeMonomialIdeal h + simp at hc + +/-- A factor of ordinal value one does not change the value of a product: it is a nonzero +constant modulo `J`, and `J` is an ideal. -/ +theorem ordinalValue_mul_of_ordinalValue_eq_one {g : Series K} (hg : ordinalValue g = 1) (y : + Series K) : + ordinalValue (g * y) = ordinalValue y := by + obtain ⟨hnear, hnotJ⟩ := ordinalValue_eq_one_iff.mp hg + set k := HahnSeries.Nonpositive.constantCoeff g with hk + have hsub : g - HahnSeries.Nonpositive.C k ∈ + HahnSeries.Nonpositive.negativeMonomialIdeal K := + mem_nearConstantSubgroup_iff_sub_C_constantCoeff_mem.mp hnear + have hkne : k ≠ 0 := by + intro h + rw [h, map_zero, sub_zero] at hsub + exact hnotJ hsub + have hmul : g * y - HahnSeries.Nonpositive.C k * y ∈ + HahnSeries.Nonpositive.negativeMonomialIdeal K := by + rw [← sub_mul] + exact Ideal.mul_mem_right _ _ hsub + rw [ordinalValue_eq_of_sub_mem_negativeMonomialIdeal hmul, ordinalValue_C_mul hkne] + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/OrdinalValueDegree.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/OrdinalValueDegree.lean new file mode 100644 index 0000000000..91e47a7886 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/OrdinalValueDegree.lean @@ -0,0 +1,329 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.DegreeAssociatedGraded +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValue +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrderType +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValueConstantMul + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValueImage +import Mathlib.Tactic.Abel + +/-! +# The exponent of Berarducci's ordinal value + +The value `Berarducci.ordinalValueDegree b` is the leading Cantor exponent of Berarducci's order +value `v_J(b)`, with bottom value on the ideal `J`. LM24 does not introduce separate notation for +this exponent-valued transform; it supplies the ordinal-value properties from which the +construction is derived. + +The additive part is proved from the intrinsic minimum defining `ordinalValue`. First, minimal +representatives give a Hessenberg-sum bound. The fact that every nonzero ordinal value is a power +of `ω` sharpens this to the max-form inequality in LM24, Fact 2.7.1(1), and gives the max-form +inequality for `ordinalValueDegree`. + +The ordinal value is invariant under multiplication by a nonzero constant, hence under negation, +and its kernel is exactly `J`. The weak and strict cuts `ordinalValueDegree b ≤ α` and +`ordinalValueDegree b < α` are identified with the intrinsic cuts `v_J(b) < ω^(α+1)` and +`v_J(b) < ω^α`. + +Everything here is valid over any field. Multiplicativity of the ordinal value is kept as the +explicit proposition `OrdinalValueMultiplicative K`, with its consequence for the exponent; it is +Berarducci, Theorem 9.7, proved with its characteristic-zero hypothesis in +`ConwayRefinement.HahnSeries.OrdinalValue.Statements.ProductValue`. The exponent is +bundled as the max-additive degree `ordinalValueDegreeValuation` in +`ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValueValuation`, from the +submultiplicative bound of Berarducci, Lemma 5.5 alone. +-/ + +universe v + +public noncomputable section + +namespace Berarducci + +open HahnSeries + +variable {K : Type v} [Field K] + +@[simp] +theorem ordinalValue_zero : ordinalValue (0 : Series K) = 0 := + ordinalValue_of_mem_negativeMonomialIdeal + (HahnSeries.Nonpositive.negativeMonomialIdeal K).zero_mem + +/-- A nonzero constant series has ordinal value one. -/ +theorem ordinalValue_C_of_ne {k : K} (hk : k ≠ 0) : + ordinalValue (HahnSeries.Nonpositive.C k : Series K) = 1 := by + apply ordinalValue_of_mem_nearConstantSubgroup_of_not_mem_negativeMonomialIdeal + · apply mem_nearConstantSubgroup_iff.mpr + exact ⟨0, (HahnSeries.Nonpositive.negativeMonomialIdeal K).zero_mem, k, by simp⟩ + · intro hmem + have hcoeff := constantCoeff_eq_zero_of_mem_negativeMonomialIdeal hmem + exact hk (by simpa using hcoeff) + +/-- The ordinal value is invariant under negation: `-b = C (-1) * b`, and a nonzero constant +factor does not change the ordinal value. -/ +@[simp] +theorem ordinalValue_neg (b : Series K) : ordinalValue (-b) = ordinalValue b := by + have hnegOne : (-1 : Series K) = HahnSeries.Nonpositive.C (-1 : K) := by simp + rw [← neg_one_mul b, hnegOne, ordinalValue_C_mul (neg_ne_zero.mpr one_ne_zero)] + +private theorem representativeOrderTypes_eq_of_sub_mem_nearConstantSubgroup + {b c : Series K} (hbc : b - c ∈ nearConstantSubgroup K) : + representativeOrderTypes b = representativeOrderTypes c := by + have hcb : c - b ∈ nearConstantSubgroup K := by + have hneg := (nearConstantSubgroup K).neg_mem hbc + have heq : -(b - c) = c - b := by abel + rwa [heq] at hneg + ext o + constructor + · intro ho + obtain ⟨d, hbd, hd⟩ := mem_representativeOrderTypes_iff.mp ho + apply mem_representativeOrderTypes_iff.mpr + refine ⟨d, ?_, hd⟩ + have hsum := (nearConstantSubgroup K).add_mem hcb hbd + have heq : (c - b) + (b - d) = c - d := by abel + rwa [heq] at hsum + · intro ho + obtain ⟨d, hcd, hd⟩ := mem_representativeOrderTypes_iff.mp ho + apply mem_representativeOrderTypes_iff.mpr + refine ⟨d, ?_, hd⟩ + have hsum := (nearConstantSubgroup K).add_mem hbc hcd + have heq : (b - c) + (c - d) = b - d := by abel + rwa [heq] at hsum + +private theorem ordinalValue_eq_of_sub_mem_nearConstantSubgroup + {b c : Series K} (hb : b ∉ nearConstantSubgroup K) + (hc : c ∉ nearConstantSubgroup K) + (hbc : b - c ∈ nearConstantSubgroup K) : + ordinalValue b = ordinalValue c := by + rw [ordinalValue_of_not_mem_nearConstantSubgroup hb, + ordinalValue_of_not_mem_nearConstantSubgroup hc, + representativeOrderTypes_eq_of_sub_mem_nearConstantSubgroup hbc] + +/-- The ordinal value of a sum is bounded by the Hessenberg sum of the two ordinal values. -/ +theorem ordinalValue_add_le_naturalAdd (b c : Series K) : + ordinalValue (b + c) ≤ ordinalValue b + ordinalValue c := by + by_cases hsumNear : b + c ∈ nearConstantSubgroup K + · by_cases hsumJ : b + c ∈ HahnSeries.Nonpositive.negativeMonomialIdeal K + · rw [ordinalValue_of_mem_negativeMonomialIdeal hsumJ] + exact bot_le + · rw [ordinalValue_of_mem_nearConstantSubgroup_of_not_mem_negativeMonomialIdeal + hsumNear hsumJ] + rw [Order.one_le_iff_pos, pos_iff_ne_zero] + intro hzero + have hbZero : ordinalValue b = 0 := + (NatOrdinal.add_eq_zero_iff.mp hzero).1 + have hcZero : ordinalValue c = 0 := + (NatOrdinal.add_eq_zero_iff.mp hzero).2 + have hbJ := ordinalValue_eq_zero_iff.mp hbZero + have hcJ := ordinalValue_eq_zero_iff.mp hcZero + exact hsumJ ((HahnSeries.Nonpositive.negativeMonomialIdeal K).add_mem hbJ hcJ) + · by_cases hbNear : b ∈ nearConstantSubgroup K + · have hcNear : c ∉ nearConstantSubgroup K := by + intro hcNear + exact hsumNear ((nearConstantSubgroup K).add_mem hbNear hcNear) + have hdiff : (b + c) - c ∈ nearConstantSubgroup K := by + simpa only [add_sub_cancel_right] using hbNear + rw [ordinalValue_eq_of_sub_mem_nearConstantSubgroup hsumNear hcNear hdiff] + exact NatOrdinal.le_add_left + · by_cases hcNear : c ∈ nearConstantSubgroup K + · have hdiff : (b + c) - b ∈ nearConstantSubgroup K := by + have heq : (b + c) - b = c := by abel + rwa [heq] + rw [ordinalValue_eq_of_sub_mem_nearConstantSubgroup hsumNear hbNear hdiff] + exact NatOrdinal.le_add_right + · obtain ⟨b', hbb', hb'Type⟩ := + mem_representativeOrderTypes_iff.mp + (ordinalValue_mem_representativeOrderTypes b) + obtain ⟨c', hcc', hc'Type⟩ := + mem_representativeOrderTypes_iff.mp + (ordinalValue_mem_representativeOrderTypes c) + have hcandidate : + NatOrdinal.of (((b' + c' : Series K) : K⟦ℝ⟧).supportOrderType) ∈ + representativeOrderTypes (b + c) := by + apply mem_representativeOrderTypes_iff.mpr + refine ⟨b' + c', ?_, rfl⟩ + have hsum := (nearConstantSubgroup K).add_mem hbb' hcc' + have heq : (b + c) - (b' + c') = (b - b') + (c - c') := by abel + rwa [heq] + calc + ordinalValue (b + c) ≤ + NatOrdinal.of (((b' + c' : Series K) : K⟦ℝ⟧).supportOrderType) := + (ordinalValue_isLeast_representativeOrderTypes hsumNear).2 hcandidate + _ ≤ NatOrdinal.of ((NatOrdinal.of (b' : K⟦ℝ⟧).supportOrderType + + NatOrdinal.of (c' : K⟦ℝ⟧).supportOrderType).val) := + NatOrdinal.of.monotone + (HahnSeries.supportOrderType_add_le_naturalAdd + (b' : K⟦ℝ⟧) (c' : K⟦ℝ⟧)) + _ = ordinalValue b + ordinalValue c := by + rw [NatOrdinal.of_val, hb'Type, hc'Type] + +/-- The leading Cantor exponent of Berarducci's ordinal value, with bottom on `J`. -/ +def ordinalValueDegree (b : Series K) : WithBot NatOrdinal := + NatOrdinal.cantorDegree (ordinalValue b) + +@[simp] +theorem ordinalValueDegree_eq_bot_iff {b : Series K} : + ordinalValueDegree b = ⊥ ↔ + b ∈ HahnSeries.Nonpositive.negativeMonomialIdeal K := by + rw [ordinalValueDegree, NatOrdinal.cantorDegree_eq_bot, ordinalValue_eq_zero_iff] + +@[simp] +theorem ordinalValueDegree_zero : ordinalValueDegree (0 : Series K) = ⊥ := by + rw [ordinalValueDegree_eq_bot_iff] + exact (HahnSeries.Nonpositive.negativeMonomialIdeal K).zero_mem + +@[simp] +theorem ordinalValueDegree_one : ordinalValueDegree (1 : Series K) = 0 := by + rw [ordinalValueDegree, ordinalValue_one] + simpa using NatOrdinal.cantorDegree_wpow (0 : NatOrdinal) + +/-- A nonzero constant series has ordinal-value degree zero. -/ +theorem ordinalValueDegree_C_of_ne {k : K} (hk : k ≠ 0) : + ordinalValueDegree (HahnSeries.Nonpositive.C k : Series K) = 0 := by + rw [ordinalValueDegree, ordinalValue_C_of_ne hk] + simpa using NatOrdinal.cantorDegree_wpow (0 : NatOrdinal) + +/-- The exponent-valued ordinal value is the leading Cantor exponent of the ordinal value. -/ +theorem ordinalValueDegree_eq_cantorDegree (b : Series K) : + ordinalValueDegree b = NatOrdinal.cantorDegree (ordinalValue b) := + (rfl) + +/-- A nonzero constant factor does not change the exponent-valued ordinal value. -/ +theorem ordinalValueDegree_C_mul {k : K} (hk : k ≠ 0) (b : Series K) : + ordinalValueDegree (HahnSeries.Nonpositive.C k * b) = ordinalValueDegree b := by + rw [ordinalValueDegree, ordinalValueDegree, ordinalValue_C_mul hk] + +/-- The exponent-valued ordinal value is invariant under negation. -/ +@[simp] +theorem ordinalValueDegree_neg (b : Series K) : ordinalValueDegree (-b) = ordinalValueDegree b := by + rw [ordinalValueDegree, ordinalValueDegree, ordinalValue_neg] + +/-- Weak degree filtration in terms of the corresponding ordinal-value cut. -/ +theorem ordinalValueDegree_le_coe_iff (b : Series K) (α : NatOrdinal) : + ordinalValueDegree b ≤ (α : WithBot NatOrdinal) ↔ ordinalValue b < ω^ (α + 1) := + NatOrdinal.cantorDegree_le_coe_iff _ _ + +/-- Strict degree filtration in terms of the corresponding ordinal-value cut. -/ +theorem ordinalValueDegree_lt_coe_iff (b : Series K) (α : NatOrdinal) : + ordinalValueDegree b < (α : WithBot NatOrdinal) ↔ ordinalValue b < ω^ α := + NatOrdinal.cantorDegree_lt_coe_iff _ _ + +/-- The exponent-valued ordinal value satisfies the max-form additive inequality. -/ +theorem ordinalValueDegree_add_le_max (b c : Series K) : + ordinalValueDegree (b + c) ≤ max (ordinalValueDegree b) (ordinalValueDegree c) := by + change NatOrdinal.cantorDegree (ordinalValue (b + c)) ≤ + max (NatOrdinal.cantorDegree (ordinalValue b)) + (NatOrdinal.cantorDegree (ordinalValue c)) + calc + NatOrdinal.cantorDegree (ordinalValue (b + c)) ≤ + NatOrdinal.cantorDegree (ordinalValue b + ordinalValue c) := + by + rw [NatOrdinal.cantorDegree_eq_ordinalCantorDegree, + NatOrdinal.cantorDegree_eq_ordinalCantorDegree] + exact Ordinal.cantorDegree_mono + (NatOrdinal.val.monotone (ordinalValue_add_le_naturalAdd b c)) + _ = max (ordinalValueDegree b) (ordinalValueDegree c) := + NatOrdinal.cantorDegree_add _ _ + +private theorem exists_ordinalValueDegree_eq_and_ordinalValue_eq_wpow + {b : Series K} (hb : ordinalValue b ≠ 0) : + ∃ α : NatOrdinal, + ordinalValueDegree b = (α : WithBot NatOrdinal) ∧ ordinalValue b = ω^ α := by + rcases ordinalValue_eq_zero_or_isAdditivelyPrincipal b with hzero | hprincipal + · exact (hb hzero).elim + obtain ⟨α, hα⟩ := Ordinal.isAdditivelyPrincipal_iff.mp hprincipal + let a : NatOrdinal := NatOrdinal.of α + have hvalue : ordinalValue b = ω^ a := by + apply NatOrdinal.val.injective + simpa only [a, NatOrdinal.val_wpow, NatOrdinal.val_of] using hα + refine ⟨a, ?_, hvalue⟩ + rw [ordinalValueDegree, hvalue, NatOrdinal.cantorDegree_wpow] + +/-- An ordinal value has degree `α` exactly when it is the pure power `ω^α`. -/ +theorem ordinalValueDegree_eq_coe_iff (b : Series K) (α : NatOrdinal) : + ordinalValueDegree b = (α : WithBot NatOrdinal) ↔ ordinalValue b = ω^ α := by + constructor + · intro hdegree + have hvalueNe : ordinalValue b ≠ 0 := by + intro hzero + have hbot : ordinalValueDegree b = ⊥ := by + rw [ordinalValueDegree, hzero, NatOrdinal.cantorDegree_zero] + exact WithBot.bot_ne_coe (hbot.symm.trans hdegree) + obtain ⟨d, hdDegree, hdValue⟩ := + exists_ordinalValueDegree_eq_and_ordinalValue_eq_wpow hvalueNe + have hdα : d = α := WithBot.coe_eq_coe.mp (hdDegree.symm.trans hdegree) + rwa [hdα] at hdValue + · intro hvalue + rw [ordinalValueDegree, hvalue, NatOrdinal.cantorDegree_wpow] + +/-- Berarducci's ordinal-value degree never exceeds the Hahn-series degree. -/ +theorem ordinalValueDegree_le_degree (b : Series K) : + ordinalValueDegree b ≤ (b : K⟦ℝ⟧).degree := by + rw [ordinalValueDegree, NatOrdinal.cantorDegree_eq_ordinalCantorDegree, + HahnSeries.degree_eq_cantorDegree] + apply Ordinal.cantorDegree_mono + simpa using NatOrdinal.val.monotone (ordinalValue_le_supportOrderType b) + +/-- Berarducci's ordinal value satisfies the max-form inequality in LM24, Fact 2.7.1(1). -/ +theorem ordinalValue_add_le_max (b c : Series K) : + ordinalValue (b + c) ≤ max (ordinalValue b) (ordinalValue c) := by + by_cases hsumZero : ordinalValue (b + c) = 0 + · rw [hsumZero] + exact bot_le + by_cases hbZero : ordinalValue b = 0 + · calc + ordinalValue (b + c) ≤ ordinalValue b + ordinalValue c := + ordinalValue_add_le_naturalAdd b c + _ = ordinalValue c := by rw [hbZero, zero_add] + _ ≤ max (ordinalValue b) (ordinalValue c) := le_max_right _ _ + by_cases hcZero : ordinalValue c = 0 + · calc + ordinalValue (b + c) ≤ ordinalValue b + ordinalValue c := + ordinalValue_add_le_naturalAdd b c + _ = ordinalValue b := by rw [hcZero, add_zero] + _ ≤ max (ordinalValue b) (ordinalValue c) := le_max_left _ _ + obtain ⟨s, hsDegree, hsValue⟩ := + exists_ordinalValueDegree_eq_and_ordinalValue_eq_wpow hsumZero + obtain ⟨a, haDegree, haValue⟩ := + exists_ordinalValueDegree_eq_and_ordinalValue_eq_wpow hbZero + obtain ⟨d, hdDegree, hdValue⟩ := + exists_ordinalValueDegree_eq_and_ordinalValue_eq_wpow hcZero + have hdegree := ordinalValueDegree_add_le_max b c + rw [hsDegree, haDegree, hdDegree, ← WithBot.coe_max, WithBot.coe_le_coe] at hdegree + rw [hsValue, haValue, hdValue] + rcases le_total a d with had | hda + · rw [max_eq_right (NatOrdinal.wpow_le_wpow.mpr had)] + exact NatOrdinal.wpow_le_wpow.mpr (hdegree.trans_eq (max_eq_right had)) + · rw [max_eq_left (NatOrdinal.wpow_le_wpow.mpr hda)] + exact NatOrdinal.wpow_le_wpow.mpr (hdegree.trans_eq (max_eq_left hda)) + +/-- Multiplicativity of Berarducci's ordinal value, isolated from its definitions. -/ +def OrdinalValueMultiplicative (K : Type v) [Field K] : Prop := + ∀ b c : Series K, ordinalValue (b * c) = ordinalValue b * ordinalValue c + +/-- Establish Berarducci ordinal-value multiplicativity from the two-series identity. -/ +theorem OrdinalValueMultiplicative.of_forall + (h : ∀ b c : Series K, ordinalValue (b * c) = ordinalValue b * ordinalValue c) : + OrdinalValueMultiplicative K := h + +/-- Apply Berarducci ordinal-value multiplicativity to two series. -/ +theorem OrdinalValueMultiplicative.ordinalValue_mul + (hmul : OrdinalValueMultiplicative K) (b c : Series K) : + ordinalValue (b * c) = ordinalValue b * ordinalValue c := + hmul b c + +/-- Multiplicativity of the exponent-valued ordinal value, assuming the single Berarducci product +theorem. -/ +theorem OrdinalValueMultiplicative.ordinalValueDegree_mul + (hmul : OrdinalValueMultiplicative K) (b c : Series K) : + ordinalValueDegree (b * c) = ordinalValueDegree b + ordinalValueDegree c := by + simpa only [ordinalValueDegree, hmul b c] using + NatOrdinal.cantorDegree_mul (ordinalValue b) (ordinalValue c) + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/OrdinalValueFinalSegment.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/OrdinalValueFinalSegment.lean new file mode 100644 index 0000000000..cf42da4747 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/OrdinalValueFinalSegment.lean @@ -0,0 +1,305 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValue +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Truncation + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Negative +import Mathlib.Tactic.Linarith + +/-! +# Final support segments and Berarducci's ordinal value + +This module proves the support consequence of Berarducci's three-clause ordinal value used in the +proof of Lemma 6.9. Every nonempty final segment of the strictly negative support of a +nonpositive series has ordinary order type at least the series' ordinal value. The exponent zero +must be excluded: a nonzero constant coefficient would otherwise give the singleton final segment +`{0}`, independently of the third-branch value. + +Translation gives the corresponding theorem for a final segment of a Hahn-series support strictly +below an arbitrary cutoff `γ`. A separate theorem proves that representatives congruent modulo +`J + K` have equal values after truncation and translation at every sufficiently large negative +cutoff. Together these results isolate the value-theoretic part of Berarducci, Lemma 6.9 from its +remaining cofinal reindexing argument. + +-/ + +universe v + +open scoped HahnSeries NatOrdinal + +public noncomputable section + +namespace Berarducci + +open HahnSeries Ordinal + +variable {K : Type v} [Field K] + +/-- The ordinal value is bounded above by the ordinary order type of every nonempty final segment +of the strictly negative support. -/ +theorem ordinalValue_le_orderType_of_isRelUpperSet_negativeSupport + {b : Series K} {C : Set ℝ} + (hC : IsRelUpperSet C (· ∈ (b : K⟦ℝ⟧).support ∩ Set.Iio 0)) + (hCne : C.Nonempty) : + (ordinalValue b).val ≤ + ((b : K⟦ℝ⟧).isPWO_support.mono fun _ hx ↦ (hC hx).1.1).orderType := by + classical + let c : Series K := + ⟨HahnSeries.filter (· ∈ C) (b : K⟦ℝ⟧), by + rw [HahnSeries.mem_nonpositiveSubring] + exact (HahnSeries.support_filter_subset (· ∈ C) (b : K⟦ℝ⟧)).trans + (HahnSeries.Nonpositive.support_subset b)⟩ + have hcSupport : (c : K⟦ℝ⟧).support = C := by + change (HahnSeries.filter (· ∈ C) (b : K⟦ℝ⟧)).support = C + rw [HahnSeries.support_filter] + ext x + constructor + · exact fun hx ↦ hx.2 + · intro hx + exact ⟨(hC hx).1.1, hx⟩ + obtain ⟨a, haC⟩ := hCne + have ha := (hC haC).1 + have hbc : b - c ∈ nearConstantSubgroup K := by + rw [mem_nearConstantSubgroup_iff_sub_C_constantCoeff_mem] + rw [HahnSeries.Nonpositive.mem_negativeMonomialIdeal_iff_supportSup_lt_zero] + let q := b - c - HahnSeries.Nonpositive.C + (HahnSeries.Nonpositive.constantCoeff (b - c)) + change HahnSeries.Nonpositive.supportSup q < 0 + by_cases hq : q = 0 + · simp [hq] + · rw [HahnSeries.Nonpositive.supportSup_of_ne hq] + apply WithBot.coe_lt_coe.mpr + refine (csSup_le (HahnSeries.support_nonempty_iff.mpr ?_) ?_).trans_lt ha.2 + · simpa using hq + · intro x hx + apply le_of_not_gt + intro hax + have hx0 : x ≤ 0 := HahnSeries.Nonpositive.support_subset q hx + rcases hx0.eq_or_lt with rfl | hx0 + · have hcoeff : (q : K⟦ℝ⟧).coeff 0 = 0 := by + simp [q] + exact (HahnSeries.mem_support _ _).mp hx hcoeff + · by_cases hxb : x ∈ (b : K⟦ℝ⟧).support + · have hxC : x ∈ C := (hC haC).2 hax.le ⟨hxb, hx0⟩ + have hcCoeff : (c : K⟦ℝ⟧).coeff x = (b : K⟦ℝ⟧).coeff x := by + simp [c, hxC] + have hcoeff : (q : K⟦ℝ⟧).coeff x = 0 := by + simp [q, hcCoeff, hx0.ne] + exact (HahnSeries.mem_support _ _).mp hx hcoeff + · have hbCoeff : (b : K⟦ℝ⟧).coeff x = 0 := by + rwa [← not_ne_iff, ← HahnSeries.mem_support] + have hcoeff : (q : K⟦ℝ⟧).coeff x = 0 := by + simp [q, c, hbCoeff, hx0.ne] + exact (HahnSeries.mem_support _ _).mp hx hcoeff + rw [NatOrdinal.val_le_iff] + by_cases hb : 1 < ordinalValue b + · have hcCandidate : + NatOrdinal.of (c : K⟦ℝ⟧).supportOrderType ∈ representativeOrderTypes b := + mem_representativeOrderTypes_iff.mpr ⟨c, hbc, rfl⟩ + have hvalue := (ordinalValue_isLeast_representativeOrderTypes + (one_lt_ordinalValue_iff.mp hb)).2 hcCandidate + calc + ordinalValue b ≤ NatOrdinal.of (c : K⟦ℝ⟧).supportOrderType := hvalue + _ = NatOrdinal.of + (((b : K⟦ℝ⟧).isPWO_support.mono fun _ hx ↦ (hC hx).1.1).orderType) := by + apply congrArg NatOrdinal.of + rw [HahnSeries.supportOrderType_eq_setOrderType] + exact (c : K⟦ℝ⟧).isPWO_support.orderType_congr + ((b : K⟦ℝ⟧).isPWO_support.mono fun _ hx ↦ (hC hx).1.1) hcSupport + · apply (le_of_not_gt hb).trans + rw [Order.one_le_iff_pos] + apply NatOrdinal.of.lt_iff_lt.mpr + apply bot_lt_iff_ne_bot.mpr + intro htypeZero + have hCempty := + (((b : K⟦ℝ⟧).isPWO_support.mono fun _ hx ↦ (hC hx).1.1).orderType_eq_zero).mp + htypeZero + simp [hCempty] at haC + +/-- A series with nonzero ordinal value has support with least upper bound zero. -/ +theorem isLUB_support_zero_of_ordinalValue_ne_zero + {b : Series K} (hb : ordinalValue b ≠ 0) : + IsLUB (b : K⟦ℝ⟧).support 0 := by + have hbJ : b ∉ HahnSeries.Nonpositive.negativeMonomialIdeal K := by + rwa [← ordinalValue_eq_zero_iff] + have hbne : b ≠ 0 := by + intro hbzero + apply hbJ + rw [hbzero] + exact (HahnSeries.Nonpositive.negativeMonomialIdeal K).zero_mem + have hsup : HahnSeries.Nonpositive.supportSup b = 0 := by + apply le_antisymm (HahnSeries.Nonpositive.supportSup_le_zero b) + apply le_of_not_gt + intro hlt + exact hbJ + (HahnSeries.Nonpositive.mem_negativeMonomialIdeal_iff_supportSup_lt_zero.mpr hlt) + exact (HahnSeries.Nonpositive.supportSup_eq_coe_iff.mp hsup).2 + +/-- A series of ordinal value greater than one has strictly negative support with least upper +bound zero. -/ +theorem isLUB_negativeSupport_zero_of_one_lt_ordinalValue + {b : Series K} (hb : 1 < ordinalValue b) : + IsLUB ((b : K⟦ℝ⟧).support ∩ Set.Iio 0) 0 := by + let n : HahnSeries.Negative ℝ K := HahnSeries.Nonpositive.negativePart ℝ K b + have hnJ : (n : Series K) ∉ HahnSeries.Nonpositive.negativeMonomialIdeal K := by + intro hnJ + apply (one_lt_ordinalValue_iff.mp hb) + apply mem_nearConstantSubgroup_iff_sub_C_constantCoeff_mem.mpr + simpa only [n, HahnSeries.Nonpositive.coe_negativePart] using hnJ + have hn : (n : Series K) ≠ 0 := by + intro hn + apply hnJ + rw [hn] + exact (HahnSeries.Nonpositive.negativeMonomialIdeal K).zero_mem + have hsup : HahnSeries.Nonpositive.supportSup (n : Series K) = 0 := by + apply le_antisymm (HahnSeries.Nonpositive.supportSup_le_zero (n : Series K)) + apply le_of_not_gt + intro hlt + exact hnJ + (HahnSeries.Nonpositive.mem_negativeMonomialIdeal_iff_supportSup_lt_zero.mpr hlt) + have hLUB := + (HahnSeries.Nonpositive.supportSup_eq_coe_iff.mp hsup).2 + simpa only [n, HahnSeries.Nonpositive.support_negativePart] using hLUB + +/-- After translating a cutoff to zero, the ordinal value is bounded above by the ordinary order +type of every nonempty final segment of the support strictly below that cutoff. -/ +theorem ordinalValue_translatedTruncation_le_orderType_of_isRelUpperSet_supportBelow + (b : K⟦ℝ⟧) (γ : ℝ) {C : Set ℝ} + (hC : IsRelUpperSet C (· ∈ b.support ∩ Set.Iio γ)) + (hCne : C.Nonempty) : + (ordinalValue (translatedTruncation b γ)).val ≤ + (b.isPWO_support.mono fun _ hx ↦ (hC hx).1.1).orderType := by + let shifted : Set ℝ := (-γ + ·) '' C + have hshifted : IsRelUpperSet shifted + (· ∈ ((translatedTruncation b γ : Series K) : K⟦ℝ⟧).support ∩ Set.Iio 0) := by + rintro _ ⟨x, hxC, rfl⟩ + refine ⟨⟨?_, ?_⟩, ?_⟩ + · rw [support_translatedTruncation] + exact ⟨x, ⟨(hC hxC).1.1, (hC hxC).1.2.le⟩, rfl⟩ + · have hxγ := (hC hxC).1.2 + change x < γ at hxγ + change -γ + x < 0 + linarith + · intro y hxy hy + rw [support_translatedTruncation] at hy + obtain ⟨⟨z, hz, hzEq⟩, hy0⟩ := hy + subst y + refine ⟨z, ?_, rfl⟩ + apply (hC hxC).2 + · linarith + · refine ⟨hz.1, ?_⟩ + change -γ + z < 0 at hy0 + change z < γ + linarith + have hshiftedNonempty : shifted.Nonempty := hCne.image _ + have hbound := ordinalValue_le_orderType_of_isRelUpperSet_negativeSupport + hshifted hshiftedNonempty + let hCPWO : C.IsPWO := b.isPWO_support.mono fun _ hx ↦ (hC hx).1.1 + let hshiftedPWO : shifted.IsPWO := + ((translatedTruncation b γ : Series K) : K⟦ℝ⟧).isPWO_support.mono + fun _ hx ↦ (hshifted hx).1.1 + let : WellFoundedLT C := hCPWO.isWF + let : WellFoundedLT shifted := hshiftedPWO.isWF + let f : C → shifted := fun x ↦ ⟨-γ + x.1, x.1, x.2, rfl⟩ + have hf : StrictMono f := by + intro x y hxy + change x.1 < y.1 at hxy + change -γ + x.1 < -γ + y.1 + linarith + have hsurjective : Function.Surjective f := by + rintro ⟨_, x, hxC, rfl⟩ + exact ⟨⟨x, hxC⟩, rfl⟩ + let e : C ≃o shifted := hf.orderIsoOfSurjective f hsurjective + have htype : hshiftedPWO.orderType = hCPWO.orderType := by + calc + hshiftedPWO.orderType = typeLT C := + hshiftedPWO.orderType_eq_typeLT_of_orderIso e.symm + _ = hCPWO.orderType := + (hCPWO.orderType_eq_typeLT_of_orderIso (OrderIso.refl C)).symm + exact hbound.trans_eq htype + +/-- A lower bound on a translated-truncation value is a lower bound on every nonempty final +segment of the support strictly below the cutoff. -/ +theorem le_orderType_of_le_ordinalValue_translatedTruncation_of_isRelUpperSet_supportBelow + (b : K⟦ℝ⟧) (γ : ℝ) {C : Set ℝ} {ρ : Ordinal} + (hρ : NatOrdinal.of ρ ≤ ordinalValue (translatedTruncation b γ)) + (hC : IsRelUpperSet C (· ∈ b.support ∩ Set.Iio γ)) + (hCne : C.Nonempty) : + ρ ≤ (b.isPWO_support.mono fun _ hx ↦ (hC hx).1.1).orderType := by + apply (NatOrdinal.of.le_iff_le.mp ?_).trans + (ordinalValue_translatedTruncation_le_orderType_of_isRelUpperSet_supportBelow b γ hC hCne) + simpa only [NatOrdinal.of_val] using hρ + +/-- A uniform lower bound on the ordinary order types of the support windows immediately below +`γ` is a lower bound on the value of the translated truncation at `γ`. This is the converse of +`Berarducci.ordinalValue_translatedTruncation_le_orderType_of_isRelUpperSet_supportBelow`. -/ +theorem le_ordinalValue_translatedTruncation_of_forall_le_orderType + (b : K⟦ℝ⟧) (γ : ℝ) {ρ : Ordinal} + (h : ∀ θ, θ < γ → ρ ≤ (b.isPWO_support.mono + (s := b.support ∩ Set.Ioo θ γ) Set.inter_subset_left).orderType) : + NatOrdinal.of ρ ≤ ordinalValue (translatedTruncation b γ) := by + apply le_ordinalValue_of_forall_mem_representativeOrderTypes + intro p hp + obtain ⟨d, hd, rfl⟩ := mem_representativeOrderTypes_iff.mp hp + rw [NatOrdinal.of.le_iff_le] + obtain ⟨θ, hθ, hcoeff⟩ := exists_coeff_eq_of_sub_mem_nearConstantSubgroup hd + set A : Set ℝ := b.support ∩ Set.Ioo (γ + θ) γ with hA + have hAPWO : A.IsPWO := b.isPWO_support.mono Set.inter_subset_left + have hmono : StrictMonoOn (fun x ↦ -γ + x) A := fun _ _ _ _ hxy ↦ by simpa using hxy + have himage : (fun x ↦ -γ + x) '' A ⊆ (d : K⟦ℝ⟧).support := by + rintro _ ⟨x, hx, rfl⟩ + obtain ⟨hxsupp, hxlow, hxhigh⟩ := hx + have hδ0 : -γ + x ≤ 0 := by linarith + have hδθ : θ < -γ + x := by linarith + have hδneg : -γ + x < 0 := by linarith + have hgerm : ((translatedTruncation b γ : Series K) : K⟦ℝ⟧).coeff (-γ + x) = b.coeff x := by + rw [coeff_translatedTruncation, ite_eq_left hδ0] + congr 1 + ring + rw [HahnSeries.mem_support, ← hcoeff (-γ + x) hδθ hδneg, hgerm] + exact (HahnSeries.mem_support _ _).mp hxsupp + calc ρ ≤ hAPWO.orderType := h (γ + θ) (by linarith) + _ = (hAPWO.image_of_monotoneOn hmono.monotoneOn).orderType := + (hAPWO.orderType_image_of_strictMonoOn hmono).symm + _ ≤ (d : K⟦ℝ⟧).isPWO_support.orderType := + (hAPWO.image_of_monotoneOn hmono.monotoneOn).orderType_mono _ himage + _ = (d : K⟦ℝ⟧).supportOrderType := + (HahnSeries.supportOrderType_eq_setOrderType _).symm + +/-- Series congruent modulo `J + K` have equal translated-truncation values at every sufficiently +large negative cutoff. -/ +theorem exists_ordinalValue_translatedTruncation_eq_of_sub_mem_nearConstantSubgroup + {b c : Series K} (hbc : b - c ∈ nearConstantSubgroup K) : + ∃ η < (0 : ℝ), ∀ γ : ℝ, η < γ → γ < 0 → + ordinalValue (translatedTruncation (b : K⟦ℝ⟧) γ) = + ordinalValue (translatedTruncation (c : K⟦ℝ⟧) γ) := by + obtain ⟨j, hj, k, hjk⟩ := mem_nearConstantSubgroup_iff.mp hbc + have hjGerm : toGerm j = toGerm 0 := by + rw [toGerm_eq_toGerm_iff] + simpa using hj + obtain ⟨η, hη, hjCoeff⟩ := + toGerm_eq_toGerm_iff_exists_coeff_eq.mp hjGerm + refine ⟨η, hη, fun γ hηγ hγ ↦ ?_⟩ + apply ordinalValue_eq_of_sub_mem_negativeMonomialIdeal + rw [← toGerm_eq_toGerm_iff] + apply toGerm_eq_toGerm_iff_exists_coeff_eq.mpr + refine ⟨η - γ, sub_neg.mpr hηγ, fun δ hδ hδ0 ↦ ?_⟩ + rw [coeff_translatedTruncation, coeff_translatedTruncation, ite_eq_left hδ0, ite_eq_left hδ0] + have hnear : η < γ + δ := by linarith + have hnegative : γ + δ < 0 := by linarith + have hjZero : (j : K⟦ℝ⟧).coeff (γ + δ) = 0 := by + simpa using hjCoeff (γ + δ) hnear hnegative.le + have hjkCoeff := congrArg + (fun q : Series K ↦ (q : K⟦ℝ⟧).coeff (γ + δ)) hjk + simp only [Subring.coe_add, HahnSeries.coeff_add, HahnSeries.Nonpositive.coe_C, + HahnSeries.C_apply] at hjkCoeff + rw [HahnSeries.coeff_single_of_ne hnegative.ne] at hjkCoeff + simp only [add_zero] at hjkCoeff + exact sub_eq_zero.mp (hjkCoeff.symm.trans hjZero) + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/OrdinalValueImage.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/OrdinalValueImage.lean new file mode 100644 index 0000000000..a83ff30d3f --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/OrdinalValueImage.lean @@ -0,0 +1,215 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValue +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.AdditivelyPrincipal + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrderType +import Mathlib.Tactic.Abel + +/-! +# Image of Berarducci's ordinal value + +Berarducci, Remark 5.3 states that the ordinal value has image in the class of additive-principal +ordinals, where that class includes zero. Thus the value is either zero or +`Ordinal.IsAdditivelyPrincipal`; equivalently, its underlying ordinary ordinal satisfies +Mathlib's `Ordinal.IsPrincipal (\x y => x + y)`. + +The proof here derives the assertion directly from the three-branch minimum in Definition 5.2. If +a minimal representative had support order type `a + d` with both summands strictly smaller, the +support-splitting theorem would write it as a lower series plus an upper series. When the upper +series lies in `J + K`, it can be removed. Otherwise it has a negative support exponent, so the +strictly lower series is bounded away from zero and lies in `J`; that lower series can instead be +removed. Either case gives a congruent representative with strictly smaller support order type, +contradicting minimality. + +The argument requires no characteristic-zero hypothesis and is therefore proved over an arbitrary +field. It supplies the additive-principality input for Berarducci's principal and residual value +definition. +-/ + +universe v + +public noncomputable section + +namespace Berarducci + +open HahnSeries + +variable {K : Type v} [Field K] + +private theorem exists_negative_support_of_not_mem_nearConstantSubgroup + {b : Series K} (hb : b ∉ nearConstantSubgroup K) : + ∃ x ∈ (b : K⟦ℝ⟧).support, x < 0 := by + by_contra hnegative + apply hb + rw [mem_nearConstantSubgroup_iff_sub_C_constantCoeff_mem] + have heq : b - HahnSeries.Nonpositive.C + (HahnSeries.Nonpositive.constantCoeff b) = 0 := by + apply Subtype.ext + ext x + by_cases hx : x = 0 + · subst x + simp + · have hxSupport : x ∉ (b : K⟦ℝ⟧).support := by + intro hxb + have hxle := HahnSeries.Nonpositive.support_subset b hxb + have hxge : 0 ≤ x := le_of_not_gt fun hxlt ↦ + hnegative ⟨x, hxb, hxlt⟩ + exact hx (le_antisymm hxle hxge) + have hxCoeff : (b : K⟦ℝ⟧).coeff x = 0 := by + rwa [← not_ne_iff, ← HahnSeries.mem_support] + simp [hx, hxCoeff] + rw [heq] + exact (HahnSeries.Nonpositive.negativeMonomialIdeal K).zero_mem + +private theorem mem_negativeMonomialIdeal_of_supportBelow_of_negative_support + {b c : Series K} + (hbc : HahnSeries.SupportBelow (b : K⟦ℝ⟧) (c : K⟦ℝ⟧)) + {x : ℝ} (hxc : x ∈ (c : K⟦ℝ⟧).support) (hx : x < 0) : + b ∈ HahnSeries.Nonpositive.negativeMonomialIdeal K := by + rw [HahnSeries.Nonpositive.mem_negativeMonomialIdeal_iff_supportSup_lt_zero] + by_cases hb : b = 0 + · subst b + simp + · rw [HahnSeries.Nonpositive.supportSup_of_ne hb] + apply WithBot.coe_lt_coe.mpr + have hb' : (b : K⟦ℝ⟧) ≠ 0 := by simpa using hb + apply (csSup_le (HahnSeries.support_nonempty_iff.mpr hb') ?_).trans_lt hx + intro y hy + exact (hbc.lt hy hxc).le + +private theorem sub_mem_nearConstantSubgroup_left_of_add_eq + {b c y z : Series K} + (hbc : b - c ∈ nearConstantSubgroup K) + (hc : c = y + z) + (hz : z ∈ nearConstantSubgroup K) : + b - y ∈ nearConstantSubgroup K := by + have hsum := (nearConstantSubgroup K).add_mem hbc hz + have heq : (b - c) + z = b - y := by + rw [hc] + abel + rwa [heq] at hsum + +private theorem sub_mem_nearConstantSubgroup_right_of_add_eq + {b c y z : Series K} + (hbc : b - c ∈ nearConstantSubgroup K) + (hc : c = y + z) + (hy : y ∈ nearConstantSubgroup K) : + b - z ∈ nearConstantSubgroup K := by + have hsum := (nearConstantSubgroup K).add_mem hbc hy + have heq : (b - c) + y = b - z := by + rw [hc] + abel + rwa [heq] at hsum + +/-- Every Berarducci ordinal value strictly above one is positive additive principal. This is the +nontrivial branch of Berarducci, Remark 5.3. -/ +theorem ordinalValue_isAdditivelyPrincipal_of_one_lt {b : Series K} + (hb : 1 < ordinalValue b) : + Ordinal.IsAdditivelyPrincipal (ordinalValue b).val := by + have hbNear : b ∉ nearConstantSubgroup K := one_lt_ordinalValue_iff.mp hb + have hleast := ordinalValue_isLeast_representativeOrderTypes hbNear + obtain ⟨c, hbc, hcType⟩ := mem_representativeOrderTypes_iff.mp hleast.1 + have hcTypeVal : (c : K⟦ℝ⟧).supportOrderType = (ordinalValue b).val := by + have h := congrArg NatOrdinal.val hcType + simpa using h + have hvalueNe : (ordinalValue b).val ≠ 0 := by + intro hzero + have : ordinalValue b = 0 := by + apply NatOrdinal.val.injective + simpa using hzero + rw [this] at hb + exact not_lt_of_ge zero_le_one hb + rw [Ordinal.isAdditivelyPrincipal_iff_ne_zero_and_isPrincipal_add] + refine ⟨hvalueNe, ?_⟩ + by_contra hprincipal + obtain ⟨a, ha, d, hd, hadd⟩ := + Ordinal.exists_lt_add_of_not_isPrincipal_add hprincipal + have hcSplit : (c : K⟦ℝ⟧).supportOrderType = a + d := by + rw [hcTypeVal, hadd] + obtain ⟨y, z, hyz, hya, hzd, hcyz⟩ := + (HahnSeries.supportOrderType_eq_add_iff (c : K⟦ℝ⟧) a d).mp hcSplit + have hySupport : y.support ⊆ (c : K⟦ℝ⟧).support := by + rw [hcyz, HahnSeries.support_add_eq_union_of_supportBelow y z hyz] + exact Set.subset_union_left + have hzSupport : z.support ⊆ (c : K⟦ℝ⟧).support := by + rw [hcyz, HahnSeries.support_add_eq_union_of_supportBelow y z hyz] + exact Set.subset_union_right + let y' : Series K := ⟨y, + (HahnSeries.mem_nonpositiveSubring (x := y)).mpr fun _ hx ↦ + HahnSeries.Nonpositive.support_subset c (hySupport hx)⟩ + let z' : Series K := ⟨z, + (HahnSeries.mem_nonpositiveSubring (x := z)).mpr fun _ hx ↦ + HahnSeries.Nonpositive.support_subset c (hzSupport hx)⟩ + have hyz' : HahnSeries.SupportBelow (y' : K⟦ℝ⟧) (z' : K⟦ℝ⟧) := hyz + have hcyz' : c = y' + z' := by + apply Subtype.ext + exact hcyz + by_cases hzNear : z' ∈ nearConstantSubgroup K + · have hby := sub_mem_nearConstantSubgroup_left_of_add_eq hbc hcyz' hzNear + have hyCandidate : NatOrdinal.of y.supportOrderType ∈ + representativeOrderTypes b := + mem_representativeOrderTypes_iff.mpr ⟨y', hby, rfl⟩ + have hle := hleast.2 hyCandidate + have hlt : NatOrdinal.of y.supportOrderType < ordinalValue b := by + rw [hya, ← hcType] + exact NatOrdinal.of.lt_iff_lt.mpr (ha.trans_eq hcTypeVal.symm) + exact not_lt_of_ge hle hlt + · obtain ⟨x, hxz, hx⟩ := + exists_negative_support_of_not_mem_nearConstantSubgroup hzNear + have hyJ := + mem_negativeMonomialIdeal_of_supportBelow_of_negative_support hyz' hxz hx + have hyNear : y' ∈ nearConstantSubgroup K := + negativeMonomialIdeal_le_nearConstantSubgroup hyJ + have hbz := sub_mem_nearConstantSubgroup_right_of_add_eq hbc hcyz' hyNear + have hzCandidate : NatOrdinal.of z.supportOrderType ∈ + representativeOrderTypes b := + mem_representativeOrderTypes_iff.mpr ⟨z', hbz, rfl⟩ + have hle := hleast.2 hzCandidate + have hlt : NatOrdinal.of z.supportOrderType < ordinalValue b := by + rw [hzd, ← hcType] + exact NatOrdinal.of.lt_iff_lt.mpr (hd.trans_eq hcTypeVal.symm) + exact not_lt_of_ge hle hlt + +/-- A Berarducci ordinal value is either zero or positive additive principal. This is the +positive formulation of Berarducci, Remark 5.3. -/ +theorem ordinalValue_eq_zero_or_isAdditivelyPrincipal (b : Series K) : + ordinalValue b = 0 ∨ + Ordinal.IsAdditivelyPrincipal (ordinalValue b).val := by + by_cases hzero : ordinalValue b = 0 + · exact Or.inl hzero + · right + have hpos : 0 < ordinalValue b := bot_lt_iff_ne_bot.mpr hzero + have hone : 1 ≤ ordinalValue b := Order.one_le_iff_pos.mpr hpos + rcases hone.eq_or_lt with hone | hone + · have hval : (ordinalValue b).val = 1 := by + rw [← hone] + simp + rw [hval] + simpa using Ordinal.isAdditivelyPrincipal_omega0_opow 0 + · exact ordinalValue_isAdditivelyPrincipal_of_one_lt hone + +/-- The underlying ordinary ordinal of every Berarducci value belongs to Berarducci's class +`H`, represented exactly by Mathlib's additive-principal predicate that includes zero. -/ +theorem ordinalValue_isPrincipal_add (b : Series K) : + Ordinal.IsPrincipal (· + ·) (ordinalValue b).val := by + rcases ordinalValue_eq_zero_or_isAdditivelyPrincipal b with hzero | hprincipal + · have hval : (ordinalValue b).val = 0 := by rw [hzero]; simp + rw [hval] + exact Ordinal.isPrincipal_zero + · exact + (Ordinal.isAdditivelyPrincipal_iff_ne_zero_and_isPrincipal_add.mp hprincipal).2 + +/-- The ordinal value induced on the germ quotient also has image in Berarducci's class `H`. -/ +theorem germOrdinalValue_isPrincipal_add (q : Germ K) : + Ordinal.IsPrincipal (· + ·) (germOrdinalValue q).val := by + obtain ⟨b, rfl⟩ := Ideal.Quotient.mk_surjective q + rw [germOrdinalValue_mk] + exact ordinalValue_isPrincipal_add b + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/OrdinalValueSubmultiplicative.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/OrdinalValueSubmultiplicative.lean new file mode 100644 index 0000000000..fd1b0f90c3 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/OrdinalValueSubmultiplicative.lean @@ -0,0 +1,142 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValue +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValueDegree + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValueConstantMul + +/-! +# Submultiplicativity of Berarducci's ordinal value + +Berarducci, Lemma 5.5(2): the ordinal value of a product is at most the Hessenberg product of the +two ordinal values. The product on the right is Hessenberg multiplication, carried by +`NatOrdinal`; it dominates ordinary ordinal multiplication and the two must not be interchanged. +This is the inequality half of Berarducci, Theorem 9.7; the opposite inequality is the deep part +of the paper and is not proved here. + +The proof follows the source. Choosing representatives `b'`, `c'` modulo `J + K` whose support +order types realize `v_J(b)` and `v_J(c)`, and writing `b - b' = j + r`, `c - c' = i + s` with +`j, i ∈ J` and `r, s` constant, expansion gives + +`b c ≡ b' c' + s b' + r c' (mod J + K)`. + +The max-form additive inequality of Berarducci, Lemma 5.5(1) then reduces the claim to the +order-type bound for `b' c'` together with constant-factor invariance for the two cross terms. + +The ideal cases `b ∈ J` and `c ∈ J` come first: the right-hand side is then zero, and the bounds +`v_J(b) ≤ v_J(b) ⊙ v_J(c)` and `v_J(c) ≤ v_J(b) ⊙ v_J(c)` used afterwards are unavailable. + +For the leading Cantor exponent, the bound reads `ordinalValueDegree (b c) ≤ ordinalValueDegree b ++ ordinalValueDegree c`, since the Cantor degree of a Hessenberg product is the Hessenberg sum of +the Cantor degrees. This is the product inequality of the max-additive degree +`ordinalValueDegreeValuation`. +-/ + +universe v + +public noncomputable section + +namespace Berarducci + +open HahnSeries + +variable {K : Type v} [Field K] + +private theorem ordinalValue_C_mul_le (k : K) (b : Series K) : + ordinalValue (HahnSeries.Nonpositive.C k * b) ≤ ordinalValue b := by + rcases eq_or_ne k 0 with rfl | hk + · rw [map_zero, zero_mul, ordinalValue_zero] + exact bot_le + · exact (ordinalValue_C_mul hk b).le + +private theorem ordinalValue_le_one_of_mem_nearConstantSubgroup {b : Series K} + (hb : b ∈ nearConstantSubgroup K) : ordinalValue b ≤ 1 := + le_of_not_gt fun h ↦ (one_lt_ordinalValue_iff.mp h) hb + +/-- Berarducci, Lemma 5.5(2): the ordinal value of a product is at most the Hessenberg product of +the ordinal values of the factors. -/ +theorem ordinalValue_mul_le_naturalMul (b c : Series K) : + ordinalValue (b * c) ≤ ordinalValue b * ordinalValue c := by + by_cases hbJ : b ∈ HahnSeries.Nonpositive.negativeMonomialIdeal K + · rw [ordinalValue_of_mem_negativeMonomialIdeal + ((HahnSeries.Nonpositive.negativeMonomialIdeal K).mul_mem_right c hbJ)] + exact bot_le + by_cases hcJ : c ∈ HahnSeries.Nonpositive.negativeMonomialIdeal K + · rw [ordinalValue_of_mem_negativeMonomialIdeal + ((HahnSeries.Nonpositive.negativeMonomialIdeal K).mul_mem_left b hcJ)] + exact bot_le + have hb1 : 1 ≤ ordinalValue b := + Order.one_le_iff_pos.mpr (pos_iff_ne_zero.mpr fun h ↦ hbJ (ordinalValue_eq_zero_iff.mp h)) + have hc1 : 1 ≤ ordinalValue c := + Order.one_le_iff_pos.mpr (pos_iff_ne_zero.mpr fun h ↦ hcJ (ordinalValue_eq_zero_iff.mp h)) + have hbmul : ordinalValue b ≤ ordinalValue b * ordinalValue c := + le_mul_of_one_le_right zero_le hc1 + have hcmul : ordinalValue c ≤ ordinalValue b * ordinalValue c := + le_mul_of_one_le_left zero_le hb1 + obtain ⟨b', hbb', hb'⟩ := + mem_representativeOrderTypes_iff.mp (ordinalValue_mem_representativeOrderTypes b) + obtain ⟨c', hcc', hc'⟩ := + mem_representativeOrderTypes_iff.mp (ordinalValue_mem_representativeOrderTypes c) + obtain ⟨j, hj, r, hjr⟩ := mem_nearConstantSubgroup_iff.mp hbb' + obtain ⟨i, hi, s, his⟩ := mem_nearConstantSubgroup_iff.mp hcc' + have hb : b = b' + (j + HahnSeries.Nonpositive.C r) := by rw [hjr]; ring + have hc : c = c' + (i + HahnSeries.Nonpositive.C s) := by rw [his]; ring + set d : Series K := + b' * c' + (HahnSeries.Nonpositive.C s * b' + HahnSeries.Nonpositive.C r * c') with hdDef + have hkey : b * c - d = + (b' * i + j * c' + j * i + j * HahnSeries.Nonpositive.C s + + HahnSeries.Nonpositive.C r * i) + HahnSeries.Nonpositive.C (r * s) := by + rw [hdDef, map_mul, hb, hc]; ring + have hrest : b * c - d ∈ nearConstantSubgroup K := by + rw [hkey] + refine mem_nearConstantSubgroup_iff.mpr ⟨_, ?_, r * s, rfl⟩ + exact Ideal.add_mem _ (Ideal.add_mem _ (Ideal.add_mem _ (Ideal.add_mem _ + (Ideal.mul_mem_left _ b' hi) (Ideal.mul_mem_right c' _ hj)) + (Ideal.mul_mem_right i _ hj)) (Ideal.mul_mem_right _ _ hj)) + (Ideal.mul_mem_left _ _ hi) + have hdle : ordinalValue d ≤ ordinalValue b * ordinalValue c := by + refine (ordinalValue_add_le_max _ _).trans (max_le ?_ ((ordinalValue_add_le_max _ _).trans + (max_le ?_ ?_))) + · calc ordinalValue (b' * c') + ≤ NatOrdinal.of ((b' * c' : Series K) : K⟦ℝ⟧).supportOrderType := + ordinalValue_le_supportOrderType _ + _ ≤ NatOrdinal.of ((NatOrdinal.of (b' : K⟦ℝ⟧).supportOrderType * + NatOrdinal.of (c' : K⟦ℝ⟧).supportOrderType).val) := by + apply NatOrdinal.of.monotone + rw [Subring.coe_mul] + exact HahnSeries.supportOrderType_mul_le_naturalMul _ _ + _ = ordinalValue b * ordinalValue c := by rw [NatOrdinal.of_val, hb', hc'] + · exact ((ordinalValue_C_mul_le s b').trans + ((ordinalValue_le_supportOrderType b').trans_eq hb')).trans hbmul + · exact ((ordinalValue_C_mul_le r c').trans + ((ordinalValue_le_supportOrderType c').trans_eq hc')).trans hcmul + have hsplit : b * c = d + (b * c - d) := by ring + calc ordinalValue (b * c) = ordinalValue (d + (b * c - d)) := by rw [← hsplit] + _ ≤ max (ordinalValue d) (ordinalValue (b * c - d)) := ordinalValue_add_le_max _ _ + _ ≤ ordinalValue b * ordinalValue c := + max_le hdle ((ordinalValue_le_one_of_mem_nearConstantSubgroup hrest).trans + (hb1.trans hbmul)) + +/-- Berarducci, Lemma 5.5(2) for the leading Cantor exponent: the exponent of a product is at +most the Hessenberg sum of the exponents. -/ +theorem ordinalValueDegree_mul_le_add (b c : Series K) : + ordinalValueDegree (b * c) ≤ ordinalValueDegree b + ordinalValueDegree c := by + rw [ordinalValueDegree_eq_cantorDegree, ordinalValueDegree_eq_cantorDegree, + ordinalValueDegree_eq_cantorDegree, ← NatOrdinal.cantorDegree_mul, + NatOrdinal.cantorDegree_eq_ordinalCantorDegree, NatOrdinal.cantorDegree_eq_ordinalCantorDegree] + exact Ordinal.cantorDegree_mono (NatOrdinal.val.monotone (ordinalValue_mul_le_naturalMul b c)) + +/-- Berarducci's germ ordinal value is submultiplicative under Hessenberg multiplication. -/ +theorem germOrdinalValue_mul_le_naturalMul (q p : Germ K) : + germOrdinalValue (q * p) ≤ germOrdinalValue q * germOrdinalValue p := by + obtain ⟨b, rfl⟩ := Ideal.Quotient.mk_surjective q + obtain ⟨c, rfl⟩ := Ideal.Quotient.mk_surjective p + rw [← map_mul, germOrdinalValue_mk, germOrdinalValue_mk, germOrdinalValue_mk] + exact ordinalValue_mul_le_naturalMul b c + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/OrdinalValueSupport.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/OrdinalValueSupport.lean new file mode 100644 index 0000000000..360b743dc1 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/OrdinalValueSupport.lean @@ -0,0 +1,85 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValue + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.StableInterval +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.NonpositiveCoefficientMap + +/-! +# Support-determined monotonicity of the ordinal value + +The ordinal value of a nonpositive series depends only on its support, so it is monotone under +inclusion of supports. The two series need not have the same coefficient field: the three regimes +that define the ordinal value — a support bounded strictly below zero, a support meeting zero only +in the constant term, and the general case measured by the order types of the negative support +tails — are each phrased in terms of the support alone. +-/ + +universe v w + +open scoped HahnSeries NatOrdinal + +namespace Berarducci + +open HahnSeries.Nonpositive + +public noncomputable section + +/-- Order-value monotonicity under support deletion, across coefficient fields. -/ +theorem ordinalValue_le_of_support_subset + {K₁ : Type v} {K₂ : Type w} [Field K₁] [Field K₂] + (u : HahnSeries.Nonpositive ℝ K₁) (v : HahnSeries.Nonpositive ℝ K₂) + (h : (u : K₁⟦ℝ⟧).support ⊆ (v : K₂⟦ℝ⟧).support) : + ordinalValue u ≤ ordinalValue v := by + by_cases hvJ : v ∈ HahnSeries.Nonpositive.negativeMonomialIdeal K₂ + · have huJ : u ∈ HahnSeries.Nonpositive.negativeMonomialIdeal K₁ := by + rw [HahnSeries.Nonpositive.mem_negativeMonomialIdeal_iff_supportSup_lt_zero] at hvJ ⊢ + exact lt_of_le_of_lt (supportSup_mono h) hvJ + rw [ordinalValue_of_mem_negativeMonomialIdeal huJ, + ordinalValue_of_mem_negativeMonomialIdeal hvJ] + · by_cases hvN : v ∈ nearConstantSubgroup K₂ + · have huN : u ∈ nearConstantSubgroup K₁ := by + rw [mem_nearConstantSubgroup_iff_sub_C_constantCoeff_mem, + HahnSeries.Nonpositive.mem_negativeMonomialIdeal_iff_supportSup_lt_zero] at hvN ⊢ + refine lt_of_le_of_lt (supportSup_mono ?_) hvN + rw [support_sub_C_constantCoeff, support_sub_C_constantCoeff] + exact Set.sdiff_subset_sdiff_left h + have h1 : ordinalValue u ≤ 1 := + not_lt.mp fun hc ↦ (one_lt_ordinalValue_iff.mp hc) huN + have h2 : (1 : NatOrdinal) ≤ ordinalValue v := + (ordinalValue_of_mem_nearConstantSubgroup_of_not_mem_negativeMonomialIdeal + hvN hvJ).ge + exact h1.trans h2 + · have hv1 : 1 < ordinalValue v := one_lt_ordinalValue_iff.mpr hvN + by_cases hu1 : ordinalValue u ≤ 1 + · exact hu1.trans hv1.le + · replace hu1 : 1 < ordinalValue u := not_le.mp hu1 + obtain ⟨ηu, hηu, hstu⟩ := + exists_forall_later_negativeSupportTail_orderType_eq_ordinalValue u hu1 + obtain ⟨ηv, hηv, hstv⟩ := + exists_forall_later_negativeSupportTail_orderType_eq_ordinalValue v hv1 + set ξ : ℝ := max ηu ηv / 2 with hξdef + have hmaxneg : max ηu ηv < 0 := max_lt hηu hηv + have hξ0 : ξ < 0 := by rw [hξdef]; linarith + have hξu : ηu < ξ := by + rw [hξdef]; have := le_max_left ηu ηv; linarith + have hξv : ηv < ξ := by + rw [hξdef]; have := le_max_right ηu ηv; linarith + have hsub : negativeSupportTail u ξ ⊆ negativeSupportTail v ξ := by + intro x hx + obtain ⟨hxs, hη, h0⟩ := mem_negativeSupportTail_iff.mp hx + exact mem_negativeSupportTail_iff.mpr ⟨h hxs, hη, h0⟩ + have hmono := Set.IsPWO.orderType_mono + ((u : K₁⟦ℝ⟧).isPWO_support.mono (negativeSupportTail_subset_support u ξ)) + ((v : K₂⟦ℝ⟧).isPWO_support.mono (negativeSupportTail_subset_support v ξ)) hsub + rw [hstu ξ hξu hξ0, hstv ξ hξv hξ0] at hmono + exact hmono + +end + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/OrdinalValueValuation.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/OrdinalValueValuation.lean new file mode 100644 index 0000000000..6f5ac68b37 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/OrdinalValueValuation.lean @@ -0,0 +1,70 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValueDegree +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValueSubmultiplicative + +/-! +# The exponent-valued order valuation + +The leading Cantor exponent of Berarducci's ordinal value `v_J` is a max-additive degree on +`K((ℝ^{≤0}))` over every coefficient field, with kernel `J`: the max-form inequality for sums is +Berarducci, Lemma 5.5(1), and the bound `v_J(bc) ≤ v_J(b) ⊙ v_J(c)` of Berarducci, Lemma 5.5(2) +gives the product inequality for the exponent. This module fixes that degree once, as +`ordinalValueDegreeValuation K`. The spaces +`P_α = J_{ω^(α+1)} / J_{ω^α}` are its homogeneous components and `P̂` is its +associated graded ring, so both exist, with their graded multiplication, over every field. + +Exact multiplicativity `v_J(bc) = v_J(b) ⊙ v_J(c)` is Berarducci, Theorem 9.7, proved for a field +of characteristic zero; it is recorded separately as the instance +`(ordinalValueDegreeValuation K).IsMultiplicative` in +`ConwayRefinement.HahnSeries.OrdinalValue.Statements.OrdinalValueDegree`, and it is what makes +the ring `P̂` a domain. +-/ + +universe v + +public noncomputable section + +namespace Berarducci + +variable (K : Type v) [Field K] + +/-- The exponent-valued order valuation of `K((ℝ^{≤0}))`, as a degree function: its value on `b` +is the leading Cantor exponent of Berarducci's ordinal value `v_J(b)`, with bottom value on `J`. +It is a max-additive degree by Berarducci, Lemma 5.5. -/ +def ordinalValueDegreeValuation : MaxAddDegree (Series K) NatOrdinal where + toFun := ordinalValueDegree + map_zero' := ordinalValueDegree_zero + map_one_le_zero' := ordinalValueDegree_one.le + map_neg' := ordinalValueDegree_neg + map_add_le_max' := ordinalValueDegree_add_le_max + map_mul_le_add' := ordinalValueDegree_mul_le_add + +variable {K} + +@[simp] +theorem ordinalValueDegreeValuation_apply (b : Series K) : + ordinalValueDegreeValuation K b = ordinalValueDegree b := + (rfl) + +/-- The kernel of the exponent-valued order valuation is exactly Berarducci's `J`. -/ +theorem ordinalValueDegreeValuation_eq_bot_iff (b : Series K) : + ordinalValueDegreeValuation K b = ⊥ ↔ b ∈ HahnSeries.Nonpositive.negativeMonomialIdeal K := by + rw [ordinalValueDegreeValuation_apply, ordinalValueDegree_eq_bot_iff] + +theorem mem_ordinalValueDegreeValuation_filtrationLE_iff (b : Series K) (α : NatOrdinal) : + b ∈ (ordinalValueDegreeValuation K).filtrationLE α ↔ ordinalValue b < ω^ (α + 1) := by + rw [MaxAddDegree.mem_filtrationLE_iff, ordinalValueDegreeValuation_apply, + ordinalValueDegree_le_coe_iff] + +theorem mem_ordinalValueDegreeValuation_filtrationLT_iff (b : Series K) (α : NatOrdinal) : + b ∈ (ordinalValueDegreeValuation K).filtrationLT α ↔ ordinalValue b < ω^ α := by + rw [MaxAddDegree.mem_filtrationLT_iff, ordinalValueDegreeValuation_apply, + ordinalValueDegree_lt_coe_iff] + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/PowerRemainder.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/PowerRemainder.lean new file mode 100644 index 0000000000..632878c11d --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/PowerRemainder.lean @@ -0,0 +1,376 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalValue +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Truncation + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Convolution +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.ConvolutionRemainder +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.GermValueCut +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.ResidualPointWellOrdered +import Mathlib.Topology.Instances.Real.Lemmas +import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.NaturalPrincipal +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValueDegree +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValueSubmultiplicative + +/-! +# The product-rule form of the convolution remainder estimate + +The form of Berarducci, Lemma 7.7 used in the proof of Lemma 8.2: when `v_J^p(b) ≤ v_J^p(c)`, the +germ of `b ^ (m + 1) * c` at a sufficiently high negative cutoff differs from + +`(m + 1) * b^{|γ} b^m c + b^{m+1} c^{|γ}` + +by a germ of ordinal value strictly below `v_J(b) ^ m ⊙ v_J^r(b) ⊙ v_J(c)`. + +The source proves this by "reasoning as in Lemma 7.7". Applying Lemma 7.7 to the pair +`(b, b^m c)` is not available, because its hypothesis compares principal values and the principal +value of a product is exactly what multiplicativity has yet to supply. The induction here avoids +that by carrying a value cut for the partial products alongside the formula: from the formula at +stage `m`, submultiplicativity bounds `v_J((b^{m+1} c)^{|ξ})` by a maximum of three terms, each of +which is small enough after multiplication by a truncation value of `b`. The three resulting +estimates are two instances of `NatOrdinal.naturalMul_mul_lt_of_lt` and the comparison +`v_J^r(b) * α < v_J(b)` for `α < v_J^p(b)`. + +The integer coefficient is a natural-number scalar on germs, so the identity holds in every +characteristic. Berarducci's characteristic-zero hypothesis is needed only where that coefficient +must be shown not to annihilate its term, which happens in Lemma 8.2. +-/ + +universe v + +public noncomputable section + +open HahnSeries + +namespace Berarducci + +variable {K : Type v} [Field K] + +/-- The remainder in the product-rule form of Berarducci, Lemma 7.7, for `b ^ (m + 1) * c`. -/ +def powerRemainder (b c : SeriesWithOrdinalValueAboveOne K) (m : ℕ) (γ : ℝ) : Germ K := + germAt ((b.1 ^ (m + 1) * c.1 : Series K) : K⟦ℝ⟧) γ + - (m + 1) • (germAt (b.1 : K⟦ℝ⟧) γ * toGerm (b.1 ^ m * c.1)) + - toGerm (b.1 ^ (m + 1)) * germAt (c.1 : K⟦ℝ⟧) γ + +/-- The remainder, unfolded. -/ +theorem powerRemainder_eq (b c : SeriesWithOrdinalValueAboveOne K) (m : ℕ) (γ : ℝ) : + powerRemainder b c m γ = germAt ((b.1 ^ (m + 1) * c.1 : Series K) : K⟦ℝ⟧) γ + - (m + 1) • (germAt (b.1 : K⟦ℝ⟧) γ * toGerm (b.1 ^ m * c.1)) + - toGerm (b.1 ^ (m + 1)) * germAt (c.1 : K⟦ℝ⟧) γ := (rfl) + +/-- The bound on that remainder. -/ +def powerRemainderBound (b c : SeriesWithOrdinalValueAboveOne K) (m : ℕ) : NatOrdinal := + ordinalValue b.1 ^ m * b.residualValue * ordinalValue c.1 + +/-- The remainder bound, unfolded. -/ +theorem powerRemainderBound_eq (b c : SeriesWithOrdinalValueAboveOne K) (m : ℕ) : + powerRemainderBound b c m = ordinalValue b.1 ^ m * b.residualValue * ordinalValue c.1 := + (rfl) + +private theorem powerRemainder_zero (b c : SeriesWithOrdinalValueAboveOne K) (γ : ℝ) : + powerRemainder b c 0 γ = + germAt ((b.1 * c.1 : Series K) : K⟦ℝ⟧) γ + - germAt (b.1 : K⟦ℝ⟧) γ * toGerm c.1 + - toGerm b.1 * germAt (c.1 : K⟦ℝ⟧) γ := by + simp only [powerRemainder, pow_one, pow_zero, one_mul, zero_add, one_smul] + +private theorem powerRemainderBound_zero (b c : SeriesWithOrdinalValueAboveOne K) : + powerRemainderBound b c 0 = b.residualValue * ordinalValue c.1 := by + simp [powerRemainderBound] + +theorem exists_powerRemainder_lt_zero + (b c : SeriesWithOrdinalValueAboveOne K) (hp : b.principalValue ≤ c.principalValue) : + ∃ η < (0 : ℝ), ∀ γ : ℝ, η < γ → γ < 0 → + germOrdinalValue (powerRemainder b c 0 γ) < powerRemainderBound b c 0 := by + obtain ⟨η, hη, h⟩ := exists_germOrdinalValue_convolution_remainder_lt b c hp + refine ⟨η, hη, fun γ hlow hhigh ↦ ?_⟩ + rw [powerRemainder_zero, powerRemainderBound_zero] + exact h γ hlow hhigh + +theorem germOrdinalValue_nsmul_le (n : ℕ) (q : Germ K) : + germOrdinalValue (n • q) ≤ germOrdinalValue q := by + induction n with + | zero => simp + | succ n ih => + rw [succ_nsmul] + exact (germOrdinalValue_add_le_max _ _).trans (max_le ih le_rfl) + +theorem ordinalValue_pow_le (b : Series K) (m : ℕ) : + ordinalValue (b ^ m) ≤ ordinalValue b ^ m := by + induction m with + | zero => simp + | succ m ih => + rw [pow_succ, pow_succ] + exact (ordinalValue_mul_le_naturalMul _ _).trans (mul_le_mul_left ih _) + +theorem ordinalValue_pow_mul_le (b c : Series K) (m : ℕ) : + ordinalValue (b ^ m * c) ≤ ordinalValue b ^ m * ordinalValue c := + (ordinalValue_mul_le_naturalMul _ _).trans (mul_le_mul_left (ordinalValue_pow_le b m) _) + +/-- The defining decomposition of the remainder, read as an expansion of the germ. -/ +theorem germAt_powerProduct_decomp + (b c : SeriesWithOrdinalValueAboveOne K) (m : ℕ) (ξ : ℝ) : + germAt ((b.1 ^ (m + 1) * c.1 : Series K) : K⟦ℝ⟧) ξ = + (m + 1) • (germAt (b.1 : K⟦ℝ⟧) ξ * toGerm (b.1 ^ m * c.1)) + + toGerm (b.1 ^ (m + 1)) * germAt (c.1 : K⟦ℝ⟧) ξ + + powerRemainder b c m ξ := by + rw [powerRemainder] + abel + +/-- The germ ordinal value of a class is the ordinal value of any representative. -/ +theorem germOrdinalValue_toGerm (x : Series K) : + germOrdinalValue (toGerm x) = ordinalValue x := by + rw [toGerm_apply, germOrdinalValue_mk] + +private theorem exists_mul_germOrdinalValue_powerProduct_lt + (b c : SeriesWithOrdinalValueAboveOne K) (hp : b.principalValue ≤ c.principalValue) (m : ℕ) + (hP : ∃ η < (0 : ℝ), ∀ γ : ℝ, η < γ → γ < 0 → + germOrdinalValue (powerRemainder b c m γ) < powerRemainderBound b c m) : + ∃ η < (0 : ℝ), ∀ ξ : ℝ, η < ξ → ξ < 0 → + ∀ α : Ordinal, α < b.principalValue.val → NatOrdinal.of (b.residualValue.val * α) * + germOrdinalValue (germAt ((b.1 ^ (m + 1) * c.1 : Series K) : K⟦ℝ⟧) ξ) + < powerRemainderBound b c (m + 1) := by + obtain ⟨ηP, hηP, hP'⟩ := hP + obtain ⟨ηb, hηb, hcutb⟩ := exists_ordinalValue_translatedTruncation_le b + obtain ⟨ηc, hηc, hcutc⟩ := exists_ordinalValue_translatedTruncation_le c + refine ⟨max ηP (max ηb ηc), max_lt hηP (max_lt hηb hηc), + fun ξ hlow hhigh α hα ↦ ?_⟩ + have hξP : ηP < ξ := (le_max_left _ _).trans_lt hlow + have hξb : ηb < ξ := ((le_max_left ηb ηc).trans (le_max_right ηP _)).trans_lt hlow + have hξc : ηc < ξ := ((le_max_right ηb ηc).trans (le_max_right ηP _)).trans_lt hlow + obtain ⟨α₁, hα₁, hα₁le⟩ := hcutb ξ hξb hhigh + obtain ⟨α₂, hα₂, hα₂le⟩ := hcutc ξ hξc hhigh + set t : NatOrdinal := NatOrdinal.of (b.residualValue.val * α) with htdef + set V := ordinalValue b.1 with hV + set W := ordinalValue c.1 with hW + have hmono : Monotone fun x : NatOrdinal ↦ t * x := fun _ _ h ↦ mul_le_mul_right h t + have hgermb : germOrdinalValue (germAt (b.1 : K⟦ℝ⟧) ξ) ≤ + NatOrdinal.of (b.residualValue.val * α₁) := by + rw [germAt_apply, toGerm_apply, germOrdinalValue_mk] + simpa using NatOrdinal.of.le_iff_le.mpr hα₁le + have hgermc : germOrdinalValue (germAt (c.1 : K⟦ℝ⟧) ξ) ≤ + NatOrdinal.of (c.residualValue.val * α₂) := by + rw [germAt_apply, toGerm_apply, germOrdinalValue_mk] + simpa using NatOrdinal.of.le_iff_le.mpr hα₂le + have hA : germOrdinalValue ((m + 1) • (germAt (b.1 : K⟦ℝ⟧) ξ * toGerm (b.1 ^ m * c.1))) ≤ + NatOrdinal.of (b.residualValue.val * α₁) * (V ^ m * W) := by + refine (germOrdinalValue_nsmul_le _ _).trans ?_ + refine (germOrdinalValue_mul_le_naturalMul _ _).trans (mul_le_mul' hgermb ?_) + rw [germOrdinalValue_toGerm] + exact ordinalValue_pow_mul_le b.1 c.1 m + have hB : germOrdinalValue (toGerm (b.1 ^ (m + 1)) * germAt (c.1 : K⟦ℝ⟧) ξ) ≤ + V ^ (m + 1) * NatOrdinal.of (c.residualValue.val * α₂) := by + refine (germOrdinalValue_mul_le_naturalMul _ _).trans (mul_le_mul' ?_ hgermc) + rw [germOrdinalValue_toGerm] + exact ordinalValue_pow_le b.1 (m + 1) + have hC : germOrdinalValue (powerRemainder b c m ξ) < V ^ m * b.residualValue * W := + hP' ξ hξP hhigh + have hval : germOrdinalValue (germAt ((b.1 ^ (m + 1) * c.1 : Series K) : K⟦ℝ⟧) ξ) ≤ + max (max (NatOrdinal.of (b.residualValue.val * α₁) * (V ^ m * W)) + (V ^ (m + 1) * NatOrdinal.of (c.residualValue.val * α₂))) + (V ^ m * b.residualValue * W) := by + rw [germAt_powerProduct_decomp b c m ξ] + refine (germOrdinalValue_add_le_max _ _).trans (max_le ?_ ?_) + · exact ((germOrdinalValue_add_le_max _ _).trans (max_le (hA.trans (le_max_left _ _)) + (hB.trans (le_max_right _ _)))).trans (le_max_left _ _) + · exact hC.le.trans (le_max_right _ _) + have hVpos : (0 : NatOrdinal) < V := lt_trans zero_lt_one b.2 + have hWpos : (0 : NatOrdinal) < W := lt_trans zero_lt_one c.2 + have hρpos : (0 : NatOrdinal) < b.residualValue := + pos_iff_ne_zero.mpr b.residualValue_ne_zero + have hσpos : (0 : NatOrdinal) < c.residualValue := + pos_iff_ne_zero.mpr c.residualValue_ne_zero + have hVmW : (0 : NatOrdinal) < V ^ m * W := mul_pos (pow_pos hVpos m) hWpos + have hVm1 : (0 : NatOrdinal) < V ^ (m + 1) := pow_pos hVpos (m + 1) + have hXpos : (0 : NatOrdinal) < V ^ m * b.residualValue * W := + mul_pos (mul_pos (pow_pos hVpos m) hρpos) hWpos + have h1 : t * (NatOrdinal.of (b.residualValue.val * α₁) * (V ^ m * W)) < + powerRemainderBound b c (m + 1) := by + have key : t * NatOrdinal.of (b.residualValue.val * α₁) < + b.residualValue * b.residualValue * b.principalValue := + NatOrdinal.naturalMul_mul_lt_of_lt + b.principalValue_isMultiplicativelyPrincipal le_rfl + (by rw [← NatOrdinal.of_val b.principalValue]; exact NatOrdinal.of.lt_iff_lt.mpr hα) + (by rw [← NatOrdinal.of_val b.principalValue]; exact NatOrdinal.of.lt_iff_lt.mpr hα₁) + (mul_pos hρpos hρpos) + calc t * (NatOrdinal.of (b.residualValue.val * α₁) * (V ^ m * W)) + = t * NatOrdinal.of (b.residualValue.val * α₁) * (V ^ m * W) := by ring + _ < b.residualValue * b.residualValue * b.principalValue * (V ^ m * W) := + mul_lt_mul_of_pos_right key hVmW + _ = powerRemainderBound b c (m + 1) := by + rw [powerRemainderBound, mul_assoc b.residualValue b.residualValue, + b.residualValue_mul_principalValue] + ring + have h2 : t * (V ^ (m + 1) * NatOrdinal.of (c.residualValue.val * α₂)) < + powerRemainderBound b c (m + 1) := by + have key : t * NatOrdinal.of (c.residualValue.val * α₂) < + b.residualValue * c.residualValue * c.principalValue := + NatOrdinal.naturalMul_mul_lt_of_lt + c.principalValue_isMultiplicativelyPrincipal hp + (by rw [← NatOrdinal.of_val b.principalValue]; exact NatOrdinal.of.lt_iff_lt.mpr hα) + (by rw [← NatOrdinal.of_val c.principalValue]; exact NatOrdinal.of.lt_iff_lt.mpr hα₂) + (mul_pos hρpos hσpos) + calc t * (V ^ (m + 1) * NatOrdinal.of (c.residualValue.val * α₂)) + = V ^ (m + 1) * (t * NatOrdinal.of (c.residualValue.val * α₂)) := by ring + _ < V ^ (m + 1) * (b.residualValue * c.residualValue * c.principalValue) := + mul_lt_mul_of_pos_left key hVm1 + _ = powerRemainderBound b c (m + 1) := by + rw [powerRemainderBound, mul_assoc b.residualValue c.residualValue, + c.residualValue_mul_principalValue] + ring + have h3 : t * (V ^ m * b.residualValue * W) < powerRemainderBound b c (m + 1) := by + have htV : t < V := by + have hle : t ≤ b.residualValue * NatOrdinal.of α := by + simpa [htdef] using NatOrdinal.of.le_iff_le.mpr + (NatOrdinal.omul_le_mul' b.residualValue.val α) + refine hle.trans_lt ?_ + have hVeq : b.residualValue * b.principalValue = V := + b.residualValue_mul_principalValue + rw [← hVeq] + refine mul_lt_mul_of_pos_left ?_ hρpos + rw [← NatOrdinal.of_val b.principalValue] + exact NatOrdinal.of.lt_iff_lt.mpr hα + calc t * (V ^ m * b.residualValue * W) < V * (V ^ m * b.residualValue * W) := + mul_lt_mul_of_pos_right htV hXpos + _ = powerRemainderBound b c (m + 1) := by + rw [powerRemainderBound] + ring + calc t * germOrdinalValue (germAt ((b.1 ^ (m + 1) * c.1 : Series K) : K⟦ℝ⟧) ξ) + ≤ t * (max (max (NatOrdinal.of (b.residualValue.val * α₁) * (V ^ m * W)) + (V ^ (m + 1) * NatOrdinal.of (c.residualValue.val * α₂))) + (V ^ m * b.residualValue * W)) := mul_le_mul_right hval t + _ = max (max (t * (NatOrdinal.of (b.residualValue.val * α₁) * (V ^ m * W))) + (t * (V ^ (m + 1) * NatOrdinal.of (c.residualValue.val * α₂)))) + (t * (V ^ m * b.residualValue * W)) := by + rw [hmono.map_max, hmono.map_max] + _ < powerRemainderBound b c (m + 1) := max_lt (max_lt h1 h2) h3 + +private theorem powerRemainder_step + (b c : SeriesWithOrdinalValueAboveOne K) (hp : b.principalValue ≤ c.principalValue) (m : ℕ) + (hP : ∃ η < (0 : ℝ), ∀ γ : ℝ, η < γ → γ < 0 → + germOrdinalValue (powerRemainder b c m γ) < powerRemainderBound b c m) : + ∃ η < (0 : ℝ), ∀ γ : ℝ, η < γ → γ < 0 → + germOrdinalValue (powerRemainder b c (m + 1) γ) < powerRemainderBound b c (m + 1) := by + classical + obtain ⟨ηQ, hηQ, hQ⟩ := exists_mul_germOrdinalValue_powerProduct_lt b c hp m hP + obtain ⟨ηP, hηP, hP'⟩ := hP + obtain ⟨ηb, hηb, hcutb⟩ := exists_ordinalValue_translatedTruncation_le b + refine ⟨max ηQ (max ηP ηb), max_lt hηQ (max_lt hηP hηb), fun γ hlow hhigh ↦ ?_⟩ + have hγQ : ηQ < γ := (le_max_left _ _).trans_lt hlow + have hγP : ηP < γ := ((le_max_left ηP ηb).trans (le_max_right ηQ _)).trans_lt hlow + have hγb : ηb < γ := ((le_max_right ηP ηb).trans (le_max_right ηQ _)).trans_lt hlow + set d : Series K := b.1 ^ (m + 1) * c.1 with hddef + set T := convolutionIndex (b.1 : K⟦ℝ⟧) ((d : Series K) : K⟦ℝ⟧) γ with hTdef + set f : ℝ → Germ K := + fun β ↦ + germAt (b.1 : K⟦ℝ⟧) β * germAt ((d : Series K) : K⟦ℝ⟧) (γ - β) with hfdef + have hclosb : closure (b.1 : K⟦ℝ⟧).support ⊆ Set.Iic 0 := + closure_minimal (HahnSeries.Nonpositive.support_subset b.1) isClosed_Iic + have hclosd : closure ((d : Series K) : K⟦ℝ⟧).support ⊆ Set.Iic 0 := + closure_minimal (HahnSeries.Nonpositive.support_subset d) isClosed_Iic + have hfγ : f γ = germAt (b.1 : K⟦ℝ⟧) γ * toGerm d := by + simp only [hfdef, sub_self, germAt_apply, translatedTruncation_zero] + have hf0 : f 0 = toGerm b.1 * germAt ((d : Series K) : K⟦ℝ⟧) γ := by + simp only [hfdef, sub_zero, germAt_apply, translatedTruncation_zero] + have hfγzero : γ ∉ T → f γ = 0 := by + intro hmem + rw [hTdef, mem_convolutionIndex] at hmem + push Not at hmem + simp only [sub_self] at hmem + simp only [hfdef, sub_self] + by_cases hb : γ ∈ closure (b.1 : K⟦ℝ⟧).support + · rw [germAt_eq_zero_of_not_mem_closure_support (hmem hb), mul_zero] + · rw [germAt_eq_zero_of_not_mem_closure_support hb, zero_mul] + have hf0zero : (0 : ℝ) ∉ T → f 0 = 0 := by + intro hmem + rw [hTdef, mem_convolutionIndex] at hmem + push Not at hmem + simp only [sub_zero] at hmem + simp only [hfdef, sub_zero] + by_cases hb : (0 : ℝ) ∈ closure (b.1 : K⟦ℝ⟧).support + · rw [germAt_eq_zero_of_not_mem_closure_support (hmem hb), mul_zero] + · rw [germAt_eq_zero_of_not_mem_closure_support hb, zero_mul] + have hstep1 : ∑ β ∈ T, f β = f γ + ∑ β ∈ T.erase γ, f β := by + by_cases hmem : γ ∈ T + · exact (Finset.add_sum_erase T f hmem).symm + · rw [Finset.erase_eq_of_notMem hmem, hfγzero hmem, zero_add] + have hmem0 : (0 : ℝ) ∈ T.erase γ ↔ (0 : ℝ) ∈ T := by + rw [Finset.mem_erase] + exact ⟨fun h ↦ h.2, fun h ↦ ⟨(ne_of_lt hhigh).symm, h⟩⟩ + have hstep2 : ∑ β ∈ T.erase γ, f β = f 0 + ∑ β ∈ (T.erase γ).erase 0, f β := by + by_cases hmem : (0 : ℝ) ∈ T.erase γ + · exact (Finset.add_sum_erase _ f hmem).symm + · rw [Finset.erase_eq_of_notMem hmem, hf0zero (fun h ↦ hmem (hmem0.mpr h)), zero_add] + have hSeries : (b.1 ^ (m + 1 + 1) * c.1 : Series K) = b.1 * d := by + rw [hddef]; ring + have hcoe : ((b.1 ^ (m + 1 + 1) * c.1 : Series K) : K⟦ℝ⟧) + = (b.1 : K⟦ℝ⟧) * ((d : Series K) : K⟦ℝ⟧) := by rw [hSeries]; rfl + have hsum : germAt ((b.1 ^ (m + 1 + 1) * c.1 : Series K) : K⟦ℝ⟧) γ + = f γ + f 0 + ∑ β ∈ (T.erase γ).erase 0, f β := by + rw [hcoe, germAt_mul, ← hTdef, ← hfdef, hstep1, hstep2] + abel + have hg1 : toGerm (b.1 ^ m * c.1) = toGerm b.1 ^ m * toGerm c.1 := by + rw [map_mul, map_pow] + have hg2 : toGerm d = toGerm b.1 ^ (m + 1) * toGerm c.1 := by + rw [hddef, map_mul, map_pow] + have hg3 : toGerm (b.1 ^ (m + 1)) = toGerm b.1 ^ (m + 1) := map_pow _ _ _ + have hg4 : toGerm (b.1 ^ (m + 1 + 1)) = toGerm b.1 ^ (m + 1 + 1) := map_pow _ _ _ + have hrewrite : powerRemainder b c (m + 1) γ + = toGerm b.1 * powerRemainder b c m γ + ∑ β ∈ (T.erase γ).erase 0, f β := by + rw [powerRemainder, hsum, hfγ, hf0, germAt_powerProduct_decomp b c m γ, + powerRemainder, hg1, hg2, hg3, hg4] + ring + have hVpos : (0 : NatOrdinal) < ordinalValue b.1 := lt_trans zero_lt_one b.2 + have hWpos : (0 : NatOrdinal) < ordinalValue c.1 := lt_trans zero_lt_one c.2 + have hρpos : (0 : NatOrdinal) < b.residualValue := + pos_iff_ne_zero.mpr b.residualValue_ne_zero + have hboundpos : (0 : NatOrdinal) < powerRemainderBound b c (m + 1) := by + rw [powerRemainderBound] + exact mul_pos (mul_pos (pow_pos hVpos (m + 1)) hρpos) hWpos + rw [hrewrite] + refine (germOrdinalValue_add_le_max _ _).trans_lt (max_lt ?_ ?_) + · calc germOrdinalValue (toGerm b.1 * powerRemainder b c m γ) + ≤ ordinalValue b.1 * germOrdinalValue (powerRemainder b c m γ) := by + refine (germOrdinalValue_mul_le_naturalMul _ _).trans ?_ + rw [germOrdinalValue_toGerm] + _ < ordinalValue b.1 * powerRemainderBound b c m := + mul_lt_mul_of_pos_left (hP' γ hγP hhigh) hVpos + _ = powerRemainderBound b c (m + 1) := by + rw [powerRemainderBound, powerRemainderBound]; ring + · refine germOrdinalValue_sum_lt hboundpos fun β hβ ↦ ?_ + obtain ⟨hβ0, hβrest⟩ := Finset.mem_erase.mp hβ + obtain ⟨hβγ, hβT⟩ := Finset.mem_erase.mp hβrest + rw [hTdef, mem_convolutionIndex] at hβT + have hβle : β ≤ 0 := hclosb hβT.1 + have hβneg : β < 0 := lt_of_le_of_ne hβle hβ0 + have hγβle : γ - β ≤ 0 := hclosd hβT.2 + have hγβ : γ < β := by + rcases lt_or_eq_of_le (by linarith : γ ≤ β) with h | h + · exact h + · exact absurd h.symm hβγ + obtain ⟨α, hα, hαle⟩ := hcutb β (hγb.trans hγβ) hβneg + have hb₁ : germOrdinalValue (germAt (b.1 : K⟦ℝ⟧) β) ≤ + NatOrdinal.of (b.residualValue.val * α) := by + rw [germAt_apply, toGerm_apply, germOrdinalValue_mk] + simpa using NatOrdinal.of.le_iff_le.mpr hαle + refine lt_of_le_of_lt ((germOrdinalValue_mul_le_naturalMul _ _).trans + (mul_le_mul_left hb₁ _)) ?_ + exact hQ (γ - β) (by linarith) (by linarith) α hα + +/-- Berarducci, Lemma 7.7 in the product-rule form used by Lemma 8.2: the germ of `b ^ (m + 1) * c` +at a sufficiently high negative cutoff differs from `(m + 1) * b^{|γ} b^m c + b^{m+1} c^{|γ}` by a +germ of ordinal value strictly below `v_J(b) ^ m ⊙ v_J^r(b) ⊙ v_J(c)`. -/ +theorem exists_powerRemainder_lt + (b c : SeriesWithOrdinalValueAboveOne K) (hp : b.principalValue ≤ c.principalValue) (m : ℕ) : + ∃ η < (0 : ℝ), ∀ γ : ℝ, η < γ → γ < 0 → + germOrdinalValue (powerRemainder b c m γ) < powerRemainderBound b c m := by + induction m with + | zero => exact exists_powerRemainder_lt_zero b c hp + | succ m ih => exact powerRemainder_step b c hp m ih + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/PrincipalComponent.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/PrincipalComponent.lean new file mode 100644 index 0000000000..8b5a50cedc --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/PrincipalComponent.lean @@ -0,0 +1,461 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.RV +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValueValuation +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.NormalForm + +import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.Residue +import Mathlib.Tactic.Abel + +/-! +# The spaces `P_α` + +For an exponent `α`, this module defines the space `P_α` intrinsically as + +`J_{ω^(α+1)} / J_{ω^α}`. + +Here `J_{ω^α}` is the additive subgroup of series whose ordinal value is strictly below `ω^α`. +In Lean, the quotient is the grade-`α` component of the multiplicative degree +`ordinalValueDegreeValuation K`, the leading Cantor exponent of `v_J`. Thus the quotient structure +and representative independence are inherited from the generic associated-graded construction; +no basis, complement, or chosen family of representatives occurs in the definition. + +The representative API proves that equality is congruence modulo `J_{ω^α}`. It also proves the +characterization from LM24, Remark 7.2.4: every nonzero class has a principal Hahn series +representative of exact degree `α`. This characterization is a theorem about the intrinsic +quotient, not its primitive definition. + +Constants act through the degree-zero residue ring, giving every homogeneous component its canonical +`K`-module structure. Everything here holds over an arbitrary coefficient field: the components and +their multiplication use only the max-additive degree structure of `ordinalValueDegreeValuation`, +that is, Berarducci, Lemma 5.5, and never the multiplicativity of the ordinal value. +-/ + +universe v + +public noncomputable section + +namespace Berarducci + +open HahnSeries +open scoped DirectSum + +variable {K : Type v} [Field K] + +variable (K) in +/-- The source space `J_{ω^α}` of series whose ordinal value is below `ω^α`. -/ +abbrev ordinalValueCut (α : NatOrdinal) := + (ordinalValueDegreeValuation K).filtrationLT α + +theorem mem_ordinalValueCut_iff (α : NatOrdinal) (b : Series K) : + b ∈ ordinalValueCut K α ↔ ordinalValue b < ω^ α := + mem_ordinalValueDegreeValuation_filtrationLT_iff b α + +variable (K) in +/-- The source space `J_{ω^(α+1)}` is the weak degree filtration at `α`. -/ +theorem ordinalValueCut_add_one_eq_filtrationLE (α : NatOrdinal) : + ordinalValueCut K (α + 1) = + (ordinalValueDegreeValuation K).filtrationLE α := by + ext b + rw [mem_ordinalValueCut_iff, + mem_ordinalValueDegreeValuation_filtrationLE_iff] + +variable (K) in +/-- The space `P_α = J_{ω^(α+1)} / J_{ω^α}`. -/ +abbrev PrincipalComponent (α : NatOrdinal) := + (ordinalValueDegreeValuation K).Component α + +/-- The class in `P_α` of a series in `J_{ω^(α+1)}`. -/ +def principalComponentMk (α : NatOrdinal) + (b : Series K) (hb : ordinalValue b < ω^ (α + 1)) : PrincipalComponent K α := + let w := ordinalValueDegreeValuation K + w.componentMk α ⟨b, (mem_ordinalValueDegreeValuation_filtrationLE_iff b α).mpr hb⟩ + +/-- `principalComponentMk` is the associated-graded quotient map on the ordinal-value filtration. -/ +theorem principalComponentMk_eq_componentMk (α : NatOrdinal) + (b : Series K) (hb : ordinalValue b < ω^ (α + 1)) : + principalComponentMk α b hb = + (ordinalValueDegreeValuation K).componentMk α + ⟨b, (mem_ordinalValueDegreeValuation_filtrationLE_iff b α).mpr hb⟩ := + (rfl) + +@[simp] +theorem principalComponentMk_eq_zero_iff + (α : NatOrdinal) (b : Series K) (hb : ordinalValue b < ω^ (α + 1)) : + principalComponentMk α b hb = 0 ↔ ordinalValue b < ω^ α := by + let w := ordinalValueDegreeValuation K + change w.componentMk α ⟨b, _⟩ = 0 ↔ _ + rw [w.componentMk_eq_zero_iff] + rw [show w b = ordinalValueDegree b from + ordinalValueDegreeValuation_apply b] + exact ordinalValueDegree_lt_coe_iff b α + +/-- Equality in `P_α` is congruence modulo the strict cut `J_{ω^α}`. -/ +theorem principalComponentMk_eq_iff (α : NatOrdinal) (b c : Series K) + (hb : ordinalValue b < ω^ (α + 1)) + (hc : ordinalValue c < ω^ (α + 1)) : + principalComponentMk α b hb = principalComponentMk α c hc ↔ + ordinalValue (b - c) < ω^ α := by + let w := ordinalValueDegreeValuation K + change w.componentMk α ⟨b, _⟩ = w.componentMk α ⟨c, _⟩ ↔ _ + rw [← sub_eq_zero, ← map_sub, w.componentMk_eq_zero_iff] + change w (b - c) < (α : WithBot NatOrdinal) ↔ _ + rw [ordinalValueDegreeValuation_apply] + exact ordinalValueDegree_lt_coe_iff (b - c) α + +/-- Every class in `P_α` has a representative in its weak ordinal-value cut. -/ +theorem exists_principalComponentMk (α : NatOrdinal) (x : PrincipalComponent K α) : + ∃ (b : Series K) (hb : ordinalValue b < ω^ (α + 1)), + principalComponentMk α b hb = x := by + let w := ordinalValueDegreeValuation K + induction x using QuotientAddGroup.induction_on with + | H b => + have hb : ordinalValue (b : Series K) < ω^ (α + 1) := + (mem_ordinalValueDegreeValuation_filtrationLE_iff (b : Series K) α).mp b.2 + refine ⟨b, hb, ?_⟩ + rw [show principalComponentMk α b hb = + w.componentMk α ⟨(b : Series K), _⟩ from rfl, + w.coe_component_eq_componentMk] + +private theorem supportSup_eq_zero_of_not_mem_nearConstantSubgroup + {b : Series K} (hb : b ∉ nearConstantSubgroup K) : + HahnSeries.Nonpositive.supportSup b = 0 := by + apply le_antisymm (HahnSeries.Nonpositive.supportSup_le_zero b) + apply le_of_not_gt + intro hlt + apply hb + apply negativeMonomialIdeal_le_nearConstantSubgroup + exact HahnSeries.Nonpositive.mem_negativeMonomialIdeal_iff_supportSup_lt_zero.mpr hlt + +private theorem principal_representative_of_ordinalValue_eq_wpow + (α : NatOrdinal) (hα : 0 < α) (b : Series K) + (hbValue : ordinalValue b = ω^ α) : + ∃ (p : Series K), + HahnSeries.Nonpositive.IsPrincipal p ∧ + (p : K⟦ℝ⟧).degree = (α : WithBot NatOrdinal) ∧ + ordinalValue p < ω^ (α + 1) ∧ + ordinalValue (b - p) < ω^ α := by + have hbOne : 1 < ordinalValue b := by + rw [hbValue] + simpa using NatOrdinal.wpow_lt_wpow.mpr hα + have hbNear : b ∉ nearConstantSubgroup K := one_lt_ordinalValue_iff.mp hbOne + obtain ⟨p, hbp, hpTypeNat⟩ := + mem_representativeOrderTypes_iff.mp + (ordinalValue_mem_representativeOrderTypes b) + have hpNear : p ∉ nearConstantSubgroup K := by + intro hpNear + apply hbNear + have hsum := (nearConstantSubgroup K).add_mem hbp hpNear + simpa only [sub_add_cancel] using hsum + have hpType : (p : K⟦ℝ⟧).supportOrderType = (ω^ α).val := by + have h := congrArg NatOrdinal.val hpTypeNat + rw [hbValue] at h + simpa using h + have hpPrincipal : HahnSeries.Nonpositive.IsPrincipal p := by + rw [HahnSeries.Nonpositive.isPrincipal_iff] + constructor + · rw [HahnSeries.isWeaklyPrincipal_iff, hpType, NatOrdinal.val_wpow] + exact Ordinal.isAdditivelyPrincipal_omega0_opow α.val + · exact supportSup_eq_zero_of_not_mem_nearConstantSubgroup hpNear + have hpDegree : (p : K⟦ℝ⟧).degree = (α : WithBot NatOrdinal) := by + rw [HahnSeries.degree_eq_cantorDegree, hpType, + ← NatOrdinal.cantorDegree_eq_ordinalCantorDegree, + NatOrdinal.cantorDegree_wpow] + have hpBound : ordinalValue p < ω^ (α + 1) := by + apply (ordinalValue_le_supportOrderType p).trans_lt + rw [hpType] + exact NatOrdinal.val.strictMono (NatOrdinal.wpow_lt_wpow.mpr (lt_add_one α)) + have hdiffBound : ordinalValue (b - p) < ω^ α := by + by_cases hdiffJ : b - p ∈ HahnSeries.Nonpositive.negativeMonomialIdeal K + · rw [ordinalValue_of_mem_negativeMonomialIdeal hdiffJ] + exact NatOrdinal.wpow_pos α + · rw [ordinalValue_of_mem_nearConstantSubgroup_of_not_mem_negativeMonomialIdeal + hbp hdiffJ] + simpa using NatOrdinal.wpow_lt_wpow.mpr hα + exact ⟨p, hpPrincipal, hpDegree, hpBound, hdiffBound⟩ + +private theorem principal_representative_of_ordinalValue_eq_one (b : Series K) + (hbValue : ordinalValue b = 1) : + ∃ (p : Series K), + HahnSeries.Nonpositive.IsPrincipal p ∧ + (p : K⟦ℝ⟧).degree = (0 : WithBot NatOrdinal) ∧ + ordinalValue p < ω^ (0 + 1 : NatOrdinal) ∧ + ordinalValue (b - p) < ω^ (0 : NatOrdinal) := by + have hb := ordinalValue_eq_one_iff.mp hbValue + let k := HahnSeries.Nonpositive.constantCoeff b + have hk : k ≠ 0 := by + intro hk + apply hb.2 + have hmem := mem_nearConstantSubgroup_iff_sub_C_constantCoeff_mem.mp hb.1 + simpa [k, hk] using hmem + let p : Series K := HahnSeries.Nonpositive.C k + have hpPrincipal : HahnSeries.Nonpositive.IsPrincipal p := + HahnSeries.Nonpositive.isPrincipal_C hk + have hpDegree : (p : K⟦ℝ⟧).degree = (0 : WithBot NatOrdinal) := by + change ((HahnSeries.Nonpositive.C k : Series K) : K⟦ℝ⟧).degree = + (0 : WithBot NatOrdinal) + rw [HahnSeries.Nonpositive.coe_C] + change (HahnSeries.C (Γ := ℝ) k).degree = (0 : WithBot NatOrdinal) + rw [HahnSeries.C_apply, HahnSeries.degree_eq_cantorDegree, + HahnSeries.supportOrderType_single hk, Ordinal.cantorDegree_one] + have hpBound : ordinalValue p < ω^ (0 + 1 : NatOrdinal) := by + rw [show p = HahnSeries.Nonpositive.C k from rfl, ordinalValue_C_of_ne hk] + simpa using NatOrdinal.wpow_lt_wpow.mpr (zero_lt_one : (0 : NatOrdinal) < 1) + have hdiffJ : b - p ∈ HahnSeries.Nonpositive.negativeMonomialIdeal K := + mem_nearConstantSubgroup_iff_sub_C_constantCoeff_mem.mp hb.1 + have hdiffBound : ordinalValue (b - p) < ω^ (0 : NatOrdinal) := by + rw [ordinalValue_of_mem_negativeMonomialIdeal hdiffJ] + exact NatOrdinal.wpow_pos 0 + exact ⟨p, hpPrincipal, hpDegree, hpBound, hdiffBound⟩ + +/-- Every nonzero class in `P_α` has a principal representative of exact series degree +`α`. This is the representative characterization in LM24, Remark 7.2.4. -/ +@[blueprint "fact:principal-series-representatives" + (phase := "Ordinal value and degree") + (title := "Principal representatives of $\\mathrm P_\\alpha$ (LM24, Remark 7.2.4)") + (statement := /-- + Every nonzero element of $\Prin_\alpha$ is represented by a principal + series $p$ of exact degree $\alpha$. + -/) + (proof := /-- + A nonzero class in $P_\alpha$ has a representative $b$ with + $v_J(b)=\omega^\alpha$. The principal-part theorem replaces $b$ by a + principal series $p$ of degree $\alpha$ with $v_J(b-p)<\omega^\alpha$; + this is exactly equality in the quotient. + -/)] +theorem exists_principal_representative_of_ne_zero (α : NatOrdinal) + (x : PrincipalComponent K α) (hx : x ≠ 0) : + ∃ (p : Series K) (hpBound : ordinalValue p < ω^ (α + 1)), + HahnSeries.Nonpositive.IsPrincipal p ∧ + (p : K⟦ℝ⟧).degree = (α : WithBot NatOrdinal) ∧ + principalComponentMk α p hpBound = x := by + obtain ⟨b, hbBound, hbx⟩ := exists_principalComponentMk α x + have hbNotLower : ¬ordinalValue b < ω^ α := by + intro hbLower + apply hx + rw [← hbx] + exact (principalComponentMk_eq_zero_iff α b hbBound).mpr hbLower + have hbDegreeLE : ordinalValueDegree b ≤ (α : WithBot NatOrdinal) := + (ordinalValueDegree_le_coe_iff b α).mpr hbBound + have hbDegreeGE : (α : WithBot NatOrdinal) ≤ ordinalValueDegree b := by + apply le_of_not_gt + intro hbDegreeLT + exact hbNotLower ((ordinalValueDegree_lt_coe_iff b α).mp hbDegreeLT) + have hbDegree : ordinalValueDegree b = (α : WithBot NatOrdinal) := + le_antisymm hbDegreeLE hbDegreeGE + have hbValue : ordinalValue b = ω^ α := + (ordinalValueDegree_eq_coe_iff b α).mp hbDegree + rcases eq_or_ne α 0 with rfl | hα + · obtain ⟨p, hp, hpDegree, hpBound, hdiff⟩ := + principal_representative_of_ordinalValue_eq_one b (by simpa using hbValue) + refine ⟨p, hpBound, hp, hpDegree, ?_⟩ + calc + principalComponentMk 0 p hpBound = + principalComponentMk 0 b hbBound := + (principalComponentMk_eq_iff 0 p b hpBound hbBound).mpr (by + have hdiffEq : p - b = -(b - p) := by abel + rw [hdiffEq, ordinalValue_neg] + exact hdiff) + _ = x := hbx + · obtain ⟨p, hp, hpDegree, hpBound, hdiff⟩ := + principal_representative_of_ordinalValue_eq_wpow α + (bot_lt_iff_ne_bot.mpr hα) b hbValue + refine ⟨p, hpBound, hp, hpDegree, ?_⟩ + calc + principalComponentMk α p hpBound = + principalComponentMk α b hbBound := + (principalComponentMk_eq_iff α p b hpBound hbBound).mpr (by + have hdiffEq : p - b = -(b - p) := by abel + rw [hdiffEq, ordinalValue_neg] + exact hdiff) + _ = x := hbx + +/-- Multiplication `P_α × P_β → P_{α + β}`, where addition is the Hessenberg sum. -/ +def principalComponentMul {α β : NatOrdinal} : + PrincipalComponent K α → PrincipalComponent K β → PrincipalComponent K (α + β) := + (ordinalValueDegreeValuation K).componentMul + +/-- Intrinsic homogeneous multiplication is the associated-graded component multiplication. -/ +theorem principalComponentMul_eq_componentMul {α β : NatOrdinal} + (x : PrincipalComponent K α) (y : PrincipalComponent K β) : + principalComponentMul x y = + (ordinalValueDegreeValuation K).componentMul x y := + (rfl) + +/-- Products of representatives from the weak cuts at `α` and `β` lie in the weak cut at +`α + β`. -/ +theorem ordinalValue_mul_lt_wpow_add_one {α β : NatOrdinal} + {b c : Series K} (hb : ordinalValue b < ω^ (α + 1)) + (hc : ordinalValue c < ω^ (β + 1)) : + ordinalValue (b * c) < ω^ (α + β + 1) := by + apply (ordinalValueDegree_le_coe_iff (b * c) (α + β)).mp + exact (ordinalValueDegree_mul_le_add b c).trans (add_le_add + ((ordinalValueDegree_le_coe_iff b α).mpr hb) + ((ordinalValueDegree_le_coe_iff c β).mpr hc)) + +/-- Homogeneous multiplication is induced by multiplication of representatives. -/ +@[simp] +theorem principalComponentMul_mk {α β : NatOrdinal} (b c : Series K) + (hb : ordinalValue b < ω^ (α + 1)) + (hc : ordinalValue c < ω^ (β + 1)) : + principalComponentMul + (principalComponentMk α b hb) + (principalComponentMk β c hc) = + principalComponentMk (α + β) (b * c) + (ordinalValue_mul_lt_wpow_add_one hb hc) := by + let w := ordinalValueDegreeValuation K + change w.componentMul + (w.componentMk α ⟨b, _⟩) + (w.componentMk β ⟨c, _⟩) = + w.componentMk (α + β) ⟨b * c, _⟩ + rw [w.componentMul_componentMk] + apply congrArg (w.componentMk (α + β)) + apply Subtype.ext + exact w.coe_mulFiltrationLE _ _ + +/-- A constant has ordinal value below the first positive principal cut. -/ +theorem ordinalValue_C_lt_wpow_one (k : K) : + ordinalValue ((HahnSeries.Nonpositive.C : K →+* Series K) k) < + ω^ (0 + 1 : NatOrdinal) := by + by_cases hk : k = 0 + · subst k + simp + · rw [ordinalValue_C_of_ne hk] + simpa only [zero_add, NatOrdinal.wpow_zero] using + NatOrdinal.wpow_lt_wpow.mpr (zero_lt_one : (0 : NatOrdinal) < 1) + +variable (K) in +private def constantToOrdinalValueNonpositiveSubring : + K →+* (ordinalValueDegreeValuation K).nonpositiveSubring := + let w := ordinalValueDegreeValuation K + (HahnSeries.Nonpositive.C : K →+* Series K).codRestrict w.nonpositiveSubring fun k ↦ by + rw [w.mem_nonpositiveSubring_iff, + ordinalValueDegreeValuation_apply] + by_cases hk : k = 0 + · subst k + simp + · rw [ordinalValueDegree_C_of_ne hk] + +variable (K) in +/-- The scalar map from constants to the grade-zero residue ring of the exponent-valued order +value. -/ +def principalComponentScalarHom : + K →+* (ordinalValueDegreeValuation K).ResidueRing := + let w := ordinalValueDegreeValuation K + w.residueMap.comp (constantToOrdinalValueNonpositiveSubring K) + +/-- The scalar map `K → P_0` sends a coefficient to the class of the corresponding constant +series. -/ +theorem principalComponentScalarHom_apply (k : K) : + principalComponentScalarHom K k = + principalComponentMk 0 + ((HahnSeries.Nonpositive.C : K →+* Series K) k) + (ordinalValue_C_lt_wpow_one k) := by + let w := ordinalValueDegreeValuation K + change w.residueMap _ = w.componentMk 0 _ + rw [w.residueMap_apply] + apply congrArg (w.componentMk 0) + apply Subtype.ext + rw [w.coe_nonpositiveEquivFiltrationLEZero] + rfl + +variable (K) in +/-- Distinct coefficients determine distinct classes in `P_0`. -/ +theorem principalComponentScalarHom_injective : + Function.Injective (principalComponentScalarHom K) := by + intro k l hkl + have hsub : principalComponentScalarHom K (k - l) = 0 := by + rw [map_sub, hkl, sub_self] + rw [principalComponentScalarHom_apply, + principalComponentMk_eq_zero_iff] at hsub + by_contra hne + rw [ordinalValue_C_of_ne (sub_ne_zero.mpr hne)] at hsub + exact (lt_irrefl (1 : NatOrdinal)) (by + simpa only [NatOrdinal.wpow_zero] using hsub) + +variable (K) in +/-- Every grade-zero principal class is represented by a unique coefficient. -/ +theorem principalComponentScalarHom_surjective : + Function.Surjective (principalComponentScalarHom K) := by + intro x + by_cases hx : x = 0 + · exact ⟨0, by simp [hx]⟩ + obtain ⟨p, hpBound, _, _, hpx⟩ := + exists_principal_representative_of_ne_zero 0 x hx + let k := HahnSeries.Nonpositive.constantCoeff p + refine ⟨k, ?_⟩ + rw [principalComponentScalarHom_apply, ← hpx] + apply (principalComponentMk_eq_iff 0 + (HahnSeries.Nonpositive.C k) p + (ordinalValue_C_lt_wpow_one k) hpBound).mpr + have hpNotLower : ¬ordinalValue p < ω^ (0 : NatOrdinal) := by + intro hpLower + apply hx + rw [← hpx] + exact (principalComponentMk_eq_zero_iff 0 p hpBound).mpr hpLower + have hpDegreeLE : ordinalValueDegree p ≤ (0 : WithBot NatOrdinal) := + (ordinalValueDegree_le_coe_iff p 0).mpr hpBound + have hpDegreeGE : (0 : WithBot NatOrdinal) ≤ ordinalValueDegree p := by + apply le_of_not_gt + intro hpDegreeLT + exact hpNotLower ((ordinalValueDegree_lt_coe_iff p 0).mp hpDegreeLT) + have hpValue : ordinalValue p = 1 := by + simpa only [NatOrdinal.wpow_zero] using + (ordinalValueDegree_eq_coe_iff p 0).mp + (le_antisymm hpDegreeLE hpDegreeGE) + have hpJ : + p - HahnSeries.Nonpositive.C k ∈ + HahnSeries.Nonpositive.negativeMonomialIdeal K := + mem_nearConstantSubgroup_iff_sub_C_constantCoeff_mem.mp + (ordinalValue_eq_one_iff.mp hpValue).1 + rw [show HahnSeries.Nonpositive.C k - p = + -(p - HahnSeries.Nonpositive.C k) by abel] + rw [ordinalValue_neg, ordinalValue_of_mem_negativeMonomialIdeal hpJ] + exact NatOrdinal.wpow_pos 0 + +/-- The space `P_0` is nontrivial because it contains the coefficient field. -/ +instance principalComponentZeroNontrivial : + Nontrivial (PrincipalComponent K 0) := + (principalComponentScalarHom_injective K).nontrivial + +/-- Every `P_α` is canonically a vector space over `K`. -/ +noncomputable instance principalComponentModule (α : NatOrdinal) : + Module K (PrincipalComponent K α) := + Module.compHom (PrincipalComponent K α) (principalComponentScalarHom K) + +/-- Scalar multiplication on `P_α` is multiplication of a representative by the corresponding +constant series. -/ +theorem smul_principalComponentMk (α : NatOrdinal) + (k : K) (b : Series K) (hb : ordinalValue b < ω^ (α + 1)) : + k • principalComponentMk α b hb = + principalComponentMk α + ((HahnSeries.Nonpositive.C : K →+* Series K) k * b) + (by + simpa only [zero_add] using + ordinalValue_mul_lt_wpow_add_one + (ordinalValue_C_lt_wpow_one k) hb) := by + let w := ordinalValueDegreeValuation K + rw [show k • principalComponentMk α b hb = + (principalComponentScalarHom K k) • principalComponentMk α b hb from rfl] + rw [principalComponentScalarHom_apply] + apply DirectSum.of_injective (β := w.Component) α + rw [DirectSum.of_zero_smul, DirectSum.of_mul_of] + change DirectSum.of w.Component (0 + α) + (principalComponentMul + (principalComponentMk 0 + ((HahnSeries.Nonpositive.C : K →+* Series K) k) + (ordinalValue_C_lt_wpow_one k)) + (principalComponentMk α b hb)) = _ + rw [principalComponentMul_mk] + apply DirectSum.of_eq_of_gradedMonoid_eq + apply Sigma.ext (zero_add α) + exact w.componentMk_heq_of_grade_eq_of_coe_eq (zero_add α) _ _ rfl + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/PrincipalComponentDegree.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/PrincipalComponentDegree.lean new file mode 100644 index 0000000000..d625b13781 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/PrincipalComponentDegree.lean @@ -0,0 +1,784 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalComponent +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Degree.Statements.DegreeValuation +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Statements.OrdinalValueDegree +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.DegreeAssociatedGradedMap + +import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.Residue +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.StableInterval +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.PrincipalAddition + +/-! +# Principal series in the two degree filtrations + +This module relates a principal Hahn series to Berarducci's ordinal value and then compares the +fixed homogeneous components for Hahn-series degree and ordinal-value degree. Both are components +of associated graded rings of `K((ℝ^{≤0}))`, and since `ordinalValueDegree b ≤ degree b`, the +identity of the ring induces the canonical component map `degreeLayerToPrincipalComponent` from the +degree-`α` component of `RV̂` to `P_α`: the generic map induced by a coarsening of filtrations. + +For a principal series of Hahn-series degree `α`, its ordinal value is exactly `ω^α`. The proof +uses the stable negative support interval for positive degree and treats degree zero separately. +Consequently, two principal representatives of exact degree `α` determine the same class in the +degree-`α` component of `RV̂` precisely when their difference lies in `J_{ω^α}`. This is +the equal-degree case of LM24, Lemma 7.2.3, and is the case used to identify the source component +with +the intrinsic quotient `J_{ω^(α+1)} / J_{ω^α}`. + +The proof uses the repaired equal-degree form of LM24, Proposition 3.6.2. The weaker printed +formulation is not assumed. + +The comparison of the two filtrations, the principal classes of a fixed degree, and their +identification with `P_α` hold over every coefficient field. Characteristic zero +enters only for the multiplication of principal classes: the product of two principal series is +principal by LM24, Proposition 3.6.1, which rests on Berarducci, Theorem 9.7, and its degree is +the Hessenberg sum of the degrees by LM24, Theorem D. +-/ + +universe v + +open scoped DirectSum HahnSeries NatOrdinal + +public noncomputable section + +namespace Berarducci + +open HahnSeries + +variable {K : Type v} [Field K] + +/-- A principal series of Hahn-series degree `α` has ordinal value `ω^α`. -/ +theorem ordinalValue_eq_wpow_of_isPrincipal {p : Series K} (hp : HahnSeries.Nonpositive.IsPrincipal + p) + {α : NatOrdinal} + (hpDegree : (p : K⟦ℝ⟧).degree = (α : WithBot NatOrdinal)) : + ordinalValue p = ω^ α := by + have hpType := hp.supportOrderType_eq_wpow_of_degree_eq hpDegree + rcases eq_or_ne α 0 with rfl | hα + · apply le_antisymm + · simpa [hpType] using ordinalValue_le_supportOrderType p + · rw [show (ω^ (0 : NatOrdinal)) = 1 by simp] + rw [Order.one_le_iff_pos, pos_iff_ne_zero] + intro hzero + have hpJ := ordinalValue_eq_zero_iff.mp hzero + have hpSupLt := + HahnSeries.Nonpositive.mem_negativeMonomialIdeal_iff_supportSup_lt_zero.mp hpJ + rw [hp.supportSup_eq_zero] at hpSupLt + exact lt_irrefl 0 hpSupLt + · have hαpos : 0 < α := bot_lt_iff_ne_bot.mpr hα + have hpZeroCoeff := hp.constantCoeff_eq_zero_of_degree_pos hpDegree hαpos + have hpOne : 1 < ordinalValue p := + one_lt_ordinalValue_of_constantCoeff_eq_zero_of_supportSup_eq_zero + hpZeroCoeff hp.supportSup_eq_zero + obtain ⟨η, hη, htail⟩ := + exists_negativeSupportTail_orderType_eq_ordinalValue p hpOne + let hpSupport : (p : K⟦ℝ⟧).support.IsPWO := (p : K⟦ℝ⟧).isPWO_support + let hpUpper : ((p : K⟦ℝ⟧).support ∩ Set.Ioi η).IsPWO := + hpSupport.mono Set.inter_subset_left + let hpTail : (negativeSupportTail p η).IsPWO := + hpSupport.mono (negativeSupportTail_subset_support p η) + have htailSet : negativeSupportTail p η = + (p : K⟦ℝ⟧).support ∩ Set.Ioi η := by + ext x + simp only [mem_negativeSupportTail_iff, Set.mem_inter_iff, Set.mem_Ioi] + constructor + · rintro ⟨hxp, hηx, -⟩ + exact ⟨hxp, hηx⟩ + · rintro ⟨hxp, hηx⟩ + refine ⟨hxp, hηx, lt_of_le_of_ne + (HahnSeries.Nonpositive.support_subset p hxp) ?_⟩ + intro hx + subst x + apply (HahnSeries.mem_support _ _).mp hxp + simpa [HahnSeries.Nonpositive.constantCoeff_apply] using hpZeroCoeff + have hpLUB : IsLUB (p : K⟦ℝ⟧).support 0 := + (HahnSeries.Nonpositive.supportSup_eq_coe_iff.mp hp.supportSup_eq_zero).2 + obtain ⟨y, hy, hηy, -⟩ := hpLUB.exists_between hη + have hpPrincipal : Ordinal.IsPrincipal (fun a b ↦ a + b) hpSupport.orderType := + by + simpa only [hpSupport, ← HahnSeries.supportOrderType_eq_setOrderType] using + (Ordinal.isAdditivelyPrincipal_iff_ne_zero_and_isPrincipal_add.mp + (HahnSeries.isWeaklyPrincipal_iff.mp hp.isWeaklyPrincipal)).2 + have hupperType : hpUpper.orderType = hpSupport.orderType := + hpSupport.orderType_inter_Ioi_eq_of_isPrincipal hpPrincipal ⟨y, hy, hηy⟩ + apply NatOrdinal.val.injective + calc + (ordinalValue p).val = hpTail.orderType := htail.symm + _ = hpUpper.orderType := hpTail.orderType_congr hpUpper htailSet + _ = hpSupport.orderType := hupperType + _ = (p : K⟦ℝ⟧).supportOrderType := + (HahnSeries.supportOrderType_eq_setOrderType _).symm + _ = (ω^ α).val := hpType + +/-- On a principal series, Berarducci's exponent-valued ordinal value equals Hahn-series degree. -/ +theorem ordinalValueDegree_eq_degree_of_isPrincipal + {p : Series K} (hp : HahnSeries.Nonpositive.IsPrincipal p) : + ordinalValueDegree p = (p : K⟦ℝ⟧).degree := by + have hpDegreeNe : (p : K⟦ℝ⟧).degree ≠ ⊥ := by + intro hbot + exact hp.ne_zero (Subtype.ext (HahnSeries.degree_eq_bot.mp hbot)) + let α := (p : K⟦ℝ⟧).degree.unbot hpDegreeNe + have hpDegree : (p : K⟦ℝ⟧).degree = (α : WithBot NatOrdinal) := + (WithBot.coe_unbot _ hpDegreeNe).symm + rw [hpDegree] + exact (ordinalValueDegree_eq_coe_iff p α).mpr + (ordinalValue_eq_wpow_of_isPrincipal hp hpDegree) + +/-- Berarducci multiplicativity implies that the product of two principal series is principal. +This recovers LM24, Proposition 3.6.1 directly from the single ordinal-value prerequisite. -/ +theorem OrdinalValueMultiplicative.isPrincipal_mul + (hmul : OrdinalValueMultiplicative K) {b c : Series K} + (hb : HahnSeries.Nonpositive.IsPrincipal b) + (hc : HahnSeries.Nonpositive.IsPrincipal c) : + HahnSeries.Nonpositive.IsPrincipal (b * c) := by + have hbDegreeNe : (b : K⟦ℝ⟧).degree ≠ ⊥ := by + intro hbot + exact hb.ne_zero (Subtype.ext (HahnSeries.degree_eq_bot.mp hbot)) + have hcDegreeNe : (c : K⟦ℝ⟧).degree ≠ ⊥ := by + intro hbot + exact hc.ne_zero (Subtype.ext (HahnSeries.degree_eq_bot.mp hbot)) + let α := (b : K⟦ℝ⟧).degree.unbot hbDegreeNe + let β := (c : K⟦ℝ⟧).degree.unbot hcDegreeNe + have hbDegree : (b : K⟦ℝ⟧).degree = (α : WithBot NatOrdinal) := + (WithBot.coe_unbot _ hbDegreeNe).symm + have hcDegree : (c : K⟦ℝ⟧).degree = (β : WithBot NatOrdinal) := + (WithBot.coe_unbot _ hcDegreeNe).symm + have hbValue := ordinalValue_eq_wpow_of_isPrincipal hb hbDegree + have hcValue := ordinalValue_eq_wpow_of_isPrincipal hc hcDegree + have hproductValue : ordinalValue (b * c) = ω^ (α + β) := by + rw [hmul.ordinalValue_mul, hbValue, hcValue, ← NatOrdinal.wpow_add] + have htypeLE : ((b * c : Series K) : K⟦ℝ⟧).supportOrderType ≤ + (ω^ (α + β)).val := by + calc + ((b * c : Series K) : K⟦ℝ⟧).supportOrderType ≤ + (NatOrdinal.of (b : K⟦ℝ⟧).supportOrderType * + NatOrdinal.of (c : K⟦ℝ⟧).supportOrderType).val := + HahnSeries.supportOrderType_mul_le_naturalMul _ _ + _ = (ω^ (α + β)).val := by + rw [hb.supportOrderType_eq_wpow_of_degree_eq hbDegree, + hc.supportOrderType_eq_wpow_of_degree_eq hcDegree, + NatOrdinal.of_val, NatOrdinal.of_val, NatOrdinal.wpow_add] + have htypeGE : (ω^ (α + β)).val ≤ + ((b * c : Series K) : K⟦ℝ⟧).supportOrderType := by + have h := NatOrdinal.val.monotone (ordinalValue_le_supportOrderType (b * c)) + rw [hproductValue, NatOrdinal.val_wpow, NatOrdinal.val_of] at h + simpa only [NatOrdinal.val_wpow] using h + have htype : ((b * c : Series K) : K⟦ℝ⟧).supportOrderType = + (ω^ (α + β)).val := le_antisymm htypeLE htypeGE + have hnotJ : b * c ∉ HahnSeries.Nonpositive.negativeMonomialIdeal K := by + rw [← ordinalValue_eq_zero_iff, hproductValue] + exact NatOrdinal.wpow_ne_zero (α + β) + rw [HahnSeries.Nonpositive.isPrincipal_iff] + constructor + · rw [HahnSeries.isWeaklyPrincipal_iff, htype, NatOrdinal.val_wpow] + exact Ordinal.isAdditivelyPrincipal_omega0_opow (α + β).val + · apply le_antisymm (HahnSeries.Nonpositive.supportSup_le_zero (b * c)) + apply le_of_not_gt + intro hlt + exact hnotJ + (HahnSeries.Nonpositive.mem_negativeMonomialIdeal_iff_supportSup_lt_zero.mpr hlt) + +/-- Projection of a Hahn series in the weak degree cut to the degree-`α` component. -/ +def degreeLayerMk (α : NatOrdinal) (b : Series K) + (hb : (b : K⟦ℝ⟧).degree ≤ (α : WithBot NatOrdinal)) : + (HahnSeries.Nonpositive.degreeValuation K).Component α := by + let w := HahnSeries.Nonpositive.degreeValuation K + have hbValue : w b ≤ (α : WithBot NatOrdinal) := by + change (HahnSeries.Nonpositive.degreeValuation K) b ≤ + (α : WithBot NatOrdinal) + rw [HahnSeries.Nonpositive.degreeValuation_apply] + exact hb + exact w.componentMk α ⟨b, (w.mem_filtrationLE_iff α b).mpr hbValue⟩ + +/-- `degreeLayerMk` is the quotient map to a component of the degree-graded ring. -/ +theorem degreeLayerMk_eq_componentMk (α : NatOrdinal) (b : Series K) + (hb : (b : K⟦ℝ⟧).degree ≤ (α : WithBot NatOrdinal)) : + degreeLayerMk α b hb = + (HahnSeries.Nonpositive.degreeValuation K).componentMk α + ⟨b, by + rw [MaxAddDegree.mem_filtrationLE_iff, + HahnSeries.Nonpositive.degreeValuation_apply] + exact hb⟩ := + (rfl) + +/-- A representative vanishes in the fixed component of `RV̂` exactly when its degree is +strictly below the component grade. -/ +@[simp] +theorem degreeLayerMk_eq_zero_iff (α : NatOrdinal) (b : Series K) + (hb : (b : K⟦ℝ⟧).degree ≤ (α : WithBot NatOrdinal)) : + degreeLayerMk α b hb = 0 ↔ + (b : K⟦ℝ⟧).degree < (α : WithBot NatOrdinal) := by + let w := HahnSeries.Nonpositive.degreeValuation K + change w.componentMk α ⟨b, _⟩ = 0 ↔ _ + rw [w.componentMk_eq_zero_iff, + HahnSeries.Nonpositive.degreeValuation_apply] + +variable (K) in +/-- The ordinal-value degree is bounded by Hahn-series degree: the degree filtration refines the +ordinal-value filtration. -/ +theorem ordinalValueDegreeValuation_le_degreeValuation (b : Series K) : + ordinalValueDegreeValuation K b ≤ HahnSeries.Nonpositive.degreeValuation K b := by + rw [ordinalValueDegreeValuation_apply, HahnSeries.Nonpositive.degreeValuation_apply] + exact ordinalValueDegree_le_degree b + +variable (K) in +/-- The canonical additive map from the degree-`α` component of `RV̂` to `P_α`: +the component map of the associated graded rings induced by the identity of `K((ℝ^{≤0}))`, which +does not increase the degree because `ordinalValueDegree b ≤ degree b`. -/ +def degreeLayerToPrincipalComponent (α : NatOrdinal) : + (HahnSeries.Nonpositive.degreeValuation K).Component α →+ + PrincipalComponent K α := + (HahnSeries.Nonpositive.degreeValuation K).componentMap (ordinalValueDegreeValuation K) + (RingHom.id (Series K)) (ordinalValueDegreeValuation_le_degreeValuation K) α + +/-- The canonical component map is the generic component map of the two filtrations. -/ +theorem degreeLayerToPrincipalComponent_eq_componentMap (α : NatOrdinal) : + degreeLayerToPrincipalComponent K α = + (HahnSeries.Nonpositive.degreeValuation K).componentMap (ordinalValueDegreeValuation K) + (RingHom.id (Series K)) (ordinalValueDegreeValuation_le_degreeValuation K) α := + (rfl) + +/-- On an arbitrary weak-filtration representative, the canonical component map keeps the +underlying Hahn series and changes only the quotient filtration. -/ +theorem degreeLayerToPrincipalComponent_componentMk (α : NatOrdinal) + (b : MaxAddDegree.filtrationLE + (HahnSeries.Nonpositive.degreeValuation K) α) : + degreeLayerToPrincipalComponent K α + (MaxAddDegree.componentMk + (HahnSeries.Nonpositive.degreeValuation K) α b) = + (ordinalValueDegreeValuation K).componentMk α + ⟨b, by + rw [MaxAddDegree.mem_filtrationLE_iff, + ordinalValueDegreeValuation_apply] + have hbDegree := + (MaxAddDegree.mem_filtrationLE_iff + (HahnSeries.Nonpositive.degreeValuation K) α b).mp b.2 + rw [HahnSeries.Nonpositive.degreeValuation_apply] at hbDegree + exact (ordinalValueDegree_le_degree (b : Series K)).trans hbDegree⟩ := by + rw [degreeLayerToPrincipalComponent, MaxAddDegree.componentMap_componentMk] + apply congrArg ((ordinalValueDegreeValuation K).componentMk α) + apply Subtype.ext + rw [MaxAddDegree.coe_mapFiltrationLE, RingHom.id_apply] + +/-- The canonical component map sends a degree-`α` representative to the same series modulo +the ordinal-value cut. -/ +@[simp] +theorem degreeLayerToPrincipalComponent_mk (α : NatOrdinal) (b : Series K) + (hbDegree : (b : K⟦ℝ⟧).degree ≤ (α : WithBot NatOrdinal)) : + degreeLayerToPrincipalComponent K α + (degreeLayerMk α b hbDegree) = + principalComponentMk α b + ((ordinalValueDegree_le_coe_iff b α).mp + ((ordinalValueDegree_le_degree b).trans hbDegree)) := by + let wDegree := HahnSeries.Nonpositive.degreeValuation K + change degreeLayerToPrincipalComponent K α + (wDegree.componentMk α ⟨b, _⟩) = _ + rw [degreeLayerToPrincipalComponent_componentMk, principalComponentMk_eq_componentMk] + +/-- Projection to a fixed component of `RV̂` preserves addition of representatives. -/ +theorem degreeLayerMk_add (α : NatOrdinal) (b c : Series K) + (hb : (b : K⟦ℝ⟧).degree ≤ (α : WithBot NatOrdinal)) + (hc : (c : K⟦ℝ⟧).degree ≤ (α : WithBot NatOrdinal)) : + degreeLayerMk α (b + c) + ((HahnSeries.degree_add_le (b : K⟦ℝ⟧) (c : K⟦ℝ⟧)).trans + (max_le hb hc)) = + degreeLayerMk α b hb + degreeLayerMk α c hc := by + let w := HahnSeries.Nonpositive.degreeValuation K + change w.componentMk α ⟨b + c, _⟩ = + w.componentMk α ⟨b, _⟩ + w.componentMk α ⟨c, _⟩ + rw [← map_add] + apply congrArg (w.componentMk α) + rfl + +/-- Projection to a fixed component of `RV̂` preserves negation of representatives. -/ +theorem degreeLayerMk_neg (α : NatOrdinal) (b : Series K) + (hb : (b : K⟦ℝ⟧).degree ≤ (α : WithBot NatOrdinal)) : + degreeLayerMk α (-b) (by simpa using hb) = + -degreeLayerMk α b hb := by + let w := HahnSeries.Nonpositive.degreeValuation K + change w.componentMk α ⟨-b, _⟩ = -w.componentMk α ⟨b, _⟩ + rw [← map_neg] + apply congrArg (w.componentMk α) + rfl + +/-- Multiplication in the degree-graded ring `RV̂` is induced by multiplication of +representatives. -/ +theorem degreeLayerMk_mul {α β : NatOrdinal} (b c : Series K) + (hb : (b : K⟦ℝ⟧).degree ≤ (α : WithBot NatOrdinal)) + (hc : (c : K⟦ℝ⟧).degree ≤ (β : WithBot NatOrdinal)) : + (HahnSeries.Nonpositive.degreeValuation K).componentMul + (degreeLayerMk α b hb) + (degreeLayerMk β c hc) = + degreeLayerMk (α + β) (b * c) (by + rw [Subring.coe_mul] + exact (HahnSeries.degree_mul_le _ _).trans (add_le_add hb hc)) := by + let w := HahnSeries.Nonpositive.degreeValuation K + change w.componentMul (w.componentMk α ⟨b, _⟩) (w.componentMk β ⟨c, _⟩) = + w.componentMk (α + β) ⟨b * c, _⟩ + rw [w.componentMul_componentMk] + apply congrArg (w.componentMk (α + β)) + apply Subtype.ext + exact w.coe_mulFiltrationLE _ _ + +/-- A constant Hahn series lies in the degree-zero weak filtration. -/ +theorem degree_C_le_zero (k : K) : + (((HahnSeries.Nonpositive.C : K →+* Series K) k : Series K) : + K⟦ℝ⟧).degree ≤ (0 : WithBot NatOrdinal) := by + rw [HahnSeries.degree_le_zero_iff] + rw [HahnSeries.Nonpositive.coe_C, HahnSeries.C_apply] + exact Set.Finite.subset (Set.finite_singleton 0) + (HahnSeries.support_single_subset (a := 0) (r := k)) + +/-- A nonzero constant Hahn series has degree zero. -/ +theorem degree_C_eq_zero_of_ne {k : K} (hk : k ≠ 0) : + (((HahnSeries.Nonpositive.C : K →+* Series K) k : Series K) : + K⟦ℝ⟧).degree = (0 : WithBot NatOrdinal) := by + apply HahnSeries.degree_eq_zero.mpr + constructor + · simpa only [HahnSeries.Nonpositive.coe_C] using HahnSeries.C_ne_zero hk + · rw [HahnSeries.Nonpositive.coe_C, HahnSeries.C_apply] + exact Set.Finite.subset (Set.finite_singleton 0) + (HahnSeries.support_single_subset (a := 0) (r := k)) + +variable (K) in +private def constantToDegreeNonpositiveSubring : + K →+* (HahnSeries.Nonpositive.degreeValuation K).nonpositiveSubring := + let w := HahnSeries.Nonpositive.degreeValuation K + (HahnSeries.Nonpositive.C : K →+* Series K).codRestrict w.nonpositiveSubring fun k ↦ by + rw [w.mem_nonpositiveSubring_iff, + HahnSeries.Nonpositive.degreeValuation_apply] + exact degree_C_le_zero k + +variable (K) in +/-- The scalar map from coefficients to the grade-zero residue ring of Hahn-series degree. -/ +def degreeLayerScalarHom : + K →+* (HahnSeries.Nonpositive.degreeValuation K).ResidueRing := + let w := HahnSeries.Nonpositive.degreeValuation K + w.residueMap.comp (constantToDegreeNonpositiveSubring K) + +/-- The scalar map into the degree-zero component sends a coefficient to the class of the +corresponding +constant Hahn series. -/ +theorem degreeLayerScalarHom_apply (k : K) : + degreeLayerScalarHom K k = + degreeLayerMk 0 + ((HahnSeries.Nonpositive.C : K →+* Series K) k) + (degree_C_le_zero k) := by + let w := HahnSeries.Nonpositive.degreeValuation K + change w.residueMap _ = w.componentMk 0 _ + rw [w.residueMap_apply] + apply congrArg (w.componentMk 0) + apply Subtype.ext + rw [w.coe_nonpositiveEquivFiltrationLEZero] + rfl + +/-- Each component of `RV̂` is canonically a vector space over the coefficient field. -/ +noncomputable instance degreeLayerModule (α : NatOrdinal) : + Module K + ((HahnSeries.Nonpositive.degreeValuation K).Component α) := + Module.compHom _ (degreeLayerScalarHom K) + +/-- Coefficient scalar multiplication on a component of `RV̂` is the action of the +corresponding grade-zero residue class. -/ +theorem degreeLayer_smul_eq_residue_smul (alpha : NatOrdinal) (k : K) + (x : (HahnSeries.Nonpositive.degreeValuation K).Component alpha) : + k • x = degreeLayerScalarHom K k • x := + (rfl) + +/-- Scalar multiplication in a component of `RV̂` is multiplication of a representative by +the corresponding constant Hahn series. -/ +theorem smul_degreeLayerMk (α : NatOrdinal) (k : K) (b : Series K) + (hb : (b : K⟦ℝ⟧).degree ≤ (α : WithBot NatOrdinal)) : + k • degreeLayerMk α b hb = + degreeLayerMk α + ((HahnSeries.Nonpositive.C : K →+* Series K) k * b) + (by + rw [Subring.coe_mul] + exact (HahnSeries.degree_mul_le _ _).trans + ((add_le_add (degree_C_le_zero k) hb).trans_eq (zero_add _))) := by + let w := HahnSeries.Nonpositive.degreeValuation K + rw [show k • degreeLayerMk α b hb = + (degreeLayerScalarHom K k) • degreeLayerMk α b hb from rfl] + rw [degreeLayerScalarHom_apply] + apply DirectSum.of_injective (β := w.Component) α + rw [DirectSum.of_zero_smul, DirectSum.of_mul_of] + change DirectSum.of w.Component (0 + α) + (w.componentMul + (degreeLayerMk 0 + ((HahnSeries.Nonpositive.C : K →+* Series K) k) + (degree_C_le_zero k)) + (degreeLayerMk α b hb)) = _ + rw [degreeLayerMk_mul] + apply DirectSum.of_eq_of_gradedMonoid_eq + apply Sigma.ext (zero_add α) + exact w.componentMk_heq_of_grade_eq_of_coe_eq (zero_add α) _ _ rfl + +/-- The canonical map from the components of `RV̂` to the spaces `P_α` commutes with +homogeneous multiplication. -/ +theorem degreeLayerToPrincipalComponent_componentMul {α β : NatOrdinal} + (x : (HahnSeries.Nonpositive.degreeValuation K).Component α) + (y : (HahnSeries.Nonpositive.degreeValuation K).Component β) : + degreeLayerToPrincipalComponent K (α + β) + (MaxAddDegree.componentMul + (HahnSeries.Nonpositive.degreeValuation K) x y) = + principalComponentMul + (degreeLayerToPrincipalComponent K α x) + (degreeLayerToPrincipalComponent K β y) := by + rw [principalComponentMul_eq_componentMul] + exact MaxAddDegree.componentMap_componentMul _ _ _ _ x y + +/-- The canonical component map is compatible with the coefficient-field actions on the two +degree filtrations. -/ +theorem degreeLayerToPrincipalComponent_map_smul (α : NatOrdinal) (k : K) + (x : (HahnSeries.Nonpositive.degreeValuation K).Component α) : + degreeLayerToPrincipalComponent K α (k • x) = + k • degreeLayerToPrincipalComponent K α x := by + let w := HahnSeries.Nonpositive.degreeValuation K + induction x using QuotientAddGroup.induction_on with + | H x => + rw [w.coe_component_eq_componentMk] + let b : Series K := x + have hb : (b : K⟦ℝ⟧).degree ≤ (α : WithBot NatOrdinal) := by + have hbValue := (w.mem_filtrationLE_iff α b).mp x.2 + rw [HahnSeries.Nonpositive.degreeValuation_apply] at hbValue + exact hbValue + change degreeLayerToPrincipalComponent K α + (k • degreeLayerMk α b hb) = + k • degreeLayerToPrincipalComponent K α + (degreeLayerMk α b hb) + rw [smul_degreeLayerMk, degreeLayerToPrincipalComponent_mk, + degreeLayerToPrincipalComponent_mk, smul_principalComponentMk] + +variable (K) in +/-- The canonical component map, bundled as a `K`-linear map. -/ +def degreeLayerToPrincipalComponentLinear (α : NatOrdinal) : + (HahnSeries.Nonpositive.degreeValuation K).Component α →ₗ[K] + PrincipalComponent K α := + { degreeLayerToPrincipalComponent K α with + map_smul' := degreeLayerToPrincipalComponent_map_smul α } + +@[simp] +theorem degreeLayerToPrincipalComponentLinear_apply (α : NatOrdinal) + (x : (HahnSeries.Nonpositive.degreeValuation K).Component α) : + degreeLayerToPrincipalComponentLinear K α x = + degreeLayerToPrincipalComponent K α x := + (rfl) + +/-- For exact-degree principal representatives, equality in the degree component is exactly +congruence modulo `J_{ω^α}`. This is the equal-degree case of LM24, Lemma 7.2.3. -/ +theorem degreeLayerMk_eq_iff_ordinalValue_sub_lt (α : NatOrdinal) {b c : Series K} + (hb : HahnSeries.Nonpositive.IsPrincipal b) + (hc : HahnSeries.Nonpositive.IsPrincipal c) + (hbDegree : (b : K⟦ℝ⟧).degree = (α : WithBot NatOrdinal)) + (hcDegree : (c : K⟦ℝ⟧).degree = (α : WithBot NatOrdinal)) : + degreeLayerMk α b hbDegree.le = + degreeLayerMk α c hcDegree.le ↔ + ordinalValue (b - c) < ω^ α := by + let w := HahnSeries.Nonpositive.degreeValuation K + change w.componentMk α ⟨b, _⟩ = w.componentMk α ⟨c, _⟩ ↔ _ + rw [w.componentMk_eq_componentMk_iff, + HahnSeries.Nonpositive.degreeValuation_apply] + constructor + · intro hdegree + apply (ordinalValueDegree_lt_coe_iff (b - c) α).mp + exact (ordinalValueDegree_le_degree (b - c)).trans_lt hdegree + · intro hvalue + have hdegreeLE : ((b - c : Series K) : K⟦ℝ⟧).degree ≤ + (α : WithBot NatOrdinal) := by + change ((b : K⟦ℝ⟧) - (c : K⟦ℝ⟧)).degree ≤ + (α : WithBot NatOrdinal) + calc + ((b : K⟦ℝ⟧) - (c : K⟦ℝ⟧)).degree = + ((b : K⟦ℝ⟧) + -(c : K⟦ℝ⟧)).degree := by + rw [sub_eq_add_neg] + _ ≤ max (b : K⟦ℝ⟧).degree (-(c : K⟦ℝ⟧)).degree := + HahnSeries.degree_add_le _ _ + _ = (α : WithBot NatOrdinal) := by + rw [HahnSeries.degree_neg, hbDegree, hcDegree, max_self] + apply lt_of_le_of_ne hdegreeLE + intro hdegreeEq + have hdiffDegree : ((b - c : Series K) : K⟦ℝ⟧).degree = + (α : WithBot NatOrdinal) := hdegreeEq + have hnegDegree : ((-c : Series K) : K⟦ℝ⟧).degree = + (b : K⟦ℝ⟧).degree := by + simp only [Subring.coe_neg, HahnSeries.degree_neg, hbDegree, hcDegree] + have hsumDegree : + (((b + (-c) : Series K) : K⟦ℝ⟧)).degree = + (b : K⟦ℝ⟧).degree := by + simpa only [sub_eq_add_neg, hbDegree] using hdiffDegree + have hdiffPrincipal : HahnSeries.Nonpositive.IsPrincipal (b - c) := by + have hprincipal := hb.add_of_degree_eq hc.neg hnegDegree hsumDegree + simpa only [sub_eq_add_neg] using hprincipal + have hordinalValue := ordinalValue_eq_wpow_of_isPrincipal hdiffPrincipal hdiffDegree + rw [hordinalValue] at hvalue + exact lt_irrefl _ hvalue + +/-- A homogeneous class of `RV̂` is principal when it is zero or has a principal +representative of exactly that degree. This is the source predicate from LM24, Definition 5.2.1. -/ +def IsPrincipalDegreeClass (α : NatOrdinal) + (x : (HahnSeries.Nonpositive.degreeValuation K).Component α) : + Prop := + x = 0 ∨ + ∃ (p : Series K) (_hp : HahnSeries.Nonpositive.IsPrincipal p) + (hpDegree : (p : K⟦ℝ⟧).degree = (α : WithBot NatOrdinal)), + x = degreeLayerMk α p hpDegree.le + +/-- Characterization of a principal homogeneous class of `RV̂` by a representative. -/ +theorem isPrincipalDegreeClass_iff (α : NatOrdinal) + (x : (HahnSeries.Nonpositive.degreeValuation K).Component α) : + IsPrincipalDegreeClass α x ↔ + x = 0 ∨ + ∃ (p : Series K) (_hp : HahnSeries.Nonpositive.IsPrincipal p) + (hpDegree : (p : K⟦ℝ⟧).degree = (α : WithBot NatOrdinal)), + x = degreeLayerMk α p hpDegree.le := + (Iff.rfl) + +variable (K) in +/-- The principal classes of a fixed Hahn degree form the `K`-subspace `P_α` from LM24, +Proposition 5.2.4 and Corollary 5.2.5. -/ +def principalDegreeClasses (α : NatOrdinal) : + Submodule K + ((HahnSeries.Nonpositive.degreeValuation K).Component α) where + carrier := {x | IsPrincipalDegreeClass α x} + zero_mem' := Or.inl rfl + add_mem' := by + intro x y hx hy + change IsPrincipalDegreeClass α x at hx + change IsPrincipalDegreeClass α y at hy + change IsPrincipalDegreeClass α (x + y) + rw [isPrincipalDegreeClass_iff] at hx hy ⊢ + rcases hx with rfl | ⟨p, hp, hpDegree, rfl⟩ + · simpa using hy + rcases hy with rfl | ⟨q, hq, hqDegree, rfl⟩ + · exact Or.inr ⟨p, hp, hpDegree, by simp⟩ + have hsumLE : (((p + q : Series K) : K⟦ℝ⟧)).degree ≤ + (α : WithBot NatOrdinal) := + (HahnSeries.degree_add_le (p : K⟦ℝ⟧) (q : K⟦ℝ⟧)).trans + (max_le hpDegree.le hqDegree.le) + have hprojection : + degreeLayerMk α p hpDegree.le + + degreeLayerMk α q hqDegree.le = + degreeLayerMk α (p + q) hsumLE := + (degreeLayerMk_add α p q hpDegree.le hqDegree.le).symm + by_cases hzero : degreeLayerMk α (p + q) hsumLE = 0 + · exact Or.inl (hprojection.trans hzero) + · have hsumNotLt : ¬(((p + q : Series K) : K⟦ℝ⟧).degree < + (α : WithBot NatOrdinal)) := by + intro hlt + apply hzero + let w := HahnSeries.Nonpositive.degreeValuation K + change w.componentMk α ⟨p + q, _⟩ = 0 + rw [w.componentMk_eq_zero_iff, + HahnSeries.Nonpositive.degreeValuation_apply] + exact hlt + have hsumDegree : (((p + q : Series K) : K⟦ℝ⟧)).degree = + (α : WithBot NatOrdinal) := + le_antisymm hsumLE (le_of_not_gt hsumNotLt) + have hsumPrincipal : HahnSeries.Nonpositive.IsPrincipal (p + q) := + hp.add_of_degree_eq hq + (hqDegree.trans hpDegree.symm) + (hsumDegree.trans hpDegree.symm) + exact Or.inr ⟨p + q, hsumPrincipal, hsumDegree, hprojection⟩ + smul_mem' := by + intro k x hx + change IsPrincipalDegreeClass α x at hx + change IsPrincipalDegreeClass α (k • x) + rw [isPrincipalDegreeClass_iff] at hx ⊢ + rcases hx with rfl | ⟨p, hp, hpDegree, rfl⟩ + · exact Or.inl (smul_zero k) + · by_cases hk : k = 0 + · subst k + exact Or.inl + (zero_smul K (degreeLayerMk α p hpDegree.le)) + · have hkpDegree : + ((((HahnSeries.Nonpositive.C : K →+* Series K) k) * p : Series K) : + K⟦ℝ⟧).degree = (α : WithBot NatOrdinal) := by + rw [← ordinalValueDegree_eq_degree_of_isPrincipal (hp.const_mul hk), + ordinalValueDegree_C_mul hk, ordinalValueDegree_eq_degree_of_isPrincipal hp, hpDegree] + exact Or.inr + ⟨(HahnSeries.Nonpositive.C : K →+* Series K) k * p, + hp.const_mul hk, hkpDegree, + smul_degreeLayerMk α k p hpDegree.le⟩ + +/-- Membership in the source presentation `P_α` is exactly the principal-class predicate. -/ +theorem mem_principalDegreeClasses_iff (α : NatOrdinal) + (x : (HahnSeries.Nonpositive.degreeValuation K).Component α) : + x ∈ principalDegreeClasses K α ↔ + IsPrincipalDegreeClass α x := + (Iff.rfl) + +variable (K) in +/-- Restriction of the canonical component map to the source principal subspace. -/ +def principalDegreeClassesToPrincipalComponent (α : NatOrdinal) : + principalDegreeClasses K α →ₗ[K] PrincipalComponent K α := + (degreeLayerToPrincipalComponentLinear K α).comp + (principalDegreeClasses K α).subtype + +/-- The restricted map is the canonical map on the underlying homogeneous class. -/ +@[simp] +theorem principalDegreeClassesToPrincipalComponent_apply + (α : NatOrdinal) (x : principalDegreeClasses K α) : + principalDegreeClassesToPrincipalComponent K α x = + degreeLayerToPrincipalComponent K α x := + (rfl) + +/-- The restricted canonical map commutes with coefficient scalar multiplication. -/ +theorem principalDegreeClassesToPrincipalComponent_smul + (α : NatOrdinal) (k : K) (x : principalDegreeClasses K α) : + principalDegreeClassesToPrincipalComponent K α (k • x) = + k • principalDegreeClassesToPrincipalComponent K α x := + map_smul (principalDegreeClassesToPrincipalComponent K α) k x + +private theorem principalComponentMk_ne_zero_of_isPrincipal (α : NatOrdinal) + {p : Series K} (hp : HahnSeries.Nonpositive.IsPrincipal p) + (hpDegree : (p : K⟦ℝ⟧).degree = (α : WithBot NatOrdinal)) + (hpBound : ordinalValue p < ω^ (α + 1)) : + principalComponentMk α p hpBound ≠ 0 := by + intro hzero + have hlt := (principalComponentMk_eq_zero_iff α p hpBound).mp hzero + rw [ordinalValue_eq_wpow_of_isPrincipal hp hpDegree] at hlt + exact lt_irrefl (ω^ α) hlt + +variable (K) in +private theorem principalDegreeClassesToPrincipalComponent_injective (α : NatOrdinal) : + Function.Injective (principalDegreeClassesToPrincipalComponent K α) := by + intro x y hxy + apply Subtype.ext + change degreeLayerToPrincipalComponent K α x = + degreeLayerToPrincipalComponent K α y at hxy + have hx := (mem_principalDegreeClasses_iff α _).mp x.2 + have hy := (mem_principalDegreeClasses_iff α _).mp y.2 + rw [isPrincipalDegreeClass_iff] at hx hy + rcases hx with hx0 | ⟨p, hp, hpDegree, hxp⟩ + · rcases hy with hy0 | ⟨q, hq, hqDegree, hyq⟩ + · exact hx0.trans hy0.symm + · rw [hx0, hyq, map_zero, degreeLayerToPrincipalComponent_mk] at hxy + exact (principalComponentMk_ne_zero_of_isPrincipal α hq hqDegree _ + hxy.symm).elim + · rcases hy with hy0 | ⟨q, hq, hqDegree, hyq⟩ + · rw [hxp, hy0, degreeLayerToPrincipalComponent_mk, map_zero] at hxy + exact (principalComponentMk_ne_zero_of_isPrincipal α hp hpDegree _ hxy).elim + · rw [hxp, hyq, degreeLayerToPrincipalComponent_mk, + degreeLayerToPrincipalComponent_mk] at hxy + have hpBound : ordinalValue p < ω^ (α + 1) := + (ordinalValueDegree_le_coe_iff p α).mp + ((ordinalValueDegree_le_degree p).trans hpDegree.le) + have hqBound : ordinalValue q < ω^ (α + 1) := + (ordinalValueDegree_le_coe_iff q α).mp + ((ordinalValueDegree_le_degree q).trans hqDegree.le) + have hcongr : ordinalValue (p - q) < ω^ α := + (principalComponentMk_eq_iff α p q hpBound hqBound).mp hxy + exact hxp.trans + (((degreeLayerMk_eq_iff_ordinalValue_sub_lt α hp hq + hpDegree hqDegree).mpr hcongr).trans hyq.symm) + +variable (K) in +private theorem principalDegreeClassesToPrincipalComponent_surjective (α : NatOrdinal) : + Function.Surjective (principalDegreeClassesToPrincipalComponent K α) := by + intro x + by_cases hx : x = 0 + · refine ⟨0, ?_⟩ + subst x + exact map_zero _ + · obtain ⟨p, hpBound, hp, hpDegree, hpx⟩ := + exists_principal_representative_of_ne_zero α x hx + let pClass := degreeLayerMk α p hpDegree.le + have hpClass : pClass ∈ principalDegreeClasses K α := by + rw [mem_principalDegreeClasses_iff, isPrincipalDegreeClass_iff] + exact Or.inr ⟨p, hp, hpDegree, rfl⟩ + refine ⟨⟨pClass, hpClass⟩, ?_⟩ + change degreeLayerToPrincipalComponent K α pClass = x + rw [show pClass = degreeLayerMk α p hpDegree.le from rfl, + degreeLayerToPrincipalComponent_mk] + exact hpx + +variable (K) in +/-- The source homogeneous principal classes are canonically linearly equivalent to the intrinsic +quotient `J_{ω^(α+1)} / J_{ω^α}`. This formalizes LM24, Remark 7.2.4. -/ +def principalDegreeClassesEquivPrincipalComponent (α : NatOrdinal) : + principalDegreeClasses K α ≃ₗ[K] PrincipalComponent K α := + LinearEquiv.ofBijective + (principalDegreeClassesToPrincipalComponent K α) + ⟨principalDegreeClassesToPrincipalComponent_injective K α, + principalDegreeClassesToPrincipalComponent_surjective K α⟩ + +/-- The canonical equivalence is the canonical component map on underlying classes. -/ +@[simp] +theorem principalDegreeClassesEquivPrincipalComponent_apply + (α : NatOrdinal) (x : principalDegreeClasses K α) : + principalDegreeClassesEquivPrincipalComponent K α x = + degreeLayerToPrincipalComponent K α x := + (rfl) + +section Multiplication + +variable [CharZero K] + +/-- Multiplication of principal classes, inherited from the degree-graded ring +ring: the product of two principal series of degrees `α` and `β` is principal of degree `α + β` +(LM24, Proposition 3.6.1 and Theorem D). -/ +def principalDegreeClassesMul {α β : NatOrdinal} + (x : principalDegreeClasses K α) + (y : principalDegreeClasses K β) : + principalDegreeClasses K (α + β) := by + let w := HahnSeries.Nonpositive.degreeValuation K + refine ⟨w.componentMul x y, ?_⟩ + rw [mem_principalDegreeClasses_iff, isPrincipalDegreeClass_iff] + have hx := (mem_principalDegreeClasses_iff α _).mp x.2 + have hy := (mem_principalDegreeClasses_iff β _).mp y.2 + rw [isPrincipalDegreeClass_iff] at hx hy + rcases hx with hx0 | ⟨p, hp, hpDegree, hxp⟩ + · exact Or.inl (by rw [hx0]; simp) + rcases hy with hy0 | ⟨q, hq, hqDegree, hyq⟩ + · exact Or.inl (by rw [hy0]; simp) + have hpqDegree : ((p * q : Series K) : K⟦ℝ⟧).degree = + ((α + β : NatOrdinal) : WithBot NatOrdinal) := by + rw [HahnSeries.Nonpositive.degree_mul, hpDegree, hqDegree, WithBot.coe_add] + apply Or.inr + refine ⟨p * q, OrdinalValueMultiplicative.isPrincipal_mul ordinalValueMultiplicative hp hq, + hpqDegree, ?_⟩ + calc + w.componentMul x y = w.componentMul + (degreeLayerMk α p hpDegree.le) + (degreeLayerMk β q hqDegree.le) := by rw [hxp, hyq] + _ = degreeLayerMk (α + β) (p * q) hpqDegree.le := + degreeLayerMk_mul p q hpDegree.le hqDegree.le + +/-- Multiplication of the source classes is multiplication in the degree-graded ring +ring on underlying classes. -/ +theorem coe_principalDegreeClassesMul {α β : NatOrdinal} + (x : principalDegreeClasses K α) + (y : principalDegreeClasses K β) : + (principalDegreeClassesMul x y : + (HahnSeries.Nonpositive.degreeValuation K).Component + (α + β)) = + (HahnSeries.Nonpositive.degreeValuation K).componentMul x y := + (rfl) + +/-- The canonical equivalence from source principal classes to the spaces `P_α` commutes with +homogeneous multiplication. -/ +theorem principalDegreeClassesEquivPrincipalComponent_mul {α β : NatOrdinal} + (x : principalDegreeClasses K α) + (y : principalDegreeClasses K β) : + principalDegreeClassesEquivPrincipalComponent K (α + β) + (principalDegreeClassesMul x y) = + principalComponentMul + (principalDegreeClassesEquivPrincipalComponent K α x) + (principalDegreeClassesEquivPrincipalComponent K β y) := by + rw [principalDegreeClassesEquivPrincipalComponent_apply, + principalDegreeClassesEquivPrincipalComponent_apply, + principalDegreeClassesEquivPrincipalComponent_apply, + coe_principalDegreeClassesMul] + exact degreeLayerToPrincipalComponent_componentMul + (x : (HahnSeries.Nonpositive.degreeValuation K).Component α) + (y : (HahnSeries.Nonpositive.degreeValuation K).Component β) + +end Multiplication + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/PrincipalComponentTensor.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/PrincipalComponentTensor.lean new file mode 100644 index 0000000000..ffc631550f --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/PrincipalComponentTensor.lean @@ -0,0 +1,766 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalSubring +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.FiniteSupportResidue +public import Mathlib.LinearAlgebra.TensorProduct.Basic + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.GermDegree +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.NormalForm +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.PrincipalAddition +import Mathlib.LinearAlgebra.TensorProduct.Basis + +/-! +# Extension of scalars for `P_α` + +This module proves LM24, Proposition 5.3.1. For each Hahn-series degree `α`, multiplication +induces the canonical linear equivalence + +`P_α ⊗[K] K(ℝ^{≤ 0}) ≃ RV_α`. + +Here `P_α` is the intrinsic quotient `J_(ω^(α+1)) / J_(ω^α)`, the finite-support +factor has its canonical monomial basis, and `RV_α` is the degree-`α` component of `RV̂`. +No basis or complement is chosen in `P_α`. + +Surjectivity follows by sending each term of the unique LM24 normal form to its principal +coefficient tensored with the corresponding monomial; lower-degree terms vanish in `RV_α`. +For injectivity, translated closed truncation at an exponent extracts the coefficient at that +monomial in `P_α`. This proves linear independence without choosing representatives coherently. +-/ + +open scoped DirectSum HahnSeries NatOrdinal TensorProduct + +universe v + +namespace Berarducci + +public noncomputable section + +variable {K : Type v} [Field K] + +/-- The ring of finite-support nonpositive real-exponent Hahn series over the coefficient field. -/ +abbrev FiniteSupportRing := + HahnSeries.Nonpositive.FiniteSupportRing (G := ℝ) (K := K) + +private theorem coe_translatedTruncation_translate (p : Series K) (h g : ℝ) : + ((translatedTruncation (HahnSeries.translate h (p : K⟦ℝ⟧)) g : Series K) : + K⟦ℝ⟧) = + HahnSeries.translate (h - g) + (HahnSeries.truncLE (g - h) (p : K⟦ℝ⟧)) := by + rw [coe_translatedTruncation, HahnSeries.truncLE_translate, + HahnSeries.translate_add_apply] + congr 2 + · ring + +variable (K) in +/-- On a series `b` of degree `≤ α`, the class of the translated truncation `b^{|γ}` in `P_α`, +additive in `b`. -/ +private def degreeLayerTruncationAtRepresentative (alpha : NatOrdinal) (g : ℝ) : + (HahnSeries.Nonpositive.degreeValuation K).filtrationLE alpha →+ + PrincipalComponent K alpha := by + let wDegree := HahnSeries.Nonpositive.degreeValuation K + let wOrder := ordinalValueDegreeValuation K + refine + { toFun := fun b ↦ wOrder.componentMk alpha ⟨translatedTruncation (b : Series K) g, ?_⟩ + map_zero' := ?_ + map_add' := ?_ } + · rw [wOrder.mem_filtrationLE_iff, + ordinalValueDegreeValuation_apply] + have hbDegree := (wDegree.mem_filtrationLE_iff alpha (b : Series K)).mp b.2 + rw [HahnSeries.Nonpositive.degreeValuation_apply] at hbDegree + exact (ordinalValueDegree_translatedTruncation_le_degree + ((b : Series K) : K⟦ℝ⟧) g).trans hbDegree + · change wOrder.componentMk alpha ⟨translatedTruncation 0 g, _⟩ = 0 + rw [← map_zero (wOrder.componentMk alpha)] + apply congrArg (wOrder.componentMk alpha) + apply Subtype.ext + exact translatedTruncation_zero_input (K := K) g + · intro b c + change wOrder.componentMk alpha + ⟨translatedTruncation ((b : Series K) + (c : Series K)) g, _⟩ = + wOrder.componentMk alpha ⟨translatedTruncation (b : Series K) g, _⟩ + + wOrder.componentMk alpha ⟨translatedTruncation (c : Series K) g, _⟩ + rw [← map_add] + apply congrArg (wOrder.componentMk alpha) + apply Subtype.ext + exact translatedTruncation_add + ((b : Series K) : K⟦ℝ⟧) ((c : Series K) : K⟦ℝ⟧) g + +variable (K) in +private theorem degreeLayerTruncationAt_lower_le_ker (alpha : NatOrdinal) (g : ℝ) : + (HahnSeries.Nonpositive.degreeValuation K).lowerFiltration alpha ≤ + (degreeLayerTruncationAtRepresentative K alpha g).ker := by + let wDegree := HahnSeries.Nonpositive.degreeValuation K + let wOrder := ordinalValueDegreeValuation K + intro b hb + rw [AddMonoidHom.mem_ker] + change wOrder.componentMk alpha ⟨translatedTruncation (b : Series K) g, _⟩ = 0 + rw [wOrder.componentMk_eq_zero_iff, + ordinalValueDegreeValuation_apply] + have hbDegree := (wDegree.mem_lowerFiltration_iff alpha b).mp hb + rw [HahnSeries.Nonpositive.degreeValuation_apply] at hbDegree + exact (ordinalValueDegree_translatedTruncation_le_degree + ((b : Series K) : K⟦ℝ⟧) g).trans_lt hbDegree + +variable (K) in +/-- The class of the translated truncation `b^{|γ}` in `P_α`, as an additive map on the degree +component `{deg ≤ α}/{deg < α}`: series of degree `< α` have `b^{|γ} ∈ J_{ω^α}`. -/ +private def degreeLayerTruncationAt (alpha : NatOrdinal) (g : ℝ) : + (HahnSeries.Nonpositive.degreeValuation K).Component alpha →+ + PrincipalComponent K alpha := + QuotientAddGroup.lift + ((HahnSeries.Nonpositive.degreeValuation K).lowerFiltration alpha) + (degreeLayerTruncationAtRepresentative K alpha g) + (degreeLayerTruncationAt_lower_le_ker K alpha g) + +/-- On the degree-`α` homogeneous class of `b`, the map is the class of `b^{|γ}` in `P_α`. -/ +private theorem degreeLayerTruncationAt_mk (alpha : NatOrdinal) (g : ℝ) + (b : Series K) (hb : (b : K⟦ℝ⟧).degree ≤ + (alpha : WithBot NatOrdinal)) : + degreeLayerTruncationAt K alpha g (degreeLayerMk alpha b hb) = + principalComponentMk alpha (translatedTruncation (b : K⟦ℝ⟧) g) + ((ordinalValueDegree_le_coe_iff (translatedTruncation (b : K⟦ℝ⟧) g) alpha).mp + ((ordinalValueDegree_translatedTruncation_le_degree (b : K⟦ℝ⟧) g).trans hb)) := by + let wDegree := HahnSeries.Nonpositive.degreeValuation K + rw [degreeLayerMk_eq_componentMk] + change degreeLayerTruncationAt K alpha g + (wDegree.componentMk alpha ⟨b, _⟩) = _ + rw [← wDegree.coe_component_eq_componentMk] + rw [principalComponentMk_eq_componentMk] + rfl + +/-- The finite-support residue equivalence sends a constant series to its canonical +degree-zero homogeneous class. -/ +theorem degreeFiniteSupportResidueEquiv_scalar (k : K) : + HahnSeries.Nonpositive.degreeFiniteSupportResidueEquiv K + (HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℝ) k) = + degreeLayerScalarHom K k := by + let w := HahnSeries.Nonpositive.degreeValuation K + rw [HahnSeries.Nonpositive.degreeFiniteSupportResidueEquiv_apply, + degreeLayerScalarHom_apply] + rw [w.residueMap_apply, degreeLayerMk_eq_componentMk] + apply congrArg (w.componentMk 0) + apply Subtype.ext + rw [w.coe_nonpositiveEquivFiltrationLEZero] + rw [RingEquiv.coe_subringCongr_apply] + apply Subtype.ext + exact (HahnSeries.Nonpositive.coe_finiteSupportScalarHom + (G := ℝ) (K := K) k).trans (HahnSeries.Nonpositive.coe_C k).symm + +/-- Successive scalar actions by degree-zero residue classes agree with multiplication in the +residue ring. -/ +theorem degreeResidue_smul_smul (alpha : NatOrdinal) + (a b : (HahnSeries.Nonpositive.degreeValuation K).ResidueRing) + (x : (HahnSeries.Nonpositive.degreeValuation K).Component alpha) : + (a * b) • x = a • (b • x) := by + let w := HahnSeries.Nonpositive.degreeValuation K + apply DirectSum.of_injective (β := w.Component) alpha + rw [DirectSum.of_zero_smul, DirectSum.of_zero_smul, + DirectSum.of_zero_smul, DirectSum.of_zero_mul] + rw [mul_assoc] + +/-- The unit residue class acts identically on every degree component. -/ +theorem degreeResidue_one_smul (alpha : NatOrdinal) + (x : (HahnSeries.Nonpositive.degreeValuation K).Component alpha) : + (1 : (HahnSeries.Nonpositive.degreeValuation K).ResidueRing) • x = + x := by + let w := HahnSeries.Nonpositive.degreeValuation K + apply DirectSum.of_injective (β := w.Component) alpha + rw [DirectSum.of_zero_smul, DirectSum.of_zero_one, one_mul] + +private theorem residue_smul_comm (alpha : NatOrdinal) + (a b : (HahnSeries.Nonpositive.degreeValuation K).ResidueRing) + (x : (HahnSeries.Nonpositive.degreeValuation K).Component alpha) : + a • (b • x) = b • (a • x) := by + rw [← degreeResidue_smul_smul alpha, + ← degreeResidue_smul_smul alpha, mul_comm] + +private theorem residueEquiv_eq_degreeLayerMk (p : FiniteSupportRing (K := K)) : + HahnSeries.Nonpositive.degreeFiniteSupportResidueEquiv K p = + degreeLayerMk 0 (p : Series K) (by + simpa using (HahnSeries.degree_le_zero_iff.mpr + ((HahnSeries.Nonpositive.mem_finiteSupportSubring_iff + (p : Series K)).mp p.2))) := by + let w := HahnSeries.Nonpositive.degreeValuation K + rw [HahnSeries.Nonpositive.degreeFiniteSupportResidueEquiv_apply, + w.residueMap_apply, degreeLayerMk_eq_componentMk] + apply congrArg (w.componentMk 0) + apply Subtype.ext + rw [w.coe_nonpositiveEquivFiltrationLEZero, + RingEquiv.coe_subringCongr_apply] + +/-- The degree-zero residue action of a finite-support series on a fixed component is +multiplication of representatives. -/ +theorem degreeFiniteSupportResidueEquiv_smul_degreeLayerMk (alpha : NatOrdinal) + (p : FiniteSupportRing (K := K)) (b : Series K) + (hb : (b : K⟦ℝ⟧).degree ≤ (alpha : WithBot NatOrdinal)) : + HahnSeries.Nonpositive.degreeFiniteSupportResidueEquiv K p • + degreeLayerMk alpha b hb = + degreeLayerMk alpha ((p : Series K) * b) (by + apply (HahnSeries.degree_mul_le _ _).trans + exact (add_le_add (by + simpa using (HahnSeries.degree_le_zero_iff.mpr + ((HahnSeries.Nonpositive.mem_finiteSupportSubring_iff + (p : Series K)).mp p.2))) hb).trans_eq (zero_add _)) := by + let w := HahnSeries.Nonpositive.degreeValuation K + apply DirectSum.of_injective (β := w.Component) alpha + rw [DirectSum.of_zero_smul, DirectSum.of_mul_of] + change DirectSum.of w.Component (0 + alpha) + (w.componentMul + (HahnSeries.Nonpositive.degreeFiniteSupportResidueEquiv K p) + (degreeLayerMk alpha b hb)) = _ + rw [residueEquiv_eq_degreeLayerMk, degreeLayerMk_mul] + apply DirectSum.of_eq_of_gradedMonoid_eq + apply Sigma.ext (zero_add alpha) + rw [degreeLayerMk_eq_componentMk, degreeLayerMk_eq_componentMk] + exact w.componentMk_heq_of_grade_eq_of_coe_eq (zero_add alpha) _ _ rfl + +theorem principalComponentToHahnDegreeLayer_mk (alpha : NatOrdinal) + (p : Series K) (hp : HahnSeries.Nonpositive.IsPrincipal p) + (hpDegree : (p : K⟦ℝ⟧).degree = (alpha : WithBot NatOrdinal)) + (hpBound : ordinalValue p < ω^ (alpha + 1)) : + principalComponentToHahnDegreeLayer K alpha + (principalComponentMk alpha p hpBound) = + degreeLayerMk alpha p hpDegree.le := by + rw [← degreeLayerToPrincipalComponent_mk alpha p hpDegree.le] + apply principalComponentToHahnDegreeLayer_degreeLayerToPrincipalComponent_of_isPrincipal + rw [isPrincipalDegreeClass_iff] + exact Or.inr ⟨p, hp, hpDegree, rfl⟩ + +variable (K) in +/-- Multiply a principal homogeneous class by a finite-support residue to obtain the +corresponding Hahn degree class. -/ +def principalComponentFiniteSupportMul (alpha : NatOrdinal) : + PrincipalComponent K alpha →ₗ[K] + FiniteSupportRing (K := K) →ₗ[K] + (HahnSeries.Nonpositive.degreeValuation K).Component alpha := + LinearMap.mk₂ K + (fun x p ↦ + HahnSeries.Nonpositive.degreeFiniteSupportResidueEquiv K p • + principalComponentToHahnDegreeLayer K alpha x) + (by + intro x y p + simpa only [map_add] using + (smul_add + (HahnSeries.Nonpositive.degreeFiniteSupportResidueEquiv K p) + (principalComponentToHahnDegreeLayer K alpha x) + (principalComponentToHahnDegreeLayer K alpha y))) + (by + intro k x p + rw [map_smul] + rw [degreeLayer_smul_eq_residue_smul, + degreeLayer_smul_eq_residue_smul] + exact residue_smul_comm alpha _ _ _) + (by + intro x p q + simpa only [map_add] using + (add_smul + (HahnSeries.Nonpositive.degreeFiniteSupportResidueEquiv K p) + (HahnSeries.Nonpositive.degreeFiniteSupportResidueEquiv K q) + (principalComponentToHahnDegreeLayer K alpha x))) + (by + intro k x p + rw [HahnSeries.Nonpositive.smul_finiteSupport_eq_scalar_mul] + rw [map_mul, degreeFiniteSupportResidueEquiv_scalar] + rw [degreeLayer_smul_eq_residue_smul] + exact degreeResidue_smul_smul alpha _ _ _) + +@[simp] +theorem principalComponentFiniteSupportMul_apply (alpha : NatOrdinal) + (x : PrincipalComponent K alpha) (p : FiniteSupportRing (K := K)) : + principalComponentFiniteSupportMul K alpha x p = + HahnSeries.Nonpositive.degreeFiniteSupportResidueEquiv K p • + principalComponentToHahnDegreeLayer K alpha x := + (rfl) + +variable (K) in +/-- The linear map from principal classes tensored with finite-support series to the +corresponding Hahn degree layer. -/ +def principalComponentTensorMap (alpha : NatOrdinal) : + PrincipalComponent K alpha ⊗[K] FiniteSupportRing (K := K) →ₗ[K] + (HahnSeries.Nonpositive.degreeValuation K).Component alpha := + TensorProduct.lift (principalComponentFiniteSupportMul K alpha) + +@[simp] +theorem principalComponentTensorMap_tmul (alpha : NatOrdinal) + (x : PrincipalComponent K alpha) (p : FiniteSupportRing (K := K)) : + principalComponentTensorMap K alpha (x ⊗ₜ p) = + HahnSeries.Nonpositive.degreeFiniteSupportResidueEquiv K p • + principalComponentToHahnDegreeLayer K alpha x := by + rw [principalComponentTensorMap, TensorProduct.lift.tmul] + rfl + +theorem principalComponentTensorMap_principal_monomial (alpha : NatOrdinal) + (p : Series K) (hp : HahnSeries.Nonpositive.IsPrincipal p) + (hpDegree : (p : K⟦ℝ⟧).degree = (alpha : WithBot NatOrdinal)) + (hpBound : ordinalValue p < ω^ (alpha + 1)) + (g : HahnSeries.Nonpositive.exponentMonoid ℝ) : + principalComponentTensorMap K alpha + (principalComponentMk alpha p hpBound ⊗ₜ + HahnSeries.Nonpositive.finiteSupportMonomial (K := K) g) = + degreeLayerMk alpha + (((HahnSeries.Nonpositive.finiteSupportMonomial (K := K) g : + FiniteSupportRing (K := K)) : Series K) * p) (by + apply (HahnSeries.degree_mul_le _ _).trans + exact (add_le_add (by + exact HahnSeries.degree_le_zero_iff.mpr + ((HahnSeries.Nonpositive.mem_finiteSupportSubring_iff + ((HahnSeries.Nonpositive.finiteSupportMonomial (K := K) g : + FiniteSupportRing (K := K)) : Series K)).mp + (HahnSeries.Nonpositive.finiteSupportMonomial + (K := K) g).2)) hpDegree.le).trans_eq (zero_add _)) := by + rw [principalComponentTensorMap_tmul, + principalComponentToHahnDegreeLayer_mk alpha p hp hpDegree hpBound] + rw [degreeFiniteSupportResidueEquiv_smul_degreeLayerMk] + +private theorem finiteSupportMonomial_degree (g : HahnSeries.Nonpositive.exponentMonoid ℝ) : + ((((HahnSeries.Nonpositive.finiteSupportMonomial (K := K) g : + FiniteSupportRing (K := K)) : Series K) : K⟦ℝ⟧).degree) = 0 := by + apply HahnSeries.degree_eq_zero.mpr + constructor + · rw [HahnSeries.Nonpositive.coe_finiteSupportMonomial] + exact HahnSeries.single_ne_zero one_ne_zero + · exact (HahnSeries.Nonpositive.mem_finiteSupportSubring_iff + ((HahnSeries.Nonpositive.finiteSupportMonomial (K := K) g : + FiniteSupportRing (K := K)) : Series K)).mp + (HahnSeries.Nonpositive.finiteSupportMonomial (K := K) g).2 + +private theorem coe_finiteSupportMonomial_mul (g : HahnSeries.Nonpositive.exponentMonoid ℝ) (p : + Series K) : + ((((HahnSeries.Nonpositive.finiteSupportMonomial (K := K) g : + FiniteSupportRing (K := K)) : Series K) * p : Series K) : K⟦ℝ⟧) = + HahnSeries.translate (g : ℝ) (p : K⟦ℝ⟧) := by + change + (((HahnSeries.Nonpositive.finiteSupportMonomial (K := K) g : + FiniteSupportRing (K := K)) : Series K) : K⟦ℝ⟧) * (p : K⟦ℝ⟧) = _ + rw [HahnSeries.Nonpositive.coe_finiteSupportMonomial, + HahnSeries.single_one_mul_eq_translate] + +private def shiftedSeries (g : HahnSeries.Nonpositive.exponentMonoid ℝ) (p : Series K) : Series K := + ⟨HahnSeries.translate (g : ℝ) (p : K⟦ℝ⟧), by + rw [HahnSeries.mem_nonpositiveSubring, HahnSeries.support_translate] + rintro _ ⟨x, hx, rfl⟩ + exact add_nonpos g.2 (HahnSeries.Nonpositive.support_subset p hx)⟩ + +@[simp] +private theorem coe_shiftedSeries (g : HahnSeries.Nonpositive.exponentMonoid ℝ) (p : Series K) : + ((shiftedSeries g p : Series K) : K⟦ℝ⟧) = + HahnSeries.translate (g : ℝ) (p : K⟦ℝ⟧) := + (rfl) + +private theorem finiteSupportMonomial_mul_eq_shiftedSeries (g : + HahnSeries.Nonpositive.exponentMonoid ℝ) (p : Series K) : + ((HahnSeries.Nonpositive.finiteSupportMonomial (K := K) g : + FiniteSupportRing (K := K)) : Series K) * p = shiftedSeries g p := by + apply Subtype.ext + exact coe_finiteSupportMonomial_mul g p + +private abbrev PrincipalMonomialTerm (K : Type v) [Field K] := + Series K × HahnSeries.Nonpositive.exponentMonoid ℝ + +private def principalMonomialTermSeries (t : PrincipalMonomialTerm K) : Series K := + (HahnSeries.Nonpositive.finiteSupportMonomial (K := K) t.2 : + FiniteSupportRing (K := K)) * t.1 + +private theorem principalMonomialTermSeries_degree (t : PrincipalMonomialTerm K) : + ((principalMonomialTermSeries t : Series K) : K⟦ℝ⟧).degree = + (t.1 : K⟦ℝ⟧).degree := by + rw [principalMonomialTermSeries, coe_finiteSupportMonomial_mul, HahnSeries.degree_translate] + +private def normalTermSeries (t : HahnSeries.NormalForm.Term K) + (ht : t.exponent ≤ 0) : Series K := + ⟨t.series, (HahnSeries.mem_nonpositiveSubring (x := t.series)).mpr (by + rw [HahnSeries.NormalForm.Term.series_eq_translate, + HahnSeries.support_translate] + rintro _ ⟨g, hg, rfl⟩ + exact add_nonpos ht (HahnSeries.Nonpositive.support_subset t.coefficient hg))⟩ + +private theorem principalMonomialTerm_series_eq_normalTermSeries + (t : HahnSeries.NormalForm.Term K) (ht : t.exponent ≤ 0) : + principalMonomialTermSeries + (⟨t.coefficient, ⟨t.exponent, ht⟩⟩ : PrincipalMonomialTerm K) = + normalTermSeries t ht := by + apply Subtype.ext + change + (((HahnSeries.Nonpositive.finiteSupportMonomial (K := K) + ⟨t.exponent, ht⟩ : FiniteSupportRing (K := K)) : Series K) : K⟦ℝ⟧) * + (t.coefficient : K⟦ℝ⟧) = t.series + rw [HahnSeries.Nonpositive.coe_finiteSupportMonomial, + HahnSeries.single_one_mul_eq_translate, + HahnSeries.NormalForm.Term.series_eq_translate] + +private theorem principalMonomialTerms_sum_degree_le (alpha : NatOrdinal) + (terms : List (PrincipalMonomialTerm K)) + (hdegree : ∀ t ∈ terms, + (t.1 : K⟦ℝ⟧).degree ≤ (alpha : WithBot NatOrdinal)) : + (((terms.map principalMonomialTermSeries).sum : Series K) : K⟦ℝ⟧).degree ≤ + (alpha : WithBot NatOrdinal) := by + induction terms with + | nil => simp + | cons t terms ih => + rw [List.map_cons, List.sum_cons] + exact (HahnSeries.degree_add_le _ _).trans (max_le + (by rw [principalMonomialTermSeries_degree] + exact hdegree t (by simp)) + (ih fun s hs ↦ hdegree s (by simp [hs]))) + +private theorem exists_tensor_eq_degreeLayerMk_terms (alpha : NatOrdinal) + (terms : List (PrincipalMonomialTerm K)) + (hprincipal : ∀ t ∈ terms, + HahnSeries.Nonpositive.IsPrincipal t.1) + (hdegree : ∀ t ∈ terms, + (t.1 : K⟦ℝ⟧).degree ≤ (alpha : WithBot NatOrdinal)) : + ∃ z : PrincipalComponent K alpha ⊗[K] FiniteSupportRing (K := K), + principalComponentTensorMap K alpha z = + degreeLayerMk alpha + (terms.map principalMonomialTermSeries).sum + (principalMonomialTerms_sum_degree_le alpha terms hdegree) := by + induction terms with + | nil => + refine ⟨0, ?_⟩ + rw [map_zero] + symm + rw [degreeLayerMk_eq_zero_iff] + simp + | cons t terms ih => + have htPrincipal := hprincipal t (by simp) + have htDegreeLE := hdegree t (by simp) + have htSeriesLE : ((principalMonomialTermSeries t : Series K) : K⟦ℝ⟧).degree ≤ + (alpha : WithBot NatOrdinal) := by + rw [principalMonomialTermSeries_degree] + exact htDegreeLE + have htailPrincipal : ∀ s ∈ terms, + HahnSeries.Nonpositive.IsPrincipal s.1 := + fun s hs ↦ hprincipal s (by simp [hs]) + have htailDegree : ∀ s ∈ terms, + (s.1 : K⟦ℝ⟧).degree ≤ (alpha : WithBot NatOrdinal) := + fun s hs ↦ hdegree s (by simp [hs]) + obtain ⟨z, hz⟩ := ih htailPrincipal htailDegree + by_cases htDegree : (t.1 : K⟦ℝ⟧).degree = + (alpha : WithBot NatOrdinal) + · have htBound : ordinalValue t.1 < ω^ (alpha + 1) := + (ordinalValueDegree_le_coe_iff t.1 alpha).mp + ((ordinalValueDegree_le_degree t.1).trans htDegreeLE) + let zt : PrincipalComponent K alpha ⊗[K] FiniteSupportRing (K := K) := + principalComponentMk alpha t.1 htBound ⊗ₜ + HahnSeries.Nonpositive.finiteSupportMonomial (K := K) t.2 + refine ⟨zt + z, ?_⟩ + rw [map_add, hz] + rw [show principalComponentTensorMap K alpha zt = + degreeLayerMk alpha (principalMonomialTermSeries t) htSeriesLE by + exact principalComponentTensorMap_principal_monomial alpha + t.1 htPrincipal htDegree htBound t.2] + simpa only [List.map_cons, List.sum_cons] using + (degreeLayerMk_add alpha (principalMonomialTermSeries t) + (terms.map principalMonomialTermSeries).sum + htSeriesLE + (principalMonomialTerms_sum_degree_le alpha terms htailDegree)).symm + · have htDegreeLT : (t.1 : K⟦ℝ⟧).degree < + (alpha : WithBot NatOrdinal) := lt_of_le_of_ne htDegreeLE htDegree + refine ⟨z, ?_⟩ + rw [hz] + have htSeriesLT : ((principalMonomialTermSeries t : Series K) : K⟦ℝ⟧).degree < + (alpha : WithBot NatOrdinal) := by + rw [principalMonomialTermSeries_degree] + exact htDegreeLT + have htZero : degreeLayerMk alpha + (principalMonomialTermSeries t) htSeriesLE = 0 := + (degreeLayerMk_eq_zero_iff alpha + (principalMonomialTermSeries t) htSeriesLE).mpr + htSeriesLT + have hadd := degreeLayerMk_add alpha (principalMonomialTermSeries t) + (terms.map principalMonomialTermSeries).sum + htSeriesLE + (principalMonomialTerms_sum_degree_le alpha terms htailDegree) + rw [htZero, zero_add] at hadd + simpa only [List.map_cons, List.sum_cons] using hadd.symm + +variable (K) in +private theorem principalComponentTensorMap_surjective (alpha : NatOrdinal) : + Function.Surjective (principalComponentTensorMap K alpha) := by + let w := HahnSeries.Nonpositive.degreeValuation K + intro y + induction y using QuotientAddGroup.induction_on with + | H b => + have hbDegree : ((b : Series K) : K⟦ℝ⟧).degree ≤ + (alpha : WithBot NatOrdinal) := by + have hbValue := (w.mem_filtrationLE_iff alpha (b : Series K)).mp b.2 + rw [HahnSeries.Nonpositive.degreeValuation_apply] at hbValue + exact hbValue + obtain ⟨terms, hterms⟩ := HahnSeries.exists_isNormalForm (b : Series K) + obtain ⟨hsum, _, hprincipal, _, hpair⟩ := + HahnSeries.isNormalForm_iff.mp hterms + have htermSupport (t : HahnSeries.NormalForm.Term K) (ht : t ∈ terms) : + t.series.support ⊆ ((b : Series K) : K⟦ℝ⟧).support := by + have htMem : t.series ∈ terms.map HahnSeries.NormalForm.Term.series := + List.mem_map.mpr ⟨t, ht, rfl⟩ + have hsubset := HahnSeries.support_subset_list_sum_of_mem hpair htMem + rwa [hsum] at hsubset + have htermExponent (t : HahnSeries.NormalForm.Term K) (ht : t ∈ terms) : + t.exponent ≤ 0 := by + rw [← HahnSeries.NormalForm.Term.csSup_support_series t + (hprincipal t ht)] + apply csSup_le + (HahnSeries.support_nonempty_iff.mpr + (HahnSeries.NormalForm.Term.series_ne_zero (hprincipal t ht))) + intro g hg + exact HahnSeries.Nonpositive.support_subset (b : Series K) + (htermSupport t ht hg) + have htermDegree (t : HahnSeries.NormalForm.Term K) (ht : t ∈ terms) : + (t.coefficient : K⟦ℝ⟧).degree ≤ + (alpha : WithBot NatOrdinal) := by + calc + (t.coefficient : K⟦ℝ⟧).degree = t.series.degree := by + rw [HahnSeries.NormalForm.Term.series_eq_translate, + HahnSeries.degree_translate] + _ ≤ ((b : Series K) : K⟦ℝ⟧).degree := + HahnSeries.degree_mono_support (htermSupport t ht) + _ ≤ (alpha : WithBot NatOrdinal) := hbDegree + let principalTerms : List (PrincipalMonomialTerm K) := terms.pmap + (fun t ht ↦ ⟨t.coefficient, ⟨t.exponent, ht⟩⟩) htermExponent + have hprincipalTerms : ∀ t ∈ principalTerms, + HahnSeries.Nonpositive.IsPrincipal t.1 := by + intro t ht + simp only [principalTerms, List.mem_pmap] at ht + obtain ⟨s, hs, rfl⟩ := ht + exact hprincipal s hs + have hdegreeTerms : ∀ t ∈ principalTerms, + (t.1 : K⟦ℝ⟧).degree ≤ + (alpha : WithBot NatOrdinal) := by + intro t ht + simp only [principalTerms, List.mem_pmap] at ht + obtain ⟨s, hs, rfl⟩ := ht + exact htermDegree s hs + have hseriesList : + principalTerms.map + (fun t ↦ ((principalMonomialTermSeries t : Series K) : K⟦ℝ⟧)) = + terms.map HahnSeries.NormalForm.Term.series := by + simp only [principalTerms, List.map_pmap] + calc + List.pmap + (fun t ht ↦ + ((principalMonomialTermSeries + (⟨t.coefficient, ⟨t.exponent, ht⟩⟩ : PrincipalMonomialTerm K) : + Series K) : K⟦ℝ⟧)) + terms htermExponent = + List.pmap (fun t _ ↦ t.series) terms htermExponent := by + apply List.pmap_congr_left + intro t _ ht _ + exact congrArg (fun x : Series K ↦ (x : K⟦ℝ⟧)) + (principalMonomialTerm_series_eq_normalTermSeries t ht) + _ = terms.map HahnSeries.NormalForm.Term.series := + List.pmap_eq_map htermExponent + have hseriesSum : + (((principalTerms.map principalMonomialTermSeries).sum : Series K) : + K⟦ℝ⟧) = (b : Series K) := by + change (HahnSeries.nonpositiveSubring ℝ K).subtype + (principalTerms.map principalMonomialTermSeries).sum = + ((b : Series K) : K⟦ℝ⟧) + rw [map_list_sum] + have hcoeList : + (principalTerms.map principalMonomialTermSeries).map + (HahnSeries.nonpositiveSubring ℝ K).subtype = + principalTerms.map + (fun t ↦ ((principalMonomialTermSeries t : Series K) : K⟦ℝ⟧)) := by + rw [List.map_map] + apply List.map_congr_left + intro t _ + rfl + rw [hcoeList] + exact (congrArg List.sum hseriesList).trans hsum + obtain ⟨z, hz⟩ := exists_tensor_eq_degreeLayerMk_terms alpha principalTerms hprincipalTerms + hdegreeTerms + refine ⟨z, ?_⟩ + rw [hz, degreeLayerMk_eq_componentMk, w.coe_component_eq_componentMk] + apply congrArg (w.componentMk alpha) + apply Subtype.ext + exact Subtype.ext hseriesSum + +private theorem degreeLayerTruncationAt_principalComponentTensorMap_tmul_monomial + (alpha : NatOrdinal) (x : PrincipalComponent K alpha) + (h g : HahnSeries.Nonpositive.exponentMonoid ℝ) : + degreeLayerTruncationAt K alpha g + (principalComponentTensorMap K alpha + (x ⊗ₜ HahnSeries.Nonpositive.finiteSupportMonomial (K := K) h)) = + if h = g then x else 0 := by + by_cases hx : x = 0 + · subst x + simp + obtain ⟨p, hpBound, hp, hpDegree, hpx⟩ := + exists_principal_representative_of_ne_zero alpha x hx + rw [← hpx] + have hshiftedDegree : ((shiftedSeries h p : Series K) : K⟦ℝ⟧).degree = + (alpha : WithBot NatOrdinal) := by + rw [coe_shiftedSeries, HahnSeries.degree_translate, hpDegree] + have himage : + principalComponentTensorMap K alpha + (principalComponentMk alpha p hpBound ⊗ₜ + HahnSeries.Nonpositive.finiteSupportMonomial (K := K) h) = + degreeLayerMk alpha (shiftedSeries h p) hshiftedDegree.le := by + rw [principalComponentTensorMap_principal_monomial alpha + p hp hpDegree hpBound h] + rw [degreeLayerMk_eq_componentMk, degreeLayerMk_eq_componentMk] + apply congrArg + ((HahnSeries.Nonpositive.degreeValuation K).componentMk alpha) + apply Subtype.ext + exact finiteSupportMonomial_mul_eq_shiftedSeries h p + rw [himage, degreeLayerTruncationAt_mk] + simp only [coe_shiftedSeries] + by_cases hhg : h = g + · subst g + rw [ite_eq_left rfl] + have hgerm : translatedTruncation + (HahnSeries.translate (h : ℝ) (p : K⟦ℝ⟧)) h = p := by + apply Subtype.ext + rw [coe_translatedTruncation_translate] + rw [sub_self, HahnSeries.truncLE_eq_self_of_support_subset_Iic + (HahnSeries.Nonpositive.support_subset p)] + simp + apply (principalComponentMk_eq_iff alpha _ p _ hpBound).mpr + rw [hgerm, sub_self, ordinalValue_zero] + exact NatOrdinal.wpow_pos alpha + · rw [ite_eq_right hhg] + rw [principalComponentMk_eq_zero_iff] + rcases lt_or_gt_of_ne (Subtype.coe_ne_coe.mpr hhg) with hhgLT | hghLT + · have htrunc : HahnSeries.truncLE ((g : ℝ) - (h : ℝ)) + (p : K⟦ℝ⟧) = p := by + apply HahnSeries.truncLE_eq_self_of_support_subset_Iic + exact (HahnSeries.Nonpositive.support_subset p).trans fun y hy ↦ + hy.trans (sub_nonneg.mpr hhgLT.le) + have hgermCoe : + ((translatedTruncation + (HahnSeries.translate (h : ℝ) (p : K⟦ℝ⟧)) g : Series K) : + K⟦ℝ⟧) = + HahnSeries.translate ((h : ℝ) - (g : ℝ)) (p : K⟦ℝ⟧) := by + rw [coe_translatedTruncation_translate, htrunc] + have hpCoeNe : (p : K⟦ℝ⟧) ≠ 0 := by simpa using hp.ne_zero + have htranslatedNe : + HahnSeries.translate ((h : ℝ) - (g : ℝ)) (p : K⟦ℝ⟧) ≠ 0 := + fun hzero ↦ hpCoeNe ((HahnSeries.translate + ((h : ℝ) - (g : ℝ))).injective (by simpa using hzero)) + have hgermNe : + translatedTruncation + (HahnSeries.translate (h : ℝ) (p : K⟦ℝ⟧)) g ≠ 0 := by + intro hzero + apply htranslatedNe + rw [← hgermCoe] + exact congrArg Subtype.val hzero + have hpSup : sSup (p : K⟦ℝ⟧).support = 0 := by + have hsup := hp.supportSup_eq_zero + rw [HahnSeries.Nonpositive.supportSup_of_ne hp.ne_zero] at hsup + change ((sSup (p : K⟦ℝ⟧).support : ℝ) : WithBot ℝ) = + ((0 : ℝ) : WithBot ℝ) at hsup + exact WithBot.coe_eq_coe.mp hsup + have hgermJ : translatedTruncation + (HahnSeries.translate (h : ℝ) (p : K⟦ℝ⟧)) g ∈ + HahnSeries.Nonpositive.negativeMonomialIdeal K := by + rw [HahnSeries.Nonpositive.mem_negativeMonomialIdeal_iff_supportSup_lt_zero] + rw [HahnSeries.Nonpositive.supportSup_of_ne hgermNe] + change + ((sSup (((translatedTruncation + (HahnSeries.translate (h : ℝ) (p : K⟦ℝ⟧)) g : Series K) : + K⟦ℝ⟧).support) : ℝ) : WithBot ℝ) < ((0 : ℝ) : WithBot ℝ) + apply WithBot.coe_lt_coe.mpr + rw [hgermCoe] + rw [HahnSeries.csSup_support_translate hpCoeNe + (HahnSeries.Nonpositive.bddAbove_support p), hpSup, add_zero] + exact sub_neg.mpr hhgLT + rw [ordinalValue_of_mem_negativeMonomialIdeal hgermJ] + exact NatOrdinal.wpow_pos alpha + · apply (ordinalValueDegree_lt_coe_iff _ alpha).mp + calc + ordinalValueDegree + (translatedTruncation + (HahnSeries.translate (h : ℝ) (p : K⟦ℝ⟧)) g) ≤ + (((translatedTruncation + (HahnSeries.translate (h : ℝ) (p : K⟦ℝ⟧)) g : Series K) : + K⟦ℝ⟧).degree) := ordinalValueDegree_le_degree _ + _ = (HahnSeries.truncLE ((g : ℝ) - (h : ℝ)) + (p : K⟦ℝ⟧)).degree := by + rw [coe_translatedTruncation_translate, HahnSeries.degree_translate] + _ < (alpha : WithBot NatOrdinal) := + hp.degree_truncLE_lt_of_degree_eq hpDegree (sub_neg.mpr hghLT) + +private theorem degreeLayerTruncationAt_principalComponentTensorMap (alpha : NatOrdinal) + (z : PrincipalComponent K alpha ⊗[K] FiniteSupportRing (K := K)) + (g : HahnSeries.Nonpositive.exponentMonoid ℝ) : + degreeLayerTruncationAt K alpha g + (principalComponentTensorMap K alpha z) = + TensorProduct.equivFinsuppOfBasisRight + (HahnSeries.Nonpositive.finiteSupportBasis (G := ℝ) (K := K)) z g := by + let basis := HahnSeries.Nonpositive.finiteSupportBasis (G := ℝ) (K := K) + let coordinates := TensorProduct.equivFinsuppOfBasisRight + (M := PrincipalComponent K alpha) basis + let f := coordinates z + change degreeLayerTruncationAt K alpha g + (principalComponentTensorMap K alpha z) = f g + have hz : z = f.sum fun i x ↦ x ⊗ₜ basis i := by + calc + z = coordinates.symm f := by simp [f] + _ = f.sum fun i x ↦ x ⊗ₜ basis i := + TensorProduct.equivFinsuppOfBasisRight_symm_apply basis f + rw [hz] + induction f using Finsupp.induction with + | zero => simp + | single_add a b f ha hb ih => + have hzero : ∀ i, + (0 : PrincipalComponent K alpha) ⊗ₜ[K] basis i = 0 := + fun i ↦ TensorProduct.zero_tmul (PrincipalComponent K alpha) (basis i) + have hadd : ∀ i b₁ b₂, + (b₁ + b₂ : PrincipalComponent K alpha) ⊗ₜ[K] basis i = + b₁ ⊗ₜ[K] basis i + b₂ ⊗ₜ[K] basis i := + fun i b₁ b₂ ↦ TensorProduct.add_tmul b₁ b₂ (basis i) + rw [Finsupp.sum_add_index' hzero hadd] + rw [Finsupp.sum_single_index (hzero a)] + rw [map_add, map_add, ih] + rw [HahnSeries.Nonpositive.finiteSupportBasis_apply] + rw [degreeLayerTruncationAt_principalComponentTensorMap_tmul_monomial] + rw [Finsupp.add_apply, Finsupp.single_apply] + +variable (K) in +private theorem principalComponentTensorMap_injective (alpha : NatOrdinal) : + Function.Injective (principalComponentTensorMap K alpha) := by + intro x y hxy + let basis := HahnSeries.Nonpositive.finiteSupportBasis (G := ℝ) (K := K) + let coordinates := TensorProduct.equivFinsuppOfBasisRight + (M := PrincipalComponent K alpha) basis + apply coordinates.injective + ext g + rw [← degreeLayerTruncationAt_principalComponentTensorMap alpha, + ← degreeLayerTruncationAt_principalComponentTensorMap alpha, hxy] + +variable (K) in +/-- The canonical extension-of-scalars equivalence +`P_α ⊗[K] K(ℝ^{≤ 0}) ≃ RV_α` from LM24, Proposition 5.3.1. -/ +def principalComponentTensorEquiv (α : NatOrdinal) : + PrincipalComponent K α ⊗[K] FiniteSupportRing (K := K) ≃ₗ[K] + (HahnSeries.Nonpositive.degreeValuation K).Component α := + LinearEquiv.ofBijective (principalComponentTensorMap K α) + ⟨principalComponentTensorMap_injective K α, + principalComponentTensorMap_surjective K α⟩ + +/-- The extension-of-scalars equivalence has the canonical multiplication map as its forward +linear map. -/ +@[simp] +theorem principalComponentTensorEquiv_apply (α : NatOrdinal) + (z : PrincipalComponent K α ⊗[K] FiniteSupportRing (K := K)) : + principalComponentTensorEquiv K α z = + principalComponentTensorMap K α z := + (rfl) + +/-- On a pure tensor, the extension-of-scalars equivalence is multiplication by the image of +the finite-support factor in the degree-zero residue ring. -/ +theorem principalComponentTensorEquiv_tmul (α : NatOrdinal) + (x : PrincipalComponent K α) (p : FiniteSupportRing (K := K)) : + principalComponentTensorEquiv K α (x ⊗ₜ p) = + HahnSeries.Nonpositive.degreeFiniteSupportResidueEquiv K p • + principalComponentToHahnDegreeLayer K α x := by + rw [principalComponentTensorEquiv_apply, principalComponentTensorMap_tmul] + +end + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/PrincipalSubring.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/PrincipalSubring.lean new file mode 100644 index 0000000000..28d95b7839 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/PrincipalSubring.lean @@ -0,0 +1,492 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalComponentDegree +public import Mathlib.Algebra.DirectSum.Algebra + +/-! +# The subring $\widehat{\mathrm P}$ of principal elements + +This module defines $\widehat{\mathrm P}$ intrinsically as the external direct sum + +`P̂ = ⨁ α, P_α`, + +where `P_α = J_{ω^(α+1)} / J_{ω^α}`. Its multiplication is induced by the homogeneous maps +`P_α × P_β → P_(α + β)`, where addition of `NatOrdinal` is Hessenberg addition. No basis, +complement, or chosen representatives enter this definition, and `P̂` is a graded commutative +`K`-algebra over every coefficient field: it is the associated graded ring of the max-additive +degree `ordinalValueDegreeValuation`, which rests on Berarducci, Lemma 5.5 alone. + +LM24, Definition 6.1.1 instead presents `P̂` as the subring of the degree-graded ring `RV̂` +whose homogeneous components are zero or principal. Both rings are associated graded rings of +`K((ℝ^{≤0}))`, for the degree and ordinal-value filtrations; since +`ordinalValueDegree b ≤ degree b`, the identity of `K((ℝ^{≤0}))` induces the canonical graded +algebra map `rvProjection : RV̂ → P̂`, the generic map of associated graded rings of +a coarsening, again over every field. The map `principalSubringEmbedding` in the other direction +chooses principal representatives of exact degree; it is a section of the projection, and its +range is exactly the componentwise-principal subalgebra. This explicit round trip identifies the +intrinsic direct sum with the paper's subring, and the projection is the left inverse that makes +the embedding injective. + +The embedding is where characteristic zero enters: it is multiplicative because the product of +two principal series is principal (LM24, Proposition 3.6.1, from Berarducci, Theorem 9.7) and +because degree is multiplicative (LM24, Theorem D). Both graded rings carry their +coefficient-field algebra structures componentwise; the embedding is an algebra homomorphism and +commutes with every homogeneous projection. +-/ + +universe v + +public noncomputable section + +namespace Berarducci + +open scoped DirectSum HahnSeries NatOrdinal + +variable {K : Type v} [Field K] + +variable (K) in +/-- The intrinsic direct sum `P̂ = ⨁ α, P_α`. -/ +abbrev PrincipalSubring := + (ordinalValueDegreeValuation K).AssociatedGraded + +variable (K) in +/-- The associated graded ring of Hahn-series degree. This is the paper's `RV̂` in the +real-exponent setting. -/ +abbrev DegreeGraded := + (HahnSeries.Nonpositive.degreeValuation K).AssociatedGraded + +/-- The coefficient-field algebra structure on `P̂`. -/ +instance principalSubringGAlgebra : + DirectSum.GAlgebra K (PrincipalComponent K) where + toFun := (principalComponentScalarHom K).toAddMonoidHom + map_one := map_one (principalComponentScalarHom K) + map_mul r s := by + change GradedMonoid.mk 0 (principalComponentScalarHom K (r * s)) = _ + rw [(principalComponentScalarHom K).map_mul] + exact GradedMonoid.mk_zero_smul _ _ + commutes _ x := DirectSum.GCommSemiring.mul_comm _ x + smul_def r x := + GradedMonoid.mk_zero_smul (principalComponentScalarHom K r) x.2 + +/-- The coefficient-field algebra structure on the degree-graded ring `RV̂`. -/ +instance degreeGradedGAlgebra : + DirectSum.GAlgebra K + (HahnSeries.Nonpositive.degreeValuation K).Component where + toFun := (degreeLayerScalarHom K).toAddMonoidHom + map_one := map_one (degreeLayerScalarHom K) + map_mul r s := by + change GradedMonoid.mk 0 (degreeLayerScalarHom K (r * s)) = _ + rw [(degreeLayerScalarHom K).map_mul] + exact GradedMonoid.mk_zero_smul _ _ + commutes _ x := DirectSum.GCommSemiring.mul_comm _ x + smul_def r x := GradedMonoid.mk_zero_smul (degreeLayerScalarHom K r) x.2 + +/-- The coefficient-field algebra structure on `P̂`. Recovering it re-traverses +`DirectSum.GAlgebra` and the componentwise multiplication, and the `Module` and `SMul` structures +used throughout are projections of it. -/ +instance principalSubringAlgebra : + Algebra K (PrincipalSubring K) := + inferInstance + +/-- The commutative ring structure on `P̂`, named for the reason given at +`principalSubringAlgebra`. -/ +instance principalSubringCommRing : + CommRing (PrincipalSubring K) := + inferInstance + +/-- The semiring structure on `P̂`. `Algebra K P̂` takes a `Semiring P̂` argument, so every +occurrence of the algebra structure resolves this too. The levels below are named for the same +reason. -/ +instance principalSubringSemiring : + Semiring (PrincipalSubring K) := + inferInstance + +instance principalSubring : + Ring (PrincipalSubring K) := + inferInstance + +instance principalSubringCommSemiring : + CommSemiring (PrincipalSubring K) := + inferInstance + +instance principalSubringAddCommGroup : + AddCommGroup (PrincipalSubring K) := + inferInstance + +/-- The coefficient-field algebra structure on `RV̂`, named for the reason given at +`principalSubringAlgebra`. -/ +instance degreeGradedAlgebra : + Algebra K (DegreeGraded K) := + inferInstance + +/-- The commutative ring structure on `RV̂`, named for the reason given at +`principalSubringAlgebra`. -/ +instance degreeGradedCommRing : + CommRing (DegreeGraded K) := + inferInstance + +/-- The semiring structure on `RV̂`, named for the reason given at `principalSubringSemiring`. -/ +instance degreeGradedSemiring : + Semiring (DegreeGraded K) := + inferInstance + +instance degreeGradedRing : + Ring (DegreeGraded K) := + inferInstance + +instance degreeGradedAddCommGroup : + AddCommGroup (DegreeGraded K) := + inferInstance + +/-- The coefficient-field algebra map lands in the intrinsic degree-zero component. -/ +@[simp] +theorem principalSubring_algebraMap_apply (k : K) : + algebraMap K (PrincipalSubring K) k = + DirectSum.of (PrincipalComponent K) 0 (principalComponentScalarHom K k) := + DirectSum.algebraMap_apply K (PrincipalComponent K) k + +/-- The ring `P̂` is nontrivial because its degree-zero component contains the +coefficient field. -/ +instance principalSubringNontrivial : + Nontrivial (PrincipalSubring K) := + (DirectSum.of_injective (β := PrincipalComponent K) 0).nontrivial + +variable (K) in +/-- The coefficient-field embedding into `P̂` is injective. -/ +theorem principalSubring_algebraMap_injective : + Function.Injective (algebraMap K (PrincipalSubring K)) := by + intro k l hkl + apply principalComponentScalarHom_injective K + apply DirectSum.of_injective (β := PrincipalComponent K) 0 + simpa only [principalSubring_algebraMap_apply] using hkl + +/-- Scalar multiplication by the coefficient field on `P̂` is +faithful. -/ +instance principalSubringFaithfulSMul : + FaithfulSMul K (PrincipalSubring K) := + (faithfulSMul_iff_algebraMap_injective K _).mpr + (principalSubring_algebraMap_injective K) + +/-- The coefficient-field algebra map for `RV̂` lands in degree zero. -/ +@[simp] +theorem degreeGraded_algebraMap_apply (k : K) : + algebraMap K (DegreeGraded K) k = + DirectSum.of + (HahnSeries.Nonpositive.degreeValuation K).Component + 0 (degreeLayerScalarHom K k) := + DirectSum.algebraMap_apply K + (HahnSeries.Nonpositive.degreeValuation K).Component k + +variable (K) in +/-- The inclusion of `P_α` into the degree-`α` component of `RV̂`. -/ +def principalComponentToHahnDegreeLayer (α : NatOrdinal) : + PrincipalComponent K α →ₗ[K] + (HahnSeries.Nonpositive.degreeValuation K).Component α := + (principalDegreeClasses K α).subtype.comp + (principalDegreeClassesEquivPrincipalComponent K α).symm.toLinearMap + +@[simp] +theorem degreeLayerToPrincipalComponent_principalComponentToHahnDegreeLayer + (α : NatOrdinal) (x : PrincipalComponent K α) : + degreeLayerToPrincipalComponent K α + (principalComponentToHahnDegreeLayer K α x) = x := by + let e := principalDegreeClassesEquivPrincipalComponent K α + have hcoe : principalComponentToHahnDegreeLayer K α x = + ((e.symm x : principalDegreeClasses K α) : + (HahnSeries.Nonpositive.degreeValuation K).Component α) := + rfl + rw [hcoe, ← principalDegreeClassesEquivPrincipalComponent_apply] + exact e.apply_symm_apply x + +variable (K) in +/-- The inclusion of `P_α` into the degree-`α` component of `RV̂` is injective. -/ +theorem principalComponentToHahnDegreeLayer_injective (α : NatOrdinal) : + Function.Injective (principalComponentToHahnDegreeLayer K α) := by + intro x y hxy + apply (degreeLayerToPrincipalComponent_principalComponentToHahnDegreeLayer α x).symm.trans + rw [hxy] + exact degreeLayerToPrincipalComponent_principalComponentToHahnDegreeLayer α y + +variable (K) in +/-- The inclusion of `P_0` sends its identity to the identity of `RV̂`. -/ +theorem principalComponentToHahnDegreeLayer_componentOne : + principalComponentToHahnDegreeLayer K 0 + (ordinalValueDegreeValuation K).componentOne = + (HahnSeries.Nonpositive.degreeValuation K).componentOne := by + let wOrder := ordinalValueDegreeValuation K + let wDegree := HahnSeries.Nonpositive.degreeValuation K + let e := principalDegreeClassesEquivPrincipalComponent K 0 + have honeDegree : (((1 : Series K) : K⟦ℝ⟧)).degree = + (0 : WithBot NatOrdinal) := by + rw [← map_one (HahnSeries.Nonpositive.C : K →+* Series K)] + exact degree_C_eq_zero_of_ne one_ne_zero + have honeClass : wDegree.componentOne ∈ principalDegreeClasses K 0 := by + rw [mem_principalDegreeClasses_iff, isPrincipalDegreeClass_iff] + refine Or.inr ⟨1, HahnSeries.Nonpositive.isPrincipal_one, honeDegree, ?_⟩ + rw [wDegree.componentOne_eq_componentMk, degreeLayerMk_eq_componentMk] + change ((e.symm wOrder.componentOne : principalDegreeClasses K 0) : + wDegree.Component 0) = wDegree.componentOne + have heq : e.symm wOrder.componentOne = ⟨wDegree.componentOne, honeClass⟩ := by + apply e.injective + rw [e.apply_symm_apply, + principalDegreeClassesEquivPrincipalComponent_apply, + degreeLayerToPrincipalComponent_eq_componentMap] + exact (MaxAddDegree.componentMap_componentOne _ _ _ _).symm + exact congrArg Subtype.val heq + +variable (K) in +/-- The canonical component map sends the degree-zero scalar of `k` to its class in +`P_0`. -/ +theorem degreeLayerToPrincipalComponent_degreeLayerScalarHom (k : K) : + degreeLayerToPrincipalComponent K 0 (degreeLayerScalarHom K k) = + principalComponentScalarHom K k := by + rw [degreeLayerScalarHom_apply, degreeLayerToPrincipalComponent_mk, + principalComponentScalarHom_apply] + +variable (K) in +/-- The canonical graded algebra map from `RV̂` to `P̂`: the map of associated graded rings +induced by the identity of `K((ℝ^{≤0}))`, which carries the degree +filtration into the coarser ordinal-value filtration because `ordinalValueDegree b ≤ degree b`. -/ +def rvProjection : + DegreeGraded K →ₐ[K] PrincipalSubring K where + toRingHom := + (HahnSeries.Nonpositive.degreeValuation K).associatedGradedMap + (ordinalValueDegreeValuation K) (RingHom.id (Series K)) + (ordinalValueDegreeValuation_le_degreeValuation K) + commutes' k := by + change (HahnSeries.Nonpositive.degreeValuation K).associatedGradedMap + (ordinalValueDegreeValuation K) (RingHom.id (Series K)) + (ordinalValueDegreeValuation_le_degreeValuation K) + (algebraMap K (DegreeGraded K) k) = algebraMap K (PrincipalSubring K) k + rw [degreeGraded_algebraMap_apply, principalSubring_algebraMap_apply, + MaxAddDegree.associatedGradedMap_of, ← degreeLayerToPrincipalComponent_eq_componentMap, + degreeLayerToPrincipalComponent_degreeLayerScalarHom K k] + +/-- The graded projection sends a homogeneous vector to the same grade. -/ +@[simp] +theorem rvProjection_of (α : NatOrdinal) + (x : (HahnSeries.Nonpositive.degreeValuation K).Component α) : + rvProjection K (DirectSum.of _ α x) = + DirectSum.of _ α (degreeLayerToPrincipalComponent K α x) := by + rw [degreeLayerToPrincipalComponent_eq_componentMap] + exact MaxAddDegree.associatedGradedMap_of _ _ _ _ α x + +/-- The graded projection commutes with every homogeneous projection. -/ +@[simp] +theorem rvProjection_apply (x : DegreeGraded K) (α : NatOrdinal) : + rvProjection K x α = + degreeLayerToPrincipalComponent K α (x α) := by + rw [degreeLayerToPrincipalComponent_eq_componentMap] + exact MaxAddDegree.associatedGradedMap_apply _ _ _ _ x α + +/-- Every vector in the image of a fixed intrinsic component is a principal degree class. -/ +theorem principalComponentToHahnDegreeLayer_isPrincipal + (α : NatOrdinal) (x : PrincipalComponent K α) : + IsPrincipalDegreeClass α + (principalComponentToHahnDegreeLayer K α x) := by + apply (mem_principalDegreeClasses_iff α _).mp + exact (principalDegreeClassesEquivPrincipalComponent K α).symm x |>.2 + +/-- On a principal class of `RV̂`, projection followed by inclusion is the identity. -/ +theorem principalComponentToHahnDegreeLayer_degreeLayerToPrincipalComponent_of_isPrincipal + (α : NatOrdinal) + (x : (HahnSeries.Nonpositive.degreeValuation K).Component α) + (hx : IsPrincipalDegreeClass α x) : + principalComponentToHahnDegreeLayer K α + (degreeLayerToPrincipalComponent K α x) = x := by + let e := principalDegreeClassesEquivPrincipalComponent K α + let x' : principalDegreeClasses K α := + ⟨x, (mem_principalDegreeClasses_iff α x).mpr hx⟩ + change ((e.symm (degreeLayerToPrincipalComponent K α x) : + principalDegreeClasses K α) : + (HahnSeries.Nonpositive.degreeValuation K).Component α) = x + have hex : e x' = degreeLayerToPrincipalComponent K α x := + principalDegreeClassesEquivPrincipalComponent_apply α x' + rw [← hex, e.symm_apply_apply] + +/-- The componentwise predicate in LM24, Definition 6.1.1: every homogeneous component is zero +or principal. -/ +def IsPrincipalGraded (x : DegreeGraded K) : Prop := + ∀ α, IsPrincipalDegreeClass α (x α) + +/-- Characterization of the paper's componentwise principal predicate. -/ +theorem isPrincipalGraded_iff (x : DegreeGraded K) : + IsPrincipalGraded x ↔ + ∀ α, IsPrincipalDegreeClass α (x α) := + Iff.rfl + +section Embedding + +variable [CharZero K] + +/-- The inclusion of each homogeneous component commutes with homogeneous multiplication. -/ +theorem principalComponentToHahnDegreeLayer_mul + {α β : NatOrdinal} (x : PrincipalComponent K α) (y : PrincipalComponent K β) : + principalComponentToHahnDegreeLayer K (α + β) + (principalComponentMul x y) = + (HahnSeries.Nonpositive.degreeValuation K).componentMul + (principalComponentToHahnDegreeLayer K α x) + (principalComponentToHahnDegreeLayer K β y) := by + let eα := principalDegreeClassesEquivPrincipalComponent K α + let eβ := principalDegreeClassesEquivPrincipalComponent K β + let eαβ := principalDegreeClassesEquivPrincipalComponent K (α + β) + let x' := eα.symm x + let y' := eβ.symm y + have hmul' := principalDegreeClassesEquivPrincipalComponent_mul x' y' + have hsource : eαβ.symm (principalComponentMul x y) = + principalDegreeClassesMul x' y' := by + apply eαβ.injective + simpa [eα, eβ, eαβ, x', y'] using hmul'.symm + change ((eαβ.symm (principalComponentMul x y) : + principalDegreeClasses K (α + β)) : + (HahnSeries.Nonpositive.degreeValuation K).Component + (α + β)) = _ + rw [hsource] + exact coe_principalDegreeClassesMul x' y' + +variable (K) in +private def principalComponentToHahnDegreeGradedLinear (α : NatOrdinal) : + PrincipalComponent K α →ₗ[K] DegreeGraded K := + (DirectSum.lof K NatOrdinal + (HahnSeries.Nonpositive.degreeValuation K).Component α).comp + (principalComponentToHahnDegreeLayer K α) + +variable (K) in +/-- The component-compatible algebra embedding of `P̂` into `RV̂`. -/ +def principalSubringEmbedding : + PrincipalSubring K →ₐ[K] DegreeGraded K := + DirectSum.toAlgebra K _ + (principalComponentToHahnDegreeGradedLinear K) + (by + let wOrder := ordinalValueDegreeValuation K + let wDegree := HahnSeries.Nonpositive.degreeValuation K + change DirectSum.of wDegree.Component 0 + (principalComponentToHahnDegreeLayer K 0 wOrder.componentOne) = + DirectSum.of wDegree.Component 0 wDegree.componentOne + rw [principalComponentToHahnDegreeLayer_componentOne K]) + (by + intro α β x y + simp only [principalComponentToHahnDegreeGradedLinear, LinearMap.comp_apply, + DirectSum.lof_eq_of] + rw [DirectSum.of_mul_of] + have hmulCompat := + principalComponentToHahnDegreeLayer_mul x y + rw [principalComponentMul_eq_componentMul] at hmulCompat + exact congrArg + (DirectSum.of + (HahnSeries.Nonpositive.degreeValuation K).Component + (α + β)) + hmulCompat) + +/-- The graded embedding sends a homogeneous vector to the same grade. -/ +@[simp] +theorem principalSubringEmbedding_of (α : NatOrdinal) (x : PrincipalComponent K α) : + principalSubringEmbedding K + (DirectSum.of (PrincipalComponent K) α x) = + DirectSum.of + (HahnSeries.Nonpositive.degreeValuation K).Component + α (principalComponentToHahnDegreeLayer K α x) := by + simp [principalSubringEmbedding, principalComponentToHahnDegreeGradedLinear, + DirectSum.toAlgebra, DirectSum.lof_eq_of] + +/-- The graded projection is a left inverse of the principal graded embedding. -/ +theorem rvProjection_principalGradedEmbedding (x : PrincipalSubring K) : + rvProjection K + (principalSubringEmbedding K x) = x := by + induction x using DirectSum.induction_on with + | zero => rw [map_zero, map_zero] + | of α x => + rw [principalSubringEmbedding_of, rvProjection_of, + degreeLayerToPrincipalComponent_principalComponentToHahnDegreeLayer] + | add x y hx hy => rw [map_add, map_add, hx, hy] + +variable (K) in +/-- The principal graded embedding is injective. -/ +theorem principalSubringEmbedding_injective : + Function.Injective (principalSubringEmbedding K) := + Function.LeftInverse.injective + rvProjection_principalGradedEmbedding + +/-- The principal graded embedding commutes with every homogeneous projection. -/ +@[simp] +theorem principalSubringEmbedding_apply (x : PrincipalSubring K) (α : NatOrdinal) : + principalSubringEmbedding K x α = + principalComponentToHahnDegreeLayer K α (x α) := by + induction x using DirectSum.induction_on with + | zero => simp + | of β x => + rw [principalSubringEmbedding_of] + by_cases hβα : β = α + · subst β + simp + · simp [DirectSum.of_apply, hβα] + | add x y hx hy => simp [map_add, hx, hy] + +variable (K) in +/-- The paper's principal graded subalgebra inside `RV̂`. -/ +def principalSubringSubalgebra : + Subalgebra K (DegreeGraded K) := + (principalSubringEmbedding K).range + +/-- The intrinsic range is exactly the componentwise definition of `P̂` from LM24, +Definition 6.1.1. -/ +theorem mem_principalGradedSubalgebra_iff (x : DegreeGraded K) : + x ∈ principalSubringSubalgebra K ↔ + IsPrincipalGraded x := by + constructor + · rintro ⟨y, hy⟩ + change principalSubringEmbedding K y = x at hy + intro α + rw [← hy, principalSubringEmbedding_apply] + exact principalComponentToHahnDegreeLayer_isPrincipal α (y α) + · intro hx + refine ⟨rvProjection K x, ?_⟩ + change principalSubringEmbedding K + (rvProjection K x) = x + apply DirectSum.ext + intro α + rw [principalSubringEmbedding_apply, rvProjection_apply] + exact + principalComponentToHahnDegreeLayer_degreeLayerToPrincipalComponent_of_isPrincipal + α (x α) (hx α) + +/-- Every element in the range of the intrinsic principal graded embedding is +componentwise principal. -/ +theorem principalSubringEmbedding_isPrincipal (x : PrincipalSubring K) : + IsPrincipalGraded (principalSubringEmbedding K x) := + (mem_principalGradedSubalgebra_iff _).mp ⟨x, rfl⟩ + +variable (K) in +/-- The intrinsic direct sum `P̂` is canonically algebra-equivalent to the subalgebra of principal +elements of `RV̂`. -/ +def principalSubringEquivSubalgebra : + PrincipalSubring K ≃ₐ[K] principalSubringSubalgebra K := + AlgEquiv.ofLeftInverse + (f := principalSubringEmbedding K) + (g := rvProjection K) + rvProjection_principalGradedEmbedding + +/-- The forward map of the intrinsic-to-paper equivalence is the graded embedding. -/ +@[simp] +theorem principalSubringEquivSubalgebra_apply (x : PrincipalSubring K) : + ((principalSubringEquivSubalgebra K x : + principalSubringSubalgebra K) : + DegreeGraded K) = + principalSubringEmbedding K x := + (rfl) + +/-- The inverse map of the intrinsic-to-paper equivalence is the graded projection. -/ +@[simp] +theorem principalSubringEquivSubalgebra_symm_apply (x : principalSubringSubalgebra K) : + (principalSubringEquivSubalgebra K).symm x = + rvProjection K x := + (rfl) + +end Embedding + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/PrincipalSubringFiniteSupport.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/PrincipalSubringFiniteSupport.lean new file mode 100644 index 0000000000..d00618a4bd --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/PrincipalSubringFiniteSupport.lean @@ -0,0 +1,239 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalSubringFraction +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.FiniteSupportScalarExtension + +/-! +# Finite-support series over the principal graded fraction field + +Let `L = Frac(P̂)`. This module defines the finite-support Hahn-series ring +`L(ℝ^{≤0})` used in LM24, Lemma 6.3.4, together with the coefficient extension +`K(ℝ^{≤0}) → L(ℝ^{≤0})`. Its range is bundled as the embedded coefficient-series subring. + +All maps are canonical. The coefficient-field embedding is the composite `K → P̂ → Frac(P̂)`, +and finite-support scalar extension preserves every exponent and applies this composite to every +coefficient. +-/ + +open scoped HahnSeries + +universe v + +namespace Berarducci + +public noncomputable section + +variable {K : Type v} [Field K] [CharZero K] + +variable (K) in +/-- The canonical coefficient-field embedding `K → P̂ → Frac(P̂)`. -/ +def principalSubringFractionCoefficientMap : + K →+* PrincipalSubringFractionField K := + (principalSubringToFraction K).comp + (algebraMap K (PrincipalSubring K)) + +/-- The coefficient-field embedding evaluates as the composite `K → P̂ → Frac(P̂)`. -/ +@[simp] +theorem principalSubringFractionCoefficientMap_apply (k : K) : + principalSubringFractionCoefficientMap K k = + principalSubringToFraction K + (algebraMap K (PrincipalSubring K) k) := + (rfl) + +variable (K) in +/-- The coefficient-field embedding into the principal graded fraction field is injective. -/ +theorem principalSubringFractionCoefficientMap_injective : + Function.Injective (principalSubringFractionCoefficientMap K) := + (principalSubringToFraction_injective K).comp + (principalSubring_algebraMap_injective K) + +variable (K) in +/-- The finite-support nonpositive real-exponent Hahn-series ring over `Frac(P̂)`. -/ +abbrev PrincipalSubringFractionFiniteSupportRing := + HahnSeries.Nonpositive.FiniteSupportRing + (G := ℝ) (K := PrincipalSubringFractionField K) + +variable (K) in +/-- Extend coefficients from `K` to `Frac(P̂)` in finite-support nonpositive real-exponent +series. -/ +def principalSubringFractionScalarExtension : + HahnSeries.Nonpositive.FiniteSupportRing (G := ℝ) (K := K) →+* + PrincipalSubringFractionFiniteSupportRing K := + HahnSeries.Nonpositive.finiteSupportMap + (G := ℝ) (principalSubringFractionCoefficientMap K) + +/-- Principal-graded fraction scalar extension applies the coefficient embedding at every +exponent. -/ +theorem principalSubringFractionScalarExtension_coeff + (b : HahnSeries.Nonpositive.FiniteSupportRing (G := ℝ) (K := K)) + (g : HahnSeries.Nonpositive.exponentMonoid ℝ) : + HahnSeries.Nonpositive.finiteSupportCoefficients + (principalSubringFractionScalarExtension K b) g = + principalSubringFractionCoefficientMap K + (HahnSeries.Nonpositive.finiteSupportCoefficients b g) := + HahnSeries.Nonpositive.finiteSupportMap_coeff + (principalSubringFractionCoefficientMap K) b g + +variable (K) in +/-- Principal-graded fraction scalar extension is injective. -/ +theorem principalSubringFractionScalarExtension_injective : + Function.Injective (principalSubringFractionScalarExtension K) := + HahnSeries.Nonpositive.finiteSupportMap_injective + (principalSubringFractionCoefficientMap K) + (principalSubringFractionCoefficientMap_injective K) + +/-- Principal-graded fraction scalar extension maps a constant series through the coefficient +embedding. -/ +@[simp] +theorem principalSubringFractionScalarExtension_scalar (k : K) : + principalSubringFractionScalarExtension K + (HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℝ) k) = + HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℝ) + (principalSubringFractionCoefficientMap K k) := + HahnSeries.Nonpositive.finiteSupportMap_scalar + (principalSubringFractionCoefficientMap K) k + +variable (K) in +/-- Principal-graded fraction scalar extension preserves every Hahn monomial. -/ +@[simp] +theorem principalSubringFractionScalarExtension_monomial + (g : HahnSeries.Nonpositive.exponentMonoid ℝ) : + principalSubringFractionScalarExtension K + (HahnSeries.Nonpositive.finiteSupportMonomial (K := K) g) = + HahnSeries.Nonpositive.finiteSupportMonomial + (K := PrincipalSubringFractionField K) g := + HahnSeries.Nonpositive.finiteSupportMap_monomial + (principalSubringFractionCoefficientMap K) g + +variable (K) in +/-- The embedded copy of `K(ℝ^{≤0})` inside `Frac(P̂)(ℝ^{≤0})`. -/ +def principalSubringFractionCoefficientSubring : + Subring (PrincipalSubringFractionFiniteSupportRing K) := + (principalSubringFractionScalarExtension K).range + +/-- Membership in the embedded coefficient-series subring is existence of a preimage over `K`. -/ +theorem mem_principalGradedFractionCoefficientSubring_iff + (b : PrincipalSubringFractionFiniteSupportRing K) : + b ∈ principalSubringFractionCoefficientSubring K ↔ + ∃ a, principalSubringFractionScalarExtension K a = b := by + rw [principalSubringFractionCoefficientSubring, RingHom.mem_range] + +variable (K) in +/-- Scalar redistribution for finite-support series over `Frac(P̂)`: a nonzero scalar may be +moved between two nonzero factors whose product has coefficients in the original field so that +both adjusted factors again have coefficients in that field. -/ +structure PrincipalSubringFractionScalarRedistribution : Prop where + exists_scalar : + ∀ {p₁ p₂ : PrincipalSubringFractionFiniteSupportRing K}, + p₁ ≠ 0 → p₂ ≠ 0 → + p₁ * p₂ ∈ principalSubringFractionCoefficientSubring K → + ∃ B : PrincipalSubringFractionField K, + B ≠ 0 ∧ + p₁ * HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℝ) B ∈ + principalSubringFractionCoefficientSubring K ∧ + p₂ * HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℝ) B⁻¹ ∈ + principalSubringFractionCoefficientSubring K + +/-- A finite-support series over `Frac(P̂)` belongs to the embedded coefficient-series subring +exactly when every coefficient belongs to the image of `K`. -/ +theorem mem_principalGradedFractionCoefficientSubring_iff_coeff + (b : PrincipalSubringFractionFiniteSupportRing K) : + b ∈ principalSubringFractionCoefficientSubring K ↔ + ∀ g, HahnSeries.Nonpositive.finiteSupportCoefficients b g ∈ + Set.range (principalSubringFractionCoefficientMap K) := by + rw [principalSubringFractionCoefficientSubring, + principalSubringFractionScalarExtension] + exact HahnSeries.Nonpositive.mem_range_finiteSupportMap_iff + (principalSubringFractionCoefficientMap K) b + +/-- If an extended nonzero series becomes a coefficient-series after multiplication by a +constant fraction, then that fraction belongs to the image of the coefficient field. -/ +theorem principalSubringFractionCoefficientMap_mem_range_of_mul_scalar_mem + {p : HahnSeries.Nonpositive.FiniteSupportRing (G := ℝ) (K := K)} + (hp : p ≠ 0) {B : PrincipalSubringFractionField K} + (hmem : principalSubringFractionScalarExtension K p * + HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℝ) B ∈ + principalSubringFractionCoefficientSubring K) : + B ∈ Set.range (principalSubringFractionCoefficientMap K) := by + apply HahnSeries.Nonpositive.coefficient_mem_range_of_map_mul_scalar_mem_range + (Field.toIsField K) (principalSubringFractionCoefficientMap K) hp + rw [principalSubringFractionCoefficientSubring, RingHom.mem_range] at hmem + change ∃ x, + HahnSeries.Nonpositive.finiteSupportMap + (principalSubringFractionCoefficientMap K) x = + HahnSeries.Nonpositive.finiteSupportMap + (principalSubringFractionCoefficientMap K) p * + HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℝ) B + simpa only [principalSubringFractionScalarExtension] using hmem + +/-- Scalar redistribution implies that the coefficient extension from `K(ℝ^{≤0})` to +`Frac(P̂)(ℝ^{≤0})` reflects divisibility. -/ +theorem principalSubringFractionScalarExtension_dvd_iff_of_scalarRedistribution (hredistribute : + ∀ {p₁ p₂ : PrincipalSubringFractionFiniteSupportRing K}, + p₁ ≠ 0 → p₂ ≠ 0 → + p₁ * p₂ ∈ principalSubringFractionCoefficientSubring K → + ∃ B : PrincipalSubringFractionField K, + B ≠ 0 ∧ + p₁ * HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℝ) B ∈ + principalSubringFractionCoefficientSubring K ∧ + p₂ * HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℝ) B⁻¹ ∈ + principalSubringFractionCoefficientSubring K) + (p q : HahnSeries.Nonpositive.FiniteSupportRing (G := ℝ) (K := K)) : + principalSubringFractionScalarExtension K p ∣ + principalSubringFractionScalarExtension K q ↔ + p ∣ q := by + apply HahnSeries.Nonpositive.finiteSupportMap_dvd_iff_of_scalarRedistribution + (principalSubringFractionCoefficientMap K) + (principalSubringFractionCoefficientMap_injective K) ?_ p q + intro p₁ p₂ hp₁ hp₂ hprod + have hprod' : + p₁ * p₂ ∈ principalSubringFractionCoefficientSubring K := by + rw [principalSubringFractionCoefficientSubring, RingHom.mem_range] + exact hprod + obtain ⟨B, hB, hleft, hright⟩ := hredistribute hp₁ hp₂ hprod' + refine ⟨B, hB, ?_, ?_⟩ + · rw [principalSubringFractionCoefficientSubring, RingHom.mem_range] at hleft + exact hleft + · rw [principalSubringFractionCoefficientSubring, RingHom.mem_range] at hright + exact hright + +/-- Scalar redistribution and greatest-common-divisor existence over `Frac(P̂)` descend primal +factor witnesses through the coefficient extension. Both descended factors remain finite-support +series over the original coefficient field. -/ +theorem principalSubringFractionScalarExtension_exists_factor_dvd_of_scalarRedistribution + (hredistribute : PrincipalSubringFractionScalarRedistribution K) + (hgcd : ∀ p q : PrincipalSubringFractionFiniteSupportRing K, + ∃ d : PrincipalSubringFractionFiniteSupportRing K, + ∀ e : PrincipalSubringFractionFiniteSupportRing K, + e ∣ p ∧ e ∣ q ↔ e ∣ d) + (p : HahnSeries.Nonpositive.FiniteSupportRing (G := ℝ) (K := K)) + (b c : PrincipalSubringFractionFiniteSupportRing K) + (hp : principalSubringFractionScalarExtension K p ∣ b * c) : + ∃ p₁ p₂ : HahnSeries.Nonpositive.FiniteSupportRing (G := ℝ) (K := K), + p = p₁ * p₂ ∧ + principalSubringFractionScalarExtension K p₁ ∣ b ∧ + principalSubringFractionScalarExtension K p₂ ∣ c := by + apply HahnSeries.Nonpositive.finiteSupportMap_exists_factor_dvd_of_scalarRedistribution + (principalSubringFractionCoefficientMap K) + (principalSubringFractionCoefficientMap_injective K) ?_ hgcd p b c hp + intro p₁ p₂ hp₁ hp₂ hprod + have hprod' : + p₁ * p₂ ∈ principalSubringFractionCoefficientSubring K := by + rw [principalSubringFractionCoefficientSubring, RingHom.mem_range] + exact hprod + obtain ⟨B, hB, hleft, hright⟩ := + hredistribute.exists_scalar hp₁ hp₂ hprod' + refine ⟨B, hB, ?_, ?_⟩ + · rw [principalSubringFractionCoefficientSubring, RingHom.mem_range] at hleft + exact hleft + · rw [principalSubringFractionCoefficientSubring, RingHom.mem_range] at hright + exact hright + +end + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/PrincipalSubringFraction.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/PrincipalSubringFraction.lean new file mode 100644 index 0000000000..4b808c0a5c --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/PrincipalSubringFraction.lean @@ -0,0 +1,231 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalSubring +public import Mathlib.RingTheory.Localization.FractionRing + +import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.AssociatedGradedDivisibility +import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.DegreeAssociatedGradedDomain +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Statements.OrdinalValueDegree + +/-! +# The fraction field of $\widehat{\mathrm P}$ + +This module defines the fraction field `Frac(P̂)` occurring in LM24, Lemmas 6.3.3--6.3.4. The +ring `P̂` is the intrinsic direct sum of the spaces `P_α`, and its canonical map to the +fraction field is injective. + +The coefficient-field algebra structure is obtained by composing `K → P̂` with the canonical +localization map `P̂ → Frac(P̂)`. It is kept distinct from the localization algebra structure, +so the two scalar structures are not conflated. +-/ + +universe v + +public noncomputable section + +namespace Berarducci + +variable {K : Type v} [Field K] [CharZero K] + +/-- The intrinsic direct sum `P̂` is an integral domain: the exponent-valued order valuation is +multiplicative (Berarducci, Theorem 9.7), so its associated graded ring has no zero divisors. -/ +instance principalSubringIsDomain : + IsDomain (PrincipalSubring K) := + NoZeroDivisors.to_isDomain _ + +variable (K) in +/-- The canonical fraction field of `P̂`. -/ +def PrincipalSubringFractionField := + FractionRing (PrincipalSubring K) + +omit [CharZero K] in +variable (K) in +/-- The principal graded fraction field is the canonical fraction-ring construction. -/ +theorem principalSubringFractionField_eq_fractionRing : + PrincipalSubringFractionField K = + FractionRing (PrincipalSubring K) := + (rfl) + +/-- The canonical field structure on the fraction field of `P̂`. -/ +noncomputable instance principalSubringFractionFieldInstance : + Field (PrincipalSubringFractionField K) := + (principalSubringFractionField_eq_fractionRing K).symm ▸ + (inferInstance : Field (FractionRing (PrincipalSubring K))) + +variable (K) in +/-- The canonical ring equivalence from the defined fraction field to the fraction-ring +construction. -/ +def principalSubringFractionRingEquiv : + PrincipalSubringFractionField K ≃+* + FractionRing (PrincipalSubring K) := by + let h := principalSubringFractionField_eq_fractionRing K + exact + { toFun := fun x ↦ h.mp x + invFun := fun x ↦ h.mpr x + left_inv := fun x ↦ by cases h; rfl + right_inv := fun x ↦ by cases h; rfl + map_add' := by + intro x y + cases h + rfl + map_mul' := by + intro x y + cases h + rfl } + +variable (K) in +/-- The canonical localization algebra structure `P̂ → Frac(P̂)`. -/ +noncomputable abbrev principalSubringFractionSelfAlgebra : + Algebra (PrincipalSubring K) + (PrincipalSubringFractionField K) := + RingHom.toAlgebra + ((principalSubringFractionRingEquiv K).symm.toRingHom.comp + (algebraMap (PrincipalSubring K) + (FractionRing (PrincipalSubring K)))) + +/-- The principal graded subring acts canonically on its explicitly constructed fraction field. -/ +local instance principalSubringFractionSelfAlgebraInstance : + Algebra (PrincipalSubring K) + (PrincipalSubringFractionField K) := + principalSubringFractionSelfAlgebra K + +variable (K) in +/-- The defined fraction field is canonically equivalent, as a `P̂`-algebra, to the fraction-ring +construction. -/ +def principalSubringFractionAlgEquiv : + FractionRing (PrincipalSubring K) ≃ₐ[PrincipalSubring K] + PrincipalSubringFractionField K where + toRingEquiv := (principalSubringFractionRingEquiv K).symm + commutes' _ := rfl + +local instance principalSubringFractionIsFractionRing : + IsFractionRing (PrincipalSubring K) + (PrincipalSubringFractionField K) := by + exact IsFractionRing.of_algEquiv (principalSubringFractionAlgEquiv K) + +variable (K) in +/-- The canonical inclusion `P̂ → Frac(P̂)`. -/ +def principalSubringToFraction : + PrincipalSubring K →+* PrincipalSubringFractionField K := + algebraMap _ _ + +/-- The canonical inclusion is the localization algebra map on each element of `P̂`. -/ +@[simp] +theorem principalSubringToFraction_apply (B : PrincipalSubring K) : + principalSubringToFraction K B = + @algebraMap (PrincipalSubring K) + (PrincipalSubringFractionField K) _ _ + (principalSubringFractionSelfAlgebra K) B := + (rfl) + +/-- Construct an element of `Frac(P̂)` from a numerator and a non-zero-divisor denominator. -/ +def principalSubringFractionMk (B : PrincipalSubring K) + (C : nonZeroDivisors (PrincipalSubring K)) : + PrincipalSubringFractionField K := + IsLocalization.mk' (PrincipalSubringFractionField K) B C + +/-- The canonical inclusion sends `B` to the localization fraction `B / 1`. -/ +theorem principalSubringToFraction_apply_eq_mk (B : PrincipalSubring K) : + principalSubringToFraction K B = + principalSubringFractionMk B + (1 : nonZeroDivisors (PrincipalSubring K)) := by + rw [principalSubringFractionMk, IsLocalization.mk'_one] + rfl + +variable (K) in +/-- A localization representative in `Frac(P̂)` is zero exactly when its numerator is zero. -/ +@[simp] +theorem principalSubringFractionMk_eq_zero_iff {B : PrincipalSubring K} + {C : nonZeroDivisors (PrincipalSubring K)} : + principalSubringFractionMk B C = 0 ↔ B = 0 := by + rw [principalSubringFractionMk] + exact IsFractionRing.mk'_eq_zero_iff_eq_zero + +variable (K) in +/-- The canonical inclusion of `P̂` in its fraction field is injective. -/ +theorem principalSubringToFraction_injective : + Function.Injective (principalSubringToFraction K) := + IsFractionRing.injective _ _ + +/-- Every element of `Frac(P̂)` has a localization representative with denominator in the +non-zero-divisor submonoid of `P̂`. -/ +theorem principalSubringFraction_exists_mk (x : PrincipalSubringFractionField K) : + ∃ (B : PrincipalSubring K) + (C : nonZeroDivisors (PrincipalSubring K)), + x = principalSubringFractionMk B C := by + obtain ⟨B, C, hBC⟩ := + IsLocalization.exists_mk'_eq + (nonZeroDivisors (PrincipalSubring K)) x + exact ⟨B, C, by simpa only [principalSubringFractionMk] using hBC.symm⟩ + +/-- Every nonzero element of `Frac(P̂)` has a localization representative with nonzero +numerator. -/ +theorem principalSubringFraction_exists_mk_of_ne_zero + {x : PrincipalSubringFractionField K} (hx : x ≠ 0) : + ∃ (B : PrincipalSubring K) + (C : nonZeroDivisors (PrincipalSubring K)), + B ≠ 0 ∧ x = principalSubringFractionMk B C := by + obtain ⟨B, C, hBC⟩ := principalSubringFraction_exists_mk x + refine ⟨B, C, ?_, hBC⟩ + intro hB + apply hx + rw [hBC, hB] + exact (principalSubringFractionMk_eq_zero_iff K).mpr rfl + +variable (K) in +/-- The coefficient-field algebra structure on `Frac(P̂)`, induced through `K → P̂`. -/ +noncomputable abbrev principalSubringFractionAlgebra : + Algebra K (PrincipalSubringFractionField K) := + RingHom.toAlgebra + ((principalSubringToFraction K).comp + (algebraMap K (PrincipalSubring K))) + +/-- The coefficient-field algebra structure on the explicitly constructed principal-subring +fraction field. -/ +local instance principalSubringFractionAlgebraInstance : + Algebra K (PrincipalSubringFractionField K) := + principalSubringFractionAlgebra K + +/-- The coefficient-field embedding in `Frac(P̂)` is the composite `K → P̂ → Frac(P̂)`. -/ +@[simp] +theorem principalSubringFraction_algebraMap_apply (k : K) : + algebraMap K (PrincipalSubringFractionField K) k = + principalSubringToFraction K + (algebraMap K (PrincipalSubring K) k) := + (rfl) + +variable (K) in +/-- The coefficient, principal-graded, and fraction-field algebra structures form the canonical +scalar tower `K → P̂ → Frac(P̂)`. -/ +theorem principalSubringFraction_isScalarTower : + @IsScalarTower K (PrincipalSubring K) + (PrincipalSubringFractionField K) + inferInstance + (principalSubringFractionSelfAlgebra K).toSMul + (principalSubringFractionAlgebra K).toSMul := by + apply @IsScalarTower.of_algebraMap_eq K (PrincipalSubring K) + (PrincipalSubringFractionField K) _ _ _ _ + (principalSubringFractionSelfAlgebra K) + (principalSubringFractionAlgebra K) + intro k + rw [principalSubringFraction_algebraMap_apply, + principalSubringToFraction_apply] + +variable (K) in +/-- The coefficient-field embedding into `Frac(P̂)` is injective. -/ +theorem principalSubringFraction_algebraMap_injective : + Function.Injective + (algebraMap K (PrincipalSubringFractionField K)) := by + intro k l hkl + apply principalSubring_algebraMap_injective K + apply principalSubringToFraction_injective K + simpa only [principalSubringFraction_algebraMap_apply] using hkl + +attribute [irreducible] PrincipalSubringFractionField + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/PrincipalSubringFractionAlgebraic.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/PrincipalSubringFractionAlgebraic.lean new file mode 100644 index 0000000000..a814b72068 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/PrincipalSubringFractionAlgebraic.lean @@ -0,0 +1,852 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalSubringFraction +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.DirectSum.LeadingGrade +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.CoefficientMap +public import Mathlib.RingTheory.Polynomial.ScaleRoots +public import Mathlib.RingTheory.Algebraic.Defs +public import Mathlib.FieldTheory.Minpoly.Basic + +import Mathlib.FieldTheory.IsAlgClosed.AlgebraicClosure +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Statements.ProductValue + +/-! +# Degrees in a homogenized algebraic relation + +An element of the fraction field of `P̂` that is algebraic over the +coefficient field satisfies a monic relation which, after clearing denominators, becomes a sum of +terms `B ^ e * C ^ f` with `e + f` constant. Because the degree is a multiplicative valuation, the +degree of such a term is `e` copies of `deg B` plus `f` copies of `deg C`, the sum taken in the +Hessenberg (natural) arithmetic of `NatOrdinal`. + +This file records the arithmetic that forces the two degrees to agree. Natural addition is +cancellative and strictly monotone and natural multiplication by a positive factor is strictly +monotone, so if the two degrees differed, the degrees of the individual terms would be pairwise +distinct and the term of largest degree could not be cancelled by the others. The consequence +recorded here is the contrapositive: distinct terms of equal degree force `deg B = deg C`. + +Where the source argument passes from a relation among leading homogeneous components back to a +degree bound on a combination of representatives, it cites LM24, Lemma 4.2.5. That appeal is +discharged here by the quotient presentation of `P_α` instead: `principalComponentMk_eq_zero_iff` +identifies the vanishing of a class with a degree drop of any representative, and additivity of +the class map turns the homogeneous relation into the required bound. No separate formalization of +the printed lemma is used. +-/ + +universe v + +open scoped HahnSeries NatOrdinal + +namespace Berarducci + +open HahnSeries.Nonpositive + +public noncomputable section + +/-- Along a homogenized relation the term degrees are strictly antitone in the exponent of the +smaller of the two degrees. -/ +theorem natOrdinal_termDegree_lt_of_lt {beta gamma : NatOrdinal} (h : beta < gamma) + {e f e' f' : ℕ} (hsum : e + f = e' + f') (hlt : e < e') : + (e' : NatOrdinal) * beta + (f' : NatOrdinal) * gamma < + (e : NatOrdinal) * beta + (f : NatOrdinal) * gamma := by + obtain ⟨m, hm⟩ := Nat.exists_eq_add_of_lt hlt + have hm0 : 0 < m + 1 := Nat.succ_pos m + have hf : f = f' + (m + 1) := by omega + have hmul : ((m + 1 : ℕ) : NatOrdinal) * beta < ((m + 1 : ℕ) : NatOrdinal) * gamma := by + refine mul_lt_mul_of_pos_left h ?_ + exact_mod_cast hm0 + have hleft : (e' : NatOrdinal) * beta + (f' : NatOrdinal) * gamma = + ((e : NatOrdinal) * beta + (f' : NatOrdinal) * gamma) + + ((m + 1 : ℕ) : NatOrdinal) * beta := by + rw [hm] + push_cast + ring + have hright : (e : NatOrdinal) * beta + (f : NatOrdinal) * gamma = + ((e : NatOrdinal) * beta + (f' : NatOrdinal) * gamma) + + ((m + 1 : ℕ) : NatOrdinal) * gamma := by + rw [hf] + push_cast + ring + rw [hleft, hright] + exact add_lt_add_of_le_of_lt le_rfl hmul + +/-- If `β ≠ γ`, two distinct exponent pairs with the same total exponent have distinct +`β, γ`-weighted degrees. -/ +theorem natOrdinal_termDegree_ne {beta gamma : NatOrdinal} (h : beta ≠ gamma) + {e f e' f' : ℕ} (hsum : e + f = e' + f') (hne : e ≠ e') : + (e : NatOrdinal) * beta + (f : NatOrdinal) * gamma ≠ + (e' : NatOrdinal) * beta + (f' : NatOrdinal) * gamma := by + have hswap : ∀ a b : ℕ, (a : NatOrdinal) * beta + (b : NatOrdinal) * gamma = + (b : NatOrdinal) * gamma + (a : NatOrdinal) * beta := fun a b ↦ add_comm _ _ + rcases lt_or_gt_of_ne h with hbg | hbg + · rcases lt_or_gt_of_ne hne with hee | hee + · exact (natOrdinal_termDegree_lt_of_lt hbg hsum hee).ne' + · exact (natOrdinal_termDegree_lt_of_lt hbg hsum.symm hee).ne + · have hfne : f ≠ f' := by omega + rw [hswap e f, hswap e' f'] + rcases lt_or_gt_of_ne hfne with hff | hff + · exact (natOrdinal_termDegree_lt_of_lt hbg (by omega : f + e = f' + e') hff).ne' + · exact (natOrdinal_termDegree_lt_of_lt hbg (by omega : f' + e' = f + e) hff).ne + +/-! ### Multiplicativity of the leading grade on `P̂` -/ + +variable {K : Type v} [Field K] [CharZero K] + +/-- Nonzero homogeneous classes have nonzero product: `P̂` is a domain, and +the product of the homogeneous inclusions is the inclusion of the graded product. -/ +theorem principalComponent_gMul_ne_zero {i j : NatOrdinal} + (a : PrincipalComponent K i) (b : PrincipalComponent K j) (ha : a ≠ 0) (hb : b ≠ 0) : + GradedMonoid.GMul.mul a b ≠ 0 := by + intro hzero + have hprod : + (DirectSum.of (PrincipalComponent K) i a) * + (DirectSum.of (PrincipalComponent K) j b) = 0 := by + rw [DirectSum.of_mul_of, hzero, map_zero] + rcases mul_eq_zero.mp hprod with h | h + · exact ha (DirectSum.of_injective i (by rw [h, map_zero])) + · exact hb (DirectSum.of_injective j (by rw [h, map_zero])) + +/-- On `P̂` the leading grade is additive on products. -/ +theorem leadingGrade_mul_principalGraded (x y : PrincipalSubring K) : + DirectSum.leadingGrade (PrincipalComponent K) (x * y) = + DirectSum.leadingGrade (PrincipalComponent K) x + + DirectSum.leadingGrade (PrincipalComponent K) y := + DirectSum.leadingGrade_mul (PrincipalComponent K) + (fun a b ha hb ↦ principalComponent_gMul_ne_zero a b ha hb) x y + +omit [CharZero K] in +variable (K) in +/-- The unit has leading grade zero. -/ +theorem leadingGrade_one_principalGraded : + DirectSum.leadingGrade (PrincipalComponent K) (1 : PrincipalSubring K) = + ((0 : NatOrdinal) : WithBot NatOrdinal) := by + have hone : (GradedMonoid.GOne.one : PrincipalComponent K 0) ≠ 0 := by + intro hzero + have : (1 : PrincipalSubring K) = 0 := by + rw [DirectSum.one_def, hzero, map_zero] + exact one_ne_zero this + rw [DirectSum.one_def] + exact DirectSum.leadingGrade_of (PrincipalComponent K) hone + +/-- The leading grade of a power multiplies the leading grade by the exponent. -/ +theorem leadingGrade_pow_principalGraded {x : PrincipalSubring K} {beta : NatOrdinal} + (hx : DirectSum.leadingGrade (PrincipalComponent K) x = (beta : WithBot NatOrdinal)) + (n : ℕ) : + DirectSum.leadingGrade (PrincipalComponent K) (x ^ n) = + (((n : NatOrdinal) * beta : NatOrdinal) : WithBot NatOrdinal) := by + induction n with + | zero => simpa using leadingGrade_one_principalGraded K + | succ n ih => + rw [pow_succ, leadingGrade_mul_principalGraded, ih, hx, ← WithBot.coe_add] + congr 1 + push_cast + ring + +omit [CharZero K] in +/-- Adding an element of strictly smaller leading grade leaves the leading grade unchanged. This +is the step that makes a uniquely maximal term impossible to cancel. -/ +theorem leadingGrade_add_eq_of_lt {x y : PrincipalSubring K} + (h : DirectSum.leadingGrade (PrincipalComponent K) y < + DirectSum.leadingGrade (PrincipalComponent K) x) : + DirectSum.leadingGrade (PrincipalComponent K) (x + y) = + DirectSum.leadingGrade (PrincipalComponent K) x := by + have hx : x ≠ 0 := by + intro hzero + rw [hzero, DirectSum.leadingGrade_zero] at h + exact (not_lt_bot h).elim + obtain ⟨m, hm, hxm⟩ := DirectSum.exists_grade_eq_leadingGrade (PrincipalComponent K) hx + have hym : y m = 0 := by + by_contra hne + exact absurd (DirectSum.grade_le_leadingGrade (PrincipalComponent K) hne) + (not_le.mpr (by rw [hm] at h; exact h)) + refine le_antisymm ?_ ?_ + · refine (DirectSum.leadingGrade_add_le_max (PrincipalComponent K) x y).trans ?_ + exact max_le le_rfl h.le + · rw [hm] + refine DirectSum.grade_le_leadingGrade (PrincipalComponent K) ?_ + rw [DirectSum.add_apply, hym, add_zero] + exact hxm + +/-! ### A uniquely maximal term cannot cancel -/ + +omit [CharZero K] in +/-- The leading grade of a finite sum is at most the supremum of the leading grades. -/ +theorem leadingGrade_finsetSum_le {iota : Type*} + (s : Finset iota) (g : iota → PrincipalSubring K) : + DirectSum.leadingGrade (PrincipalComponent K) (∑ i ∈ s, g i) ≤ + s.sup fun i ↦ DirectSum.leadingGrade (PrincipalComponent K) (g i) := by + classical + induction s using Finset.induction with + | empty => simp [DirectSum.leadingGrade_zero] + | insert a t ha ih => + rw [Finset.sum_insert ha, Finset.sup_insert] + exact (DirectSum.leadingGrade_add_le_max (PrincipalComponent K) _ _).trans + (max_le_max le_rfl ih) + +omit [CharZero K] in +/-- A finite sum in which one nonzero term has strictly largest leading grade has that leading +grade. In particular such a sum cannot vanish, which is what forbids the degrees of two distinct +terms of the homogenized relation from being separated. -/ +theorem leadingGrade_finsetSum_eq_of_unique_max + {iota : Type*} (s : Finset iota) (g : iota → PrincipalSubring K) + {i₀ : iota} (hi₀ : i₀ ∈ s) (hg₀ : g i₀ ≠ 0) + (hmax : ∀ i ∈ s, i ≠ i₀ → + DirectSum.leadingGrade (PrincipalComponent K) (g i) < + DirectSum.leadingGrade (PrincipalComponent K) (g i₀)) : + DirectSum.leadingGrade (PrincipalComponent K) (∑ i ∈ s, g i) = + DirectSum.leadingGrade (PrincipalComponent K) (g i₀) := by + classical + have hbot : (⊥ : WithBot NatOrdinal) < + DirectSum.leadingGrade (PrincipalComponent K) (g i₀) := + bot_lt_iff_ne_bot.mpr fun hb ↦ + hg₀ ((DirectSum.leadingGrade_eq_bot_iff (PrincipalComponent K) _).mp hb) + rw [← Finset.add_sum_erase s g hi₀] + refine leadingGrade_add_eq_of_lt ?_ + refine lt_of_le_of_lt (leadingGrade_finsetSum_le _ g) ?_ + exact (Finset.sup_lt_iff hbot).mpr fun i hi ↦ + hmax i (Finset.mem_of_mem_erase hi) (Finset.ne_of_mem_erase hi) + +/-! ### The two degrees of a homogenized relation agree -/ + +omit [CharZero K] in +/-- A nonzero scalar has leading grade zero. -/ +theorem leadingGrade_algebraMap_of_ne_zero {a : K} + (ha : a ≠ 0) : + DirectSum.leadingGrade (PrincipalComponent K) (algebraMap K (PrincipalSubring K) a) = + ((0 : NatOrdinal) : WithBot NatOrdinal) := by + rw [principalSubring_algebraMap_apply] + refine DirectSum.leadingGrade_of (PrincipalComponent K) ?_ + intro hzero + exact ha (principalComponentScalarHom_injective K (by rw [hzero, map_zero])) + +/-- The leading grade of a term of a homogenized relation. -/ +theorem leadingGrade_relationTerm {a : K} (ha : a ≠ 0) + {B C : PrincipalSubring K} {beta gamma : NatOrdinal} + (hB : DirectSum.leadingGrade (PrincipalComponent K) B = (beta : WithBot NatOrdinal)) + (hC : DirectSum.leadingGrade (PrincipalComponent K) C = (gamma : WithBot NatOrdinal)) + (i f : ℕ) : + DirectSum.leadingGrade (PrincipalComponent K) + (algebraMap K (PrincipalSubring K) a * B ^ i * C ^ f) = + (((i : NatOrdinal) * beta + (f : NatOrdinal) * gamma : NatOrdinal) : + WithBot NatOrdinal) := by + rw [leadingGrade_mul_principalGraded, leadingGrade_mul_principalGraded, + leadingGrade_algebraMap_of_ne_zero ha, + leadingGrade_pow_principalGraded hB, leadingGrade_pow_principalGraded hC, + ← WithBot.coe_add, ← WithBot.coe_add, zero_add] + +/-- The two degrees of a homogenized relation agree. If `∑ i, k i * B ^ i * C ^ (d - i) = 0` with +top coefficient nonzero and `B`, `C` nonzero, then `B` and `C` have the same leading grade: +otherwise the term degrees would be pairwise distinct, so the term of largest degree could not be +cancelled and the sum could not vanish. -/ +theorem leadingGrade_eq_of_relation {B C : PrincipalSubring K} (hB : B ≠ 0) (hC : C ≠ 0) + {d : ℕ} (k : ℕ → K) (hkd : k d ≠ 0) + (hrel : ∑ i ∈ Finset.range (d + 1), + algebraMap K (PrincipalSubring K) (k i) * B ^ i * C ^ (d - i) = 0) : + DirectSum.leadingGrade (PrincipalComponent K) B = + DirectSum.leadingGrade (PrincipalComponent K) C := by + classical + obtain ⟨beta, hbeta⟩ := WithBot.ne_bot_iff_exists.mp + (fun hb ↦ hB ((DirectSum.leadingGrade_eq_bot_iff (PrincipalComponent K) B).mp hb)) + obtain ⟨gamma, hgamma⟩ := WithBot.ne_bot_iff_exists.mp + (fun hb ↦ hC ((DirectSum.leadingGrade_eq_bot_iff (PrincipalComponent K) C).mp hb)) + rw [← hbeta, ← hgamma] + by_contra hne + have hbg : beta ≠ gamma := fun h ↦ hne (by rw [h]) + obtain ⟨i₀, hi₀S, hi₀max⟩ := + ((Finset.range (d + 1)).filter fun i ↦ k i ≠ 0).exists_max_image + (fun i ↦ (i : NatOrdinal) * beta + ((d - i : ℕ) : NatOrdinal) * gamma) + ⟨d, Finset.mem_filter.mpr ⟨Finset.self_mem_range_succ d, hkd⟩⟩ + have hi₀range : i₀ ∈ Finset.range (d + 1) := (Finset.mem_filter.mp hi₀S).1 + have hk₀ : k i₀ ≠ 0 := (Finset.mem_filter.mp hi₀S).2 + have hgrade₀ := leadingGrade_relationTerm hk₀ hbeta.symm hgamma.symm i₀ (d - i₀) + have hg₀ : algebraMap K (PrincipalSubring K) (k i₀) * B ^ i₀ * C ^ (d - i₀) ≠ 0 := by + intro hzero + rw [hzero, DirectSum.leadingGrade_zero] at hgrade₀ + exact WithBot.coe_ne_bot hgrade₀.symm + have hsum := leadingGrade_finsetSum_eq_of_unique_max (Finset.range (d + 1)) + (fun i ↦ algebraMap K (PrincipalSubring K) (k i) * B ^ i * C ^ (d - i)) + hi₀range hg₀ (fun i hi hine ↦ ?_) + · rw [hrel, DirectSum.leadingGrade_zero, hgrade₀] at hsum + exact WithBot.coe_ne_bot hsum.symm + · by_cases hki : k i = 0 + · have hzero : algebraMap K (PrincipalSubring K) (k i) * B ^ i * C ^ (d - i) = 0 := by + rw [hki, map_zero, zero_mul, zero_mul] + rw [hzero, DirectSum.leadingGrade_zero, hgrade₀] + exact bot_lt_iff_ne_bot.mpr WithBot.coe_ne_bot + · rw [leadingGrade_relationTerm hki hbeta.symm hgamma.symm i (d - i), hgrade₀, + WithBot.coe_lt_coe] + refine lt_of_le_of_ne (hi₀max i (Finset.mem_filter.mpr ⟨hi, hki⟩)) ?_ + have hile : i ≤ d := Nat.lt_succ_iff.mp (Finset.mem_range.mp hi) + have hi₀le : i₀ ≤ d := Nat.lt_succ_iff.mp (Finset.mem_range.mp hi₀range) + exact natOrdinal_termDegree_ne hbg (by omega) hine + +/-! ### Homogenizing a split polynomial -/ + +/-- Scaling the roots of a product of monic linear factors and evaluating produces the +homogenized linear factors. This is the identity that turns the cleared relation into a product +over the roots of the minimal polynomial. -/ +theorem eval_scaleRoots_prod_X_sub_C {R : Type*} [CommRing R] [Nontrivial R] (s : Multiset R) + (b c : R) : + Polynomial.eval b + ((s.map fun z ↦ Polynomial.X - Polynomial.C z).prod.scaleRoots c) = + (s.map fun z ↦ b - z * c).prod := by + induction s using Multiset.induction with + | empty => simp + | cons z t ih => + have hmonic : (t.map fun z ↦ Polynomial.X - Polynomial.C z).prod.Monic := + Polynomial.monic_multiset_prod_of_monic t _ fun w _ ↦ Polynomial.monic_X_sub_C w + have hlead : (Polynomial.X - Polynomial.C z).leadingCoeff * + (t.map fun z ↦ Polynomial.X - Polynomial.C z).prod.leadingCoeff ≠ 0 := by + rw [(Polynomial.monic_X_sub_C z).leadingCoeff, hmonic.leadingCoeff, one_mul] + exact one_ne_zero + have hlin : (Polynomial.X - Polynomial.C z).scaleRoots c = + Polynomial.X - Polynomial.C (z * c) := by + have := Polynomial.X_add_C_scaleRoots (-z) c + rwa [map_neg, ← sub_eq_add_neg, neg_mul, map_neg, ← sub_eq_add_neg] at this + rw [Multiset.map_cons, Multiset.prod_cons, Polynomial.mul_scaleRoots' _ _ _ hlead, hlin, + Polynomial.eval_mul, ih, Multiset.map_cons, Multiset.prod_cons] + simp + +/-! ### Passing to leading terms -/ + +omit [CharZero K] in +/-- The leading term of a product is the product of the leading terms. Stated in the graded ring +itself rather than in its homogeneous components, so no grade casts appear. -/ +theorem of_apply_add_mul {x y : PrincipalSubring K} + {m n : NatOrdinal} + (hx : DirectSum.leadingGrade (PrincipalComponent K) x = (m : WithBot NatOrdinal)) + (hy : DirectSum.leadingGrade (PrincipalComponent K) y = (n : WithBot NatOrdinal)) : + DirectSum.of (PrincipalComponent K) (m + n) ((x * y) (m + n)) = + DirectSum.of (PrincipalComponent K) m (x m) * + DirectSum.of (PrincipalComponent K) n (y n) := by + rw [DirectSum.of_mul_of, DirectSum.mul_apply_add_eq_of_leadingGrade_eq _ hx hy] + +/-- The leading term of a power is the power of the leading term. -/ +theorem of_apply_pow {x : PrincipalSubring K} + {m : NatOrdinal} + (hx : DirectSum.leadingGrade (PrincipalComponent K) x = (m : WithBot NatOrdinal)) (i : ℕ) : + DirectSum.of (PrincipalComponent K) ((i : NatOrdinal) * m) + ((x ^ i) ((i : NatOrdinal) * m)) = + (DirectSum.of (PrincipalComponent K) m (x m)) ^ i := by + induction i with + | zero => + have h1 : (1 : PrincipalSubring K) 0 = GradedMonoid.GOne.one := by + rw [DirectSum.one_def, DirectSum.of_eq_same] + rw [pow_zero, pow_zero, Nat.cast_zero, zero_mul, h1] + exact (DirectSum.one_def (PrincipalComponent K)).symm + | succ i ih => + have hgrade : ((i + 1 : ℕ) : NatOrdinal) * m = (i : NatOrdinal) * m + m := by + push_cast; ring + have hshift : DirectSum.of (PrincipalComponent K) (((i + 1 : ℕ) : NatOrdinal) * m) + ((x ^ (i + 1)) (((i + 1 : ℕ) : NatOrdinal) * m)) = + DirectSum.of (PrincipalComponent K) ((i : NatOrdinal) * m + m) + ((x ^ (i + 1)) ((i : NatOrdinal) * m + m)) := + DirectSum.of_eq_of_gradedMonoid_eq (by rw [hgrade]) + rw [hshift, pow_succ, pow_succ, ← ih, + of_apply_add_mul (leadingGrade_pow_principalGraded hx i) hx] + +/-- The homogenized relation passes to the leading terms. Every term of the relation has leading +grade `d * beta`, so taking that component turns the relation into the same relation among the +homogeneous leading terms of `B` and `C`. -/ +theorem sum_leadingTerm_eq_zero + {B C : PrincipalSubring K} {beta : NatOrdinal} {d : ℕ} (k : ℕ → K) + (hB : DirectSum.leadingGrade (PrincipalComponent K) B = (beta : WithBot NatOrdinal)) + (hC : DirectSum.leadingGrade (PrincipalComponent K) C = (beta : WithBot NatOrdinal)) + (hrel : ∑ i ∈ Finset.range (d + 1), + algebraMap K (PrincipalSubring K) (k i) * B ^ i * C ^ (d - i) = 0) : + ∑ i ∈ Finset.range (d + 1), algebraMap K (PrincipalSubring K) (k i) * + (DirectSum.of (PrincipalComponent K) beta (B beta)) ^ i * + (DirectSum.of (PrincipalComponent K) beta (C beta)) ^ (d - i) = 0 := by + classical + have hterm : ∀ i ∈ Finset.range (d + 1), + DirectSum.of (PrincipalComponent K) ((d : NatOrdinal) * beta) + ((algebraMap K (PrincipalSubring K) (k i) * B ^ i * C ^ (d - i)) + ((d : NatOrdinal) * beta)) = + algebraMap K (PrincipalSubring K) (k i) * + (DirectSum.of (PrincipalComponent K) beta (B beta)) ^ i * + (DirectSum.of (PrincipalComponent K) beta (C beta)) ^ (d - i) := by + intro i hi + have hile : i ≤ d := Nat.lt_succ_iff.mp (Finset.mem_range.mp hi) + have hgr : (d : NatOrdinal) * beta = + (i : NatOrdinal) * beta + ((d - i : ℕ) : NatOrdinal) * beta := by + have : ((d : ℕ) : NatOrdinal) = ((i : ℕ) : NatOrdinal) + ((d - i : ℕ) : NatOrdinal) := by + rw [← Nat.cast_add] + congr 1 + omega + rw [this, add_mul] + have hshift : DirectSum.of (PrincipalComponent K) ((d : NatOrdinal) * beta) + ((B ^ i * C ^ (d - i)) ((d : NatOrdinal) * beta)) = + DirectSum.of (PrincipalComponent K) + ((i : NatOrdinal) * beta + ((d - i : ℕ) : NatOrdinal) * beta) + ((B ^ i * C ^ (d - i)) + ((i : NatOrdinal) * beta + ((d - i : ℕ) : NatOrdinal) * beta)) := + DirectSum.of_eq_of_gradedMonoid_eq (by rw [hgr]) + have hsmul : (algebraMap K (PrincipalSubring K) (k i) * (B ^ i * C ^ (d - i))) + ((d : NatOrdinal) * beta) = k i • ((B ^ i * C ^ (d - i)) ((d : NatOrdinal) * beta)) := by + rw [← Algebra.smul_def] + rfl + rw [mul_assoc, hsmul, DirectSum.of_smul, Algebra.smul_def, hshift, + of_apply_add_mul (leadingGrade_pow_principalGraded hB i) + (leadingGrade_pow_principalGraded hC (d - i)), + of_apply_pow hB, of_apply_pow hC, mul_assoc] + have hfinal : DirectSum.of (PrincipalComponent K) ((d : NatOrdinal) * beta) + ((∑ i ∈ Finset.range (d + 1), + algebraMap K (PrincipalSubring K) (k i) * B ^ i * C ^ (d - i)) + ((d : NatOrdinal) * beta)) = 0 := by + rw [hrel] + simp + rw [← Finset.sum_congr rfl hterm, ← map_sum, ← DFinsupp.finsetSum_apply] + exact hfinal + +/-! ### Descending to representatives -/ + +omit [CharZero K] in +/-- A power of a homogeneous class is the class of the power of a representative. The grade is +written with `nsmul`, for which the successor identity is definitional, so no grade cast +intervenes. -/ +theorem of_principalComponentMk_pow {beta : NatOrdinal} + (b : Series K) (hb : ordinalValue b < ω^ (beta + 1)) (i : ℕ) : + ∃ h : ordinalValue (b ^ i) < ω^ (i • beta + 1), + (DirectSum.of (PrincipalComponent K) beta (principalComponentMk beta b hb)) ^ i = + DirectSum.of (PrincipalComponent K) (i • beta) + (principalComponentMk (i • beta) (b ^ i) h) := by + induction i with + | zero => + have h0 : ordinalValue ((b : Series K) ^ 0) < ω^ ((0 : ℕ) • beta + 1) := by + rw [pow_zero, ordinalValue_one, zero_nsmul, zero_add] + simpa using NatOrdinal.wpow_lt_wpow.mpr (zero_lt_one : (0 : NatOrdinal) < 1) + refine ⟨h0, ?_⟩ + rw [pow_zero, DirectSum.one_def] + congr 1 + have hone : (GradedMonoid.GOne.one : PrincipalComponent K 0) = + (ordinalValueDegreeValuation K).componentOne := rfl + rw [hone, MaxAddDegree.componentOne_eq_componentMk] + simp only [pow_zero] + rw [principalComponentMk_eq_componentMk] + rfl + | succ i ih => + obtain ⟨hi, hstep⟩ := ih + have hbound : ordinalValue (b ^ (i + 1)) < ω^ ((i + 1) • beta + 1) := by + have h := ordinalValue_mul_lt_wpow_add_one hi hb + rwa [← pow_succ] at h + refine ⟨hbound, ?_⟩ + rw [pow_succ, hstep, DirectSum.of_mul_of] + congr 1 + rw [show (GradedMonoid.GMul.mul + (principalComponentMk (i • beta) (b ^ i) hi) + (principalComponentMk beta b hb)) = + principalComponentMul _ _ from + (principalComponentMul_eq_componentMul _ _).symm, + principalComponentMul_mk] + congr 1 + +omit [CharZero K] in +/-- A product of powers of two homogeneous classes is the class of the corresponding product of +representatives. -/ +theorem of_principalComponentMk_pow_mul_pow {beta : NatOrdinal} + (b c : Series K) (hb : ordinalValue b < ω^ (beta + 1)) (hc : ordinalValue c < ω^ (beta + 1)) + (i j : ℕ) : + ∃ h : ordinalValue (b ^ i * c ^ j) < ω^ (i • beta + j • beta + 1), + (DirectSum.of (PrincipalComponent K) beta (principalComponentMk beta b hb)) ^ i * + (DirectSum.of (PrincipalComponent K) beta (principalComponentMk beta c hc)) ^ j = + DirectSum.of (PrincipalComponent K) (i • beta + j • beta) + (principalComponentMk (i • beta + j • beta) (b ^ i * c ^ j) h) := by + obtain ⟨hi, hpi⟩ := of_principalComponentMk_pow b hb i + obtain ⟨hj, hpj⟩ := of_principalComponentMk_pow c hc j + refine ⟨ordinalValue_mul_lt_wpow_add_one hi hj, ?_⟩ + rw [hpi, hpj, DirectSum.of_mul_of] + congr 1 + rw [show (GradedMonoid.GMul.mul + (principalComponentMk (i • beta) (b ^ i) hi) + (principalComponentMk (j • beta) (c ^ j) hj)) = + principalComponentMul _ _ from + (principalComponentMul_eq_componentMul _ _).symm, + principalComponentMul_mk] + +omit [CharZero K] in +/-- The same statement with the grade presented in normalized form. -/ +theorem of_principalComponentMk_pow_mul_pow' {beta : NatOrdinal} + (b c : Series K) (hb : ordinalValue b < ω^ (beta + 1)) (hc : ordinalValue c < ω^ (beta + 1)) + (i j : ℕ) {p : NatOrdinal} (hp : i • beta + j • beta = p) : + ∃ h : ordinalValue (b ^ i * c ^ j) < ω^ (p + 1), + (DirectSum.of (PrincipalComponent K) beta (principalComponentMk beta b hb)) ^ i * + (DirectSum.of (PrincipalComponent K) beta (principalComponentMk beta c hc)) ^ j = + DirectSum.of (PrincipalComponent K) p + (principalComponentMk p (b ^ i * c ^ j) h) := by + subst hp + exact of_principalComponentMk_pow_mul_pow b c hb hc i j + +omit [CharZero K] in +/-- The class of a finite sum of representatives is the sum of the classes. -/ +theorem principalComponentMk_finsetSum {iota : Type*} + (s : Finset iota) (alpha : NatOrdinal) (u : iota → Series K) + (hu : ∀ i, ordinalValue (u i) < ω^ (alpha + 1)) + (hsum : ordinalValue (∑ i ∈ s, u i) < ω^ (alpha + 1)) : + ∑ i ∈ s, principalComponentMk alpha (u i) (hu i) = + principalComponentMk alpha (∑ i ∈ s, u i) hsum := by + classical + simp only [principalComponentMk_eq_componentMk] + rw [← map_sum] + congr 1 + apply Subtype.ext + rw [AddSubmonoidClass.coe_finsetSum] + +omit [CharZero K] in +/-- A finite sum of series each of ordinal value below a positive bound stays below that bound. -/ +theorem ordinalValue_finsetSum_lt {iota : Type*} (s : Finset iota) (u : iota → Series K) + {X : NatOrdinal} (hX : 0 < X) (hu : ∀ i ∈ s, ordinalValue (u i) < X) : + ordinalValue (∑ i ∈ s, u i) < X := by + classical + induction s using Finset.induction with + | empty => simpa using hX + | insert a t ha ih => + rw [Finset.sum_insert ha] + refine lt_of_le_of_lt (ordinalValue_add_le_max _ _) ?_ + exact max_lt (hu a (Finset.mem_insert_self a t)) + (ih fun i hi ↦ hu i (Finset.mem_insert_of_mem hi)) + +omit [CharZero K] in +/-- The relation among leading terms descends to a degree bound on the corresponding combination +of representatives. This is where the source argument's appeal to LM24, Lemma 4.2.5 is replaced +by the intrinsic homogeneous-component interface. -/ +theorem ordinalValue_relationSum_lt {beta : NatOrdinal} + {d : ℕ} (k : ℕ → K) (b c : Series K) + (hb : ordinalValue b < ω^ (beta + 1)) (hc : ordinalValue c < ω^ (beta + 1)) + (hrel : ∑ i ∈ Finset.range (d + 1), + algebraMap K (PrincipalSubring K) (k i) * + (DirectSum.of (PrincipalComponent K) beta (principalComponentMk beta b hb)) ^ i * + (DirectSum.of (PrincipalComponent K) beta (principalComponentMk beta c hc)) ^ (d - i) + = 0) : + ordinalValue (∑ i ∈ Finset.range (d + 1), + (HahnSeries.Nonpositive.C : K →+* Series K) (k i) * (b ^ i * c ^ (d - i))) < + ω^ (d • beta) := by + classical + have hterm : ∀ i ∈ Finset.range (d + 1), + ∃ h : ordinalValue ((HahnSeries.Nonpositive.C : K →+* Series K) (k i) * + (b ^ i * c ^ (d - i))) < ω^ (d • beta + 1), + algebraMap K (PrincipalSubring K) (k i) * + (DirectSum.of (PrincipalComponent K) beta (principalComponentMk beta b hb)) ^ i * + (DirectSum.of (PrincipalComponent K) beta (principalComponentMk beta c hc)) ^ (d - i) = + DirectSum.of (PrincipalComponent K) (d • beta) + (principalComponentMk (d • beta) + ((HahnSeries.Nonpositive.C : K →+* Series K) (k i) * (b ^ i * c ^ (d - i))) h) := by + intro i hi + have hile : i ≤ d := Nat.lt_succ_iff.mp (Finset.mem_range.mp hi) + have hp : i • beta + (d - i) • beta = d • beta := by + rw [← add_nsmul] + congr 1 + omega + obtain ⟨h1, e1⟩ := of_principalComponentMk_pow_mul_pow' b c hb hc i (d - i) hp + refine ⟨?_, ?_⟩ + · simpa only [zero_add] using + ordinalValue_mul_lt_wpow_add_one (ordinalValue_C_lt_wpow_one (k i)) h1 + · rw [mul_assoc, ← Algebra.smul_def, e1, ← DirectSum.of_smul K, smul_principalComponentMk] + have hupos : (0 : NatOrdinal) < ω^ (d • beta + 1) := + lt_of_lt_of_le zero_lt_one + (by rw [← NatOrdinal.wpow_zero]; exact NatOrdinal.wpow_le_wpow.mpr zero_le) + classical + set u : ℕ → Series K := fun i ↦ + if i ∈ Finset.range (d + 1) then + (HahnSeries.Nonpositive.C : K →+* Series K) (k i) * (b ^ i * c ^ (d - i)) else 0 with hu_def + have hu : ∀ i : ℕ, ordinalValue (u i) < ω^ (d • beta + 1) := by + intro i + by_cases hi : i ∈ Finset.range (d + 1) + · rw [hu_def] + simp only [hi, ite_true] + exact (hterm i hi).choose + · rw [hu_def] + simp only [hi, ite_false] + simp + have hu_eq : ∀ j ∈ Finset.range (d + 1), u j = + (HahnSeries.Nonpositive.C : K →+* Series K) (k j) * (b ^ j * c ^ (d - j)) := by + intro j hj + rw [hu_def] + simp only [hj, ite_true] + have hcongr : ∑ i ∈ Finset.range (d + 1), + (HahnSeries.Nonpositive.C : K →+* Series K) (k i) * (b ^ i * c ^ (d - i)) = + ∑ i ∈ Finset.range (d + 1), u i := + Finset.sum_congr rfl fun i hi ↦ (hu_eq i hi).symm + have hsum : ordinalValue (∑ i ∈ Finset.range (d + 1), u i) < ω^ (d • beta + 1) := + ordinalValue_finsetSum_lt _ _ hupos fun i _ ↦ hu i + rw [hcongr, ← principalComponentMk_eq_zero_iff (d • beta) _ hsum, + ← principalComponentMk_finsetSum (Finset.range (d + 1)) (d • beta) u hu hsum] + apply DirectSum.of_injective (d • beta) + rw [map_zero, map_sum, ← hrel] + refine Finset.sum_congr rfl fun i hi ↦ ?_ + obtain ⟨h, e⟩ := hterm i hi + rw [e] + congr 1 + rw [principalComponentMk_eq_iff, hu_eq i hi, sub_self] + simp + +omit [CharZero K] in +/-- The homogenized relation sum is the scaled-roots evaluation of the polynomial pushed along a +ring homomorphism out of the coefficient field. -/ +theorem eval_scaleRoots_map {R : Type*} [CommRing R] [Nontrivial R] (g : K →+* R) + (p : Polynomial K) (b c : R) : + Polynomial.eval b ((p.map g).scaleRoots c) = + ∑ i ∈ Finset.range (p.natDegree + 1), + g (p.coeff i) * (b ^ i * c ^ (p.natDegree - i)) := by + have hdeg : (p.map g).natDegree = p.natDegree := + Polynomial.natDegree_map_eq_of_injective g.injective p + rw [Polynomial.eval_eq_sum_range' (by + rw [Polynomial.natDegree_scaleRoots, hdeg] + exact Nat.lt_succ_self _)] + refine Finset.sum_congr rfl fun i _ ↦ ?_ + rw [Polynomial.coeff_scaleRoots, Polynomial.coeff_map, hdeg] + ring + +omit [CharZero K] in +/-- Coefficient extension carries the homogenized relation sum of a polynomial to that of the +extended polynomial. -/ +theorem map_relationSum {E : Type v} [Field E] (f : K →+* E) (p : Polynomial K) (b c : Series K) + (n : ℕ) : + nonpositiveCoefficientMap f + (∑ i ∈ Finset.range (n + 1), + (HahnSeries.Nonpositive.C : K →+* Series K) (p.coeff i) * (b ^ i * c ^ (n - i))) = + ∑ i ∈ Finset.range (n + 1), + (HahnSeries.Nonpositive.C : E →+* Series E) ((p.map f).coeff i) * + ((nonpositiveCoefficientMap f b) ^ i * (nonpositiveCoefficientMap f c) ^ (n - i)) := by + rw [map_sum] + refine Finset.sum_congr rfl fun i _ ↦ ?_ + rw [map_mul, map_mul, map_pow, map_pow, nonpositiveCoefficientMap_C, Polynomial.coeff_map] + +/-! ### Pigeonhole on the factor degrees -/ + +/-- If a product of ordinal-value-multiplicative factors has ordinal value below `ω ^ (n * beta)`, +where `n` is the number of factors, then some factor has ordinal value below `ω ^ beta`. -/ +theorem exists_ordinalValue_lt_of_prod_lt {E : Type v} [Field E] [CharZero E] + (s : Multiset (Series E)) (beta : NatOrdinal) + (h : ordinalValue s.prod < ω^ ((s.card : NatOrdinal) * beta)) : + ∃ u ∈ s, ordinalValue u < ω^ beta := by + by_contra hcon + simp only [not_exists, not_and, not_lt] at hcon + have key : ∀ t : Multiset (Series E), (∀ u ∈ t, ω^ beta ≤ ordinalValue u) → + ω^ ((t.card : NatOrdinal) * beta) ≤ ordinalValue t.prod := by + intro t + induction t using Multiset.induction with + | empty => intro _; simp [ordinalValue_one] + | cons a u ih => + intro hall + rw [Multiset.prod_cons, ordinalValueMultiplicative.ordinalValue_mul, Multiset.card_cons] + push_cast + rw [add_mul, one_mul, NatOrdinal.wpow_add, mul_comm] + exact mul_le_mul' (hall a (Multiset.mem_cons_self a u)) + (ih fun v hv ↦ hall v (Multiset.mem_cons_of_mem hv)) + exact absurd (key s hcon) (not_le.mpr h) + +/-! ### Rationality of a root read off a single exponent -/ + +/-- The single-exponent rationality step. If, after extending the coefficients along `f`, +subtracting `zeta` times `c` from `b` strictly lowers the ordinal value below that of `b`, then some +exponent must cancel, and at that exponent `zeta` is the ratio of a coefficient of `b` by a +coefficient of `c`. Hence `zeta` lies in the range of `f`. + +This is the step of the source argument that returns a root of the minimal polynomial from the +algebraic closure of the coefficient field to the coefficient field itself. -/ +theorem mem_range_of_ordinalValue_sub_C_mul_lt {K E : Type v} [Field K] [Field E] (f : K →+* E) + (b c : HahnSeries.Nonpositive ℝ K) (zeta : E) + (h : ordinalValue (nonpositiveCoefficientMap f b - + HahnSeries.Nonpositive.C zeta * nonpositiveCoefficientMap f c) < + ordinalValue (nonpositiveCoefficientMap f b)) : + zeta ∈ f.range := by + by_contra hzeta + refine absurd (ordinalValue_le_of_support_subset _ _ ?_) (not_le.mpr h) + intro x hx + rw [HahnSeries.mem_support] at hx ⊢ + rw [coe_nonpositiveCoefficientMap] at hx + intro hzero + apply hzeta + rw [AddSubgroupClass.coe_sub, HahnSeries.coeff_sub, Subring.coe_mul, + HahnSeries.Nonpositive.coe_C, HahnSeries.C_mul_eq_smul, HahnSeries.coeff_smul, + coe_nonpositiveCoefficientMap, coe_nonpositiveCoefficientMap, smul_eq_mul, + sub_eq_zero] at hzero + have hcx : f ((c : K⟦ℝ⟧).coeff x) ≠ 0 := by + intro hc0 + rw [hc0, mul_zero] at hzero + exact hx hzero + rw [RingHom.mem_range] + refine ⟨(b : K⟦ℝ⟧).coeff x / (c : K⟦ℝ⟧).coeff x, ?_⟩ + rw [map_div₀, hzero, mul_div_assoc, div_self hcx, mul_one] + +/-! ### A root in the coefficient field -/ + +/-- If the homogenized relation sum of a monic polynomial at two representatives has strictly +smaller degree than the product of the degrees, the polynomial already has a root in the +coefficient field. The source argument factors over the algebraic closure; the ordinal value is +multiplicative there because the multiplicativity theorem is field-polymorphic. -/ +theorem exists_isRoot_of_ordinalValue_relationSum_lt {beta : NatOrdinal} {d : ℕ} + (Q : Polynomial K) (hQ : Q.Monic) (hdeg : Q.natDegree = d) (b c : Series K) + (hbdeg : ω^ beta ≤ ordinalValue b) + (hlt : ordinalValue (∑ i ∈ Finset.range (d + 1), + (HahnSeries.Nonpositive.C : K →+* Series K) (Q.coeff i) * (b ^ i * c ^ (d - i))) < + ω^ (d • beta)) : + ∃ z : K, Q.IsRoot z := by + classical + set f : K →+* AlgebraicClosure K := algebraMap K (AlgebraicClosure K) with hf + have hQLmonic : (Q.map f).Monic := hQ.map f + have hQLdeg : (Q.map f).natDegree = d := by + rw [Polynomial.natDegree_map_eq_of_injective f.injective, hdeg] + have hsplits : Polynomial.Splits (Q.map f) := IsAlgClosed.splits _ + have hprod : Q.map f = ((Q.map f).roots.map fun z ↦ Polynomial.X - Polynomial.C z).prod := + hsplits.eq_prod_roots_of_monic hQLmonic + have hcard : (Q.map f).roots.card = d := by + rw [← hQLdeg] + exact Polynomial.splits_iff_card_roots.mp hsplits + have hsum_eq : nonpositiveCoefficientMap f + (∑ i ∈ Finset.range (d + 1), + (HahnSeries.Nonpositive.C : K →+* Series K) (Q.coeff i) * (b ^ i * c ^ (d - i))) = + ((Q.map f).roots.map fun z ↦ + nonpositiveCoefficientMap f b - + (HahnSeries.Nonpositive.C : AlgebraicClosure K →+* Series (AlgebraicClosure K)) z * + nonpositiveCoefficientMap f c).prod := by + rw [map_relationSum, ← hQLdeg, ← eval_scaleRoots_map] + conv_lhs => rw [hprod] + rw [Polynomial.map_multiset_prod, Multiset.map_map] + have hlin : ∀ z : AlgebraicClosure K, + ((fun q : Polynomial (AlgebraicClosure K) ↦ + q.map (HahnSeries.Nonpositive.C : AlgebraicClosure K →+* Series (AlgebraicClosure K))) + ∘ fun z ↦ Polynomial.X - Polynomial.C z) z = + Polynomial.X - Polynomial.C ((HahnSeries.Nonpositive.C : + AlgebraicClosure K →+* Series (AlgebraicClosure K)) z) := by + intro z + simp + rw [Multiset.map_congr rfl fun z _ ↦ hlin z] + rw [show (Multiset.map (fun z ↦ Polynomial.X - Polynomial.C + ((HahnSeries.Nonpositive.C : AlgebraicClosure K →+* Series (AlgebraicClosure K)) z)) + (Q.map f).roots) = + Multiset.map (fun w ↦ Polynomial.X - Polynomial.C w) + (Multiset.map (HahnSeries.Nonpositive.C : + AlgebraicClosure K →+* Series (AlgebraicClosure K)) (Q.map f).roots) from + by rw [Multiset.map_map]; rfl, + eval_scaleRoots_prod_X_sub_C, Multiset.map_map] + rfl + have hprodlt : ordinalValue (((Q.map f).roots.map fun z ↦ + nonpositiveCoefficientMap f b - + (HahnSeries.Nonpositive.C : AlgebraicClosure K →+* Series (AlgebraicClosure K)) z * + nonpositiveCoefficientMap f c).prod) < + ω^ ((((Q.map f).roots.map fun z ↦ + nonpositiveCoefficientMap f b - + (HahnSeries.Nonpositive.C : AlgebraicClosure K →+* Series (AlgebraicClosure K)) z * + nonpositiveCoefficientMap f c).card : NatOrdinal) * beta) := by + rw [← hsum_eq, ordinalValue_nonpositiveCoefficientMap, Multiset.card_map, hcard, + ← nsmul_eq_mul] + exact hlt + obtain ⟨w, hw_mem, hw_lt⟩ := exists_ordinalValue_lt_of_prod_lt _ beta hprodlt + obtain ⟨z, hz_mem, rfl⟩ := Multiset.mem_map.mp hw_mem + have hzrange : z ∈ f.range := by + refine mem_range_of_ordinalValue_sub_C_mul_lt f b c z (lt_of_lt_of_le hw_lt ?_) + rw [ordinalValue_nonpositiveCoefficientMap] + exact hbdeg + obtain ⟨z₀, hz₀⟩ := hzrange + refine ⟨z₀, ?_⟩ + have hroot : (Q.map f).IsRoot z := Polynomial.isRoot_of_mem_roots hz_mem + rw [Polynomial.IsRoot, Polynomial.eval_map, ← hz₀, Polynomial.eval₂_at_apply] at hroot + exact f.injective (by rw [hroot, map_zero]) + +/-! ### Clearing denominators -/ + +/-- The principal-subring algebra structure used locally when clearing denominators. -/ +local instance principalSubringFractionSelfAlgebraLocal : + Algebra (PrincipalSubring K) (PrincipalSubringFractionField K) := + principalSubringFractionSelfAlgebra K + +local instance principalSubringFractionIsFractionRingLocal : + IsFractionRing (PrincipalSubring K) (PrincipalSubringFractionField K) := + IsFractionRing.of_algEquiv (principalSubringFractionAlgEquiv K) + +/-- The coefficient-field algebra structure used locally when clearing denominators. -/ +local instance principalSubringFractionAlgebraLocal : + Algebra K (PrincipalSubringFractionField K) := + principalSubringFractionAlgebra K + +/-- Clearing denominators in an algebraic relation satisfied by a nonzero fraction. -/ +theorem exists_relation_of_aeval_eq_zero (Q : Polynomial K) + {x : PrincipalSubringFractionField K} (hQ : Polynomial.aeval x Q = 0) (hx0 : x ≠ 0) : + ∃ B C : PrincipalSubring K, B ≠ 0 ∧ C ≠ 0 ∧ + ∑ i ∈ Finset.range (Q.natDegree + 1), + algebraMap K (PrincipalSubring K) (Q.coeff i) * B ^ i * + C ^ (Q.natDegree - i) = 0 := by + have : IsScalarTower K (PrincipalSubring K) (PrincipalSubringFractionField K) := + principalSubringFraction_isScalarTower K + have hinj : Function.Injective + (algebraMap (PrincipalSubring K) (PrincipalSubringFractionField K)) := + IsFractionRing.injective _ _ + obtain ⟨⟨B, C⟩, hBC⟩ := + IsLocalization.surj (nonZeroDivisors (PrincipalSubring K)) x + have hCne : (C : PrincipalSubring K) ≠ 0 := nonZeroDivisors.coe_ne_zero C + have hmapC : algebraMap (PrincipalSubring K) (PrincipalSubringFractionField K) + (C : PrincipalSubring K) ≠ 0 := fun h ↦ hCne (hinj (by rw [h, map_zero])) + have hdiv : x = + algebraMap (PrincipalSubring K) (PrincipalSubringFractionField K) B / + algebraMap (PrincipalSubring K) (PrincipalSubringFractionField K) + (C : PrincipalSubring K) := + eq_div_of_mul_eq hmapC hBC + have hBne : B ≠ 0 := by + intro hB + exact hx0 (by rw [hdiv, hB, map_zero, zero_div]) + refine ⟨B, (C : PrincipalSubring K), hBne, hCne, ?_⟩ + have haeval : Polynomial.aeval + (algebraMap (PrincipalSubring K) (PrincipalSubringFractionField K) B / + algebraMap (PrincipalSubring K) (PrincipalSubringFractionField K) + (C : PrincipalSubring K)) + (Q.map (algebraMap K (PrincipalSubring K))) = 0 := by + rw [Polynomial.aeval_map_algebraMap, ← hdiv] + exact hQ + have hsr := Polynomial.scaleRoots_aeval_eq_zero_of_aeval_div_eq_zero hinj haeval C.2 + have hmapped : algebraMap (PrincipalSubring K) (PrincipalSubringFractionField K) + (Polynomial.eval B ((Q.map (algebraMap K (PrincipalSubring K))).scaleRoots + (C : PrincipalSubring K))) = 0 := by + rw [← hsr, Polynomial.aeval_def, Polynomial.eval₂_at_apply] + have heval : Polynomial.eval B ((Q.map (algebraMap K (PrincipalSubring K))).scaleRoots + (C : PrincipalSubring K)) = 0 := hinj (by rw [hmapped, map_zero]) + rw [eval_scaleRoots_map] at heval + rw [← heval] + refine Finset.sum_congr rfl fun i _ ↦ ?_ + ring + +/-! ### The minimal-polynomial bound -/ + +/-- LM24, Lemma 6.3.3: a nonzero element of the fraction field of `P̂` that +is algebraic over the coefficient field has minimal polynomial of degree at most one. -/ +theorem principalSubringFraction_minpoly_natDegree_le_one_of_ne_zero (x : + PrincipalSubringFractionField K) + (hx : IsAlgebraic K x) (hx0 : x ≠ 0) : + (minpoly K x).natDegree ≤ 1 := by + classical + have hint : IsIntegral K x := hx.isIntegral + have hQmonic : (minpoly K x).Monic := minpoly.monic hint + have hcd : (minpoly K x).coeff (minpoly K x).natDegree ≠ 0 := by + rw [hQmonic.coeff_natDegree] + exact one_ne_zero + obtain ⟨B, C, hB, hC, hrel⟩ := + exists_relation_of_aeval_eq_zero (minpoly K x) (minpoly.aeval K x) hx0 + have hgr := leadingGrade_eq_of_relation hB hC (fun i ↦ (minpoly K x).coeff i) hcd hrel + obtain ⟨m, hm, hBm⟩ := DirectSum.exists_grade_eq_leadingGrade (PrincipalComponent K) hB + have hCm : DirectSum.leadingGrade (PrincipalComponent K) C = (m : WithBot NatOrdinal) := by + rw [← hgr, hm] + obtain ⟨b, hb, hbeq⟩ := exists_principalComponentMk m (B m) + obtain ⟨c, hc, hceq⟩ := exists_principalComponentMk m (C m) + have hlead := sum_leadingTerm_eq_zero (fun i ↦ (minpoly K x).coeff i) hm hCm hrel + rw [← hbeq, ← hceq] at hlead + have hlt := ordinalValue_relationSum_lt (fun i ↦ (minpoly K x).coeff i) b c hb hc hlead + have hbdeg : ω^ m ≤ ordinalValue b := by + by_contra hcon + exact hBm (by rw [← hbeq, principalComponentMk_eq_zero_iff]; exact not_le.mp hcon) + obtain ⟨z, hz⟩ := + exists_isRoot_of_ordinalValue_relationSum_lt (minpoly K x) hQmonic rfl b c hbdeg hlt + obtain ⟨u, hu⟩ := Polynomial.dvd_iff_isRoot.mpr hz + rcases (minpoly.irreducible hint).isUnit_or_isUnit hu with hunit | hunit + · exact absurd hunit (Polynomial.not_isUnit_X_sub_C z) + · have hune : u ≠ 0 := hunit.ne_zero + rw [hu, Polynomial.natDegree_mul (Polynomial.X_sub_C_ne_zero z) hune, + Polynomial.natDegree_X_sub_C, Polynomial.natDegree_eq_zero_of_isUnit hunit] + +end + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/PrincipalSubringLocalization.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/PrincipalSubringLocalization.lean new file mode 100644 index 0000000000..5a1f2b796f --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/PrincipalSubringLocalization.lean @@ -0,0 +1,413 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalSubringFiniteSupport +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalSubringTensor +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.FiniteSupportScalarTensor + +import Mathlib.RingTheory.TensorProduct.Maps +import Mathlib.RingTheory.Flat.Domain + +/-! +# Localization of the degree-graded ring + +Let `P̂` be the subring of principal elements and let `RV̂` be the degree-graded ring. +Using the tensor decomposition `RV̂ ≃ P̂ ⊗[K] K(ℝ^{≤ 0})`, extension of the principal +factor to `Frac(P̂)` gives the canonical map + +`RV̂ → Frac(P̂)(ℝ^{≤ 0})`. + +The two evaluation theorems identify its restrictions to the finite-support and principal graded +factors. They are the concrete form of the localization identification used in LM24, Corollary +6.3.6. +-/ + +open scoped HahnSeries TensorProduct + +universe v + +namespace Berarducci + +public noncomputable section + +open HahnSeries.Nonpositive + +variable {K : Type v} [Field K] [CharZero K] + +/-- The coefficient-field algebra structure on principal-subring fractions used in localization. -/ +local instance principalSubringFractionAlgebraLocalization : + Algebra K (PrincipalSubringFractionField K) := + principalSubringFractionAlgebra K + +variable (K) in +/-- Extend the principal factor of `P̂ ⊗[K] K(ℝ^{≤ 0})` to `Frac(P̂)` while leaving the +finite-support factor unchanged. -/ +def principalSubringTensorToFractionTensor : + PrincipalSubring K ⊗[K] FiniteSupportRing (K := K) →ₐ[K] + PrincipalSubringFractionField K ⊗[K] FiniteSupportRing (K := K) := by + letI : Algebra (PrincipalSubring K) + (PrincipalSubringFractionField K) := + principalSubringFractionSelfAlgebra K + letI : IsScalarTower K (PrincipalSubring K) + (PrincipalSubringFractionField K) := + principalSubringFraction_isScalarTower K + exact Algebra.TensorProduct.map + (IsScalarTower.toAlgHom K (PrincipalSubring K) + (PrincipalSubringFractionField K)) + (AlgHom.id K (FiniteSupportRing (K := K))) + +/-- Extension of the principal tensor factor sends a pure tensor to the tensor of the canonical +fraction-field image and the unchanged finite-support factor. -/ +@[simp] +theorem principalSubringTensorToFractionTensor_tmul + (x : PrincipalSubring K) (p : FiniteSupportRing (K := K)) : + principalSubringTensorToFractionTensor K (x ⊗ₜ p) = + principalSubringToFraction K x ⊗ₜ p := by + rw [principalSubringTensorToFractionTensor, Algebra.TensorProduct.map_tmul] + congr 1 + exact (principalSubringToFraction_apply x).symm + +variable (K) in +/-- The canonical map from the degree-graded ring `RV̂` to finite-support series over +`Frac(P̂)`. -/ +def principalSubringLocalizationMap : + DegreeGraded K →+* + PrincipalSubringFractionFiniteSupportRing K := by + let e := HahnSeries.Nonpositive.finiteSupportScalarTensorEquiv + (G := ℝ) (K := K) (L := PrincipalSubringFractionField K) + let f := principalSubringTensorToFractionTensor K + let g := (principalSubringTensorEquiv K).symm + exact e.toRingEquiv.toRingHom.comp (f.toRingHom.comp g.toRingEquiv.toRingHom) + +/-- The graded localization map is the composite of the inverse tensor decomposition, extension +of the principal factor to its fraction field, and finite-support scalar base change. -/ +theorem principalSubringLocalizationMap_apply (x : DegreeGraded K) : + principalSubringLocalizationMap K x = + HahnSeries.Nonpositive.finiteSupportScalarTensorEquiv + (G := ℝ) (K := K) (L := PrincipalSubringFractionField K) + (principalSubringTensorToFractionTensor K + ((principalSubringTensorEquiv K).symm x)) := + (rfl) + +/-- The graded localization map restricts to coefficientwise scalar extension on the +finite-support factor. -/ +theorem principalSubringLocalizationMap_finiteSupport (p : FiniteSupportRing (K := K)) : + principalSubringLocalizationMap K + (finiteSupportGradedEmbedding K p) = + principalSubringFractionScalarExtension K p := by + rw [principalSubringLocalizationMap_apply, + principalSubringTensorEquiv_symm_finiteSupportGradedEmbedding, + principalSubringTensorToFractionTensor_tmul, + HahnSeries.Nonpositive.finiteSupportScalarTensorEquiv_tmul] + rw [(principalSubringToFraction K).map_one, + (HahnSeries.Nonpositive.finiteSupportScalarHom + (G := ℝ) (K := PrincipalSubringFractionField K)).map_one, + one_mul] + apply HahnSeries.Nonpositive.finiteSupportFinsuppEquiv.injective + ext g + rw [HahnSeries.Nonpositive.finiteSupportFinsuppEquiv_apply, + HahnSeries.Nonpositive.finiteSupportFinsuppEquiv_apply] + rw [HahnSeries.Nonpositive.finiteSupportScalarExtension_coeff, + principalSubringFractionScalarExtension_coeff] + rw [principalSubringFraction_algebraMap_apply, + principalSubringFractionCoefficientMap_apply] + +/-- The graded localization map sends the principal factor to the corresponding constant series +over `Frac(P̂)`. -/ +@[simp] +theorem principalSubringLocalizationMap_principal (x : PrincipalSubring K) : + principalSubringLocalizationMap K + (principalSubringEmbedding K x) = + HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℝ) + (principalSubringToFraction K x) := by + rw [principalSubringLocalizationMap_apply, + principalSubringTensorEquiv_symm_principalGradedEmbedding, + principalSubringTensorToFractionTensor_tmul, + HahnSeries.Nonpositive.finiteSupportScalarTensorEquiv_tmul] + change HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℝ) + (principalSubringToFraction K x) * + HahnSeries.Nonpositive.finiteSupportScalarExtension 1 = _ + rw [map_one, mul_one] + +variable (K) in +/-- The submonoid of nonzero principal graded factors inverted by the graded localization map. -/ +def principalSubringDenominators : + Submonoid (DegreeGraded K) := + (nonZeroDivisors (PrincipalSubring K)).map + (principalSubringEmbedding K).toRingHom + +/-- A graded element is a localization denominator exactly when it is the image of a nonzero +principal graded element. -/ +theorem mem_principalGradedDenominators_iff (x : DegreeGraded K) : + x ∈ principalSubringDenominators K ↔ + ∃ y : PrincipalSubring K, + y ≠ 0 ∧ principalSubringEmbedding K y = x := by + rw [principalSubringDenominators] + constructor + · rintro ⟨y, hy, rfl⟩ + exact ⟨y, (mem_nonZeroDivisors_iff_ne_zero.mp hy), rfl⟩ + · rintro ⟨y, hy, rfl⟩ + exact ⟨y, mem_nonZeroDivisors_iff_ne_zero.mpr hy, rfl⟩ + +/-- The canonical algebra structure induced by the graded localization map. -/ +noncomputable instance principalSubringLocalizationAlgebra : + Algebra (DegreeGraded K) + (PrincipalSubringFractionFiniteSupportRing K) := + (principalSubringLocalizationMap K).toAlgebra + +/-- The algebra map of the graded localization is the explicitly constructed localization map. -/ +@[simp] +theorem principalSubringLocalization_algebraMap_apply (x : DegreeGraded K) : + algebraMap (DegreeGraded K) + (PrincipalSubringFractionFiniteSupportRing K) x = + principalSubringLocalizationMap K x := + (rfl) + +variable (K) in +private abbrev PrincipalTensor := + PrincipalSubring K ⊗[K] FiniteSupportRing (K := K) + +variable (K) in +private abbrev FractionTensor := + PrincipalSubringFractionField K ⊗[K] FiniteSupportRing (K := K) + +/-- The principal-subring algebra structure on its fraction field used in tensor localization. -/ +local instance principalSubringFractionSelfAlgebraLocalization : + Algebra (PrincipalSubring K) (PrincipalSubringFractionField K) := + principalSubringFractionSelfAlgebra K + +local instance principalSubringFractionScalarTowerLocalization : + IsScalarTower K (PrincipalSubring K) + (PrincipalSubringFractionField K) := + principalSubringFraction_isScalarTower K + +local instance principalSubringFractionIsLocalizationLocalization : + IsFractionRing (PrincipalSubring K) + (PrincipalSubringFractionField K) := + IsFractionRing.of_algEquiv (principalSubringFractionAlgEquiv K) + +attribute [local instance 1100] Module.Free.of_divisionRing Module.Flat.of_free in +variable (K) in +/-- Extending the principal tensor factor to `Frac(P̂)` is injective. -/ +theorem principalSubringTensorToFractionTensor_injective : + Function.Injective (principalSubringTensorToFractionTensor K) := by + change Function.Injective + (TensorProduct.map + (IsScalarTower.toAlgHom K (PrincipalSubring K) + (PrincipalSubringFractionField K)).toLinearMap + (AlgHom.id K (FiniteSupportRing (K := K))).toLinearMap) + apply TensorProduct.map_injective_of_flat_flat + · intro x y hxy + apply principalSubringToFraction_injective K + calc + principalSubringToFraction K x = + (IsScalarTower.toAlgHom K (PrincipalSubring K) + (PrincipalSubringFractionField K)) x := + principalSubringToFraction_apply x + _ = (IsScalarTower.toAlgHom K (PrincipalSubring K) + (PrincipalSubringFractionField K)) y := hxy + _ = principalSubringToFraction K y := + (principalSubringToFraction_apply y).symm + · exact Function.injective_id + +/-- The canonical map from the degree-graded ring `RV̂` to its principal localization is +injective. -/ +theorem principalSubringLocalizationMap_injective {x y : DegreeGraded K} + (hxy : principalSubringLocalizationMap K x = + principalSubringLocalizationMap K y) : + x = y := by + apply (principalSubringTensorEquiv K).symm.injective + apply principalSubringTensorToFractionTensor_injective K + apply (HahnSeries.Nonpositive.finiteSupportScalarTensorEquiv + (G := ℝ) (K := K) (L := PrincipalSubringFractionField K)).injective + calc + _ = principalSubringLocalizationMap K x := + (principalSubringLocalizationMap_apply x).symm + _ = principalSubringLocalizationMap K y := hxy + _ = _ := principalSubringLocalizationMap_apply y + +private instance principalTensorFractionTensorAlgebra : + Algebra (PrincipalTensor K) (FractionTensor K) := + (principalSubringTensorToFractionTensor K).toAlgebra + +private instance principalTensorPrincipalAlgebra : + Algebra (PrincipalSubring K) (PrincipalTensor K) := + inferInstance + +private instance fractionTensorPrincipalAlgebra : + Algebra (PrincipalSubring K) (FractionTensor K) := + inferInstance + +private instance principalTensorPrincipalSMul : + SMul (PrincipalSubring K) (PrincipalTensor K) := + principalTensorPrincipalAlgebra.toSMul + +private instance fractionTensorPrincipalSMul : + SMul (PrincipalSubring K) (FractionTensor K) := + fractionTensorPrincipalAlgebra.toSMul + +private instance principalTensorFractionTensorTower : + IsScalarTower (PrincipalSubring K) + (PrincipalTensor K) (FractionTensor K) := by + apply IsScalarTower.of_algebraMap_eq + intro x + change principalSubringTensorToFractionTensor K + (algebraMap (PrincipalSubring K) (PrincipalTensor K) x) = + algebraMap (PrincipalSubring K) (FractionTensor K) x + change principalSubringTensorToFractionTensor K (x ⊗ₜ 1) = _ + rw [principalSubringTensorToFractionTensor_tmul] + simp + +variable (K) in +private def principalTensorDenominators : Submonoid (PrincipalTensor K) := + Algebra.algebraMapSubmonoid (PrincipalTensor K) + (nonZeroDivisors (PrincipalSubring K)) + +private instance fractionTensorIsLocalization : + IsLocalization (principalTensorDenominators K) (FractionTensor K) := by + apply IsLocalization.tensorProduct_tensorProduct K + (FiniteSupportRing (K := K)) + (nonZeroDivisors (PrincipalSubring K)) + (PrincipalSubringFractionField K) + ext p + change principalSubringTensorToFractionTensor K (1 ⊗ₜ p) = 1 ⊗ₜ p + rw [principalSubringTensorToFractionTensor_tmul] + simp + +variable (K) in +private theorem principalSubringDenominators_eq_map : + principalSubringDenominators K = + (principalTensorDenominators K).map + (principalSubringTensorEquiv K).toRingEquiv.toMonoidHom := by + ext z + constructor + · rintro ⟨x, hx, rfl⟩ + refine ⟨algebraMap (PrincipalSubring K) (PrincipalTensor K) x, ?_, ?_⟩ + · exact ⟨x, hx, rfl⟩ + · change principalSubringTensorEquiv K (x ⊗ₜ 1) = + principalSubringEmbedding K x + exact principalSubringTensorEquiv_tmul_one x + · rintro ⟨_, ⟨x, hx, rfl⟩, rfl⟩ + refine ⟨x, hx, ?_⟩ + change principalSubringEmbedding K x = + principalSubringTensorEquiv K (x ⊗ₜ 1) + exact (principalSubringTensorEquiv_tmul_one x).symm + +private instance gradedFractionTensorAlgebra : + Algebra (DegreeGraded K) (FractionTensor K) := + ((algebraMap (PrincipalTensor K) (FractionTensor K)).comp + (principalSubringTensorEquiv K).symm.toRingEquiv.toRingHom).toAlgebra + +private instance gradedFractionTensorIsLocalization : + IsLocalization (principalSubringDenominators K) (FractionTensor K) := by + rw [principalSubringDenominators_eq_map] + exact IsLocalization.isLocalization_of_base_ringEquiv + (principalTensorDenominators K) (FractionTensor K) + (principalSubringTensorEquiv K).toRingEquiv + +variable (K) in +private def fractionTensorFiniteSupportAlgEquiv : + FractionTensor K ≃ₐ[DegreeGraded K] + PrincipalSubringFractionFiniteSupportRing K where + toRingEquiv := + (HahnSeries.Nonpositive.finiteSupportScalarTensorEquiv + (G := ℝ) (K := K) (L := PrincipalSubringFractionField K)).toRingEquiv + commutes' _ := rfl + +/-- Finite-support series over `Frac(P̂)` are the localization of the degree-graded ring `RV̂` at +the nonzero principal graded factors. -/ +noncomputable instance principalSubringLocalizationIsLocalization : + IsLocalization (principalSubringDenominators K) + (PrincipalSubringFractionFiniteSupportRing K) := + IsLocalization.isLocalization_of_algEquiv + (principalSubringDenominators K) + (fractionTensorFiniteSupportAlgEquiv K) + +/-- Every element of the graded localization has a numerator in `RV̂` and a nonzero principal +graded denominator. The equation is the denominator-cleared form of `z = x / d`. -/ +theorem principalSubringLocalization_exists_mul_principalDenominator + (z : PrincipalSubringFractionFiniteSupportRing K) : + ∃ x : DegreeGraded K, + ∃ d : PrincipalSubring K, + d ≠ 0 ∧ + z * principalSubringLocalizationMap K + (principalSubringEmbedding K d) = + principalSubringLocalizationMap K x := by + obtain ⟨⟨x, s⟩, hs⟩ := + IsLocalization.surj (principalSubringDenominators K) z + obtain ⟨d, hd, hds⟩ := + (mem_principalGradedDenominators_iff (s : DegreeGraded K)).mp s.2 + refine ⟨x, d, hd, ?_⟩ + rw [hds] + simpa only [principalSubringLocalization_algebraMap_apply] using hs + +/-- A localized divisibility relation by an embedded finite-support series can be cleared by a +nonzero principal graded denominator. -/ +theorem principalSubringLocalization_exists_finiteSupport_dvd_mul_principal + {p : FiniteSupportRing (K := K)} + {B : DegreeGraded K} + (hp : principalSubringFractionScalarExtension K p ∣ + principalSubringLocalizationMap K B) : + ∃ X : DegreeGraded K, + ∃ d : PrincipalSubring K, + d ≠ 0 ∧ + B * principalSubringEmbedding K d = + finiteSupportGradedEmbedding K p * X := by + obtain ⟨z, hz⟩ := hp + obtain ⟨X, d, hd, hclear⟩ := + principalSubringLocalization_exists_mul_principalDenominator z + refine ⟨X, d, hd, ?_⟩ + apply principalSubringLocalizationMap_injective + calc + principalSubringLocalizationMap K + (B * principalSubringEmbedding K d) = + principalSubringLocalizationMap K B * + principalSubringLocalizationMap K + (principalSubringEmbedding K d) := + (principalSubringLocalizationMap K).map_mul _ _ + _ = (principalSubringFractionScalarExtension K p * z) * + principalSubringLocalizationMap K + (principalSubringEmbedding K d) := by + rw [hz] + _ = principalSubringFractionScalarExtension K p * + (z * principalSubringLocalizationMap K + (principalSubringEmbedding K d)) := + mul_assoc _ _ _ + _ = principalSubringFractionScalarExtension K p * + principalSubringLocalizationMap K X := by + rw [hclear] + _ = principalSubringLocalizationMap K + (finiteSupportGradedEmbedding K p) * + principalSubringLocalizationMap K X := by + rw [principalSubringLocalizationMap_finiteSupport] + _ = principalSubringLocalizationMap K + (finiteSupportGradedEmbedding K p * X) := + ((principalSubringLocalizationMap K).map_mul _ _).symm + +/-- The graded localization map preserves divisibility by an embedded finite-support series. -/ +theorem principalSubringLocalizationMap_finiteSupport_dvd {p : FiniteSupportRing (K := K)} + {B : DegreeGraded K} + (hp : finiteSupportGradedEmbedding K p ∣ B) : + principalSubringFractionScalarExtension K p ∣ + principalSubringLocalizationMap K B := by + simpa only [principalSubringLocalizationMap_finiteSupport] using + map_dvd (principalSubringLocalizationMap K) hp + +/-- The localization image of an embedded finite-support divisor of a product divides the +product of the two localization images. -/ +theorem principalSubringLocalizationMap_finiteSupport_dvd_mul {p : FiniteSupportRing (K := K)} + {B C : DegreeGraded K} + (hp : finiteSupportGradedEmbedding K p ∣ B * C) : + principalSubringFractionScalarExtension K p ∣ + principalSubringLocalizationMap K B * + principalSubringLocalizationMap K C := by + simpa only [(principalSubringLocalizationMap K).map_mul] using + principalSubringLocalizationMap_finiteSupport_dvd hp + +end + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/PrincipalSubringMonoidAlgebra.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/PrincipalSubringMonoidAlgebra.lean new file mode 100644 index 0000000000..8d56326648 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/PrincipalSubringMonoidAlgebra.lean @@ -0,0 +1,191 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalSubringTensor +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.FiniteSupportMonoidAlgebra + +import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MonoidAlgebra.SingleZeroFactors +import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.AssociatedGradedDivisibility +import Mathlib.Algebra.Algebra.Tower +import Mathlib.RingTheory.TensorProduct.MonoidAlgebra + +/-! +# The degree-graded ring as a monoid algebra + +LM24, Proposition 6.1.2 identifies the degree-graded ring with the tensor product of +`P̂` and the finite-support Hahn-series ring. Combining that identification +with the canonical monoid-algebra presentation of finite-support Hahn series presents the full +graded ring as a finite-support monoid algebra over `P̂`. + +Under this presentation, the principal graded subring consists precisely of the terms supported +at exponent zero. Therefore, if a product of two nonzero graded elements lies in the principal +graded subring, then both factors lie there. This is the algebraic step used in LM24, +Corollary 6.2.2. +-/ + +open scoped DirectSum HahnSeries NatOrdinal TensorProduct + +universe v + +namespace Berarducci + +public noncomputable section + +variable {K : Type v} [Field K] [CharZero K] + +variable (K) in +/-- The canonical monoid-algebra presentation of the degree-graded ring. -/ +def degreeGradedEquivPrincipalMonoidAlgebra : + DegreeGraded K ≃ₐ[K] + AddMonoidAlgebra (PrincipalSubring K) + (HahnSeries.Nonpositive.exponentMonoid ℝ) := + (principalSubringTensorEquiv K).symm |>.trans + (Algebra.TensorProduct.congr AlgEquiv.refl + HahnSeries.Nonpositive.finiteSupportAddMonoidAlgebraEquiv) |>.trans + ((AddMonoidAlgebra.scalarTensorEquiv K (PrincipalSubring K) + (M := HahnSeries.Nonpositive.exponentMonoid ℝ)).restrictScalars K) + +/-- A principal graded element corresponds to a term supported at exponent zero. -/ +@[simp] +theorem degreeGradedEquivPrincipalMonoidAlgebra_principal + (x : PrincipalSubring K) : + degreeGradedEquivPrincipalMonoidAlgebra K + (principalSubringEmbedding K x) = + AddMonoidAlgebra.single 0 x := by + have htensor : + (principalSubringTensorEquiv K).symm + (principalSubringEmbedding K x) = + x ⊗ₜ (1 : FiniteSupportRing (K := K)) := by + apply (principalSubringTensorEquiv K).injective + rw [(principalSubringTensorEquiv K).apply_symm_apply] + rw [principalSubringTensorEquiv_tmul] + rw [map_one, mul_one] + rw [degreeGradedEquivPrincipalMonoidAlgebra, + AlgEquiv.trans_apply, AlgEquiv.trans_apply, htensor] + simp only [Algebra.TensorProduct.congr_apply, AlgEquiv.refl_toAlgHom, + Algebra.TensorProduct.map_tmul, AlgHom.coe_id, id_eq, map_one, + AlgEquiv.coe_restrictScalars, AddMonoidAlgebra.scalarTensorEquiv_tmul] + rw [AddMonoidAlgebra.one_def, AddMonoidAlgebra.smul_single', mul_one] + +variable (K) in +/-- A finite-support Hahn monomial corresponds to the same exponent with coefficient one. -/ +theorem degreeGradedEquivPrincipalMonoidAlgebra_finiteSupportMonomial + (g : HahnSeries.Nonpositive.exponentMonoid ℝ) : + degreeGradedEquivPrincipalMonoidAlgebra K + (finiteSupportGradedEmbedding K + (HahnSeries.Nonpositive.finiteSupportMonomial (K := K) g)) = + AddMonoidAlgebra.single g 1 := by + have htensor : + (principalSubringTensorEquiv K).symm + (finiteSupportGradedEmbedding K + (HahnSeries.Nonpositive.finiteSupportMonomial (K := K) g)) = + (1 : PrincipalSubring K) ⊗ₜ + HahnSeries.Nonpositive.finiteSupportMonomial (K := K) g := by + apply (principalSubringTensorEquiv K).injective + rw [(principalSubringTensorEquiv K).apply_symm_apply] + rw [principalSubringTensorEquiv_tmul] + rw [map_one, one_mul] + rw [degreeGradedEquivPrincipalMonoidAlgebra, + AlgEquiv.trans_apply, AlgEquiv.trans_apply, htensor] + simp only [Algebra.TensorProduct.congr_apply, AlgEquiv.refl_toAlgHom, + Algebra.TensorProduct.map_tmul, AlgEquiv.coe_toAlgHom, + HahnSeries.Nonpositive.finiteSupportAddMonoidAlgebraEquiv_monomial, + AlgEquiv.coe_restrictScalars, AddMonoidAlgebra.scalarTensorEquiv_tmul, + AddMonoidAlgebra.mapAlgHom_single, map_one, one_smul] + +/-- A principal coefficient multiplied by a finite-support Hahn monomial corresponds to a +single formal monomial. -/ +theorem degreeGradedEquivPrincipalMonoidAlgebra_principal_monomial + (x : PrincipalSubring K) + (g : HahnSeries.Nonpositive.exponentMonoid ℝ) : + degreeGradedEquivPrincipalMonoidAlgebra K + (principalSubringEmbedding K x * + finiteSupportGradedEmbedding K + (HahnSeries.Nonpositive.finiteSupportMonomial (K := K) g)) = + AddMonoidAlgebra.single g x := by + rw [map_mul, + degreeGradedEquivPrincipalMonoidAlgebra_principal, + degreeGradedEquivPrincipalMonoidAlgebra_finiteSupportMonomial] + rw [AddMonoidAlgebra.single_mul_single, zero_add, mul_one] + +/-- The inverse presentation sends one formal monomial to the corresponding product of the +principal coefficient and finite-support Hahn monomial. -/ +@[simp] +theorem degreeGradedEquivPrincipalMonoidAlgebra_symm_single + (g : HahnSeries.Nonpositive.exponentMonoid ℝ) + (x : PrincipalSubring K) : + (degreeGradedEquivPrincipalMonoidAlgebra K).symm + (AddMonoidAlgebra.single g x) = + principalSubringEmbedding K x * + finiteSupportGradedEmbedding K + (HahnSeries.Nonpositive.finiteSupportMonomial (K := K) g) := by + apply (degreeGradedEquivPrincipalMonoidAlgebra K).injective + rw [(degreeGradedEquivPrincipalMonoidAlgebra K).apply_symm_apply] + exact (degreeGradedEquivPrincipalMonoidAlgebra_principal_monomial x g).symm + +/-- Nonzero factors of an element of the principal graded subalgebra lie in that subalgebra. -/ +theorem factors_mem_principalGradedSubalgebra_of_mul_mem {B C : DegreeGraded K} + (hB : B ≠ 0) (hC : C ≠ 0) + (hBC : B * C ∈ principalSubringSubalgebra K) : + B ∈ principalSubringSubalgebra K ∧ + C ∈ principalSubringSubalgebra K := by + let eP := principalSubringEquivSubalgebra K + let BC : principalSubringSubalgebra K := ⟨B * C, hBC⟩ + let x := eP.symm BC + have hx : principalSubringEmbedding K x = B * C := by + calc + principalSubringEmbedding K x = (eP x : DegreeGraded K) := + (principalSubringEquivSubalgebra_apply x).symm + _ = B * C := congrArg Subtype.val (eP.apply_symm_apply BC) + let e := degreeGradedEquivPrincipalMonoidAlgebra K + have hProduct : e B * e C = AddMonoidAlgebra.single 0 x := by + calc + e B * e C = e (B * C) := (e.map_mul B C).symm + _ = e (principalSubringEmbedding K x) := congrArg e hx.symm + _ = AddMonoidAlgebra.single 0 x := by + change degreeGradedEquivPrincipalMonoidAlgebra K + (principalSubringEmbedding K x) = _ + exact degreeGradedEquivPrincipalMonoidAlgebra_principal x + have heB : e B ≠ 0 := fun h ↦ hB (e.injective (h.trans (map_zero e).symm)) + have heC : e C ≠ 0 := fun h ↦ hC (e.injective (h.trans (map_zero e).symm)) + obtain ⟨b, c, hb, hc⟩ := + AddMonoidAlgebra.exists_eq_single_zero_of_mul_eq_single_zero + (R := PrincipalSubring K) + (M := HahnSeries.Nonpositive.exponentMonoid ℝ) + (HahnSeries.Nonpositive.exponentMonoid_top_eq_zero ℝ) + heB heC hProduct + constructor + · have hB_eq : principalSubringEmbedding K b = B := by + apply e.injective + calc + e (principalSubringEmbedding K b) = + AddMonoidAlgebra.single 0 b := by + change degreeGradedEquivPrincipalMonoidAlgebra K + (principalSubringEmbedding K b) = _ + exact degreeGradedEquivPrincipalMonoidAlgebra_principal b + _ = e B := hb.symm + rw [← hB_eq, mem_principalGradedSubalgebra_iff, isPrincipalGraded_iff] + intro α + rw [principalSubringEmbedding_apply] + exact principalComponentToHahnDegreeLayer_isPrincipal α (b α) + · have hC_eq : principalSubringEmbedding K c = C := by + apply e.injective + calc + e (principalSubringEmbedding K c) = + AddMonoidAlgebra.single 0 c := by + change degreeGradedEquivPrincipalMonoidAlgebra K + (principalSubringEmbedding K c) = _ + exact degreeGradedEquivPrincipalMonoidAlgebra_principal c + _ = e C := hc.symm + rw [← hC_eq, mem_principalGradedSubalgebra_iff, isPrincipalGraded_iff] + intro α + rw [principalSubringEmbedding_apply] + exact principalComponentToHahnDegreeLayer_isPrincipal α (c α) + +end + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/PrincipalSubringScalarRedistributionProof.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/PrincipalSubringScalarRedistributionProof.lean new file mode 100644 index 0000000000..2a4d19527b --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/PrincipalSubringScalarRedistributionProof.lean @@ -0,0 +1,233 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalSubringFiniteSupport +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.FiniteSupportGCDProof +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.FactorCoefficients +public import LeanPool.ConwayRefinement.ConwayRefinement.FieldTheory.RelativeAlgebraicClosure + +/-! +# Redistributing a coefficient between two finite-support factors + +Two series with finite support have finitely many exponents between them, so both are supported +in the subgroup those exponents generate. That subgroup is finitely generated and torsion-free, +hence free of finite rank, and its group ring over a field therefore has unique factorisation. + +This file records the passage from a pair of finite-support series to such a common subgroup, +which is the setting in which the redistribution argument factors a product. +-/ + +universe u v + +namespace Berarducci + +public noncomputable section + +/-- Two finite-support series lie in the group ring of a common finitely generated subgroup of +the exponent group, and that group ring has unique factorisation. -/ +theorem exists_common_subgroup_uniqueFactorization {G : Type u} {L : Type v} [LinearOrder G] + [AddCommGroup G] [IsOrderedAddMonoid G] [Field L] (p q : HahnSeries G L) + (hp : p.support.Finite) (hq : q.support.Finite) : + ∃ H : AddSubgroup G, UniqueFactorizationMonoid (AddMonoidAlgebra L H) ∧ + p.support ⊆ (H : Set G) ∧ q.support ⊆ (H : Set G) := by + classical + refine ⟨AddSubgroup.closure ((hp.toFinset ∪ hq.toFinset : Finset G) : Set G), + HahnSeries.uniqueFactorizationMonoid_subgroupAlgebra + (HahnSeries.exists_addEquiv_fin (hp.toFinset ∪ hq.toFinset)), ?_, ?_⟩ + · exact fun x hx ↦ AddSubgroup.subset_closure + (Finset.mem_coe.mpr (Finset.mem_union_left _ (hp.mem_toFinset.mpr hx))) + · exact fun x hx ↦ AddSubgroup.subset_closure + (Finset.mem_coe.mpr (Finset.mem_union_right _ (hq.mem_toFinset.mpr hx))) + +section Redistribution + +variable {K : Type v} [Field K] [CharZero K] + +/-- The coefficient-field algebra structure on principal-subring fractions used for scalar +redistribution. -/ +local instance algLocal : + Algebra K (PrincipalSubringFractionField K) := principalSubringFractionAlgebra K + +/-- Multiplying a finite-support series by a constant scales every coefficient. -/ +theorem coeff_mul_finiteSupportScalarHom {L : Type*} [Field L] + (p : HahnSeries.Nonpositive.FiniteSupportRing (G := ℝ) (K := L)) (c : L) (x : ℝ) : + ((((p * HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℝ) c : + HahnSeries.Nonpositive.FiniteSupportRing (G := ℝ) (K := L)) : + HahnSeries.Nonpositive ℝ L) : HahnSeries ℝ L)).coeff x = + ((((p : HahnSeries.Nonpositive ℝ L) : HahnSeries ℝ L)).coeff x) * c := by + have h1 : (((p * HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℝ) c : + HahnSeries.Nonpositive.FiniteSupportRing (G := ℝ) (K := L)) : + HahnSeries.Nonpositive ℝ L) : HahnSeries ℝ L) = + (((p : HahnSeries.Nonpositive ℝ L) : HahnSeries ℝ L)) * HahnSeries.C c := by + rw [Subring.coe_mul, Subring.coe_mul, + HahnSeries.Nonpositive.coe_finiteSupportScalarHom (G := ℝ) (K := L) c] + rw [h1, mul_comm, HahnSeries.C_mul_eq_smul, HahnSeries.coeff_smul, smul_eq_mul, mul_comm] + +omit [CharZero K] in +/-- Coefficient extension of finite-support series is coefficientwise on Hahn series. -/ +theorem coe_finiteSupportMap {L : Type*} [Field L] (f : K →+* L) + (b : HahnSeries.Nonpositive.FiniteSupportRing (G := ℝ) (K := K)) : + (((HahnSeries.Nonpositive.finiteSupportMap (G := ℝ) f b : + HahnSeries.Nonpositive ℝ L) : HahnSeries ℝ L)) = + (((b : HahnSeries.Nonpositive ℝ K) : HahnSeries ℝ K)).map f := by + refine HahnSeries.coeff_injective (funext fun x ↦ ?_) + rw [HahnSeries.map_coeff] + rcases le_or_gt x 0 with hx | hx + · have h1 := HahnSeries.Nonpositive.finiteSupportMap_coeff (G := ℝ) f b ⟨x, hx⟩ + rw [HahnSeries.Nonpositive.finiteSupportCoefficients_apply, + HahnSeries.Nonpositive.finiteSupportCoefficients_apply] at h1 + exact h1 + · have hzK : (((b : HahnSeries.Nonpositive ℝ K) : HahnSeries ℝ K)).coeff x = 0 := by + by_contra hne + exact absurd (HahnSeries.Nonpositive.support_subset _ + ((HahnSeries.mem_support _ _).mpr hne)) (by simpa using hx) + have hzL : ((((HahnSeries.Nonpositive.finiteSupportMap (G := ℝ) f b : + HahnSeries.Nonpositive ℝ L)) : HahnSeries ℝ L)).coeff x = 0 := by + by_contra hne + exact absurd (HahnSeries.Nonpositive.support_subset _ + ((HahnSeries.mem_support _ _).mpr hne)) (by simpa using hx) + rw [hzK, hzL, map_zero] + +variable (K) in +/-- The algebra map of the fraction field is the coefficient embedding. -/ +theorem algebraMap_eq_coefficientMap : + algebraMap K (PrincipalSubringFractionField K) = + principalSubringFractionCoefficientMap K := by + refine RingHom.ext fun k ↦ ?_ + rw [principalSubringFraction_algebraMap_apply, principalSubringFractionCoefficientMap_apply] + +/-- The scalar extension acts coefficientwise on the underlying Hahn series. -/ +theorem coe_scalarExtension (b : HahnSeries.Nonpositive.FiniteSupportRing (G := ℝ) (K := K)) : + (((principalSubringFractionScalarExtension K b : + HahnSeries.Nonpositive ℝ (PrincipalSubringFractionField K)) : + HahnSeries ℝ (PrincipalSubringFractionField K))) = + (((b : HahnSeries.Nonpositive ℝ K) : HahnSeries ℝ K)).map + (algebraMap K (PrincipalSubringFractionField K)) := by + refine HahnSeries.coeff_injective (funext fun x ↦ ?_) + rw [HahnSeries.map_coeff, algebraMap_eq_coefficientMap] + rcases le_or_gt x 0 with hx | hx + · have h1 := principalSubringFractionScalarExtension_coeff b ⟨x, hx⟩ + rw [HahnSeries.Nonpositive.finiteSupportCoefficients_apply, + HahnSeries.Nonpositive.finiteSupportCoefficients_apply] at h1 + exact h1 + · have hzK : (((b : HahnSeries.Nonpositive ℝ K) : HahnSeries ℝ K)).coeff x = 0 := by + by_contra hne + exact absurd (HahnSeries.Nonpositive.support_subset _ + ((HahnSeries.mem_support _ _).mpr hne)) (by simpa using hx) + have hzL : (((principalSubringFractionScalarExtension K b : + HahnSeries.Nonpositive ℝ (PrincipalSubringFractionField K)) : + HahnSeries ℝ (PrincipalSubringFractionField K))).coeff x = 0 := by + by_contra hne + exact absurd (HahnSeries.Nonpositive.support_subset _ + ((HahnSeries.mem_support _ _).mpr hne)) (by simpa using hx) + rw [hzK, hzL, map_zero] + +/-- One factor is cleared into the coefficient field by a single nonzero scalar. -/ +theorem exists_clearing_scalar + (hclosed : Algebra.IsRelativelyAlgebraicallyClosed K (PrincipalSubringFractionField K)) + {p q : PrincipalSubringFractionFiniteSupportRing K} (hp : p ≠ 0) (hq : q ≠ 0) + (hpq : p * q ∈ principalSubringFractionCoefficientSubring K) : + ∃ c : PrincipalSubringFractionField K, c ≠ 0 ∧ + p * HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℝ) c ∈ + principalSubringFractionCoefficientSubring K := by + obtain ⟨a, ha⟩ := (mem_principalGradedFractionCoefficientSubring_iff _).mp hpq + have hPfin := (HahnSeries.Nonpositive.mem_finiteSupportSubring_iff _).mp p.2 + have hQfin := (HahnSeries.Nonpositive.mem_finiteSupportSubring_iff _).mp q.2 + have hP0 : (((p : HahnSeries.Nonpositive ℝ (PrincipalSubringFractionField K)) : + HahnSeries ℝ (PrincipalSubringFractionField K))) ≠ 0 := by + intro h0 + exact hp (Subtype.ext (Subtype.ext h0)) + have hQ0 : (((q : HahnSeries.Nonpositive ℝ (PrincipalSubringFractionField K)) : + HahnSeries ℝ (PrincipalSubringFractionField K))) ≠ 0 := by + intro h0 + exact hq (Subtype.ext (Subtype.ext h0)) + have hrel : (((p : HahnSeries.Nonpositive ℝ (PrincipalSubringFractionField K)) : + HahnSeries ℝ (PrincipalSubringFractionField K))) * + (((q : HahnSeries.Nonpositive ℝ (PrincipalSubringFractionField K)) : + HahnSeries ℝ (PrincipalSubringFractionField K))) = + (((a : HahnSeries.Nonpositive ℝ K) : HahnSeries ℝ K)).map + (algebraMap K (PrincipalSubringFractionField K)) := by + have h1 : (((p * q : PrincipalSubringFractionFiniteSupportRing K) : + HahnSeries.Nonpositive ℝ (PrincipalSubringFractionField K)) : + HahnSeries ℝ (PrincipalSubringFractionField K)) = + (((p : HahnSeries.Nonpositive ℝ (PrincipalSubringFractionField K)) : + HahnSeries ℝ (PrincipalSubringFractionField K))) * + (((q : HahnSeries.Nonpositive ℝ (PrincipalSubringFractionField K)) : + HahnSeries ℝ (PrincipalSubringFractionField K))) := by + rw [Subring.coe_mul, Subring.coe_mul] + rw [← h1, ← ha] + exact coe_scalarExtension a + obtain ⟨c, hc, hcoeff⟩ := + HahnSeries.exists_scalar_of_hahn_mul_eq_map hclosed hP0 hQ0 hPfin hQfin hrel + refine ⟨c, hc, ?_⟩ + rw [mem_principalGradedFractionCoefficientSubring_iff_coeff] + intro g + rw [HahnSeries.Nonpositive.finiteSupportCoefficients_apply, + coeff_mul_finiteSupportScalarHom, mul_comm] + have := hcoeff (g : ℝ) + rw [algebraMap_eq_coefficientMap] at this + exact this + +/-- A constant whose value lies in the coefficient field is a coefficient series. -/ +theorem finiteSupportScalarHom_mem_of_mem_range {B : PrincipalSubringFractionField K} + (hB : B ∈ Set.range (principalSubringFractionCoefficientMap K)) : + HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℝ) B ∈ + principalSubringFractionCoefficientSubring K := by + obtain ⟨k, rfl⟩ := hB + rw [mem_principalGradedFractionCoefficientSubring_iff] + exact ⟨HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℝ) k, + principalSubringFractionScalarExtension_scalar k⟩ + +/-- The product of two clearing scalars lies in the coefficient field. -/ +theorem mul_clearing_scalars_mem_range + {p₁ p₂ : PrincipalSubringFractionFiniteSupportRing K} (hp₁ : p₁ ≠ 0) (hp₂ : p₂ ≠ 0) + (hprod : p₁ * p₂ ∈ principalSubringFractionCoefficientSubring K) + {c₁ c₂ : PrincipalSubringFractionField K} + (hm₁ : p₁ * HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℝ) c₁ ∈ + principalSubringFractionCoefficientSubring K) + (hm₂ : p₂ * HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℝ) c₂ ∈ + principalSubringFractionCoefficientSubring K) : + c₁ * c₂ ∈ Set.range (principalSubringFractionCoefficientMap K) := by + obtain ⟨a, ha⟩ := (mem_principalGradedFractionCoefficientSubring_iff _).mp hprod + have ha0 : a ≠ 0 := by + intro h0 + rw [h0, map_zero] at ha + exact (mul_ne_zero hp₁ hp₂) ha.symm + refine principalSubringFractionCoefficientMap_mem_range_of_mul_scalar_mem ha0 ?_ + rw [ha, map_mul, mul_mul_mul_comm] + exact Subring.mul_mem _ hm₁ hm₂ + +/-- LM24, Lemma 6.3.4: a nonzero scalar may be moved between two nonzero finite-support factors +whose product has coefficients in the coefficient field. -/ +theorem principalSubringFraction_exists_scalarRedistribution_of_isRelativelyAlgebraicallyClosed + (hclosed : Algebra.IsRelativelyAlgebraicallyClosed K (PrincipalSubringFractionField K)) + {p₁ p₂ : PrincipalSubringFractionFiniteSupportRing K} + (hp₁ : p₁ ≠ 0) (hp₂ : p₂ ≠ 0) + (hprod : p₁ * p₂ ∈ principalSubringFractionCoefficientSubring K) : + ∃ B : PrincipalSubringFractionField K, B ≠ 0 ∧ + p₁ * HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℝ) B ∈ + principalSubringFractionCoefficientSubring K ∧ + p₂ * HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℝ) B⁻¹ ∈ + principalSubringFractionCoefficientSubring K := by + obtain ⟨c₁, hc₁, hm₁⟩ := exists_clearing_scalar hclosed hp₁ hp₂ hprod + obtain ⟨c₂, hc₂, hm₂⟩ := exists_clearing_scalar hclosed hp₂ hp₁ + (by rw [mul_comm]; exact hprod) + have hrange := mul_clearing_scalars_mem_range hp₁ hp₂ hprod hm₁ hm₂ + refine ⟨c₁, hc₁, hm₁, ?_⟩ + have hinv : c₁⁻¹ = c₂ * (c₁ * c₂)⁻¹ := by + rw [mul_inv, ← mul_assoc, mul_comm c₂ c₁⁻¹, mul_assoc, mul_inv_cancel₀ hc₂, mul_one] + have hrangeinv : (c₁ * c₂)⁻¹ ∈ Set.range (principalSubringFractionCoefficientMap K) := by + obtain ⟨k, hk⟩ := hrange + exact ⟨k⁻¹, by rw [map_inv₀, hk]⟩ + rw [hinv, map_mul, ← mul_assoc] + exact Subring.mul_mem _ hm₂ (finiteSupportScalarHom_mem_of_mem_range hrangeinv) + +end Redistribution + +end + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/PrincipalSubringTensor.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/PrincipalSubringTensor.lean new file mode 100644 index 0000000000..443d58fc4e --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/PrincipalSubringTensor.lean @@ -0,0 +1,370 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalComponentTensor +public import Mathlib.RingTheory.TensorProduct.Basic +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.DegreeInitialForm + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint +import Mathlib.LinearAlgebra.DirectSum.TensorProduct +import Mathlib.RingTheory.TensorProduct.Maps + +/-! +# Extension of scalars from $\widehat{\mathrm P}$ + +This module proves LM24, Proposition 6.1.2. The homogeneous-component equivalences of Proposition +5.3.1 +assemble to the graded algebra equivalence + +`P̂ ⊗[K] K(ℝ^{≤ 0}) ≃ₐ[K] RV̂`. + +The map sends a pure tensor to the product of the principal graded embedding and the grade-zero +finite-support embedding. Its component at `α` is exactly the equivalence on the +`α`-component. Thus both scalar factors and all homogeneous projections remain visible in the +public API. The displayed orientation agrees with Proposition 5.3.1; one sentence in the printed +proof reverses the corresponding component arrow. + +The construction is stated over a coefficient field of characteristic zero, which supplies the +two multiplicativity theorems behind the principal and degree gradings. +-/ + +open scoped DirectSum HahnSeries NatOrdinal TensorProduct + +universe v + +namespace Berarducci + +public noncomputable section + +variable {K : Type v} [Field K] + +variable (K) in +private def principalSubringTensorLinearEquiv : + PrincipalSubring K ⊗[K] FiniteSupportRing (K := K) ≃ₗ[K] + DegreeGraded K := + TensorProduct.directSumLeft K K (PrincipalComponent K) + (FiniteSupportRing (K := K)) ≪≫ₗ + DirectSum.congrLinearEquiv + (fun α ↦ principalComponentTensorEquiv K α) + +variable (K) in +/-- The canonical projection of the tensor product onto its tensor factor in principal grade +`α`. -/ +def principalSubringTensorComponent (α : NatOrdinal) : + PrincipalSubring K ⊗[K] FiniteSupportRing (K := K) →ₗ[K] + PrincipalComponent K α ⊗[K] FiniteSupportRing (K := K) := + (DirectSum.component K NatOrdinal + (fun β ↦ PrincipalComponent K β ⊗[K] FiniteSupportRing (K := K)) + α).comp + (TensorProduct.directSumLeft K K (PrincipalComponent K) + (FiniteSupportRing (K := K))).toLinearMap + +/-- The tensor component of a pure tensor is the tensor of the corresponding principal +component. -/ +@[simp] +theorem principalSubringTensorComponent_tmul (α : NatOrdinal) (x : PrincipalSubring K) + (p : FiniteSupportRing (K := K)) : + principalSubringTensorComponent K α (x ⊗ₜ p) = x α ⊗ₜ p := by + exact TensorProduct.directSumLeft_tmul K K x p α + +private theorem principalSubringTensorLinearEquiv_tmul_apply + (x : PrincipalSubring K) (p : FiniteSupportRing (K := K)) + (α : NatOrdinal) : + principalSubringTensorLinearEquiv K (x ⊗ₜ p) α = + principalComponentTensorEquiv K α (x α ⊗ₜ p) := by + simp [principalSubringTensorLinearEquiv, DirectSum.coe_congrLinearEquiv] + +variable (K) in +/-- The finite-support ring embeds in the degree-graded ring through the +degree-zero residue equivalence. -/ +def finiteSupportGradedEmbedding : + FiniteSupportRing (K := K) →ₐ[K] DegreeGraded K where + toRingHom := (DirectSum.ofZeroRingHom + (HahnSeries.Nonpositive.degreeValuation K).Component).comp + (HahnSeries.Nonpositive.degreeFiniteSupportResidueEquiv K).toRingHom + commutes' k := by + change DirectSum.of _ 0 + (HahnSeries.Nonpositive.degreeFiniteSupportResidueEquiv K + (HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℝ) k)) = + algebraMap K (DegreeGraded K) k + rw [degreeFiniteSupportResidueEquiv_scalar, + degreeGraded_algebraMap_apply] + +/-- The finite-support embedding places the degree residue class in grade zero. -/ +@[simp] +theorem finiteSupportGradedEmbedding_apply (p : FiniteSupportRing (K := K)) : + finiteSupportGradedEmbedding K p = + DirectSum.of _ 0 + (HahnSeries.Nonpositive.degreeFiniteSupportResidueEquiv K p) := + (rfl) + +/-- Multiplication by the grade-zero finite-support embedding is the residue-ring scalar action +on each homogeneous component. -/ +theorem finiteSupportGradedEmbedding_mul_of (p : FiniteSupportRing (K := K)) (α : NatOrdinal) + (x : (HahnSeries.Nonpositive.degreeValuation K).Component α) : + finiteSupportGradedEmbedding K p * + DirectSum.of + (HahnSeries.Nonpositive.degreeValuation K).Component α x = + DirectSum.of + (HahnSeries.Nonpositive.degreeValuation K).Component α + (HahnSeries.Nonpositive.degreeFiniteSupportResidueEquiv K p • x) := by + rw [finiteSupportGradedEmbedding_apply, ← DirectSum.of_zero_smul] + +variable (K) in +/-- The grade-zero finite-support embedding is injective. -/ +theorem finiteSupportGradedEmbedding_injective : + Function.Injective (finiteSupportGradedEmbedding K) := by + intro p q hpq + apply (HahnSeries.Nonpositive.degreeFiniteSupportResidueEquiv K).injective + exact (DirectSum.of_injective 0) hpq + +variable (K) in +/-- Multiplication of the two canonical graded embeddings induces the global tensor map. -/ +def principalSubringTensorMap [CharZero K] : + PrincipalSubring K ⊗[K] FiniteSupportRing (K := K) →ₐ[K] + DegreeGraded K := + Algebra.TensorProduct.productMap + (principalSubringEmbedding K) + (finiteSupportGradedEmbedding K) + +/-- On a pure tensor, the global tensor map is multiplication of the two embedded factors. -/ +theorem principalSubringTensorMap_tmul [CharZero K] (x : PrincipalSubring K) (p : + FiniteSupportRing (K := K)) : + principalSubringTensorMap K (x ⊗ₜ p) = + principalSubringEmbedding K x * + finiteSupportGradedEmbedding K p := + (rfl) + +private theorem degreeGraded_of_zero_mul + (a : (HahnSeries.Nonpositive.degreeValuation K).Component 0) + (x : DegreeGraded K) : + DirectSum.of _ 0 a * x = a • x := by + induction x using DirectSum.induction_on with + | zero => rw [mul_zero, smul_zero] + | of α x => + rw [← DirectSum.of_zero_smul] + exact (DirectSum.lof + ((HahnSeries.Nonpositive.degreeValuation K).Component 0) + NatOrdinal + (HahnSeries.Nonpositive.degreeValuation K).Component + α).map_smul a x + | add x y hx hy => rw [mul_add, smul_add, hx, hy] + +private theorem principalSubringTensorMap_eq_linearEquiv [CharZero K] + (z : PrincipalSubring K ⊗[K] FiniteSupportRing (K := K)) : + principalSubringTensorMap K z = + principalSubringTensorLinearEquiv K z := by + induction z using TensorProduct.inductionOn with + | tmul x p => + rw [principalSubringTensorMap_tmul, + finiteSupportGradedEmbedding_apply, mul_comm, + degreeGraded_of_zero_mul] + ext α + rw [DirectSum.smul_apply, + principalSubringTensorLinearEquiv_tmul_apply, + principalSubringEmbedding_apply, + principalComponentTensorEquiv_tmul] + | add x y hx hy => + calc + principalSubringTensorMap K (x + y) = + principalSubringTensorMap K x + + principalSubringTensorMap K y := + (principalSubringTensorMap K).map_add x y + _ = principalSubringTensorLinearEquiv K x + + principalSubringTensorLinearEquiv K y := + congrArg₂ (· + ·) hx hy + _ = principalSubringTensorLinearEquiv K (x + y) := + ((principalSubringTensorLinearEquiv K).map_add x y).symm + +variable (K) in +/-- The multiplication-induced global tensor map is bijective. -/ +theorem principalSubringTensorMap_bijective [CharZero K] : + Function.Bijective (principalSubringTensorMap K) := by + have hfunctions : + (principalSubringTensorMap K : + PrincipalSubring K ⊗[K] FiniteSupportRing (K := K) → + DegreeGraded K) = + principalSubringTensorLinearEquiv K := by + funext z + exact principalSubringTensorMap_eq_linearEquiv z + rw [hfunctions] + exact (principalSubringTensorLinearEquiv K).bijective + +variable (K) in +/-- LM24, Proposition 6.1.2: the algebra equivalence induced by multiplication. -/ +@[blueprint "fact:principal-subring-tensor-decomposition" + (phase := "Polynomial presentations") + (title := "Scalar extension from $\\widehat{\\mathrm P}$ to $\\widehat{\\mathrm{RV}}$ (LM24, \ + Proposition 6.1.2)") + (statement := /-- + Let $K$ be a field of characteristic zero. Multiplication of initial forms + induces an isomorphism of $K$-algebras + \[ + \widehat{\mathrm P}\otimes_K K(\mathbb R^{\le 0}) + \xrightarrow{\sim}\widehat{\mathrm{RV}}. + \] + -/) + (proof := /-- + \ref{fact:principal-series-representatives} gives in each degree the + component equivalence of LM24, Proposition 5.3.1. + \ref{fact:degree-multiplicativity} makes multiplication of initial forms respect those + components, so their direct sum is an algebra homomorphism. Every element has finite degree + support; applying the inverse component maps degree by degree proves bijectivity. + -/)] +def principalSubringTensorEquiv [CharZero K] : + PrincipalSubring K ⊗[K] FiniteSupportRing (K := K) ≃ₐ[K] + DegreeGraded K := + AlgEquiv.ofBijective (principalSubringTensorMap K) + (principalSubringTensorMap_bijective K) + +/-- The graded tensor equivalence has the multiplication-induced tensor map as its forward map. -/ +@[simp] +theorem principalSubringTensorEquiv_apply [CharZero K] + (z : PrincipalSubring K ⊗[K] FiniteSupportRing (K := K)) : + principalSubringTensorEquiv K z = + principalSubringTensorMap K z := + (rfl) + +/-- The graded tensor equivalence multiplies the images of a pure tensor's two factors. -/ +theorem principalSubringTensorEquiv_tmul [CharZero K] + (x : PrincipalSubring K) (p : FiniteSupportRing (K := K)) : + principalSubringTensorEquiv K (x ⊗ₜ p) = + principalSubringEmbedding K x * + finiteSupportGradedEmbedding K p := by + rw [principalSubringTensorEquiv_apply, principalSubringTensorMap_tmul] + +/-- On a pure tensor, each homogeneous projection of the global equivalence is the corresponding +homogeneous-component equivalence. -/ +theorem principalSubringTensorEquiv_tmul_apply [CharZero K] + (x : PrincipalSubring K) (p : FiniteSupportRing (K := K)) + (α : NatOrdinal) : + principalSubringTensorEquiv K (x ⊗ₜ p) α = + principalComponentTensorEquiv K α (x α ⊗ₜ p) := by + rw [principalSubringTensorEquiv_apply, + principalSubringTensorMap_eq_linearEquiv, + principalSubringTensorLinearEquiv_tmul_apply] + +/-- On an arbitrary tensor, every homogeneous projection of the global equivalence is the +corresponding homogeneous-component equivalence applied to the canonical tensor component. -/ +theorem principalSubringTensorEquiv_component [CharZero K] + (z : PrincipalSubring K ⊗[K] FiniteSupportRing (K := K)) + (α : NatOrdinal) : + principalSubringTensorEquiv K z α = + principalComponentTensorEquiv K α + (principalSubringTensorComponent K α z) := by + rw [principalSubringTensorEquiv_apply, + principalSubringTensorMap_eq_linearEquiv] + rw [principalSubringTensorLinearEquiv, LinearEquiv.trans_apply, + principalSubringTensorComponent, LinearMap.comp_apply, + DirectSum.coe_congrLinearEquiv, DirectSum.lmap_apply, + ← DirectSum.apply_eq_component] + rfl + +/-- The canonical tensor component of the inverse global equivalence is the inverse +homogeneous-component +equivalence of that homogeneous component. -/ +@[simp] +theorem principalSubringTensorComponent_symm_apply [CharZero K] + (y : DegreeGraded K) (α : NatOrdinal) : + principalSubringTensorComponent K α + ((principalSubringTensorEquiv K).symm y) = + (principalComponentTensorEquiv K α).symm (y α) := by + apply (principalComponentTensorEquiv K α).injective + rw [← principalSubringTensorEquiv_component] + simp + +/-- Restricting the global equivalence to the finite-support factor gives its grade-zero +embedding. -/ +theorem principalSubringTensorEquiv_one_tmul [CharZero K] (p : FiniteSupportRing (K := K)) : + principalSubringTensorEquiv K (1 ⊗ₜ p) = + finiteSupportGradedEmbedding K p := by + rw [principalSubringTensorEquiv_tmul, map_one, one_mul] + +/-- Restricting the global equivalence to the principal graded factor gives its canonical +embedding. -/ +theorem principalSubringTensorEquiv_tmul_one [CharZero K] (x : PrincipalSubring K) : + principalSubringTensorEquiv K (x ⊗ₜ 1) = + principalSubringEmbedding K x := by + rw [principalSubringTensorEquiv_tmul, map_one, mul_one] + +/-- The inverse global tensor equivalence sends the finite-support embedding to the corresponding +pure tensor. -/ +theorem principalSubringTensorEquiv_symm_finiteSupportGradedEmbedding [CharZero K] + (p : FiniteSupportRing (K := K)) : + (principalSubringTensorEquiv K).symm + (finiteSupportGradedEmbedding K p) = 1 ⊗ₜ p := by + apply (principalSubringTensorEquiv K).injective + rw [AlgEquiv.apply_symm_apply, principalSubringTensorEquiv_one_tmul] + +/-- The inverse global tensor equivalence sends the principal graded embedding to the +corresponding pure tensor. -/ +@[simp] +theorem principalSubringTensorEquiv_symm_principalGradedEmbedding [CharZero K] (x : + PrincipalSubring K) : + (principalSubringTensorEquiv K).symm + (principalSubringEmbedding K x) = x ⊗ₜ 1 := by + apply (principalSubringTensorEquiv K).injective + rw [AlgEquiv.apply_symm_apply, principalSubringTensorEquiv_tmul_one] + +/-- A nonzero finite-support series has degree zero. -/ +theorem degreeValuation_finiteSupport_eq_zero (p : FiniteSupportRing (K := K)) (hp : p ≠ 0) : + HahnSeries.Nonpositive.degreeValuation K (p : Series K) = 0 := by + rw [HahnSeries.Nonpositive.degreeValuation_apply, HahnSeries.degree_eq_zero] + refine ⟨fun h ↦ hp (Subtype.ext (Subtype.ext h)), ?_⟩ + exact (HahnSeries.Nonpositive.mem_finiteSupportSubring_iff (p : Series K)).mp p.property + +/-- A finite-support series as a representative in the weak degree filtration at zero. -/ +def finiteSupportFiltrationRepresentative (p : FiniteSupportRing (K := K)) : + (HahnSeries.Nonpositive.degreeValuation K).filtrationLE 0 := + ⟨(p : Series K), ((HahnSeries.Nonpositive.degreeValuation K).mem_filtrationLE_iff 0 _).mpr (by + by_cases hp : p = 0 + · subst hp + simp + · rw [degreeValuation_finiteSupport_eq_zero p hp, WithBot.coe_zero])⟩ + +@[simp] +theorem coe_finiteSupportFiltrationRepresentative (p : FiniteSupportRing (K := K)) : + (finiteSupportFiltrationRepresentative p : Series K) = (p : Series K) := + (rfl) + +/-- The finite-support embedding sends a series to its grade-zero homogeneous class. -/ +theorem finiteSupportGradedEmbedding_eq_homogeneousMk (p : FiniteSupportRing (K := K)) : + finiteSupportGradedEmbedding K p = + (HahnSeries.Nonpositive.degreeValuation K).homogeneousMk 0 + (finiteSupportFiltrationRepresentative p) := by + rw [finiteSupportGradedEmbedding_apply, + HahnSeries.Nonpositive.degreeFiniteSupportResidueEquiv_apply, + (HahnSeries.Nonpositive.degreeValuation K).residueMap_apply, + MaxAddDegree.homogeneousMk_apply] + apply congrArg (DirectSum.of (HahnSeries.Nonpositive.degreeValuation K).Component 0) + apply congrArg ((HahnSeries.Nonpositive.degreeValuation K).componentMk 0) + apply Subtype.ext + rw [(HahnSeries.Nonpositive.degreeValuation K).coe_nonpositiveEquivFiltrationLEZero, + RingEquiv.coe_subringCongr_apply, coe_finiteSupportFiltrationRepresentative] + +/-- The finite-support embedding sends a series to its initial form. -/ +theorem finiteSupportGradedEmbedding_eq_initialForm (p : FiniteSupportRing (K := K)) : + finiteSupportGradedEmbedding K p = + (HahnSeries.Nonpositive.degreeValuation K).initialForm (p : Series K) := by + rw [finiteSupportGradedEmbedding_eq_homogeneousMk] + by_cases hp : p = 0 + · have hzero : (HahnSeries.Nonpositive.degreeValuation K).homogeneousMk 0 + (finiteSupportFiltrationRepresentative p) = 0 := by + rw [MaxAddDegree.homogeneousMk_eq_zero_iff, coe_finiteSupportFiltrationRepresentative, hp, + ZeroMemClass.coe_zero, MaxAddDegree.map_zero] + exact WithBot.bot_lt_coe 0 + rw [hzero, hp, ZeroMemClass.coe_zero, MaxAddDegree.initialForm_zero] + · have hne : (HahnSeries.Nonpositive.degreeValuation K).componentMk 0 + (finiteSupportFiltrationRepresentative p) ≠ 0 := by + rw [ne_eq, MaxAddDegree.componentMk_eq_zero_iff, coe_finiteSupportFiltrationRepresentative, + degreeValuation_finiteSupport_eq_zero p hp] + exact lt_irrefl _ + exact (MaxAddDegree.initialForm_eq_homogeneousMk_of_componentMk_ne_zero _ 0 _ hne).symm + +end + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/PrincipalValue.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/PrincipalValue.lean new file mode 100644 index 0000000000..b53eb81cc7 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/PrincipalValue.lean @@ -0,0 +1,360 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValue +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.FinitePart +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.MultiplicativelyPrincipal +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.LeastTerm + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValueImage +import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.SuccessorFactorization +import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.GeneralFactorization + +/-! +# Principal and residual ordinal values + +Berarducci, Definition 6.4 assigns principal and residual values to a nonpositive Hahn series +`b` whose ordinal value satisfies `1 < v_J(b)`. Its value is a positive additive-principal +ordinal, and therefore has a unique nonincreasing factorisation into infinite multiplicatively +principal ordinals greater than one. The principal value is the final factor. The residual value +is the product of all preceding factors, with value one when there is only one factor. + +`SeriesWithOrdinalValueAboveOne` is the exact domain of these operations. The definitions therefore +have no arbitrary branch at ordinal values zero and one. Both values are represented by +`NatOrdinal`: this makes Berarducci's Hessenberg-product reconstruction directly available while +the corresponding theorem on underlying ordinary ordinals records the product printed in the +source. + +The factor list and its ordinary-versus-Hessenberg product comparison are provided by the ordinal +factorisation module. The image theorem for `ordinalValue` supplies the additive-principality +hypothesis required to enter its exact domain. +-/ + +universe v + +open scoped NatOrdinal + +public noncomputable section + +namespace Berarducci + +variable {K : Type v} [Field K] + +/-- Nonpositive Hahn series in the exact domain of Berarducci's principal and residual values. -/ +abbrev SeriesWithOrdinalValueAboveOne (K : Type v) [Field K] := + {b : Series K // 1 < ordinalValue b} + +namespace SeriesWithOrdinalValueAboveOne + +private def factorOrdinal (b : SeriesWithOrdinalValueAboveOne K) : + Ordinal.AdditivePrincipalAboveOne := + ⟨(ordinalValue b.1).val, ordinalValue_isAdditivelyPrincipal_of_one_lt b.2, b.2⟩ + +/-- The final factor in the canonical multiplicative factorisation of `v_J(b)`. -/ +noncomputable def principalValue (b : SeriesWithOrdinalValueAboveOne K) : NatOrdinal := + NatOrdinal.of b.factorOrdinal.principalFactor + +/-- The product of all but the final factor in the canonical factorisation of `v_J(b)`. -/ +noncomputable def residualValue (b : SeriesWithOrdinalValueAboveOne K) : NatOrdinal := + NatOrdinal.of b.factorOrdinal.residualFactor + +/-- The principal value is an infinite multiplicatively principal ordinal. -/ +theorem principalValue_isInfiniteMultiplicativelyPrincipal + (b : SeriesWithOrdinalValueAboveOne K) : + Ordinal.IsInfiniteMultiplicativelyPrincipal b.principalValue.val := by + simp only [principalValue, NatOrdinal.val_of] + exact b.factorOrdinal.principalFactor_isInfiniteMultiplicativelyPrincipal + +/-- The principal value satisfies Berarducci's printed multiplicative-principality predicate. -/ +theorem principalValue_isMultiplicativelyPrincipal + (b : SeriesWithOrdinalValueAboveOne K) : + Ordinal.IsMultiplicativelyPrincipal b.principalValue.val := + (Ordinal.isInfiniteMultiplicativelyPrincipal_iff_two_lt_and_isMultiplicativelyPrincipal.mp + b.principalValue_isInfiniteMultiplicativelyPrincipal).2 + +/-- The principal value is strictly greater than one. -/ +theorem one_lt_principalValue (b : SeriesWithOrdinalValueAboveOne K) : + 1 < b.principalValue := by + change NatOrdinal.of (1 : Ordinal) < + NatOrdinal.of b.factorOrdinal.principalFactor + exact NatOrdinal.of.lt_iff_lt.mpr b.factorOrdinal.one_lt_principalFactor + +/-- The residual value is a positive additive-principal ordinal. -/ +theorem residualValue_isAdditivelyPrincipal + (b : SeriesWithOrdinalValueAboveOne K) : + Ordinal.IsAdditivelyPrincipal b.residualValue.val := by + simp only [residualValue, NatOrdinal.val_of] + exact b.factorOrdinal.residualFactor_isAdditivelyPrincipal + +/-- The residual value is nonzero. -/ +theorem residualValue_ne_zero (b : SeriesWithOrdinalValueAboveOne K) : + b.residualValue ≠ 0 := by + intro hzero + apply b.residualValue_isAdditivelyPrincipal.ne_zero + have hval := congrArg NatOrdinal.val hzero + simpa using hval + +/-- Ordinary ordinal multiplication of the residual and principal values recovers `v_J(b)`. -/ +theorem residualValue_val_mul_principalValue_val + (b : SeriesWithOrdinalValueAboveOne K) : + b.residualValue.val * b.principalValue.val = (ordinalValue b.1).val := by + simpa only [residualValue, principalValue, NatOrdinal.val_of, factorOrdinal] using + b.factorOrdinal.residualFactor_mul_principalFactor + +/-- Hessenberg multiplication of the residual and principal values also recovers `v_J(b)`. -/ +theorem residualValue_mul_principalValue + (b : SeriesWithOrdinalValueAboveOne K) : + b.residualValue * b.principalValue = ordinalValue b.1 := by + change NatOrdinal.of b.factorOrdinal.residualFactor * + NatOrdinal.of b.factorOrdinal.principalFactor = ordinalValue b.1 + rw [b.factorOrdinal.naturalResidual_mul_naturalPrincipal] + simp [factorOrdinal] + +/-- Every canonical multiplicative factor of the ordinal value is at least the principal value, +read on Cantor terms of the logarithm. -/ +theorem log_principalValue_le_of_mem_terms_ordinalValue + (b : SeriesWithOrdinalValueAboveOne K) {t : Ordinal} + (ht : t ∈ (Ordinal.log Ordinal.omega0 (ordinalValue b.1).val).additivePrincipalTerms) : + Ordinal.log Ordinal.omega0 b.principalValue.val ≤ t := by + have h := b.factorOrdinal.log_principalFactor_le_of_mem_terms ht + simpa [principalValue] using h + +/-- The same bound for the canonical factors of the residual value. -/ +theorem log_principalValue_le_of_mem_terms_residualValue + (b : SeriesWithOrdinalValueAboveOne K) {t : Ordinal} + (ht : t ∈ (Ordinal.log Ordinal.omega0 b.residualValue.val).additivePrincipalTerms) : + Ordinal.log Ordinal.omega0 b.principalValue.val ≤ t := by + have hmem : t ∈ + (Ordinal.log Ordinal.omega0 b.factorOrdinal.1).additivePrincipalTerms := + b.factorOrdinal.mem_terms_of_mem_terms_log_residualFactor (by simpa [residualValue] using ht) + have h := b.factorOrdinal.log_principalFactor_le_of_mem_terms hmem + simpa [principalValue] using h + +/-- The logarithm of the principal value is additive principal. -/ +theorem isAdditivelyPrincipal_log_principalValue (b : SeriesWithOrdinalValueAboveOne K) : + Ordinal.IsAdditivelyPrincipal (Ordinal.log Ordinal.omega0 b.principalValue.val) := by + obtain ⟨e, he⟩ := Ordinal.isInfiniteMultiplicativelyPrincipal_iff.mp + b.principalValue_isInfiniteMultiplicativelyPrincipal + rw [he, Ordinal.log_opow Ordinal.one_lt_omega0] + exact Ordinal.isAdditivelyPrincipal_omega0_opow e + +/-- The principal value is the power of `ω` at that logarithm. -/ +theorem principalValue_val_eq_opow_log (b : SeriesWithOrdinalValueAboveOne K) : + Ordinal.omega0 ^ Ordinal.log Ordinal.omega0 b.principalValue.val = b.principalValue.val := + (b.principalValue_isInfiniteMultiplicativelyPrincipal.isAdditivelyPrincipal).opow_log_self + +/-- The residual value is strictly smaller than the ordinal value. -/ +theorem residualValue_lt_ordinalValue (b : SeriesWithOrdinalValueAboveOne K) : + b.residualValue < ordinalValue b.1 := by + rw [← b.residualValue_mul_principalValue] + simpa only [mul_one] using + mul_lt_mul_of_pos_left b.one_lt_principalValue + (pos_iff_ne_zero.mpr b.residualValue_ne_zero) + +/-- Berarducci, Remark 6.7: a series whose ordinal value is the residual value of `b` has +principal value at least that of `b`. -/ +theorem principalValue_le_of_ordinalValue_eq_residualValue + (b d : SeriesWithOrdinalValueAboveOne K) (hd : ordinalValue d.1 = b.residualValue) : + b.principalValue ≤ d.principalValue := by + have hval : d.factorOrdinal.1 = b.factorOrdinal.residualFactor := by + change (ordinalValue d.1).val = b.factorOrdinal.residualFactor + rw [hd] + rfl + exact NatOrdinal.of.le_iff_le.mpr + (Ordinal.AdditivePrincipalAboveOne.principalFactor_le_principalFactor_of_eq_residualFactor + b.factorOrdinal d.factorOrdinal hval) + +/-- When `v_J(b)` is already infinite multiplicatively principal, it is the principal value. -/ +theorem principalValue_eq_ordinalValue_of_isInfiniteMultiplicativelyPrincipal + (b : SeriesWithOrdinalValueAboveOne K) + (hb : Ordinal.IsInfiniteMultiplicativelyPrincipal (ordinalValue b.1).val) : + b.principalValue = ordinalValue b.1 := by + apply NatOrdinal.val.injective + simp only [principalValue, NatOrdinal.val_of] + exact + b.factorOrdinal.principalFactor_eq_self_of_isInfiniteMultiplicativelyPrincipal hb + +/-- When `v_J(b)` is already infinite multiplicatively principal, the residual value is one. -/ +theorem residualValue_eq_one_of_isInfiniteMultiplicativelyPrincipal + (b : SeriesWithOrdinalValueAboveOne K) + (hb : Ordinal.IsInfiniteMultiplicativelyPrincipal (ordinalValue b.1).val) : + b.residualValue = 1 := by + apply NatOrdinal.val.injective + simp only [residualValue, NatOrdinal.val_of, NatOrdinal.val_one] + exact + b.factorOrdinal.residualFactor_eq_one_of_isInfiniteMultiplicativelyPrincipal hb + +private theorem ordinalValue_isInfiniteMultiplicativelyPrincipal_of_isMultiplicativelyPrincipal + (b : SeriesWithOrdinalValueAboveOne K) + (hb : Ordinal.IsMultiplicativelyPrincipal (ordinalValue b.1).val) : + Ordinal.IsInfiniteMultiplicativelyPrincipal (ordinalValue b.1).val := by + rw [Ordinal.isInfiniteMultiplicativelyPrincipal_iff_two_lt_and_isMultiplicativelyPrincipal] + refine ⟨?_, hb⟩ + have hone : (1 : Ordinal) < (ordinalValue b.1).val := + NatOrdinal.of_lt_iff.mp b.2 + have homega : Ordinal.omega0 ≤ (ordinalValue b.1).val := + (ordinalValue_isAdditivelyPrincipal_of_one_lt b.2).omega0_le_of_one_lt hone + exact (Ordinal.natCast_lt_omega0 2).trans_le homega + +/-- Under Berarducci's exact multiplicative-principality hypothesis, the principal value is the +ordinal value itself. -/ +theorem principalValue_eq_ordinalValue_of_isMultiplicativelyPrincipal + (b : SeriesWithOrdinalValueAboveOne K) + (hb : Ordinal.IsMultiplicativelyPrincipal (ordinalValue b.1).val) : + b.principalValue = ordinalValue b.1 := + b.principalValue_eq_ordinalValue_of_isInfiniteMultiplicativelyPrincipal + (ordinalValue_isInfiniteMultiplicativelyPrincipal_of_isMultiplicativelyPrincipal b hb) + +/-- Under Berarducci's exact multiplicative-principality hypothesis, the residual value is one. -/ +theorem residualValue_eq_one_of_isMultiplicativelyPrincipal + (b : SeriesWithOrdinalValueAboveOne K) + (hb : Ordinal.IsMultiplicativelyPrincipal (ordinalValue b.1).val) : + b.residualValue = 1 := + b.residualValue_eq_one_of_isInfiniteMultiplicativelyPrincipal + (ordinalValue_isInfiniteMultiplicativelyPrincipal_of_isMultiplicativelyPrincipal b hb) + +/-- Conversely, a lower bound on every canonical multiplicative factor of `v_J(c)` is a lower +bound on `v_J^p(c)`. -/ +theorem le_principalValue_of_forall_mem_terms (b c : SeriesWithOrdinalValueAboveOne K) + (h : ∀ t ∈ (Ordinal.log Ordinal.omega0 (ordinalValue c.1).val).additivePrincipalTerms, + Ordinal.log Ordinal.omega0 b.principalValue.val ≤ t) : + b.principalValue ≤ c.principalValue := by + have hmem : Ordinal.log Ordinal.omega0 c.principalValue.val + ∈ (Ordinal.log Ordinal.omega0 (ordinalValue c.1).val).additivePrincipalTerms := by + simpa [principalValue, factorOrdinal] using c.factorOrdinal.log_principalFactor_mem_terms + refine NatOrdinal.val.le_iff_le.mp ?_ + rw [← b.principalValue_val_eq_opow_log, ← c.principalValue_val_eq_opow_log] + exact (Ordinal.opow_le_opow_iff_right Ordinal.one_lt_omega0).mpr (h _ hmem) + +/-- Principal and residual values depend only on the ordinal value of the series. -/ +theorem principalValue_eq_and_residualValue_eq_of_ordinalValue_eq + (b c : SeriesWithOrdinalValueAboveOne K) (hbc : ordinalValue b.1 = ordinalValue c.1) : + b.principalValue = c.principalValue ∧ b.residualValue = c.residualValue := by + have hfactor : b.factorOrdinal = c.factorOrdinal := by + apply Subtype.ext + exact congrArg NatOrdinal.val hbc + constructor + · simp [principalValue, hfactor] + · simp [residualValue, hfactor] + +/-- If `v_J(b) = ω^α` and `α` has positive constant Cantor coefficient, the final +multiplicative factor of `v_J(b)` is `ω`. -/ +theorem principalValue_eq_wpow_one_of_ordinalValue_eq_wpow + (b : SeriesWithOrdinalValueAboveOne K) (alpha : NatOrdinal) + (halpha : 0 < alpha.constantCoeff) (hb : ordinalValue b.1 = ω^ alpha) : + b.principalValue = ω^ (1 : NatOrdinal) := by + apply NatOrdinal.val.injective + simp only [principalValue, NatOrdinal.val_of, NatOrdinal.val_wpow, + NatOrdinal.val_one, Ordinal.opow_one] + change Ordinal.AdditivePrincipalAboveOne.principalFactor + (⟨(ordinalValue b.1).val, + ordinalValue_isAdditivelyPrincipal_of_one_lt b.2, b.2⟩ : + Ordinal.AdditivePrincipalAboveOne) = Ordinal.omega0 + have hbval : (ordinalValue b.1).val = Ordinal.omega0 ^ alpha.val := by + simpa only [NatOrdinal.val_wpow] using congrArg NatOrdinal.val hb + let q : Ordinal.AdditivePrincipalAboveOne := + ⟨Ordinal.omega0 ^ alpha.val, + Ordinal.isAdditivelyPrincipal_omega0_opow alpha.val, + hbval ▸ b.2⟩ + have hfactor : + (⟨(ordinalValue b.1).val, + ordinalValue_isAdditivelyPrincipal_of_one_lt b.2, b.2⟩ : + Ordinal.AdditivePrincipalAboveOne) = q := + Subtype.ext hbval + rw [hfactor] + dsimp only [q] + exact Ordinal.AdditivePrincipalAboveOne.principalFactor_wpow_of_constantCoeff_pos + alpha halpha (Ordinal.isAdditivelyPrincipal_omega0_opow alpha.val) + (hbval ▸ b.2) + +/-- If `v_J(b) = ω^α` and `α` has positive constant Cantor coefficient, deleting the +final multiplicative factor leaves `ω^(α.removeNat 1)`. -/ +theorem residualValue_eq_wpow_removeNat_of_ordinalValue_eq_wpow + (b : SeriesWithOrdinalValueAboveOne K) (alpha : NatOrdinal) + (halpha : 0 < alpha.constantCoeff) (hb : ordinalValue b.1 = ω^ alpha) : + b.residualValue = ω^ (alpha.removeNat 1) := by + apply NatOrdinal.val.injective + simp only [residualValue, NatOrdinal.val_of, NatOrdinal.val_wpow] + change Ordinal.AdditivePrincipalAboveOne.residualFactor + (⟨(ordinalValue b.1).val, + ordinalValue_isAdditivelyPrincipal_of_one_lt b.2, b.2⟩ : + Ordinal.AdditivePrincipalAboveOne) = + Ordinal.omega0 ^ (alpha.removeNat 1).val + have hbval : (ordinalValue b.1).val = Ordinal.omega0 ^ alpha.val := by + simpa only [NatOrdinal.val_wpow] using congrArg NatOrdinal.val hb + let q : Ordinal.AdditivePrincipalAboveOne := + ⟨Ordinal.omega0 ^ alpha.val, + Ordinal.isAdditivelyPrincipal_omega0_opow alpha.val, + hbval ▸ b.2⟩ + have hfactor : + (⟨(ordinalValue b.1).val, + ordinalValue_isAdditivelyPrincipal_of_one_lt b.2, b.2⟩ : + Ordinal.AdditivePrincipalAboveOne) = q := + Subtype.ext hbval + rw [hfactor] + dsimp only [q] + exact Ordinal.AdditivePrincipalAboveOne.residualFactor_wpow_of_constantCoeff_pos + alpha halpha (Ordinal.isAdditivelyPrincipal_omega0_opow alpha.val) + (hbval ▸ b.2) + +theorem residualValue_eq_wpow_removeLeastTerm + (b : SeriesWithOrdinalValueAboveOne K) (alpha : NatOrdinal) + (hb : ordinalValue b.1 = ω^ alpha) : + b.residualValue = ω^ (NatOrdinal.removeLeastTerm alpha) := by + apply NatOrdinal.val.injective + simp only [residualValue, NatOrdinal.val_of, NatOrdinal.val_wpow] + have hbval : (ordinalValue b.1).val = Ordinal.omega0 ^ alpha.val := by + simpa only [NatOrdinal.val_wpow] using congrArg NatOrdinal.val hb + change Ordinal.AdditivePrincipalAboveOne.residualFactor + (⟨(ordinalValue b.1).val, + ordinalValue_isAdditivelyPrincipal_of_one_lt b.2, b.2⟩ : + Ordinal.AdditivePrincipalAboveOne) = _ + have hfactor : + (⟨(ordinalValue b.1).val, + ordinalValue_isAdditivelyPrincipal_of_one_lt b.2, b.2⟩ : + Ordinal.AdditivePrincipalAboveOne) = + (⟨Ordinal.omega0 ^ alpha.val, + Ordinal.isAdditivelyPrincipal_omega0_opow alpha.val, hbval ▸ b.2⟩ : + Ordinal.AdditivePrincipalAboveOne) := + Subtype.ext hbval + rw [hfactor, Ordinal.residualFactor_omega0_opow alpha.val + (Ordinal.isAdditivelyPrincipal_omega0_opow alpha.val) (hbval ▸ b.2), + NatOrdinal.val_removeLeastTerm] + +theorem principalValue_eq_wpow_leastTerm + (b : SeriesWithOrdinalValueAboveOne K) (alpha : NatOrdinal) + (hb : ordinalValue b.1 = ω^ alpha) : + b.principalValue = ω^ (NatOrdinal.leastTerm alpha) := by + have halpha : alpha ≠ 0 := by + intro hzero + rw [hzero, NatOrdinal.wpow_zero] at hb + exact absurd hb b.2.ne' + have hne : alpha.val.additivePrincipalTerms ≠ [] := + NatOrdinal.additivePrincipalTerms_ne_nil halpha + apply NatOrdinal.val.injective + simp only [principalValue, NatOrdinal.val_of, NatOrdinal.val_wpow] + have hbval : (ordinalValue b.1).val = Ordinal.omega0 ^ alpha.val := by + simpa only [NatOrdinal.val_wpow] using congrArg NatOrdinal.val hb + change Ordinal.AdditivePrincipalAboveOne.principalFactor + (⟨(ordinalValue b.1).val, + ordinalValue_isAdditivelyPrincipal_of_one_lt b.2, b.2⟩ : + Ordinal.AdditivePrincipalAboveOne) = _ + have hfactor : + (⟨(ordinalValue b.1).val, + ordinalValue_isAdditivelyPrincipal_of_one_lt b.2, b.2⟩ : + Ordinal.AdditivePrincipalAboveOne) = + (⟨Ordinal.omega0 ^ alpha.val, + Ordinal.isAdditivelyPrincipal_omega0_opow alpha.val, hbval ▸ b.2⟩ : + Ordinal.AdditivePrincipalAboveOne) := + Subtype.ext hbval + rw [hfactor, Ordinal.principalFactor_omega0_opow alpha.val + (Ordinal.isAdditivelyPrincipal_omega0_opow alpha.val) (hbval ▸ b.2) hne, + NatOrdinal.val_leastTerm hne] + +end SeriesWithOrdinalValueAboveOne + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/PurePowerRemainder.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/PurePowerRemainder.lean new file mode 100644 index 0000000000..172835b6bd --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/PurePowerRemainder.lean @@ -0,0 +1,88 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PowerRemainder + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.ConvolutionRemainder + +/-! +# The remainder estimate for pure powers + +Berarducci's induction computes the value of a pure power `b ^ k` by applying Lemma 8.2 with +`c = 1`. That reading is not available: Definition 6.4 defines `v_J^p` only for value above one, +so the hypothesis `v_J^p(b) ≤ v_J^p(c)` of Lemma 8.2 is undefined at `c = 1`. Nor can the case be +absorbed by choosing some other factor for `c`, since the doubling in Lemma 9.5 then raises the +exponent of `b` instead of lowering it. The pure-power case is therefore developed on its own. + +It is strictly easier than the general one. The term carrying the truncation of `c` disappears, +and with it the only use of that hypothesis. At a positive exponent the remainder for `b ^ (m + 1)` +is literally the two-factor remainder for the pair `(b, b)` one step down, so Lemma 7.7 transfers +with no new analysis; at exponent zero the remainder vanishes. +-/ + +universe v + +public noncomputable section + +open HahnSeries Ordinal + +namespace Berarducci + +variable {K : Type v} [Field K] + +/-- The remainder in the product rule for `b ^ (m + 1)`. -/ +def powerRemainderOne (b : SeriesWithOrdinalValueAboveOne K) (m : ℕ) (γ : ℝ) : Germ K := + germAt ((b.1 ^ (m + 1) : Series K) : K⟦ℝ⟧) γ + - (m + 1) • (germAt (b.1 : K⟦ℝ⟧) γ * toGerm (b.1 ^ m)) + +/-- The bound on that remainder. -/ +def powerRemainderBoundOne (b : SeriesWithOrdinalValueAboveOne K) (m : ℕ) : NatOrdinal := + ordinalValue b.1 ^ m * b.residualValue + +theorem powerRemainderBoundOne_eq (b : SeriesWithOrdinalValueAboveOne K) (m : ℕ) : + powerRemainderBoundOne b m = ordinalValue b.1 ^ m * b.residualValue := (rfl) + +/-- The defining decomposition, read as an expansion of the germ. -/ +theorem germAt_purePower_decomp (b : SeriesWithOrdinalValueAboveOne K) (m : ℕ) (ξ : ℝ) : + germAt ((b.1 ^ (m + 1) : Series K) : K⟦ℝ⟧) ξ = + (m + 1) • (germAt (b.1 : K⟦ℝ⟧) ξ * toGerm (b.1 ^ m)) + powerRemainderOne b m ξ := by + rw [powerRemainderOne] + abel + +/-- Taking both factors equal shifts the two-factor bound by one exponent. -/ +theorem powerRemainderBound_self (b : SeriesWithOrdinalValueAboveOne K) (m : ℕ) : + powerRemainderBound b b m = powerRemainderBoundOne b (m + 1) := by + rw [powerRemainderBound_eq, powerRemainderBoundOne_eq, pow_succ] + ring + +/-- Taking both factors equal shifts the two-factor remainder by one exponent. -/ +theorem powerRemainderOne_succ (b : SeriesWithOrdinalValueAboveOne K) (m : ℕ) (γ : ℝ) : + powerRemainderOne b (m + 1) γ = powerRemainder b b m γ := by + rw [powerRemainderOne, powerRemainder_eq] + simp only [← pow_succ] + rw [mul_comm (toGerm (b.1 ^ (m + 1))) (germAt (b.1 : K⟦ℝ⟧) γ), succ_nsmul] + abel + +/-- Berarducci, Lemma 7.7 for a pure power. -/ +theorem exists_powerRemainderOne_lt (b : SeriesWithOrdinalValueAboveOne K) (m : ℕ) : + ∃ η < (0 : ℝ), ∀ γ : ℝ, η < γ → γ < 0 → + germOrdinalValue (powerRemainderOne b m γ) < powerRemainderBoundOne b m := by + cases m with + | zero => + refine ⟨-1, by norm_num, fun γ _ _ ↦ ?_⟩ + have hzero : powerRemainderOne b 0 γ = 0 := by + rw [powerRemainderOne] + simp + rw [hzero, germOrdinalValue_zero, powerRemainderBoundOne_eq, pow_zero, one_mul] + exact pos_iff_ne_zero.mpr b.residualValue_ne_zero + | succ n => + obtain ⟨η, hη, h⟩ := exists_powerRemainder_lt b b le_rfl n + refine ⟨η, hη, fun γ hlow hhigh ↦ ?_⟩ + rw [powerRemainderOne_succ, ← powerRemainderBound_self] + exact h γ hlow hhigh + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/ResidualPoint.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/ResidualPoint.lean new file mode 100644 index 0000000000..ef0775d0a4 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/ResidualPoint.lean @@ -0,0 +1,125 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalValue +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Truncation + +/-! +# Berarducci residual points + +For a nonpositive real Hahn series `b` with `1 < v_J(b)`, Berarducci, Definition 6.6 defines +`X(b)` to consist of the strictly negative exponents `γ` for which the translated closed +truncation `b^{|γ}` has ordinal value equal to the residual value of `b`. + +The definition below uses the exact domain already imposed on principal and residual values. Its +strict inequality `γ < 0`, closed truncation at `γ`, and equality with the residual value are +all part of the carrier. In later statements, the source phrase "sufficiently close to zero" is +represented by `nhdsWithin 0 (Set.Iio 0)`, Mathlib's left-neighborhood filter; no separate +informal predicate is introduced. + +When `v_J(b)` satisfies Berarducci's exact multiplicative-principality predicate, its residual +value is one. The corresponding theorem recovers the description immediately following +Definition 6.6. + +-/ + +universe v + +open scoped HahnSeries + +public noncomputable section + +namespace Berarducci + +variable {K : Type v} [Field K] + +/-- The set `X(b)` of residual points from Berarducci, Definition 6.6. -/ +def residualPointSet (b : SeriesWithOrdinalValueAboveOne K) : Set ℝ := + {γ | γ < 0 ∧ + ordinalValue (translatedTruncation (b.1 : K⟦ℝ⟧) γ) = b.residualValue} + +/-- Membership in `X(b)` is the conjunction printed in Berarducci, Definition 6.6. -/ +theorem mem_residualPointSet_iff {b : SeriesWithOrdinalValueAboveOne K} {γ : ℝ} : + γ ∈ residualPointSet b ↔ + γ < 0 ∧ + ordinalValue (translatedTruncation (b.1 : K⟦ℝ⟧) γ) = b.residualValue := + (Iff.rfl) + +/-- Every residual point is strictly negative. -/ +theorem residualPointSet_subset_Iio (b : SeriesWithOrdinalValueAboveOne K) : + residualPointSet b ⊆ Set.Iio 0 := + fun _ hγ ↦ hγ.1 + +/-- At zero, the translated truncation has the value of the original series, which is strictly +larger than its residual value. -/ +theorem ordinalValue_translatedTruncation_zero_ne_residualValue + (b : SeriesWithOrdinalValueAboveOne K) : + ordinalValue (translatedTruncation (b.1 : K⟦ℝ⟧) 0) ≠ b.residualValue := by + rw [translatedTruncation_zero] + exact ne_of_gt b.residualValue_lt_ordinalValue + +/-- On the domain `1 < v_J(b)`, the value equality already excludes zero. Thus replacing the +printed condition `γ < 0` by `γ ≤ 0` gives an extensionally equal set, although the defining +characteristic theorem retains Berarducci's strict inequality. -/ +theorem mem_residualPointSet_iff_le_zero + {b : SeriesWithOrdinalValueAboveOne K} {γ : ℝ} : + γ ∈ residualPointSet b ↔ + γ ≤ 0 ∧ ordinalValue (translatedTruncation (b.1 : K⟦ℝ⟧) γ) = b.residualValue := by + constructor + · rintro ⟨hγ, hvalue⟩ + exact ⟨hγ.le, hvalue⟩ + · rintro ⟨hγ, hvalue⟩ + apply mem_residualPointSet_iff.mpr + refine ⟨lt_of_le_of_ne hγ ?_, hvalue⟩ + intro hzero + subst γ + exact ordinalValue_translatedTruncation_zero_ne_residualValue b hvalue + +/-- Zero is not a residual point. -/ +@[simp] +theorem zero_not_mem_residualPointSet (b : SeriesWithOrdinalValueAboveOne K) : + (0 : ℝ) ∉ residualPointSet b := + fun hzero ↦ (mem_residualPointSet_iff.mp hzero).1.false + +/-- At a residual point, the translated truncation does not belong to the negative-monomial +ideal. -/ +theorem translatedTruncation_not_mem_negativeMonomialIdeal_of_mem_residualPointSet + {b : SeriesWithOrdinalValueAboveOne K} {γ : ℝ} + (hγ : γ ∈ residualPointSet b) : + translatedTruncation (b.1 : K⟦ℝ⟧) γ ∉ + HahnSeries.Nonpositive.negativeMonomialIdeal K := by + intro hmem + have hzero := ordinalValue_of_mem_negativeMonomialIdeal hmem + have hresidual := (mem_residualPointSet_iff.mp hγ).2 + exact b.residualValue_ne_zero (hresidual.symm.trans hzero) + +/-- At a residual point, the translated truncation has support supremum zero. -/ +theorem supportSup_translatedTruncation_eq_zero_of_mem_residualPointSet + {b : SeriesWithOrdinalValueAboveOne K} {γ : ℝ} + (hγ : γ ∈ residualPointSet b) : + HahnSeries.Nonpositive.supportSup (translatedTruncation (b.1 : K⟦ℝ⟧) γ) = 0 := by + apply le_antisymm + · exact HahnSeries.Nonpositive.supportSup_le_zero _ + · apply le_of_not_gt + intro hlt + have hmem : translatedTruncation (b.1 : K⟦ℝ⟧) γ ∈ + HahnSeries.Nonpositive.negativeMonomialIdeal K := + HahnSeries.Nonpositive.mem_negativeMonomialIdeal_iff_supportSup_lt_zero.mpr hlt + exact translatedTruncation_not_mem_negativeMonomialIdeal_of_mem_residualPointSet hγ hmem + +/-- If `v_J(b)` is multiplicatively principal, `X(b)` consists exactly of the strictly negative +exponents whose translated truncations have value one. -/ +theorem residualPointSet_eq_setOf_ordinalValue_eq_one_of_isMultiplicativelyPrincipal + (b : SeriesWithOrdinalValueAboveOne K) + (hb : Ordinal.IsMultiplicativelyPrincipal (ordinalValue b.1).val) : + residualPointSet b = + {γ : ℝ | γ < 0 ∧ ordinalValue (translatedTruncation (b.1 : K⟦ℝ⟧) γ) = 1} := by + ext γ + rw [mem_residualPointSet_iff, Set.mem_ofPred_eq, + b.residualValue_eq_one_of_isMultiplicativelyPrincipal hb] + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/ResidualPointCofinality.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/ResidualPointCofinality.lean new file mode 100644 index 0000000000..bdc799e76e --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/ResidualPointCofinality.lean @@ -0,0 +1,421 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.ResidualPoint + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.StableInterval +import Mathlib.Order.Bounds.OrderIso +import Mathlib.SetTheory.Ordinal.Arithmetic +import Mathlib.Tactic.Linarith + +/-! +# Cofinality of Berarducci residual points + +This module proves the first conclusion of Berarducci, Lemma 6.8: for a nonpositive real Hahn +series `b` with `1 < v_J(b)`, the residual-point set `X(b)` has least upper bound zero. + +Write `v_J(b) = ρ l`, where `ρ` is the residual value and `l` is the principal value. When +`1 < ρ`, the proof extracts, above any prescribed negative cutoff, a final support block of +ordinary order type `ρ`. Its real supremum is a residual point because translation makes that +block a stable interval of the germ. + +The case `ρ = 1` requires a separate argument. Berarducci's proof takes the supremum of the +first `ρ(α + 1)` support elements and states that the resulting germ has value `ρ`. For +`ρ = 1` and limit `α`, that supremum can be an attained limit point, whose germ need not have +value one. The theorem is repaired without changing its statement: above any cutoff, take the +least later support exponent. It is isolated from below, so its germ lies in `(J + K) \ J` and +has value one. + +-/ + +universe v + +open scoped HahnSeries NatOrdinal + +public noncomputable section + +namespace Berarducci + +open HahnSeries + +variable {K : Type v} [Field K] + +private theorem ordinalValue_translatedTruncation_eq_one_of_isolatedBelow + (b : Series K) {z y : ℝ} + (hySupport : y ∈ (b : K⟦ℝ⟧).support) (hzy : z < y) + (hgap : (b : K⟦ℝ⟧).support ∩ Set.Ioo z y = ∅) : + ordinalValue (translatedTruncation (b : K⟦ℝ⟧) y) = 1 := by + apply ordinalValue_eq_one_iff.mpr + constructor + · rw [mem_nearConstantSubgroup_iff_sub_C_constantCoeff_mem] + rw [HahnSeries.Nonpositive.mem_negativeMonomialIdeal_iff_supportSup_lt_zero] + let q := translatedTruncation (b : K⟦ℝ⟧) y - + HahnSeries.Nonpositive.C + (HahnSeries.Nonpositive.constantCoeff (translatedTruncation (b : K⟦ℝ⟧) y)) + change HahnSeries.Nonpositive.supportSup q < 0 + by_cases hq : q = 0 + · simp [hq] + · rw [HahnSeries.Nonpositive.supportSup_of_ne hq] + apply WithBot.coe_lt_coe.mpr + refine (csSup_le (HahnSeries.support_nonempty_iff.mpr ?_) ?_).trans_lt + (sub_neg.mpr hzy) + · simpa using hq + · intro δ hδSupport + apply le_of_not_gt + intro hzyδ + have hδ0 : δ ≤ 0 := HahnSeries.Nonpositive.support_subset q hδSupport + rcases hδ0.eq_or_lt with rfl | hδ0 + · have hcoeff : (q : K⟦ℝ⟧).coeff 0 = 0 := by + simp [q] + exact (HahnSeries.mem_support _ _).mp hδSupport hcoeff + · have hbySupport : y + δ ∈ (b : K⟦ℝ⟧).support := by + rw [HahnSeries.mem_support] + have hcoeff : (q : K⟦ℝ⟧).coeff δ = + (b : K⟦ℝ⟧).coeff (y + δ) := by + simp [q, hδ0.le, hδ0.ne] + rw [← hcoeff] + exact (HahnSeries.mem_support _ _).mp hδSupport + have hby : y + δ < y := by linarith + have hzby : z < y + δ := by linarith + have : y + δ ∈ (b : K⟦ℝ⟧).support ∩ Set.Ioo z y := + ⟨hbySupport, hzby, hby⟩ + simp [hgap] at this + · intro hmem + have hconstant := constantCoeff_eq_zero_of_mem_negativeMonomialIdeal hmem + have hyCoeff : (b : K⟦ℝ⟧).coeff y ≠ 0 := + (HahnSeries.mem_support _ _).mp hySupport + apply hyCoeff + simpa [HahnSeries.Nonpositive.constantCoeff_apply] using hconstant + +private theorem isLUB_negativeSupport_translatedTruncation_of_cofinal_support + (b : Series K) {gamma : ℝ} {B : Set ℝ} + (hBSupport : B ⊆ (b : K⟦ℝ⟧).support) + (hBlt : ∀ x ∈ B, x < gamma) (hBLUB : IsLUB B gamma) : + IsLUB + (((translatedTruncation (b : K⟦ℝ⟧) gamma : Series K) : K⟦ℝ⟧).support ∩ + Set.Iio 0) 0 := by + have hshiftedLUB : IsLUB ((fun x ↦ -gamma + x) '' B) 0 := by + simpa using (OrderIso.addLeft (-gamma)).isLUB_image'.mpr hBLUB + have hshiftedSubset : (fun x ↦ -gamma + x) '' B ⊆ + ((translatedTruncation (b : K⟦ℝ⟧) gamma : Series K) : K⟦ℝ⟧).support ∩ + Set.Iio 0 := by + rintro delta ⟨x, hxB, rfl⟩ + have hxCoeff : (b : K⟦ℝ⟧).coeff x ≠ 0 := + (HahnSeries.mem_support _ _).mp (hBSupport hxB) + have hdelta0 : -gamma + x < 0 := by + linarith [hBlt x hxB] + constructor + · rw [HahnSeries.mem_support, coeff_translatedTruncation, ite_eq_left hdelta0.le] + simpa using hxCoeff + · exact hdelta0 + constructor + · intro delta hdelta + exact hdelta.2.le + · intro x hxUpper + apply hshiftedLUB.2 + intro delta hdelta + exact hxUpper (hshiftedSubset hdelta) + +private theorem exists_cofinal_final_block_of_orderType_eq_mul + {T : Set ℝ} (hT : T.IsPWO) (hT0 : T ⊆ Set.Iio 0) + (hTLUB : IsLUB T 0) {rho l : Ordinal} + (hrho : 0 < rho) (hl : Order.IsSuccLimit l) + (hTType : hT.orderType = rho * l) {a : ℝ} (ha : a < 0) : + ∃ (gamma : ℝ) (B : Set ℝ) (hB : B.IsPWO), + a < gamma ∧ gamma < 0 ∧ B ⊆ T ∧ hB.orderType = rho ∧ + IsLUB B gamma ∧ + ∀ {x}, x ∈ B → ∀ {y}, y ∈ T → x < y → y < gamma → y ∈ B := by + obtain ⟨z, hzT, haz, _⟩ := hTLUB.exists_between ha + let hBelow : (T ∩ Set.Iio z).IsPWO := hT.mono Set.inter_subset_left + have hBelowLt : hBelow.orderType < rho * l := by + rw [← hTType] + exact hT.orderType_inter_Iio_lt hzT + obtain ⟨c, hc, hBelowMul⟩ := + (Ordinal.lt_mul_iff_of_isSuccLimit hl).mp hBelowLt + let k := rho * Order.succ c + have hck : rho * c ≤ k := + mul_le_mul_right (Order.le_succ c) rho + have hBelowK : hBelow.orderType < k := hBelowMul.trans_le hck + have hkType : k < hT.orderType := by + rw [hTType] + exact mul_lt_mul_of_pos_left (hl.succ_lt hc) hrho + let d := hT.orderType - k + have hkd : k + d = hT.orderType := + Ordinal.add_sub_cancel_of_le hkType.le + obtain ⟨S, U, hS, hU, hST, hUT, hSU, hSType, hUType, hTUnion⟩ := + (hT.orderType_eq_add_iff k d).mp hkd.symm + have hzS : z ∈ S := by + have hzUnion : z ∈ S ∪ U := by + rw [← hTUnion] + exact hzT + rcases hzUnion with hzS | hzU + · exact hzS + · exfalso + have hSBelow : S ⊆ T ∩ Set.Iio z := by + intro x hxS + exact ⟨hST hxS, hSU x hxS z hzU⟩ + have hle := hS.orderType_mono hBelow hSBelow + rw [hSType] at hle + exact (not_lt_of_ge hle) hBelowK + have hSne : S.Nonempty := ⟨z, hzS⟩ + have hdne : d ≠ 0 := Ordinal.sub_ne_zero_iff_lt.mpr hkType + have hUne : U.Nonempty := by + apply Set.nonempty_iff_ne_empty.mpr + intro hUempty + have hzero := hU.orderType_eq_zero.mpr hUempty + rw [hUType] at hzero + exact hdne hzero + obtain ⟨u, huU⟩ := hUne + have hSbdd : BddAbove S := + ⟨u, fun x hxS ↦ (hSU x hxS u huU).le⟩ + let gamma := sSup S + have hSLUB : IsLUB S gamma := isLUB_csSup hSne hSbdd + have hgamma0 : gamma < 0 := + (hSLUB.2 fun x hxS ↦ (hSU x hxS u huU).le).trans_lt (hT0 (hUT huU)) + have hagamma : a < gamma := haz.trans_le (hSLUB.1 hzS) + have hSTypeSplit : hS.orderType = rho * c + rho := by + rw [hSType] + simp only [k, Ordinal.mul_succ] + obtain ⟨A, B, hA, hB, hAS, hBS, hAB, hAType, hBType, hSUnion⟩ := + (hS.orderType_eq_add_iff (rho * c) rho).mp hSTypeSplit + have hBne : B.Nonempty := by + apply Set.nonempty_iff_ne_empty.mpr + intro hBempty + have hzero := hB.orderType_eq_zero.mpr hBempty + rw [hBType] at hzero + exact hrho.ne' hzero + obtain ⟨b0, hb0B⟩ := hBne + have hBLUB : IsLUB B gamma := by + constructor + · intro x hxB + exact hSLUB.1 (hBS hxB) + · intro x hxUpper + apply hSLUB.2 + intro y hyS + rw [hSUnion] at hyS + rcases hyS with hyA | hyB + · exact (hAB y hyA b0 hb0B).le.trans (hxUpper hb0B) + · exact hxUpper hyB + refine ⟨gamma, B, hB, hagamma, hgamma0, hBS.trans hST, hBType, hBLUB, ?_⟩ + intro x hxB y hyT hxy hygamma + have hyUnion : y ∈ S ∪ U := by + rw [← hTUnion] + exact hyT + rcases hyUnion with hyS | hyU + · rw [hSUnion] at hyS + rcases hyS with hyA | hyB + · exfalso + exact (not_lt_of_ge (hAB y hyA x hxB).le) hxy + · exact hyB + · exfalso + have hgammaY : gamma ≤ y := + hSLUB.2 fun s hsS ↦ (hSU s hsS y hyU).le + exact (not_lt_of_ge hgammaY) hygamma + +private theorem ordinalValue_translatedTruncation_eq_of_cofinal_final_block + (b : Series K) {eta gamma : ℝ} (rho : NatOrdinal) + (hrhoPrincipal : Ordinal.IsAdditivelyPrincipal rho.val) + (hrho : 1 < rho) {B : Set ℝ} (hB : B.IsPWO) + (hBSub : B ⊆ negativeSupportTail b eta) + (hBType : hB.orderType = rho.val) (hBLUB : IsLUB B gamma) + (hgamma0 : gamma < 0) + (hfinal : ∀ {x}, x ∈ B → ∀ {y}, y ∈ negativeSupportTail b eta → + x < y → y < gamma → y ∈ B) : + ordinalValue (translatedTruncation (b : K⟦ℝ⟧) gamma) = rho := by + have hrhoVal : 1 < rho.val := NatOrdinal.one_lt_val.mpr hrho + have hrhoLimit : Order.IsSuccLimit rho.val := + hrhoPrincipal.isSuccLimit_of_one_lt hrhoVal + have hBOrderLimit : Order.IsSuccLimit hB.orderType := by + rw [hBType] + exact hrhoLimit + have hBne : B.Nonempty := by + apply Set.nonempty_iff_ne_empty.mpr + intro hBempty + have hzero := hB.orderType_eq_zero.mpr hBempty + rw [hBType] at hzero + exact (zero_lt_one.trans hrhoVal).ne' hzero + have hBlt : ∀ x ∈ B, x < gamma := by + intro x hxB + obtain ⟨y, hyB, hxy⟩ := + hB.exists_gt_of_isSuccLimit_orderType hBOrderLimit hxB + exact hxy.trans_le (hBLUB.1 hyB) + let q : Series K := translatedTruncation (b : K⟦ℝ⟧) gamma + have hqLUB : IsLUB ((q : K⟦ℝ⟧).support ∩ Set.Iio 0) 0 := by + apply isLUB_negativeSupport_translatedTruncation_of_cofinal_support b + (B := B) (gamma := gamma) + · exact fun _ hxB ↦ negativeSupportTail_subset_support b eta (hBSub hxB) + · exact hBlt + · exact hBLUB + have hqValue : 1 < ordinalValue q := + one_lt_ordinalValue_of_isLUB_negativeSupport hqLUB + obtain ⟨theta, htheta, hstable⟩ := + exists_forall_later_negativeSupportTail_orderType_eq_ordinalValue q hqValue + obtain ⟨b0, hb0B⟩ := hBne + have hb0gamma : b0 < gamma := hBlt b0 hb0B + have hthetaGamma : gamma + theta < gamma := by linarith + have hmaxGamma : max (gamma + theta) b0 < gamma := + max_lt hthetaGamma hb0gamma + obtain ⟨x, hxB, hmaxX, _⟩ := hBLUB.exists_between hmaxGamma + have hxgamma : x < gamma := hBlt x hxB + let xi := x - gamma + have hthetaXi : theta < xi := by + have hgammaThetaX : gamma + theta < x := + (le_max_left (gamma + theta) b0).trans_lt hmaxX + dsimp only [xi] + linarith + have hxi0 : xi < 0 := by + dsimp only [xi] + linarith + let BFinal := B ∩ Set.Ioi x + let hBFinal : BFinal.IsPWO := hB.mono Set.inter_subset_left + have hBUpper : ∃ y ∈ B, x < y := + hB.exists_gt_of_isSuccLimit_orderType hBOrderLimit hxB + have hBPrincipal : Ordinal.IsPrincipal (fun a b ↦ a + b) hB.orderType := by + rw [hBType] + exact + (Ordinal.isAdditivelyPrincipal_iff_ne_zero_and_isPrincipal_add.mp + hrhoPrincipal).2 + have hBFinalType : hBFinal.orderType = hB.orderType := + hB.orderType_inter_Ioi_eq_of_isPrincipal hBPrincipal hBUpper + have hsupport : negativeSupportTail q xi = + (fun y ↦ -gamma + y) '' BFinal := by + ext delta + constructor + · intro hdelta + obtain ⟨hdeltaSupport, hxiDelta, hdelta0⟩ := + mem_negativeSupportTail_iff.mp hdelta + rw [support_translatedTruncation] at hdeltaSupport + obtain ⟨y, hySupport, hdelta⟩ := hdeltaSupport + have hxy : x < y := by + dsimp only [xi] at hxiDelta + linarith + have hygamma : y < gamma := by linarith + have hyTail : y ∈ negativeSupportTail b eta := by + apply mem_negativeSupportTail_iff.mpr + exact ⟨hySupport.1, + (mem_negativeSupportTail_iff.mp (hBSub hxB)).2.1.trans hxy, + hygamma.trans hgamma0⟩ + have hyB : y ∈ B := hfinal hxB hyTail hxy hygamma + exact ⟨y, ⟨hyB, hxy⟩, hdelta⟩ + · rintro ⟨y, ⟨hyB, hxy⟩, rfl⟩ + change x < y at hxy + have hygamma : y < gamma := hBlt y hyB + apply mem_negativeSupportTail_iff.mpr + constructor + · rw [support_translatedTruncation] + exact ⟨y, + ⟨negativeSupportTail_subset_support b eta (hBSub hyB), hygamma.le⟩, rfl⟩ + · constructor + · dsimp only [xi] + linarith + · linarith + let hShifted : ((fun y ↦ -gamma + y) '' BFinal).IsPWO := + hBFinal.image_of_monotone (OrderIso.addLeft (-gamma)).monotone + let hQTail : (negativeSupportTail q xi).IsPWO := + (q : K⟦ℝ⟧).isPWO_support.mono (negativeSupportTail_subset_support q xi) + apply NatOrdinal.val.injective + calc + (ordinalValue (translatedTruncation (b : K⟦ℝ⟧) gamma)).val = + (ordinalValue q).val := rfl + _ = hQTail.orderType := (hstable xi hthetaXi hxi0).symm + _ = hShifted.orderType := hQTail.orderType_congr hShifted hsupport + _ = hBFinal.orderType := + hBFinal.orderType_image_of_strictMonoOn + ((OrderIso.addLeft (-gamma)).strictMono.strictMonoOn BFinal) + _ = hB.orderType := hBFinalType + _ = rho.val := hBType + +private theorem residualPointSet_isLUB_zero_of_residualValue_eq_one + (b : SeriesWithOrdinalValueAboveOne K) (hresidual : b.residualValue = 1) : + IsLUB (residualPointSet b) 0 := by + obtain ⟨eta, heta, _⟩ := + exists_negativeSupportTail_orderType_eq_ordinalValue b.1 b.2 + have htailLUB := + isLUB_negativeSupportTail_zero_of_one_lt_ordinalValue b.1 b.2 heta + refine ⟨fun _ hx ↦ (residualPointSet_subset_Iio b hx).le, ?_⟩ + intro a ha + apply le_of_not_gt + intro ha0 + obtain ⟨z, hzTail, haz, _⟩ := htailLUB.exists_between ha0 + have hzTail' := mem_negativeSupportTail_iff.mp hzTail + obtain ⟨w, hwTail, hzw, _⟩ := htailLUB.exists_between hzTail'.2.2 + let laterSupport := negativeSupportTail b.1 eta ∩ Set.Ioi z + have hlaterPWO : laterSupport.IsPWO := + (b.1 : K⟦ℝ⟧).isPWO_support.mono fun _ hx ↦ + negativeSupportTail_subset_support b.1 eta hx.1 + have hwLater : w ∈ laterSupport := ⟨hwTail, hzw⟩ + obtain ⟨y, hyMinimal⟩ := hlaterPWO.exists_minimal ⟨w, hwLater⟩ + have hyTail : y ∈ negativeSupportTail b.1 eta := hyMinimal.1.1 + have hyTail' := mem_negativeSupportTail_iff.mp hyTail + have hzy : z < y := hyMinimal.1.2 + have hgap : (b.1 : K⟦ℝ⟧).support ∩ Set.Ioo z y = ∅ := by + apply Set.eq_empty_iff_forall_notMem.mpr + intro x hx + have hxLater : x ∈ laterSupport := by + refine ⟨?_, hx.2.1⟩ + apply mem_negativeSupportTail_iff.mpr + exact ⟨hx.1, hzTail'.2.1.trans hx.2.1, hx.2.2.trans hyTail'.2.2⟩ + exact (not_lt_of_ge (hyMinimal.le hxLater)) hx.2.2 + have hyValue : ordinalValue (translatedTruncation (b.1 : K⟦ℝ⟧) y) = 1 := + ordinalValue_translatedTruncation_eq_one_of_isolatedBelow b.1 hyTail'.1 hzy hgap + have hyResidual : y ∈ residualPointSet b := by + apply mem_residualPointSet_iff.mpr + exact ⟨hyTail'.2.2, hyValue.trans hresidual.symm⟩ + exact (not_lt_of_ge (ha hyResidual)) (haz.trans hzy) + +private theorem residualPointSet_isLUB_zero_of_one_lt_residualValue + (b : SeriesWithOrdinalValueAboveOne K) (hresidual : 1 < b.residualValue) : + IsLUB (residualPointSet b) 0 := by + obtain ⟨eta, heta, hstable⟩ := + exists_negativeSupportTail_orderType_eq_ordinalValue b.1 b.2 + let T := negativeSupportTail b.1 eta + let hT : T.IsPWO := + (b.1 : K⟦ℝ⟧).isPWO_support.mono (negativeSupportTail_subset_support b.1 eta) + have hT0 : T ⊆ Set.Iio 0 := fun _ hx ↦ + (mem_negativeSupportTail_iff.mp hx).2.2 + have hTLUB : IsLUB T 0 := + isLUB_negativeSupportTail_zero_of_one_lt_ordinalValue b.1 b.2 heta + have hTType : hT.orderType = + b.residualValue.val * b.principalValue.val := + hstable.trans b.residualValue_val_mul_principalValue_val.symm + have hresidualVal : 1 < b.residualValue.val := + NatOrdinal.one_lt_val.mpr hresidual + have hresidualPos : 0 < b.residualValue.val := + zero_lt_one.trans hresidualVal + have hprincipalLimit : Order.IsSuccLimit b.principalValue.val := + b.principalValue_isInfiniteMultiplicativelyPrincipal.isSuccLimit + refine ⟨fun _ hx ↦ (residualPointSet_subset_Iio b hx).le, ?_⟩ + intro a haUpper + apply le_of_not_gt + intro ha0 + have hmax0 : max a eta < 0 := max_lt ha0 heta + obtain ⟨gamma, B, hB, hmaxGamma, hgamma0, hBSub, hBType, hBLUB, hfinal⟩ := + exists_cofinal_final_block_of_orderType_eq_mul hT hT0 hTLUB + hresidualPos hprincipalLimit hTType hmax0 + have hgammaValue : + ordinalValue (translatedTruncation (b.1 : K⟦ℝ⟧) gamma) = b.residualValue := + ordinalValue_translatedTruncation_eq_of_cofinal_final_block b.1 b.residualValue + b.residualValue_isAdditivelyPrincipal hresidual hB hBSub hBType hBLUB + hgamma0 hfinal + have hgammaResidual : gamma ∈ residualPointSet b := + mem_residualPointSet_iff.mpr ⟨hgamma0, hgammaValue⟩ + have hagamma : a < gamma := + (le_max_left a eta).trans_lt hmaxGamma + exact (not_lt_of_ge (haUpper hgammaResidual)) hagamma + +/-- The residual-point set has zero as its least upper bound. This is the cofinality conclusion in +the first part of Berarducci, Lemma 6.8. -/ +theorem residualPointSet_isLUB_zero (b : SeriesWithOrdinalValueAboveOne K) : + IsLUB (residualPointSet b) 0 := by + have honeLe : 1 ≤ b.residualValue := by + rw [Order.one_le_iff_pos] + exact pos_iff_ne_zero.mpr b.residualValue_ne_zero + rcases honeLe.eq_or_lt with hone | hone + · exact residualPointSet_isLUB_zero_of_residualValue_eq_one b hone.symm + · exact residualPointSet_isLUB_zero_of_one_lt_residualValue b hone + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/ResidualPointOrderType.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/ResidualPointOrderType.lean new file mode 100644 index 0000000000..595e6c2704 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/ResidualPointOrderType.lean @@ -0,0 +1,650 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.ResidualPointTail +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.StableInterval +public import Mathlib.Topology.MetricSpace.Pseudo.Defs + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValueFinalSegment +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.ResidualPointCofinality +import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.OrderedUnion +import LeanPool.ConwayRefinement.ConwayRefinement.Topology.Order.LeftNeighborhood +import Mathlib.Topology.Instances.Real.Lemmas + +/-! +# The residual-point tail order type + +The order-type computation in Berarducci, Lemma 6.8: on a stable interval, the ordinary order type +of a residual-point tail is exactly `v_J^p(b)`. + +The support of `b` restricted to the stable interval is covered by the truncations at the residual +points of the tail. Every residual point has translated-truncation value `v_J^r(b)`, so every +nonempty final segment of each piece has order type at least `v_J^r(b)`, and consecutive pieces +are strictly separated because the truncation at a residual point has support supremum zero. The +ordered-union estimate of Berarducci, Lemma 4.7 then bounds `v_J^r(b) * λ` by the order type of +the stable interval, which is `v_J^r(b) * v_J^p(b)`, and left cancellation gives `λ ≤ v_J^p(b)`. + +The residual value one is treated separately: the pieces are then closed at their right endpoint, +since a residual point of value one is an isolated support point and admits no support point +immediately below it, and the final-segment hypothesis is the trivial nonemptiness bound. + +For the reverse bound the source constructs, for each `α < v_J^p(b)`, the supremum of the first +`v_J^r(b) * (α + 1)` elements of the stable interval and asserts that it is a residual point. That +construction can fail when `v_J^r(b) = 1` and `α` is a limit: the supremum is then the `α`-th +support point, which need not be isolated from below. If it is a limit of earlier support points, +as at the final point of a support block of order type `ω + 1`, its translated truncation has +value above one. Thus the printed construction does not establish the asserted residuality in +general. The conclusion is unaffected, and this module proves it by splitting on the residual +value. For residual value above one the printed construction is used, and the first +`v_J^r(b) * (α + 1)` elements have limit order type, so their supremum is not attained and every +window below it is a nonempty final segment of order type at least `v_J^r(b)`. For residual value +one the residual points are exactly the isolated support points, and the successor-indexed support +points supply a strictly increasing family of the required order type, which is Berarducci, +Lemma 4.6. +-/ + +universe v + +public noncomputable section + +open Ordinal HahnSeries + +namespace Berarducci + +variable {K : Type v} [Field K] + +/-- The residual points of a tail accumulate at `0`, so every residual point of the tail has a +larger one, and the ordinary order type of the tail is a limit ordinal. -/ +private theorem residualPointTail_orderType_isSuccLimit + (b : SeriesWithOrdinalValueAboveOne K) (hX : (residualPointSet b).IsPWO) + {η : ℝ} (hη : η < 0) : + Order.IsSuccLimit (residualPointTail_isPWO b η hX).orderType := by + obtain ⟨htailNe, htailLUB⟩ := + residualPointTail_nonempty_and_isLUB b hη (residualPointSet_isLUB_zero b) + refine Set.IsPWO.isSuccLimit_orderType_of_forall_exists_gt _ htailNe fun x hx ↦ ?_ + have hx0 : x < 0 := + residualPointSet_subset_Iio b (residualPointTail_subset_residualPointSet b η hx) + obtain ⟨y, hy, hxy, _⟩ := htailLUB.exists_between hx0 + exact ⟨y, hy, hxy⟩ + +/-- Between a point `θ` and a residual point `γ' > θ` there is a support point of `b` in the +half-open interval `(θ, γ']`, because the translated truncation at a residual point has support +supremum `0`. -/ +private theorem exists_mem_support_Ioc_of_lt_of_mem_residualPointSet + (b : SeriesWithOrdinalValueAboveOne K) {θ γ' : ℝ} (hγ' : γ' ∈ residualPointSet b) + (hθ : θ < γ') : ∃ y ∈ (b.1 : K⟦ℝ⟧).support, θ < y ∧ y ≤ γ' := by + have hsup := supportSup_translatedTruncation_eq_zero_of_mem_residualPointSet hγ' + have hLUB := (HahnSeries.Nonpositive.supportSup_eq_coe_iff.mp hsup).2 + have hcut : θ - γ' < 0 := sub_neg.mpr hθ + obtain ⟨δ, hδ, hδabove, _⟩ := hLUB.exists_between hcut + rw [support_translatedTruncation] at hδ + obtain ⟨y, hy, hyeq⟩ := hδ + rw [← hyeq] at hδabove + refine ⟨y, hy.1, ?_, hy.2⟩ + change -γ' + y > θ - γ' at hδabove + linarith + +/-- If the translated truncation at `γ'` has ordinal value above one, then between a point +`θ < γ'` and `γ'` there is a support point of `b` in the open interval `(θ, γ')`, because the +negative support of that truncation has supremum `0`. -/ +private theorem exists_mem_support_Ioo_of_lt_of_one_lt_ordinalValue + (b : SeriesWithOrdinalValueAboveOne K) {θ γ' : ℝ} + (hγ' : 1 < ordinalValue (translatedTruncation (b.1 : K⟦ℝ⟧) γ')) (hθ : θ < γ') : + ∃ y ∈ (b.1 : K⟦ℝ⟧).support, θ < y ∧ y < γ' := by + have hLUB := isLUB_negativeSupport_zero_of_one_lt_ordinalValue hγ' + have hcut : θ - γ' < 0 := sub_neg.mpr hθ + obtain ⟨δ, hδ, hδabove, _⟩ := hLUB.exists_between hcut + rw [support_translatedTruncation] at hδ + obtain ⟨⟨y, hy, hyeq⟩, hδneg⟩ := hδ + rw [← hyeq] at hδabove hδneg + refine ⟨y, hy.1, ?_, ?_⟩ + · change -γ' + y > θ - γ' at hδabove + linarith + · change -γ' + y < 0 at hδneg + linarith + +/-- A nonempty final segment of the support of `b` in `(η, γ')`, for a residual point `γ'`, has +order type at least the residual value: it is a final segment of the support below `γ'`, and +those have order type at least the value of the translated truncation at `γ'`. -/ +private theorem residualValue_le_orderType_of_isRelUpperSet_support_Ioo + (b : SeriesWithOrdinalValueAboveOne K) {η γ' : ℝ} (hγ' : γ' ∈ residualPointSet b) + {C : Set ℝ} (hC : IsRelUpperSet C (· ∈ (b.1 : K⟦ℝ⟧).support ∩ Set.Ioo η γ')) + (hCne : C.Nonempty) : + b.residualValue.val ≤ + ((b.1 : K⟦ℝ⟧).isPWO_support.mono fun _ hx ↦ (hC hx).1.1).orderType := by + have hC' : IsRelUpperSet C (· ∈ (b.1 : K⟦ℝ⟧).support ∩ Set.Iio γ') := by + intro a ha + obtain ⟨haB, hup⟩ := hC ha + refine ⟨⟨haB.1, haB.2.2⟩, ?_⟩ + intro d had hd + exact hup had ⟨hd.1, haB.2.1.trans_le had, hd.2⟩ + have hbound := + le_orderType_of_le_ordinalValue_translatedTruncation_of_isRelUpperSet_supportBelow + (b.1 : K⟦ℝ⟧) γ' (ρ := b.residualValue.val) + (by rw [(mem_residualPointSet_iff.mp hγ').2]; simp) hC' hCne + exact hbound.trans_eq (Set.IsPWO.orderType_proof_irrel _ _) + +/-- The ordered-union estimate of Berarducci, Lemma 4.7, for residual value one. Given a strictly +increasing family `γ : l.ToType → ℝ` of residual points of the tail above `η`, with `l` a limit, +the pieces `supp(b) ∩ (η, γ i]` are nonempty and strictly separated, since between two residual +points there is a support point; so `1 ⬝ l` is at most the order type of the support of `b` on +`(η, 0)`. -/ +private theorem residualValue_mul_le_orderType_negativeSupportTail_of_eq_one + (b : SeriesWithOrdinalValueAboveOne K) {η : ℝ} (hρ1 : b.residualValue = 1) + {l : Ordinal} (hl : Order.IsSuccLimit l) (γ : l.ToType → ℝ) (hγmono : StrictMono γ) + (hγtail : ∀ i, γ i ∈ residualPointTail b η) : + b.residualValue.val * l ≤ + ((b.1 : K⟦ℝ⟧).isPWO_support.mono + (negativeSupportTail_subset_support b.1 η)).orderType := by + have hγX : ∀ i, γ i ∈ residualPointSet b := fun i ↦ + residualPointTail_subset_residualPointSet b η (hγtail i) + have hγneg : ∀ i, γ i < 0 := fun i ↦ residualPointSet_subset_Iio b (hγX i) + have hγη : ∀ i, η < γ i := fun i ↦ (mem_residualPointTail_iff.mp (hγtail i)).2 + set B : l.ToType → Set ℝ := + fun i ↦ (b.1 : K⟦ℝ⟧).support ∩ Set.Ioc η (γ i) with hBdef + have hB : ∀ i, (B i).IsPWO := fun _ ↦ + (b.1 : K⟦ℝ⟧).isPWO_support.mono Set.inter_subset_left + have hUnionSub : (⋃ i, B i) ⊆ negativeSupportTail b.1 η := by + intro x hx + obtain ⟨i, hi⟩ := Set.mem_iUnion.mp hx + exact mem_negativeSupportTail_iff.mpr + ⟨hi.1, hi.2.1, hi.2.2.trans_lt (hγneg i)⟩ + have hUnion : (⋃ i, B i).IsPWO := + (b.1 : K⟦ℝ⟧).isPWO_support.mono + (hUnionSub.trans (negativeSupportTail_subset_support b.1 η)) + have hsep : ∀ {i j : l.ToType}, i < j → ∃ y ∈ B j, ∀ x ∈ B i, x < y := by + intro i j hij + obtain ⟨y, hy, hγiy, hyγj⟩ := + exists_mem_support_Ioc_of_lt_of_mem_residualPointSet b (hγX j) (hγmono hij) + exact ⟨y, ⟨hy, (hγη i).trans hγiy, hyγj⟩, fun x hx ↦ hx.2.2.trans_lt hγiy⟩ + have hfinal : ∀ (i : l.ToType) (C : Set ℝ) + (hC : IsRelUpperSet C (· ∈ B i)), C.Nonempty → + b.residualValue.val ≤ ((hB i).mono fun _ hx ↦ (hC hx).1).orderType := by + intro i C hC hCne + rw [hρ1] + change (1 : Ordinal) ≤ _ + rw [Order.one_le_iff_ne_zero] + intro hzero + obtain ⟨x, hx⟩ := hCne + have := ((hB i).mono fun _ hx ↦ (hC hx).1).orderType_eq_zero.mp hzero + rw [this] at hx + exact hx + calc b.residualValue.val * l + ≤ hUnion.orderType := + Set.IsPWO.mul_le_orderType_iUnion_of_isSuccLimit hl B hB hsep hfinal hUnion + _ ≤ ((b.1 : K⟦ℝ⟧).isPWO_support.mono + (negativeSupportTail_subset_support b.1 η)).orderType := + hUnion.orderType_mono _ hUnionSub + +/-- The ordered-union estimate of Berarducci, Lemma 4.7, for residual value above one. Given a +strictly increasing family `γ : l.ToType → ℝ` of residual points of the tail above `η`, with `l` +a limit, the pieces `supp(b) ∩ (η, γ i)` are strictly separated, since the negative support of +the truncation at a residual point accumulates at `0`, and every nonempty final segment of a +piece has order type at least the residual value; so `v_J^r(b) ⬝ l` is at most the order type of +the support of `b` on `(η, 0)`. -/ +private theorem residualValue_mul_le_orderType_negativeSupportTail_of_one_lt + (b : SeriesWithOrdinalValueAboveOne K) {η : ℝ} (h1ρ : 1 < b.residualValue) + {l : Ordinal} (hl : Order.IsSuccLimit l) (γ : l.ToType → ℝ) (hγmono : StrictMono γ) + (hγtail : ∀ i, γ i ∈ residualPointTail b η) : + b.residualValue.val * l ≤ + ((b.1 : K⟦ℝ⟧).isPWO_support.mono + (negativeSupportTail_subset_support b.1 η)).orderType := by + have hγX : ∀ i, γ i ∈ residualPointSet b := fun i ↦ + residualPointTail_subset_residualPointSet b η (hγtail i) + have hγneg : ∀ i, γ i < 0 := fun i ↦ residualPointSet_subset_Iio b (hγX i) + have hγη : ∀ i, η < γ i := fun i ↦ (mem_residualPointTail_iff.mp (hγtail i)).2 + have hvalueOne : ∀ i, 1 < ordinalValue (translatedTruncation (b.1 : K⟦ℝ⟧) (γ i)) := by + intro i + rw [(mem_residualPointSet_iff.mp (hγX i)).2] + exact h1ρ + set B : l.ToType → Set ℝ := + fun i ↦ (b.1 : K⟦ℝ⟧).support ∩ Set.Ioo η (γ i) with hBdef + have hB : ∀ i, (B i).IsPWO := fun _ ↦ + (b.1 : K⟦ℝ⟧).isPWO_support.mono Set.inter_subset_left + have hUnionSub : (⋃ i, B i) ⊆ negativeSupportTail b.1 η := by + intro x hx + obtain ⟨i, hi⟩ := Set.mem_iUnion.mp hx + exact mem_negativeSupportTail_iff.mpr + ⟨hi.1, hi.2.1, hi.2.2.trans (hγneg i)⟩ + have hUnion : (⋃ i, B i).IsPWO := + (b.1 : K⟦ℝ⟧).isPWO_support.mono + (hUnionSub.trans (negativeSupportTail_subset_support b.1 η)) + have hsep : ∀ {i j : l.ToType}, i < j → ∃ y ∈ B j, ∀ x ∈ B i, x < y := by + intro i j hij + obtain ⟨y, hy, hγiy, hyγj⟩ := + exists_mem_support_Ioo_of_lt_of_one_lt_ordinalValue b (hvalueOne j) (hγmono hij) + exact ⟨y, ⟨hy, (hγη i).trans hγiy, hyγj⟩, fun x hx ↦ hx.2.2.trans hγiy⟩ + have hfinal : ∀ (i : l.ToType) (C : Set ℝ) + (hC : IsRelUpperSet C (· ∈ B i)), C.Nonempty → + b.residualValue.val ≤ ((hB i).mono fun _ hx ↦ (hC hx).1).orderType := + fun i C hC hCne ↦ + (residualValue_le_orderType_of_isRelUpperSet_support_Ioo b (hγX i) hC hCne).trans_eq + (Set.IsPWO.orderType_proof_irrel _ _) + calc b.residualValue.val * l + ≤ hUnion.orderType := + Set.IsPWO.mul_le_orderType_iUnion_of_isSuccLimit hl B hB hsep hfinal hUnion + _ ≤ ((b.1 : K⟦ℝ⟧).isPWO_support.mono + (negativeSupportTail_subset_support b.1 η)).orderType := + hUnion.orderType_mono _ hUnionSub + +/-- The ordered-union estimate for a residual-point tail: the residual value times the ordinary +order type of the tail is at most the order type of the support of `b` on `(η, 0)`. The tail is +enumerated by its order type, a limit, and the estimate splits on the residual value. -/ +private theorem residualValue_mul_residualPointTail_orderType_le + (b : SeriesWithOrdinalValueAboveOne K) (hX : (residualPointSet b).IsPWO) + {η : ℝ} (hη : η < 0) : + b.residualValue.val * (residualPointTail_isPWO b η hX).orderType ≤ + ((b.1 : K⟦ℝ⟧).isPWO_support.mono + (negativeSupportTail_subset_support b.1 η)).orderType := by + classical + have hlimit := residualPointTail_orderType_isSuccLimit b hX hη + obtain ⟨e⟩ := (residualPointTail_isPWO b η hX).nonempty_orderIso_toType + have hγmono : StrictMono fun i ↦ (e i).1 := fun i j hij ↦ e.strictMono hij + have hγtail : ∀ i, (e i).1 ∈ residualPointTail b η := fun i ↦ (e i).2 + rcases (Order.one_le_iff_ne_zero.mpr b.residualValue_ne_zero).lt_or_eq with hρ | hρ + · exact residualValue_mul_le_orderType_negativeSupportTail_of_one_lt b hρ hlimit _ + hγmono hγtail + · exact residualValue_mul_le_orderType_negativeSupportTail_of_eq_one b hρ.symm hlimit _ + hγmono hγtail + +/-- The upper bound of Berarducci, Lemma 6.8: on a stable interval the residual-point tail has +ordinary order type at most the principal value. The ordered-union estimate bounds +`v_J^r(b) ⬝ λ` by the order type `v_J^r(b) ⬝ v_J^p(b)` of the stable interval, and left +multiplication by the nonzero residual value is strictly increasing. -/ +theorem residualPointTail_orderType_le + (b : SeriesWithOrdinalValueAboveOne K) (hX : (residualPointSet b).IsPWO) + {η : ℝ} (hη : η < 0) + (hstable : ((b.1 : K⟦ℝ⟧).isPWO_support.mono + (negativeSupportTail_subset_support b.1 η)).orderType = (ordinalValue b.1).val) : + (residualPointTail_isPWO b η hX).orderType ≤ b.principalValue.val := by + have hρpos : 0 < b.residualValue.val := by + rw [pos_iff_ne_zero] + intro h + exact b.residualValue_ne_zero (NatOrdinal.val.injective (by simpa using h)) + have hkey := residualValue_mul_residualPointTail_orderType_le b hX hη + rw [hstable, ← b.residualValue_val_mul_principalValue_val] at hkey + exact (Ordinal.isNormal_mul_right hρpos).strictMono.le_iff_le.mp hkey + +/-- The supremum of a proper initial segment of limit order type. Let `S ⊆ ℝ` be partially +well-ordered and `κ < ot(S)` a limit ordinal. The initial segment of `S` of order type `κ` has +no greatest element, so its supremum `γ` is not attained: the segment is `S ∩ (-∞, γ)`, it is +nonempty, `γ` is its least upper bound, and some element of `S` lies weakly above `γ`. -/ +private theorem exists_isLUB_orderType_inter_Iio_eq_of_isSuccLimit + {S : Set ℝ} (hS : S.IsPWO) {κ : Ordinal} (hκ : Order.IsSuccLimit κ) + (hκlt : κ < hS.orderType) : + ∃ γ : ℝ, (S ∩ Set.Iio γ).Nonempty ∧ IsLUB (S ∩ Set.Iio γ) γ ∧ (∃ y ∈ S, γ ≤ y) ∧ + (hS.mono (s := S ∩ Set.Iio γ) Set.inter_subset_left).orderType = κ := by + obtain ⟨x, hxS, hxot⟩ := hS.exists_orderType_inter_Iio_eq hκlt + set I := S ∩ Set.Iio x with hIdef + set hI := hS.mono (s := I) Set.inter_subset_left with hIpwo + have hIot : hI.orderType = κ := hxot + have hIne : I.Nonempty := by + rw [Set.nonempty_iff_ne_empty] + intro hempty + have hzero : hI.orderType = 0 := hI.orderType_eq_zero.mpr hempty + rw [hIot] at hzero + exact hκ.ne_bot (by simpa using hzero) + have hInomax : ∀ y ∈ I, ∃ z ∈ I, y < z := fun y hy ↦ + hI.exists_gt_of_isSuccLimit_orderType (by rw [hIot]; exact hκ) hy + have hIbdd : BddAbove I := ⟨x, fun y hy ↦ le_of_lt hy.2⟩ + set γ := sSup I with hγdef + have hle : ∀ y ∈ I, y ≤ γ := fun y hy ↦ le_csSup hIbdd hy + have hlt : ∀ y ∈ I, y < γ := by + intro y hy + obtain ⟨z, hz, hyz⟩ := hInomax y hy + exact hyz.trans_le (hle z hz) + have hSIio : S ∩ Set.Iio γ = I := by + ext y + constructor + · rintro ⟨hyS, hyγ⟩ + by_contra hyI + have hub : ∀ z ∈ I, z ≤ y := by + intro z hz + by_contra hzy + exact hyI ⟨hyS, lt_trans (lt_of_not_ge hzy) hz.2⟩ + exact absurd (csSup_le hIne hub) (not_le.mpr hyγ) + · exact fun hy ↦ ⟨hy.1, hlt y hy⟩ + refine ⟨γ, ?_, ?_, ⟨x, hxS, csSup_le hIne fun y hy ↦ le_of_lt hy.2⟩, ?_⟩ + · rw [hSIio] + exact hIne + · rw [hSIio] + exact isLUB_csSup hIne hIbdd + · rw [Set.IsPWO.orderType_congr _ hI hSIio, hIot] + +/-- The upper bound on the value at the supremum. Let `I = S ∩ (-∞, γ)` be an initial segment +of the stable interval `S` of order type `ρ ⬝ (α + 1)`, with `ρ` a limit and `γ ≤ 0`. Then `I` +splits at the point `w` with `ot(S ∩ (-∞, w)) = ρ ⬝ α` into its first `ρ ⬝ α` elements and a +final segment of order type `ρ`; the window `S ∩ (w, γ)` is therefore a nonempty final segment of +the support below `γ` of order type at most `ρ`, which bounds the value of the translated +truncation at `γ`. -/ +private theorem ordinalValue_translatedTruncation_val_le_of_orderType_inter_Iio_eq + (b : SeriesWithOrdinalValueAboveOne K) {η γ : ℝ} {ρ α : Ordinal} + (hρ0 : 0 < ρ) (hρlimit : Order.IsSuccLimit ρ) (hγ0 : γ ≤ 0) + (hIot : (((b.1 : K⟦ℝ⟧).isPWO_support.mono + (negativeSupportTail_subset_support b.1 η)).mono + (s := negativeSupportTail b.1 η ∩ Set.Iio γ) Set.inter_subset_left).orderType = + ρ * (α + 1)) : + (ordinalValue (translatedTruncation (b.1 : K⟦ℝ⟧) γ)).val ≤ ρ := by + classical + set S := negativeSupportTail b.1 η with hSdef + set hS := ((b.1 : K⟦ℝ⟧).isPWO_support.mono + (negativeSupportTail_subset_support b.1 η)) with hSpwo + set I := S ∩ Set.Iio γ with hIdef + set hI := hS.mono (s := I) Set.inter_subset_left with hIpwo + have hsucc : ρ * α < ρ * (α + 1) := + (Ordinal.isNormal_mul_right hρ0).strictMono (lt_add_one α) + have hραlt : ρ * α < hS.orderType := + hsucc.trans_le (hIot.symm.le.trans (hI.orderType_mono hS Set.inter_subset_left)) + obtain ⟨w, hwS, hwot⟩ := hS.exists_orderType_inter_Iio_eq hραlt + have hwγ : w < γ := by + by_contra hγw + have hsub : I ⊆ S ∩ Set.Iio w := + fun y hy ↦ ⟨hy.1, lt_of_lt_of_le hy.2 (not_lt.mp hγw)⟩ + have := hI.orderType_mono (hS.mono (s := S ∩ Set.Iio w) Set.inter_subset_left) hsub + rw [hIot, hwot] at this + exact absurd this (not_le.mpr hsucc) + have hwI : w ∈ I := ⟨hwS, hwγ⟩ + have hIiow : I ∩ Set.Iio w = S ∩ Set.Iio w := by + ext y + exact ⟨fun hy ↦ ⟨hy.1.1, hy.2⟩, fun hy ↦ ⟨⟨hy.1, lt_trans hy.2 hwγ⟩, hy.2⟩⟩ + let : WellFoundedLT I := hI.isWF + have hsplit := hI.orderType_inter_Iio_add_inter_Ici hwI + have hIiowot : (hI.mono (s := I ∩ Set.Iio w) Set.inter_subset_left).orderType = ρ * α := by + rw [Set.IsPWO.orderType_congr _ (hS.mono (s := S ∩ Set.Iio w) Set.inter_subset_left) hIiow] + exact hwot + rw [hIiowot, hIot, mul_add_one] at hsplit + have hIciwot : (hI.mono (s := I ∩ Set.Ici w) Set.inter_subset_left).orderType = ρ := + (add_left_cancel hsplit) + have hCeq : S ∩ Set.Ioo w γ = I ∩ Set.Ioi w := by + ext y + exact ⟨fun ⟨hyS, hwy, hyγ⟩ ↦ ⟨⟨hyS, hyγ⟩, hwy⟩, fun ⟨hyI, hwy⟩ ↦ ⟨hyI.1, hwy, hyI.2⟩⟩ + have hCne : (S ∩ Set.Ioo w γ).Nonempty := by + have hwT : w ∈ I ∩ Set.Ici w := ⟨hwI, le_refl w⟩ + obtain ⟨z, hz, hwz⟩ := Set.IsPWO.exists_gt_of_isSuccLimit_orderType + (hI.mono (s := I ∩ Set.Ici w) Set.inter_subset_left) + (by rw [hIciwot]; exact hρlimit) hwT + exact ⟨z, by rw [hCeq]; exact ⟨hz.1, hwz⟩⟩ + have hCupper : IsRelUpperSet (S ∩ Set.Ioo w γ) + (· ∈ (b.1 : K⟦ℝ⟧).support ∩ Set.Iio γ) := by + rintro a ⟨haS, hwa, haγ⟩ + refine ⟨⟨(mem_negativeSupportTail_iff.mp haS).1, haγ⟩, ?_⟩ + rintro d had ⟨hdsupp, hdγ⟩ + exact ⟨mem_negativeSupportTail_iff.mpr + ⟨hdsupp, lt_of_lt_of_le (mem_negativeSupportTail_iff.mp haS).2.1 had, + lt_of_lt_of_le hdγ hγ0⟩, lt_of_lt_of_le hwa had, hdγ⟩ + refine (ordinalValue_translatedTruncation_le_orderType_of_isRelUpperSet_supportBelow + (b.1 : K⟦ℝ⟧) γ hCupper hCne).trans ?_ + have hCsub : S ∩ Set.Ioo w γ ⊆ I ∩ Set.Ici w := by + rw [hCeq] + exact fun y hy ↦ ⟨hy.1, Set.mem_Ici.mpr (le_of_lt hy.2)⟩ + calc ((b.1 : K⟦ℝ⟧).isPWO_support.mono fun _ hx ↦ (hCupper hx).1.1).orderType + ≤ (hI.mono (s := I ∩ Set.Ici w) Set.inter_subset_left).orderType := + Set.IsPWO.orderType_mono _ _ hCsub + _ = ρ := hIciwot + +/-- The lower bound on the value at the supremum. Let `γ` be the least upper bound of the initial +segment `I = S ∩ (-∞, γ)` of the stable interval `S`, of order type `ρ ⬝ (α + 1)` with `ρ` +additive principal. Every window `(θ, γ)` contains a final segment `I ∩ [z, γ)` of `I`, whose +order type is at least `ρ`, because `ot(I ∩ (-∞, z)) + ot(I ∩ [z, γ)) = ρ ⬝ (α + 1)` with the +first summand strictly smaller; so the value of the translated truncation at `γ` is at least +`ρ`. -/ +private theorem le_ordinalValue_translatedTruncation_of_isLUB_of_orderType_inter_Iio_eq + (b : SeriesWithOrdinalValueAboveOne K) {η γ : ℝ} {ρ α : Ordinal} + (hρprin : Ordinal.IsAdditivelyPrincipal ρ) + (hLUB : IsLUB (negativeSupportTail b.1 η ∩ Set.Iio γ) γ) + (hIot : (((b.1 : K⟦ℝ⟧).isPWO_support.mono + (negativeSupportTail_subset_support b.1 η)).mono + (s := negativeSupportTail b.1 η ∩ Set.Iio γ) Set.inter_subset_left).orderType = + ρ * (α + 1)) : + NatOrdinal.of ρ ≤ ordinalValue (translatedTruncation (b.1 : K⟦ℝ⟧) γ) := by + classical + set S := negativeSupportTail b.1 η with hSdef + set hS := ((b.1 : K⟦ℝ⟧).isPWO_support.mono + (negativeSupportTail_subset_support b.1 η)) with hSpwo + set I := S ∩ Set.Iio γ with hIdef + set hI := hS.mono (s := I) Set.inter_subset_left with hIpwo + let : WellFoundedLT I := hI.isWF + apply le_ordinalValue_translatedTruncation_of_forall_le_orderType + intro θ hθ + obtain ⟨z, hzI, hθz, _⟩ := hLUB.exists_between hθ + have hsplit2 := hI.orderType_inter_Iio_add_inter_Ici hzI + have hlt2 : (hI.mono (s := I ∩ Set.Iio z) Set.inter_subset_left).orderType + < hI.orderType := hI.orderType_inter_Iio_lt hzI + rw [hIot] at hsplit2 hlt2 + refine (hρprin.le_of_add_eq_mul_succ hlt2 hsplit2).trans + (Set.IsPWO.orderType_mono _ _ ?_) + rintro y ⟨hyI, hzy⟩ + exact ⟨(mem_negativeSupportTail_iff.mp hyI.1).1, lt_of_lt_of_le hθz hzy, hyI.2⟩ + +/-- The printed construction of Berarducci, Lemma 6.8, for residual value above one. For each +`α` below the principal value, the supremum `γ` of the first `v_J^r(b) ⬝ (α + 1)` elements of the +stable interval is a residual point of the tail: that order type is a limit, so `γ` is not +attained, and the two value bounds at the supremum pin the translated truncation at `γ` to value +exactly `v_J^r(b)`. -/ +theorem exists_residualPoint_orderType_eq + (b : SeriesWithOrdinalValueAboveOne K) {η : ℝ} + (hstable : ((b.1 : K⟦ℝ⟧).isPWO_support.mono + (negativeSupportTail_subset_support b.1 η)).orderType = (ordinalValue b.1).val) + (hρ : 1 < b.residualValue) (i : b.principalValue.val.ToType) : + ∃ γ : ℝ, γ ∈ residualPointTail b η ∧ + (((b.1 : K⟦ℝ⟧).isPWO_support.mono + (negativeSupportTail_subset_support b.1 η)).mono + (s := negativeSupportTail b.1 η ∩ Set.Iio γ) Set.inter_subset_left).orderType + = b.residualValue.val * + (Ordinal.typein (α := b.principalValue.val.ToType) (· < ·) i + 1) := by + classical + set S := negativeSupportTail b.1 η with hSdef + set hS := ((b.1 : K⟦ℝ⟧).isPWO_support.mono + (negativeSupportTail_subset_support b.1 η)) with hSpwo + set ρ := b.residualValue.val with hρdef + set α := Ordinal.typein (α := b.principalValue.val.ToType) (· < ·) i with hαdef + have hρprin : Ordinal.IsAdditivelyPrincipal ρ := b.residualValue_isAdditivelyPrincipal + have hρ0 : 0 < ρ := by + rw [pos_iff_ne_zero] + exact NatOrdinal.val_ne_zero.mpr b.residualValue_ne_zero + have hρlimit : Order.IsSuccLimit ρ := + hρprin.isSuccLimit_of_one_lt (NatOrdinal.val.lt_iff_lt.mpr hρ) + have hκlimit : Order.IsSuccLimit (ρ * (α + 1)) := by + rw [mul_add_one] + exact Ordinal.isSuccLimit_add _ hρlimit + have hκlt : ρ * (α + 1) < hS.orderType := by + rw [hstable, ← b.residualValue_val_mul_principalValue_val] + exact (Ordinal.isNormal_mul_right hρ0).strictMono + (b.principalValue_isInfiniteMultiplicativelyPrincipal.isSuccLimit.succ_lt + (Ordinal.typein_lt_self i)) + obtain ⟨γ, ⟨y, hy⟩, hLUB, ⟨x, hxS, hγx⟩, hIot⟩ := + exists_isLUB_orderType_inter_Iio_eq_of_isSuccLimit hS hκlimit hκlt + have hγneg : γ < 0 := hγx.trans_lt (mem_negativeSupportTail_iff.mp hxS).2.2 + have hγη : η < γ := lt_of_lt_of_le (mem_negativeSupportTail_iff.mp hy.1).2.1 (hLUB.1 hy) + have hveq : ordinalValue (translatedTruncation (b.1 : K⟦ℝ⟧) γ) = b.residualValue := by + apply NatOrdinal.val.injective + refine le_antisymm + (ordinalValue_translatedTruncation_val_le_of_orderType_inter_Iio_eq b hρ0 hρlimit + hγneg.le hIot) ?_ + have hmono := NatOrdinal.val.monotone + (le_ordinalValue_translatedTruncation_of_isLUB_of_orderType_inter_Iio_eq b hρprin + hLUB hIot) + rwa [NatOrdinal.val_of] at hmono + exact ⟨γ, mem_residualPointTail_iff.mpr + ⟨mem_residualPointSet_iff.mpr ⟨hγneg, hveq⟩, hγη⟩, hIot⟩ + +private theorem principalValue_le_of_exists_residualPoint + (b : SeriesWithOrdinalValueAboveOne K) (hX : (residualPointSet b).IsPWO) {η : ℝ} + (g : b.principalValue.val.ToType → Ordinal) (hg : StrictMono g) + (h : ∀ i, ∃ γ : ℝ, γ ∈ residualPointTail b η ∧ + ((((b.1 : K⟦ℝ⟧).isPWO_support.mono + (negativeSupportTail_subset_support b.1 η)).mono + (s := negativeSupportTail b.1 η ∩ Set.Iio γ) Set.inter_subset_left)).orderType = g i) : + b.principalValue.val ≤ (residualPointTail_isPWO b η hX).orderType := by + classical + choose f hf hfot using h + set hS := ((b.1 : K⟦ℝ⟧).isPWO_support.mono + (negativeSupportTail_subset_support b.1 η)) with hSpwo + have hmono : StrictMono f := by + intro i j hij + by_contra hle + rw [not_lt] at hle + have hsub : negativeSupportTail b.1 η ∩ Set.Iio (f j) ⊆ + negativeSupportTail b.1 η ∩ Set.Iio (f i) := + fun y hy ↦ ⟨hy.1, lt_of_lt_of_le hy.2 hle⟩ + have hcmp := Set.IsPWO.orderType_mono + (hS.mono (s := negativeSupportTail b.1 η ∩ Set.Iio (f j)) Set.inter_subset_left) + (hS.mono (s := negativeSupportTail b.1 η ∩ Set.Iio (f i)) Set.inter_subset_left) hsub + rw [hfot i, hfot j] at hcmp + exact absurd hcmp (not_le.mpr (hg hij)) + have hrange : Set.range f ⊆ residualPointTail b η := by + rintro _ ⟨i, rfl⟩ + exact hf i + have hRPWO : (Set.range f).IsPWO := (residualPointTail_isPWO b η hX).mono hrange + have hRot : hRPWO.orderType = b.principalValue.val := by + rw [hRPWO.orderType_eq_typeLT_of_orderIso (hmono.orderIso f).symm] + exact Ordinal.type_toType _ + calc b.principalValue.val = hRPWO.orderType := hRot.symm + _ ≤ (residualPointTail_isPWO b η hX).orderType := + hRPWO.orderType_mono _ hrange + +theorem principalValue_le_residualPointTail_orderType_of_one_lt + (b : SeriesWithOrdinalValueAboveOne K) (hX : (residualPointSet b).IsPWO) {η : ℝ} + (hstable : ((b.1 : K⟦ℝ⟧).isPWO_support.mono + (negativeSupportTail_subset_support b.1 η)).orderType = (ordinalValue b.1).val) + (hρ : 1 < b.residualValue) : + b.principalValue.val ≤ (residualPointTail_isPWO b η hX).orderType := by + have hρ0 : 0 < b.residualValue.val := by + rw [pos_iff_ne_zero] + exact NatOrdinal.val_ne_zero.mpr b.residualValue_ne_zero + refine principalValue_le_of_exists_residualPoint b hX + (fun i ↦ b.residualValue.val * + (Ordinal.typein (α := b.principalValue.val.ToType) (· < ·) i + 1)) ?_ + (exists_residualPoint_orderType_eq b hstable hρ) + intro i j hij + have hlt : Ordinal.typein (α := b.principalValue.val.ToType) (· < ·) i < + Ordinal.typein (α := b.principalValue.val.ToType) (· < ·) j := + (Ordinal.typein_lt_typein (· < ·)).mpr hij + exact (Ordinal.isNormal_mul_right hρ0).strictMono + ((Order.add_one_le_iff.mpr hlt).trans_lt (lt_add_one _)) + +theorem exists_residualPoint_orderType_eq_of_residualValue_eq_one + (b : SeriesWithOrdinalValueAboveOne K) {η : ℝ} + (hstable : ((b.1 : K⟦ℝ⟧).isPWO_support.mono + (negativeSupportTail_subset_support b.1 η)).orderType = (ordinalValue b.1).val) + (hρ : b.residualValue = 1) (i : b.principalValue.val.ToType) : + ∃ γ : ℝ, γ ∈ residualPointTail b η ∧ + (((b.1 : K⟦ℝ⟧).isPWO_support.mono + (negativeSupportTail_subset_support b.1 η)).mono + (s := negativeSupportTail b.1 η ∩ Set.Iio γ) Set.inter_subset_left).orderType + = Ordinal.typein (α := b.principalValue.val.ToType) (· < ·) i + 1 := by + classical + set S := negativeSupportTail b.1 η with hSdef + set hS := ((b.1 : K⟦ℝ⟧).isPWO_support.mono + (negativeSupportTail_subset_support b.1 η)) with hSpwo + set α := Ordinal.typein (α := b.principalValue.val.ToType) (· < ·) i with hαdef + have hαπ : α < b.principalValue.val := Ordinal.typein_lt_self i + have hπlimit : Order.IsSuccLimit b.principalValue.val := + b.principalValue_isInfiniteMultiplicativelyPrincipal.isSuccLimit + have hSot : hS.orderType = b.principalValue.val := by + rw [hstable, ← b.residualValue_val_mul_principalValue_val, hρ] + simp + have hsucclt : α + 1 < b.principalValue.val := hπlimit.succ_lt hαπ + obtain ⟨y, hyS, hyot⟩ := hS.exists_orderType_inter_Iio_eq (by rw [hSot]; exact hsucclt) + set T := S ∩ Set.Iio y with hTdef + set hT := hS.mono (s := T) Set.inter_subset_left with hTpwo + have hTot : hT.orderType = α + 1 := hyot + have hTmax : ∃ z ∈ T, ∀ u ∈ T, u ≤ z := by + by_contra hcon + push Not at hcon + have hne : T.Nonempty := by + rw [Set.nonempty_iff_ne_empty] + intro hempty + have := hT.orderType_eq_zero.mpr hempty + rw [hTot] at this + rw [← Order.succ_eq_add_one] at this + exact Order.succ_ne_bot α this + have hgt : ∀ u ∈ T, ∃ v ∈ T, u < v := by + intro u hu + obtain ⟨v, hv, hvu⟩ := hcon u hu + exact ⟨v, hv, hvu⟩ + have := Set.IsPWO.isSuccLimit_orderType_of_forall_exists_gt hT hne hgt + rw [hTot, ← Order.succ_eq_add_one] at this + exact Order.not_isSuccLimit_succ α this + obtain ⟨z, hzT, hzmax⟩ := hTmax + have hzy : z < y := hzT.2 + have hgap : ∀ u : ℝ, z < u → u < y → u ∉ (b.1 : K⟦ℝ⟧).support := by + intro u hzu huy hu + have huS : u ∈ S := mem_negativeSupportTail_iff.mpr + ⟨hu, lt_trans (mem_negativeSupportTail_iff.mp hzT.1).2.1 hzu, + lt_trans huy (mem_negativeSupportTail_iff.mp hyS).2.2⟩ + exact absurd (hzmax u ⟨huS, huy⟩) (not_le.mpr hzu) + have hycoeff : (b.1 : K⟦ℝ⟧).coeff y ≠ 0 := + (HahnSeries.mem_support _ _).mp (mem_negativeSupportTail_iff.mp hyS).1 + have hyneg : y < 0 := (mem_negativeSupportTail_iff.mp hyS).2.2 + have hyη : η < y := (mem_negativeSupportTail_iff.mp hyS).2.1 + have hnear : translatedTruncation (b.1 : K⟦ℝ⟧) y ∈ nearConstantSubgroup K := by + refine mem_nearConstantSubgroup_iff_exists_germ_eq_constant.mpr + ⟨(b.1 : K⟦ℝ⟧).coeff y, ?_⟩ + refine toGerm_eq_toGerm_iff_exists_coeff_eq.mpr + ⟨z - y, by linarith, fun δ hδlow hδ0 ↦ ?_⟩ + rw [coeff_translatedTruncation, ite_eq_left hδ0, HahnSeries.Nonpositive.coe_C] + rcases hδ0.eq_or_lt with rfl | hδneg + · simp + · rw [HahnSeries.C_apply, HahnSeries.coeff_single_of_ne (by linarith : δ ≠ (0 : ℝ))] + by_contra hne + exact hgap (y + δ) (by linarith) (by linarith) + ((HahnSeries.mem_support _ _).mpr hne) + have hnotJ : translatedTruncation (b.1 : K⟦ℝ⟧) y ∉ + HahnSeries.Nonpositive.negativeMonomialIdeal K := by + intro hmem + have hzero := constantCoeff_eq_zero_of_mem_negativeMonomialIdeal hmem + rw [HahnSeries.Nonpositive.constantCoeff_apply, coeff_translatedTruncation, + ite_eq_left le_rfl] at hzero + exact hycoeff (by simpa using hzero) + have hveq : ordinalValue (translatedTruncation (b.1 : K⟦ℝ⟧) y) = b.residualValue := by + rw [hρ] + exact ordinalValue_of_mem_nearConstantSubgroup_of_not_mem_negativeMonomialIdeal hnear hnotJ + exact ⟨y, mem_residualPointTail_iff.mpr + ⟨mem_residualPointSet_iff.mpr ⟨hyneg, hveq⟩, hyη⟩, hyot⟩ + +theorem principalValue_le_residualPointTail_orderType_of_eq_one + (b : SeriesWithOrdinalValueAboveOne K) (hX : (residualPointSet b).IsPWO) {η : ℝ} + (hstable : ((b.1 : K⟦ℝ⟧).isPWO_support.mono + (negativeSupportTail_subset_support b.1 η)).orderType = (ordinalValue b.1).val) + (hρ : b.residualValue = 1) : + b.principalValue.val ≤ (residualPointTail_isPWO b η hX).orderType := by + refine principalValue_le_of_exists_residualPoint b hX + (fun i ↦ Ordinal.typein (α := b.principalValue.val.ToType) (· < ·) i + 1) ?_ + (exists_residualPoint_orderType_eq_of_residualValue_eq_one b hstable hρ) + intro i j hij + have hlt : Ordinal.typein (α := b.principalValue.val.ToType) (· < ·) i < + Ordinal.typein (α := b.principalValue.val.ToType) (· < ·) j := + (Ordinal.typein_lt_typein (· < ·)).mpr hij + exact (Order.add_one_le_iff.mpr hlt).trans_lt (lt_add_one _) + +/-- The order-type computation in Berarducci, Lemma 6.8: on a stable interval the residual-point +tail has ordinary order type exactly the principal value. -/ +theorem residualPointTail_orderType_eq + (b : SeriesWithOrdinalValueAboveOne K) (hX : (residualPointSet b).IsPWO) + {η : ℝ} (hη : η < 0) + (hstable : ((b.1 : K⟦ℝ⟧).isPWO_support.mono + (negativeSupportTail_subset_support b.1 η)).orderType = (ordinalValue b.1).val) : + (residualPointTail_isPWO b η hX).orderType = b.principalValue.val := by + refine le_antisymm (residualPointTail_orderType_le b hX hη hstable) ?_ + rcases (Order.one_le_iff_ne_zero.mpr b.residualValue_ne_zero).lt_or_eq with hρ | hρ + · exact principalValue_le_residualPointTail_orderType_of_one_lt b hX hstable hρ + · exact principalValue_le_residualPointTail_orderType_of_eq_one b hX hstable hρ.symm + +/-- Berarducci, Lemma 6.8, order-type half: sufficiently high residual-point tails have ordinary +order type equal to the principal value. -/ +theorem residualPointTail_orderType_eventually + (b : SeriesWithOrdinalValueAboveOne K) (hX : (residualPointSet b).IsPWO) : + ∀ᶠ η in nhdsWithin (0 : ℝ) (Set.Iio 0), + (residualPointTail_isPWO b η hX).orderType = b.principalValue.val := by + obtain ⟨η₀, hη₀, hstable⟩ := + exists_forall_later_negativeSupportTail_orderType_eq_ordinalValue b.1 b.2 + rw [eventually_nhdsLT_iff_exists] + exact ⟨η₀, hη₀, fun ξ hlow hhigh ↦ + residualPointTail_orderType_eq b hX hhigh (hstable ξ hlow hhigh)⟩ + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/ResidualPointSupport.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/ResidualPointSupport.lean new file mode 100644 index 0000000000..2fda4e66af --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/ResidualPointSupport.lean @@ -0,0 +1,191 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.ResidualPointTail + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValueFinalSegment +import Mathlib.Tactic.Linarith + +/-! +# Support families along Berarducci residual points + +This module proves the support-family construction in Berarducci, Lemma 6.9. A final segment of a +residual-point tail still has the full principal order type. This permits a strictly increasing +reindexing by `v_J^p(b)`. Congruence modulo `J + K` then transports the translated-truncation +value bound from the given series to every representative used in the definition of `v_J`. + +For the support blocks there is an essential boundary distinction. When `ρ = 1`, a block retains +the cutoff exponent and uses closed lower support. When `1 < ρ`, a block uses strict lower support; +excluding the cutoff prevents a constant endpoint from forming a final segment of order type one. +The final-segment estimate in +`ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValueFinalSegment` supplies the required lower +bound in the latter case. + +This expands the source's terse application of Lemma 4.7 and makes the residual-value-one +endpoint case explicit. +-/ + +universe v + +open scoped HahnSeries NatOrdinal + +public noncomputable section + +namespace Berarducci + +open Ordinal + +variable {K : Type v} [Field K] + +/-- A residual-point tail contains a strictly increasing copy of its full principal order type on +which the translated-truncation lower bound holds for any fixed representative modulo `J + K`. -/ +theorem exists_strictMono_cutoff_of_residualPointTail + (b : SeriesWithOrdinalValueAboveOne K) (c : Series K) {ρ : Ordinal} {η : ℝ} + (htail : (residualPointTail b η).IsPWO) + (htailType : htail.orderType = b.principalValue.val) + (htailLUB : IsLUB (residualPointTail b η) 0) + (hc : ∀ γ ∈ residualPointTail b η, + NatOrdinal.of ρ ≤ ordinalValue (translatedTruncation (c : K⟦ℝ⟧) γ)) + (d : Series K) (hcd : c - d ∈ nearConstantSubgroup K) : + ∃ γ : b.principalValue.val.ToType → ℝ, + StrictMono γ ∧ + (∀ i, γ i ∈ residualPointTail b η) ∧ + ∀ i, NatOrdinal.of ρ ≤ + ordinalValue (translatedTruncation (d : K⟦ℝ⟧) (γ i)) := by + obtain ⟨θ, hθ, hvalueEq⟩ := + exists_ordinalValue_translatedTruncation_eq_of_sub_mem_nearConstantSubgroup hcd + let finalTail : Set ℝ := residualPointTail b η ∩ Set.Ioi θ + let hfinalTail : finalTail.IsPWO := htail.mono Set.inter_subset_left + obtain ⟨x, hxTail, hθx, _⟩ := htailLUB.exists_between hθ + have hfinalTailType : hfinalTail.orderType = b.principalValue.val := by + calc + hfinalTail.orderType = htail.orderType := by + apply htail.orderType_inter_Ioi_eq_of_isPrincipal + · rw [htailType] + exact + (isAdditivelyPrincipal_iff_ne_zero_and_isPrincipal_add.mp + b.principalValue_isInfiniteMultiplicativelyPrincipal.isAdditivelyPrincipal).2 + · exact ⟨x, hxTail, hθx⟩ + _ = b.principalValue.val := htailType + let : WellFoundedLT finalTail := hfinalTail.isWF + have htypes : typeLT b.principalValue.val.ToType = typeLT finalTail := by + calc + typeLT b.principalValue.val.ToType = b.principalValue.val := + type_toType b.principalValue.val + _ = hfinalTail.orderType := hfinalTailType.symm + _ = typeLT finalTail := + hfinalTail.orderType_eq_typeLT_of_orderIso (OrderIso.refl finalTail) + let e : b.principalValue.val.ToType ≃o finalTail := + OrderIso.ofRelIsoLT (Classical.choice (Ordinal.type_eq.mp htypes)) + let γ : b.principalValue.val.ToType → ℝ := fun i ↦ (e i).1 + refine ⟨γ, ?_, ?_, ?_⟩ + · intro i j hij + exact e.strictMono hij + · intro i + exact (e i).2.1 + · intro i + have hθγ : θ < γ i := (e i).2.2 + have hγTail : γ i ∈ residualPointTail b η := (e i).2.1 + have hγ0 : γ i < 0 := + residualPointSet_subset_Iio b + (residualPointTail_subset_residualPointSet b η hγTail) + rw [← hvalueEq (γ i) hθγ hγ0] + exact hc (γ i) hγTail + +/-- A residual-point tail yields a well-ordered family of subsets of the support of `d`, strictly +separated between indices and with every nonempty upper subset of each member having order type +at least `ρ`. -/ +theorem exists_supportFamily_of_residualPointTail + (b : SeriesWithOrdinalValueAboveOne K) (c : Series K) {ρ : Ordinal} {η : ℝ} + (hρ0 : ρ ≠ 0) + (htail : (residualPointTail b η).IsPWO) + (htailType : htail.orderType = b.principalValue.val) + (htailLUB : IsLUB (residualPointTail b η) 0) + (hc : ∀ γ ∈ residualPointTail b η, + NatOrdinal.of ρ ≤ ordinalValue (translatedTruncation (c : K⟦ℝ⟧) γ)) + (d : Series K) (hcd : c - d ∈ nearConstantSubgroup K) : + ∃ B : b.principalValue.val.ToType → Set ℝ, + ∃ hB : ∀ i, (B i).IsPWO, + (∀ {i j}, i < j → ∃ y ∈ B j, ∀ x ∈ B i, x < y) ∧ + (∀ (i : b.principalValue.val.ToType) (C : Set ℝ) + (hC : IsRelUpperSet C (· ∈ B i)), C.Nonempty → + ρ ≤ ((hB i).mono fun _ hx ↦ (hC hx).1).orderType) ∧ + ∃ _ : (⋃ i, B i).IsPWO, + (⋃ i, B i) ⊆ (d : K⟦ℝ⟧).support := by + obtain ⟨γ, hγmono, _, hγvalue⟩ := + exists_strictMono_cutoff_of_residualPointTail b c htail htailType htailLUB hc d hcd + by_cases hρ1 : ρ = 1 + · subst ρ + let B : b.principalValue.val.ToType → Set ℝ := + fun i ↦ (d : K⟦ℝ⟧).support ∩ Set.Iic (γ i) + let hB : ∀ i, (B i).IsPWO := + fun _ ↦ (d : K⟦ℝ⟧).isPWO_support.mono Set.inter_subset_left + refine ⟨B, hB, ?_, ?_, ?_⟩ + · intro i j hij + have hvalueNe : ordinalValue (translatedTruncation (d : K⟦ℝ⟧) (γ j)) ≠ 0 := by + intro hzero + have hle := hγvalue j + rw [hzero] at hle + exact (not_le_of_gt zero_lt_one) hle + have hLUB := isLUB_support_zero_of_ordinalValue_ne_zero hvalueNe + have hcutoff : γ i - γ j < 0 := sub_neg.mpr (hγmono hij) + obtain ⟨δ, hδSupport, hδAbove, _⟩ := hLUB.exists_between hcutoff + rw [support_translatedTruncation] at hδSupport + obtain ⟨y, hy, hδ⟩ := hδSupport + refine ⟨y, ⟨hy.1, hy.2⟩, fun x hx ↦ ?_⟩ + rw [← hδ] at hδAbove + exact hx.2.trans_lt (by linarith) + · intro i C hC hCne + apply Order.one_le_iff_ne_zero.mpr + intro hzero + have hCempty := ((hB i).mono fun _ hx ↦ (hC hx).1).orderType_eq_zero.mp hzero + obtain ⟨x, hx⟩ := hCne + simp [hCempty] at hx + · let hUnion : (⋃ i, B i).IsPWO := + (d : K⟦ℝ⟧).isPWO_support.mono fun _ hx ↦ by + obtain ⟨i, hi⟩ := Set.mem_iUnion.mp hx + exact hi.1 + exact ⟨hUnion, fun _ hx ↦ by + obtain ⟨i, hi⟩ := Set.mem_iUnion.mp hx + exact hi.1⟩ + · have h1ρ : 1 < ρ := + lt_of_le_of_ne (Order.one_le_iff_ne_zero.mpr hρ0) (Ne.symm hρ1) + let B : b.principalValue.val.ToType → Set ℝ := + fun i ↦ (d : K⟦ℝ⟧).support ∩ Set.Iio (γ i) + let hB : ∀ i, (B i).IsPWO := + fun _ ↦ (d : K⟦ℝ⟧).isPWO_support.mono Set.inter_subset_left + have hvalueOneLt (i : b.principalValue.val.ToType) : + 1 < ordinalValue (translatedTruncation (d : K⟦ℝ⟧) (γ i)) := by + apply (show (1 : NatOrdinal) < NatOrdinal.of ρ by + exact NatOrdinal.of.lt_iff_lt.mpr h1ρ).trans_le + exact hγvalue i + refine ⟨B, hB, ?_, ?_, ?_⟩ + · intro i j hij + have hLUB := isLUB_negativeSupport_zero_of_one_lt_ordinalValue (hvalueOneLt j) + have hcutoff : γ i - γ j < 0 := sub_neg.mpr (hγmono hij) + obtain ⟨δ, hδSupport, hδAbove, _⟩ := hLUB.exists_between hcutoff + rw [support_translatedTruncation] at hδSupport + obtain ⟨⟨y, hy, hδ⟩, hδ0⟩ := hδSupport + refine ⟨y, ⟨hy.1, ?_⟩, fun x hx ↦ ?_⟩ + · rw [← hδ] at hδ0 + change -γ j + y < 0 at hδ0 + change y < γ j + linarith + · rw [← hδ] at hδAbove + exact hx.2.trans (by linarith) + · intro i C hC hCne + exact le_orderType_of_le_ordinalValue_translatedTruncation_of_isRelUpperSet_supportBelow + (d : K⟦ℝ⟧) (γ i) (hγvalue i) hC hCne + · let hUnion : (⋃ i, B i).IsPWO := + (d : K⟦ℝ⟧).isPWO_support.mono fun _ hx ↦ by + obtain ⟨i, hi⟩ := Set.mem_iUnion.mp hx + exact hi.1 + exact ⟨hUnion, fun _ hx ↦ by + obtain ⟨i, hi⟩ := Set.mem_iUnion.mp hx + exact hi.1⟩ + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/ResidualPointTail.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/ResidualPointTail.lean new file mode 100644 index 0000000000..b2e9c94337 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/ResidualPointTail.lean @@ -0,0 +1,95 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.ResidualPoint + +/-! +# Final tails of Berarducci residual points + +For a cutoff `η`, `residualPointTail b η` is the final part of `X(b)` strictly above `η`. +Since every residual point is strictly negative, this is exactly `X(b) ∩ (η, 0)`. + +The source phrase "sufficiently close to zero" is represented later by +`nhdsWithin 0 (Set.Iio 0)`. Its generic cutoff interface prevents a silent change of side or +inclusion of zero. + +The remaining results isolate elementary consequences of well-ordering and least-upper-bound +hypotheses. They are the proved part of the interface needed to state and partially prove +Berarducci, Lemmas 6.8 and 6.9. +-/ + +universe v + +open scoped HahnSeries + +public noncomputable section + +namespace Berarducci + +variable {K : Type v} [Field K] + +/-- The residual points strictly above the real cutoff `η`. -/ +def residualPointTail (b : SeriesWithOrdinalValueAboveOne K) (η : ℝ) : Set ℝ := + residualPointSet b ∩ Set.Ioi η + +/-- Membership in a residual-point tail records both residual-point membership and the strict +cutoff inequality. -/ +theorem mem_residualPointTail_iff + {b : SeriesWithOrdinalValueAboveOne K} {η γ : ℝ} : + γ ∈ residualPointTail b η ↔ γ ∈ residualPointSet b ∧ η < γ := + (Iff.rfl) + +/-- A residual-point tail is exactly the intersection of `X(b)` with `(η, 0)`. -/ +theorem residualPointTail_eq_inter_Ioo + (b : SeriesWithOrdinalValueAboveOne K) (η : ℝ) : + residualPointTail b η = residualPointSet b ∩ Set.Ioo η 0 := by + ext γ + rw [mem_residualPointTail_iff] + constructor + · rintro ⟨hγ, hηγ⟩ + exact ⟨hγ, hηγ, residualPointSet_subset_Iio b hγ⟩ + · rintro ⟨hγ, hηγ, _⟩ + exact ⟨hγ, hηγ⟩ + +/-- Every residual-point tail is contained in `X(b)`. -/ +theorem residualPointTail_subset_residualPointSet + (b : SeriesWithOrdinalValueAboveOne K) (η : ℝ) : + residualPointTail b η ⊆ residualPointSet b := + Set.inter_subset_left + +/-- Residual-point tails are antitone in their cutoff. -/ +theorem residualPointTail_antitone + (b : SeriesWithOrdinalValueAboveOne K) : Antitone (residualPointTail b) := by + intro η ξ hηξ γ hγ + exact ⟨hγ.1, hηξ.trans_lt hγ.2⟩ + +/-- A tail of a partially well-ordered residual-point set is partially well ordered. -/ +theorem residualPointTail_isPWO + (b : SeriesWithOrdinalValueAboveOne K) (η : ℝ) + (hX : (residualPointSet b).IsPWO) : + (residualPointTail b η).IsPWO := + hX.mono (residualPointTail_subset_residualPointSet b η) + +/-- If zero is the least upper bound of `X(b)`, every tail with negative cutoff is nonempty and +still has least upper bound zero. -/ +theorem residualPointTail_nonempty_and_isLUB + (b : SeriesWithOrdinalValueAboveOne K) {η : ℝ} (hη : η < 0) + (hX : IsLUB (residualPointSet b) 0) : + (residualPointTail b η).Nonempty ∧ IsLUB (residualPointTail b η) 0 := by + obtain ⟨x, hxX, hηx, _⟩ := hX.exists_between hη + have hxTail : x ∈ residualPointTail b η := ⟨hxX, hηx⟩ + refine ⟨⟨x, hxTail⟩, ⟨?_, ?_⟩⟩ + · intro y hy + exact hX.1 hy.1 + · intro a ha + apply hX.2 + intro y hy + by_cases hηy : η < y + · exact ha ⟨hy, hηy⟩ + · exact (le_of_not_gt hηy).trans (hηx.le.trans (ha hxTail)) + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/ResidualPointValue.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/ResidualPointValue.lean new file mode 100644 index 0000000000..63acf9d6de --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/ResidualPointValue.lean @@ -0,0 +1,60 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalValue +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.ResidualPoint + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.GermValueCut + +/-! +# Values of translated truncations at residual points + +Berarducci, Remark 9.4 and Remark 6.7, in the forms used by the complexity induction of Section 9. + +Every sufficiently high translated truncation has strictly smaller ordinal value, because the +value cut bounds it by a proper ordinary multiple of the residual value. At a residual point the +truncation value is the residual value itself, so its principal value is the principal factor of +the residual factor, which is at least the principal value of the series. +-/ + +universe v + +public noncomputable section + +open HahnSeries Ordinal + +namespace Berarducci + +variable {K : Type v} [Field K] + +/-- Berarducci, Remark 9.4: sufficiently high translated truncations have strictly smaller +ordinal value. -/ +theorem exists_ordinalValue_translatedTruncation_lt (b : SeriesWithOrdinalValueAboveOne K) : + ∃ η < (0 : ℝ), ∀ γ : ℝ, η < γ → γ < 0 → + ordinalValue (translatedTruncation (b.1 : K⟦ℝ⟧) γ) < ordinalValue b.1 := by + obtain ⟨η, hη, hcut⟩ := exists_ordinalValue_translatedTruncation_le b + refine ⟨η, hη, fun γ hlow hhigh ↦ ?_⟩ + obtain ⟨α, hα, hle⟩ := hcut γ hlow hhigh + have hρpos : 0 < b.residualValue.val := by + rw [pos_iff_ne_zero] + exact NatOrdinal.val_ne_zero.mpr b.residualValue_ne_zero + have hlt : b.residualValue.val * α < (ordinalValue b.1).val := by + rw [← b.residualValue_val_mul_principalValue_val] + exact (Ordinal.isNormal_mul_right hρpos).strictMono hα + exact NatOrdinal.val.lt_iff_lt.mp (hle.trans_lt hlt) + +/-- Berarducci, Remark 6.7: at a residual point, the translated truncation has principal value at +least that of the series. -/ +theorem principalValue_le_of_mem_residualPointSet + (b d : SeriesWithOrdinalValueAboveOne K) {γ : ℝ} (hγ : γ ∈ residualPointSet b) + (hd : d.1 = translatedTruncation (b.1 : K⟦ℝ⟧) γ) : + b.principalValue ≤ d.principalValue := by + refine b.principalValue_le_of_ordinalValue_eq_residualValue d ?_ + rw [hd] + exact (mem_residualPointSet_iff.mp hγ).2 + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/ResidualPointWellOrdered.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/ResidualPointWellOrdered.lean new file mode 100644 index 0000000000..186fcc068d --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/ResidualPointWellOrdered.lean @@ -0,0 +1,51 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.ResidualPoint +public import Mathlib.Topology.MetricSpace.Pseudo.Defs + +import LeanPool.ConwayRefinement.ConwayRefinement.Topology.Order.PWOSumset + +/-! +# Residual points form a well-ordered set + +Berarducci, Remark 6.3: the translated truncation `b^{|γ}` lies in `J` unless `γ` belongs to the +order-topological closure of the support of `b`, so it is nonzero modulo `J` only for `γ` ranging +over a well-ordered set. Since a residual point has translated truncation of nonzero ordinal +value, the residual-point set is contained in that closure and is therefore partially well +ordered. + +The two inputs are the vanishing of a germ outside the closed support, which is an elementary +metric argument, and the fact that the closure of a partially well-ordered set of reals is again +partially well ordered. +-/ + +universe v + +public noncomputable section + +open HahnSeries + +namespace Berarducci + +variable {K : Type v} [Field K] + +/-- Residual points lie in the closure of the support. -/ +theorem residualPointSet_subset_closure_support (b : SeriesWithOrdinalValueAboveOne K) : + residualPointSet b ⊆ closure (b.1 : K⟦ℝ⟧).support := by + intro γ hγ + by_contra hmem + exact translatedTruncation_not_mem_negativeMonomialIdeal_of_mem_residualPointSet hγ + (translatedTruncation_mem_negativeMonomialIdeal_of_not_mem_closure_support hmem) + +/-- Berarducci, Remark 6.3: the residual-point set is partially well ordered. -/ +theorem residualPointSet_isPWO (b : SeriesWithOrdinalValueAboveOne K) : + (residualPointSet b).IsPWO := + (Set.isPWO_closure (b.1 : K⟦ℝ⟧).isPWO_support).mono + (residualPointSet_subset_closure_support b) + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/StableInterval.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/StableInterval.lean new file mode 100644 index 0000000000..526e044b85 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/StableInterval.lean @@ -0,0 +1,250 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValue +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.SetOrderType + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValueFinalSegment +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValueImage +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint + +/-! +# Stable support intervals for Berarducci's ordinal value + +Berarducci's discussion after Definition 5.2 describes the ordinal value through sufficiently +short open intervals immediately below zero. For a nonpositive series `b`, the set +`negativeSupportTail b η` is its support in the open interval `(η, 0)`. If the ordinal value is +greater than one, some such tail has ordinary order type exactly `v_J(b)`, and every shorter +nonempty tail has the same order type. These are the stable intervals used in Lemma 6.8. + +The endpoint zero is excluded because the third clause of the ordinal value works modulo `J + K`, +not merely modulo `J`. The proofs first choose a representative of minimum support order type and +then use eventual equality of negative coefficients modulo `J + K`. + +-/ + +universe v + +open scoped HahnSeries NatOrdinal + +public noncomputable section + +namespace Berarducci + +open HahnSeries + +variable {K : Type v} [Field K] + +/-- The support of a nonpositive series in the open interval `(η, 0)`. -/ +def negativeSupportTail (b : Series K) (η : ℝ) : Set ℝ := + (b : K⟦ℝ⟧).support ∩ Set.Ioo η 0 + +/-- Membership in a negative support tail records both strict endpoints. -/ +theorem mem_negativeSupportTail_iff {b : Series K} {η x : ℝ} : + x ∈ negativeSupportTail b η ↔ + x ∈ (b : K⟦ℝ⟧).support ∧ η < x ∧ x < 0 := + (Iff.rfl) + +/-- A negative support tail is contained in the support of the original series. -/ +theorem negativeSupportTail_subset_support (b : Series K) (η : ℝ) : + negativeSupportTail b η ⊆ (b : K⟦ℝ⟧).support := + fun _ hx ↦ (mem_negativeSupportTail_iff.mp hx).1 + +private def negativeSupportTailSeries (b : Series K) (η : ℝ) : Series K := + ⟨HahnSeries.filter (fun x ↦ η < x ∧ x < 0) (b : K⟦ℝ⟧), by + rw [HahnSeries.mem_nonpositiveSubring] + intro x hx + rw [HahnSeries.support_filter] at hx + exact hx.2.2.le⟩ + +private theorem support_negativeSupportTailSeries (b : Series K) (η : ℝ) : + ((negativeSupportTailSeries b η : Series K) : K⟦ℝ⟧).support = + negativeSupportTail b η := by + change (HahnSeries.filter (fun x ↦ η < x ∧ x < 0) (b : K⟦ℝ⟧)).support = _ + rw [HahnSeries.support_filter] + rfl + +private theorem negativeSupportTailSeries_sub_mem_nearConstantSubgroup + (b : Series K) (η : ℝ) (hη : η < 0) : + b - negativeSupportTailSeries b η ∈ nearConstantSubgroup K := by + rw [mem_nearConstantSubgroup_iff_sub_C_constantCoeff_mem] + rw [HahnSeries.Nonpositive.mem_negativeMonomialIdeal_iff_supportSup_lt_zero] + let q := b - negativeSupportTailSeries b η - + HahnSeries.Nonpositive.C + (HahnSeries.Nonpositive.constantCoeff (b - negativeSupportTailSeries b η)) + change HahnSeries.Nonpositive.supportSup q < 0 + by_cases hq : q = 0 + · simp [hq] + · rw [HahnSeries.Nonpositive.supportSup_of_ne hq] + apply WithBot.coe_lt_coe.mpr + refine (csSup_le (HahnSeries.support_nonempty_iff.mpr ?_) ?_).trans_lt hη + · simpa using hq + · intro x hx + apply le_of_not_gt + intro hηx + have hx0 : x ≤ 0 := HahnSeries.Nonpositive.support_subset q hx + rcases hx0.eq_or_lt with rfl | hx0 + · have hcoeff : (q : K⟦ℝ⟧).coeff 0 = 0 := by + simp [q] + exact (HahnSeries.mem_support _ _).mp hx hcoeff + · have htailCoeff : + ((negativeSupportTailSeries b η : Series K) : K⟦ℝ⟧).coeff x = + (b : K⟦ℝ⟧).coeff x := by + simp [negativeSupportTailSeries, hηx, hx0] + have hcoeff : (q : K⟦ℝ⟧).coeff x = 0 := by + simp [q, htailCoeff, hx0.ne] + exact (HahnSeries.mem_support _ _).mp hx hcoeff + +/-- A series of ordinal value greater than one has an open negative support tail whose ordinary +order type is exactly its ordinal value. -/ +@[blueprint "fact:ordinal-value-support-tail" + (phase := "Ordinal value and degree") + (title := "Support-tail characterization of the ordinal value \ + (Ber00, Definition 5.2)") + (statement := /-- + Let $K$ be a field and let $b\in K((\mathbb R^{\le0}))$. If + $1 rw [valueProd_zero] + | cons a s ih => + rw [valueProd, Multiset.map_cons, Multiset.prod_cons, ← valueProd] + calc (1 : NatOrdinal) = 1 * 1 := (one_mul 1).symm + _ ≤ ordinalValue a.1 * valueProd s := mul_le_mul' a.2.le ih + +theorem one_lt_valueProd {w : FormalExpression K} (hw : w ≠ 0) : 1 < valueProd w := by + obtain ⟨a, ha⟩ := Multiset.exists_mem_of_ne_zero hw + obtain ⟨s, rfl⟩ := Multiset.exists_cons_of_mem ha + rw [valueProd, Multiset.map_cons, Multiset.prod_cons, ← valueProd] + calc (1 : NatOrdinal) < ordinalValue a.1 := a.2 + _ = ordinalValue a.1 * 1 := (mul_one _).symm + _ ≤ ordinalValue a.1 * valueProd s := mul_le_mul' le_rfl (one_le_valueProd s) + +open Classical in +/-- Splitting an expression at its selected factor. -/ +theorem replicate_selectedExponent_add_unselected (w : FormalExpression K) (hw : w ≠ 0) : + Multiset.replicate (selectedExponent w hw) (selected w hw) + unselected w hw = w := by + refine Multiset.ext.mpr fun y ↦ ?_ + rw [Multiset.count_add, unselected_eq, Multiset.count_replicate, Multiset.count_filter] + by_cases hy : y = selected w hw + · subst hy + rw [ite_eq_left rfl, ite_eq_right (fun h ↦ h rfl), add_zero, selectedExponent_eq_count] + · rw [ite_eq_right (Ne.symm hy), ite_eq_left hy, zero_add] + +end FormalExpression + +open FormalExpression + +/-- Berarducci, Lemma 9.6: the value of a product is the Hessenberg product of the values. -/ +theorem ordinalValue_eval [CharZero K] (w : FormalExpression K) : + ordinalValue (eval w) = valueProd w := by + suffices h : ∀ p : Multiset Ordinal × ℕ, ∀ (w : FormalExpression K) (hw : w ≠ 0), + complexity w hw = p → ordinalValue (eval w) = valueProd w by + rcases eq_or_ne w 0 with rfl | hw + · rw [eval_zero, valueProd_zero, ordinalValue_one] + · exact h _ w hw rfl + refine fun p ↦ wellFounded_complexityLT.induction + (C := fun q ↦ ∀ (w : FormalExpression K) (hw : w ≠ 0), complexity w hw = q → + ordinalValue (eval w) = valueProd w) p ?_ + clear p + intro p ih w hw hp + classical + have IH : ∀ w' : FormalExpression K, + (∀ hw' : w' ≠ 0, ComplexityLT (complexity w' hw') (complexity w hw)) → + ordinalValue (eval w') = valueProd w' := by + intro w' hlt + rcases eq_or_ne w' 0 with rfl | hw' + · rw [eval_zero, valueProd_zero, ordinalValue_one] + · exact ih (complexity w' hw') (hp ▸ hlt hw') w' hw' rfl + set x := selected w hw with hx + set r := unselected w hw with hrdef + obtain ⟨m, hm⟩ : ∃ m, selectedExponent w hw = m + 1 := + ⟨selectedExponent w hw - 1, by have := one_le_selectedExponent w hw; omega⟩ + have hdecomp : w = Multiset.replicate (m + 1) x + r := by + rw [hrdef, hx, ← hm, replicate_selectedExponent_add_unselected] + have heval : eval w = x.1 ^ (m + 1) * eval r := by + conv_lhs => rw [hdecomp] + rw [eval_add, eval_replicate] + have hvp : valueProd w = ordinalValue x.1 ^ (m + 1) * valueProd r := by + conv_lhs => rw [hdecomp] + rw [valueProd_add, valueProd_replicate] + have hr : ordinalValue (eval r) = valueProd r := + IH r fun hr0 ↦ complexityLT_unselected hw hr0 + -- the induction hypothesis at the reduced expression, for any admissible truncation factors + have hIHred : ∀ t : FormalExpression K, (∀ u ∈ t, ordinalValue u.1 < ordinalValue x.1) → + (∀ u ∈ t, x.principalValue ≤ u.principalValue) → + ordinalValue (eval t * x.1 ^ m * (eval r * eval r)) + = valueProd t * ordinalValue x.1 ^ m * (valueProd r * valueProd r) := by + intro t ht htp + have hred := IH (reduced w hw t) fun hne ↦ complexityLT_reduced w hw t ht htp hne + rw [reduced_eq, hm, Nat.add_sub_cancel] at hred + simpa only [eval_add, eval_replicate, valueProd_add, valueProd_replicate] using hred + -- the eventual hypothesis of Lemma 8.2 + have hkey : ∀ᶠ γ in nhdsWithin (0 : ℝ) (Set.Iio 0), γ ∈ residualPointSet x → + ordinalValue (translatedTruncation (x.1 : K⟦ℝ⟧) γ * x.1 ^ m * (eval r * eval r)) + = ordinalValue x.1 ^ m * ordinalValue (translatedTruncation (x.1 : K⟦ℝ⟧) γ) + * valueProd r * valueProd r := by + obtain ⟨η, hη, hlt⟩ := exists_ordinalValue_translatedTruncation_lt x + rw [eventually_nhdsLT_iff_exists] + refine ⟨η, hη, fun γ hlow hhigh hγ ↦ ?_⟩ + have hgv : ordinalValue (translatedTruncation (x.1 : K⟦ℝ⟧) γ) < ordinalValue x.1 := hlt γ hlow + hhigh + by_cases hg1 : 1 < ordinalValue (translatedTruncation (x.1 : K⟦ℝ⟧) γ) + · have h := hIHred {⟨translatedTruncation (x.1 : K⟦ℝ⟧) γ, hg1⟩} + (fun u hu ↦ by rw [Multiset.mem_singleton.mp hu]; exact hgv) + (fun u hu ↦ by + rw [Multiset.mem_singleton.mp hu] + exact principalValue_le_of_mem_residualPointSet x _ hγ rfl) + rw [eval_eq, valueProd, Multiset.map_singleton, Multiset.map_singleton, + Multiset.prod_singleton, Multiset.prod_singleton] at h + rw [h] + ring + · have hone : ordinalValue (translatedTruncation (x.1 : K⟦ℝ⟧) γ) = 1 := by + have hne : ordinalValue (translatedTruncation (x.1 : K⟦ℝ⟧) γ) ≠ 0 := by + rw [(mem_residualPointSet_iff.mp hγ).2] + exact x.residualValue_ne_zero + rcases eq_or_lt_of_le (Order.one_le_iff_pos.mpr (pos_iff_ne_zero.mpr hne)) with h | h + · exact h.symm + · exact absurd h hg1 + have h := hIHred 0 (by simp) (by simp) + rw [eval_zero, valueProd_zero, one_mul, one_mul] at h + rw [mul_assoc, ordinalValue_mul_of_ordinalValue_eq_one hone, h, hone] + ring + rcases eq_or_ne r 0 with hr0 | hr0 + · -- no other factor: the pure-power form of Lemma 8.2 + rw [heval, hvp, hr0, eval_zero, valueProd_zero, mul_one, mul_one] + refine ordinalValue_pow_eq_of_eventually x m (hkey.mono fun γ hγ hmem ↦ ?_) + have h := hγ hmem + simp only [hr0, eval_zero, valueProd_zero, mul_one] at h + exact h + · -- at least one other factor: the general form + have hc1 : 1 < ordinalValue (eval r) := hr ▸ one_lt_valueProd hr0 + set c : SeriesWithOrdinalValueAboveOne K := ⟨eval r, hc1⟩ with hcdef + have hce : c.1 = eval r := rfl + have hp' : x.principalValue ≤ c.principalValue := + principalValue_le_of_forall_mem x c r + (fun y hy ↦ (isSelected_selected w hw).min_principalValue y (mem_unselected.mp hy).1) + (by rw [hce]; exact hr) + have hev : ∀ᶠ γ in nhdsWithin (0 : ℝ) (Set.Iio 0), γ ∈ residualPointSet x → + ordinalValue (translatedTruncation (x.1 : K⟦ℝ⟧) γ * x.1 ^ m * c.1 ^ 2) + = ordinalValue x.1 ^ m * ordinalValue (translatedTruncation (x.1 : K⟦ℝ⟧) γ) + * ordinalValue c.1 * ordinalValue c.1 := by + refine hkey.mono fun γ hγ hmem ↦ ?_ + rw [hce, sq, hr] + exact hγ hmem + have h82 := ordinalValue_pow_mul_eq_of_eventually x c hp' m hev + rw [hce] at h82 + rw [heval, hvp, h82, hr] + +/-- Berarducci, Theorem 9.7: the ordinal value is multiplicative for the Hessenberg product. +Factors in `J` make both sides zero and factors of value one are deleted from both sides, which +reduces the statement to Lemma 9.6 on a two-factor expression. -/ +@[blueprint "fact:ordinal-value-multiplicativity" + (phase := "Ordinal value and degree") + (title := "Multiplicative property of the ordinal value (Ber00, Theorem 9.7)") + (statement := /-- + Let $K$ be a field of characteristic zero. For all + $b,c\in K((\mathbb R^{\le 0}))$, + \[ + v_J(bc)=v_J(b)\odot v_J(c). + \] + -/) + (proof := /-- + The cases $v_J(b)=0$, $v_J(c)=0$, $v_J(b)=1$, and $v_J(c)=1$ follow from + the ideal $J$ and multiplication by a series of ordinal value one. In the + remaining case, \ref{fact:ordinal-value-support-tail} bounds every sufficiently high + proper translated truncation below the value of its factor. Together with + \ref{lem:convolution-formula}, this supplies + Berarducci's well-founded induction on finite products of factors of ordinal + value greater than one. Applying the resulting identity to $b,c$ gives the + formula. + -/)] +theorem ordinalValue_mul [CharZero K] (b c : Series K) : + ordinalValue (b * c) = ordinalValue b * ordinalValue c := by + rcases eq_or_ne (ordinalValue b) 0 with hb0 | hb0 + · rw [hb0, zero_mul, ordinalValue_eq_zero_iff] + exact Ideal.mul_mem_right _ _ (ordinalValue_eq_zero_iff.mp hb0) + rcases eq_or_ne (ordinalValue c) 0 with hc0 | hc0 + · rw [hc0, mul_zero, ordinalValue_eq_zero_iff] + exact Ideal.mul_mem_left _ _ (ordinalValue_eq_zero_iff.mp hc0) + rcases eq_or_lt_of_le (Order.one_le_iff_pos.mpr (pos_iff_ne_zero.mpr hb0)) with hb1 | hb1 + · rw [← hb1, one_mul, ordinalValue_mul_of_ordinalValue_eq_one hb1.symm] + rcases eq_or_lt_of_le (Order.one_le_iff_pos.mpr (pos_iff_ne_zero.mpr hc0)) with hc1 | hc1 + · rw [← hc1, mul_one, mul_comm b c, ordinalValue_mul_of_ordinalValue_eq_one hc1.symm] + have h := ordinalValue_eval ({⟨b, hb1⟩, ⟨c, hc1⟩} : FormalExpression K) + rw [eval_eq, valueProd] at h + simpa using h + +/-- Berarducci, Corollary 9.8: the ideal of infinitesimal series is prime. -/ +theorem negativeMonomialIdeal_isPrime [CharZero K] : + (HahnSeries.Nonpositive.negativeMonomialIdeal K).IsPrime := by + rw [Ideal.isPrime_iff] + refine ⟨HahnSeries.Nonpositive.negativeMonomialIdeal_ne_top, ?_⟩ + intro b c hbc + have hzero : ordinalValue b * ordinalValue c = 0 := by + rw [← ordinalValue_mul, ordinalValue_eq_zero_iff] + exact hbc + by_cases hb : ordinalValue b = 0 + · exact Or.inl (ordinalValue_eq_zero_iff.mp hb) + · right + apply ordinalValue_eq_zero_iff.mp + by_contra hc + have hpos : 0 < ordinalValue b * ordinalValue c := + mul_pos (pos_iff_ne_zero.mpr hb) (pos_iff_ne_zero.mpr hc) + rw [hzero] at hpos + exact (lt_irrefl 0) hpos + +/-- Berarducci ordinal-value multiplicativity, imported as LM24, Fact 2.7.1(2). -/ +theorem ordinalValueMultiplicative [CharZero K] : OrdinalValueMultiplicative K := + OrdinalValueMultiplicative.of_forall ordinalValue_mul + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Statements/ResidualPoint.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Statements/ResidualPoint.lean new file mode 100644 index 0000000000..f1feea92ca --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Statements/ResidualPoint.lean @@ -0,0 +1,117 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.ResidualPointTail +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.SetOrderType +public import Mathlib.Topology.MetricSpace.Pseudo.Defs + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.ResidualPointSupport +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.ResidualPointOrderType +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.ResidualPointWellOrdered +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.ResidualPointCofinality +import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.OrderedUnion +import LeanPool.ConwayRefinement.ConwayRefinement.Topology.Order.LeftNeighborhood +import Mathlib.Topology.MetricSpace.Pseudo.Lemmas + +/-! +# Berarducci residual-point tail statements + +This module gives direct Lean statements of Berarducci, Lemmas 6.8 and 6.9. Lemma 6.8 combines +the proved cofinality, well-ordering, and order-type results. Lemma 6.9 invokes Lemma 6.8, applies +the proved support-family construction, and then applies the proved ordered-union estimate from +Berarducci, Lemma 4.7. + +The phrase "sufficiently close to zero" is the filter `nhdsWithin 0 (Set.Iio 0)`. The order type +in Lemma 6.8 is an `Ordinal`, hence the explicit `.val` on the `NatOrdinal` principal value. The +product in Lemma 6.9 is ordinary ordinal multiplication inside `NatOrdinal.of`, not Hessenberg +multiplication. + +Berarducci prints Lemma 6.9 for arbitrary `b`, although both `X(b)` and `v_J^p(b)` were +defined only when `1 < v_J(b)`. The Lean statement uses `SeriesWithOrdinalValueAboveOne K` for `b`, +making that necessary domain explicit without adding a mathematical hypothesis to a well-formed +source formula. + +The theorem statements agree with the printed Lemmas 6.8 and 6.9. For residual value one, the +proof of Lemma 6.8 uses isolated successor-indexed support points instead of the failing +limit-index construction in the printed proof; its conclusion is unchanged. + +Berarducci's ambient coefficient field has characteristic zero. The source statements retain +that hypothesis even though their proved definitions and cofinality prerequisite are available over +an arbitrary field. +-/ + +universe v + +open scoped HahnSeries NatOrdinal Topology + +public noncomputable section + +namespace Berarducci + +variable {K : Type v} [Field K] + +/-- Berarducci, Lemma 6.8: sufficiently high residual-point tails have principal order type and +least upper bound zero. -/ +theorem residualPointTail_eventually + (b : SeriesWithOrdinalValueAboveOne K) : + ∀ᶠ η in nhdsWithin (0 : ℝ) (Set.Iio 0), + (residualPointTail b η).Nonempty ∧ + ∃ htail : (residualPointTail b η).IsPWO, + htail.orderType = b.principalValue.val ∧ + IsLUB (residualPointTail b η) 0 := by + have hX := residualPointSet_isPWO b + have hXLUB := residualPointSet_isLUB_zero b + filter_upwards [residualPointTail_orderType_eventually b hX, + self_mem_nhdsWithin] with η htailType hη + have htailStructure := residualPointTail_nonempty_and_isLUB b hη hXLUB + exact ⟨htailStructure.1, residualPointTail_isPWO b η hX, + htailType, htailStructure.2⟩ + +/-- Berarducci, Lemma 6.9: an eventual lower bound on values of translated truncations along +`X(b)` gives the corresponding ordinary-product lower bound on `v_J(c)`. -/ +theorem ordinalValue_ge_of_eventually_ordinalValue_translatedTruncation_ge + (b : SeriesWithOrdinalValueAboveOne K) (c : Series K) {ρ : Ordinal} + (hρ : Ordinal.IsPrincipal (fun α β ↦ α + β) ρ) + (hc : ∀ᶠ γ in nhdsWithin (0 : ℝ) (Set.Iio 0), + γ ∈ residualPointSet b → + NatOrdinal.of ρ ≤ ordinalValue (translatedTruncation (c : K⟦ℝ⟧) γ)) : + NatOrdinal.of (ρ * b.principalValue.val) ≤ ordinalValue c := by + by_cases hρ0 : ρ = 0 + · subst ρ + simp + obtain ⟨ηc, hηc, hcAbove⟩ := + eventually_nhdsLT_iff_exists.mp hc + obtain ⟨ηt, hηt, htailAbove⟩ := + eventually_nhdsLT_iff_exists.mp (residualPointTail_eventually b) + obtain ⟨η, hηLower, hη⟩ := exists_between (max_lt hηc hηt) + have hηcη : ηc < η := (le_max_left ηc ηt).trans_lt hηLower + have hηtη : ηt < η := (le_max_right ηc ηt).trans_lt hηLower + obtain ⟨_, ⟨htail, htailType, htailLUB⟩⟩ := + htailAbove η hηtη hη + have hcTail : ∀ γ ∈ residualPointTail b η, + NatOrdinal.of ρ ≤ ordinalValue (translatedTruncation (c : K⟦ℝ⟧) γ) := by + intro γ hγ + obtain ⟨hγX, hηγ⟩ := mem_residualPointTail_iff.mp hγ + exact hcAbove γ (hηcη.trans hηγ) + (residualPointSet_subset_Iio b hγX) hγX + apply le_ordinalValue_of_forall_mem_representativeOrderTypes + intro o ho + obtain ⟨d, hcd, rfl⟩ := mem_representativeOrderTypes_iff.mp ho + rw [NatOrdinal.of.le_iff_le] + obtain ⟨B, hB, hseparated, hfinal, hUnion, hsubset⟩ := + exists_supportFamily_of_residualPointTail b c hρ0 htail htailType htailLUB hcTail d hcd + have hproduct := hUnion.mul_le_orderType_iUnion_of_isSuccLimit + b.principalValue_isInfiniteMultiplicativelyPrincipal.isSuccLimit B hB + hseparated hfinal + calc + ρ * b.principalValue.val ≤ hUnion.orderType := hproduct + _ ≤ (d : K⟦ℝ⟧).isPWO_support.orderType := + hUnion.orderType_mono (d : K⟦ℝ⟧).isPWO_support hsubset + _ = (d : K⟦ℝ⟧).supportOrderType := + (HahnSeries.supportOrderType_eq_setOrderType _).symm + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests.lean new file mode 100644 index 0000000000..d06f04d3b9 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests.lean @@ -0,0 +1,29 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Tests.AlgebraicIndependence +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Tests.BerarducciPrimitives +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Tests.ComplexityDecrease +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Tests.Convolution +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Tests.ConvolutionList +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Tests.ConvolutionRemainder +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Tests.CriticalPoint +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Tests.OrdinalValueFinalSegment +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Tests.OrdinalValueSubmultiplicative +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Tests.PrincipalComponent +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Tests.PrincipalComponentDegree +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Tests.PrincipalComponentTensor +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Tests.PrincipalSubring +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Tests.PrincipalSubringFiniteSupport +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Tests.PrincipalSubringFraction +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Tests.PrincipalSubringTensor +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Tests.PrincipalValue +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Tests.ResidualPoint +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Tests.SectionSixThree + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/AlgebraicIndependence.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/AlgebraicIndependence.lean new file mode 100644 index 0000000000..c4818ad03a --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/AlgebraicIndependence.lean @@ -0,0 +1,19 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Tests.AlgebraicIndependence.BaseChange +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Tests.AlgebraicIndependence.CutoffConvolution +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Tests.AlgebraicIndependence.DerivAt +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Tests.AlgebraicIndependence.FinitePowerFamily +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Tests.AlgebraicIndependence.LoweringDerivation +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Tests.AlgebraicIndependence.OmegaOmegaBoundary +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Tests.AlgebraicIndependence.PrincipalGraded +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Tests.AlgebraicIndependence.PrincipalIdealGE +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Tests.AlgebraicIndependence.SuccessorLeibniz + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/AlgebraicIndependence/BaseChange.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/AlgebraicIndependence/BaseChange.lean new file mode 100644 index 0000000000..9e0d5af381 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/AlgebraicIndependence/BaseChange.lean @@ -0,0 +1,193 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.BaseChange +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValueSupport +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.StableInterval + +/-! +# API checks for coefficient base change + +Coefficient extension is exercised where it is supposed to be rigid: it fixes the support, hence +the ordinal value, and it carries constants to constants, so a nonzero constant series keeps its +ordinal value along any extension of fields. The zero series is checked separately, since an empty +support is the boundary case of the support computations. + +On the homogeneous components, the checks run through the intrinsic classes rather than through +representatives: the class of an extended representative is the extension of the class, +componentwise +base change is +evaluated on a pure tensor, and its injectivity, valid for every field extension, shows that +distinct classes stay distinct. + +The graded checks evaluate the base-change map on a homogeneous pure tensor, record that it is an +injective algebra map, and draw the conclusion used by the structure theorem: `E ⊗[K] P̂` is a +domain. They also record the graded ring homomorphism `P̂ → P̂^(E)` of coefficient extension on a +homogeneous element and as the factor of the base change on an arbitrary pure tensor. The +remaining checks record the coefficientwise formulas for a `K`-linear map between extensions: a +functional into `K`, and the structure map `K → E`, along which the coefficientwise map is +coefficient extension and preserves the ordinal value. +-/ + +universe v w + +open scoped DirectSum HahnSeries NatOrdinal TensorProduct + +public noncomputable section + +namespace Tests + +open Berarducci + +open Berarducci + +open HahnSeries.Nonpositive + +variable {K : Type v} {E : Type w} [Field K] [Field E] + +/-! ### Coefficient extension of nonpositive series -/ + +/-- Coefficient extension fixes the ordinal value of a nonzero constant series, and computes it as +the constant series on the extended value. This runs the extension along the structure map of a +genuine field extension rather than along an endomorphism of the base. -/ +theorem baseChange_ordinalValue_coefficientMap_C [Algebra K E] (k : K) : + ordinalValue (nonpositiveCoefficientMap (algebraMap K E) + (HahnSeries.Nonpositive.C k)) = + ordinalValue (HahnSeries.Nonpositive.C k) ∧ + nonpositiveCoefficientMap (algebraMap K E) (HahnSeries.Nonpositive.C k) = + HahnSeries.Nonpositive.C (algebraMap K E k) := + ⟨ordinalValue_nonpositiveCoefficientMap _ _, nonpositiveCoefficientMap_C _ k⟩ + +/-- Boundary case: the zero series has empty support, and coefficient extension preserves both +the support and the individual coefficients there. -/ +theorem baseChange_coefficientMap_zero (f : K →+* E) (x : ℝ) : + ((nonpositiveCoefficientMap f (0 : HahnSeries.Nonpositive ℝ K) : + HahnSeries.Nonpositive ℝ E) : E⟦ℝ⟧).support = ∅ ∧ + ((nonpositiveCoefficientMap f (0 : HahnSeries.Nonpositive ℝ K) : + HahnSeries.Nonpositive ℝ E) : E⟦ℝ⟧).coeff x = 0 := by + refine ⟨?_, ?_⟩ + · rw [support_nonpositiveCoefficientMap] + simp + · rw [coe_nonpositiveCoefficientMap] + simp + +/-- Deleting the constant term cannot increase the ordinal value or the support supremum. -/ +theorem baseChange_ordinalValue_sub_C_constantCoeff_le (b : HahnSeries.Nonpositive ℝ K) : + ordinalValue (b - HahnSeries.Nonpositive.C (HahnSeries.Nonpositive.constantCoeff b)) ≤ + ordinalValue b ∧ + supportSup (b - HahnSeries.Nonpositive.C (HahnSeries.Nonpositive.constantCoeff b)) ≤ + supportSup b := by + have hsub : ((b - HahnSeries.Nonpositive.C (HahnSeries.Nonpositive.constantCoeff b) : + HahnSeries.Nonpositive ℝ K) : K⟦ℝ⟧).support ⊆ (b : K⟦ℝ⟧).support := by + rw [support_sub_C_constantCoeff] + exact Set.sdiff_subset + exact ⟨ordinalValue_le_of_support_subset _ _ hsub, supportSup_mono hsub⟩ + +/-- Interface check: along the structure map `K → E`, viewed as a `K`-linear map between the +extensions `K` and `E` of `K`, the coefficientwise linear map is coefficient extension, and it +preserves the ordinal value, as every injective `K`-linear map does. -/ +theorem baseChange_linearCoeffMap_algebraMap [Algebra K E] (u : HahnSeries.Nonpositive ℝ K) : + nonpositiveLinearCoeffMap (Algebra.linearMap K E) u = + nonpositiveCoefficientMap (algebraMap K E) u ∧ + ordinalValue (nonpositiveLinearCoeffMap (Algebra.linearMap K E) u) = ordinalValue u := + ⟨Subtype.ext (by + ext x + rw [coe_nonpositiveLinearCoeffMap, coe_nonpositiveCoefficientMap] + rfl), + ordinalValue_nonpositiveLinearCoeffMap_of_injective _ (algebraMap K E).injective u⟩ + +/-! ### Base change of `P_α` -/ + +section Layer + + +/-- The class of an extended representative is the extension of the class, both for the additive +component map and for its semilinear refinement. -/ +theorem baseChange_layer_mk [Algebra K E] (alpha : NatOrdinal) + (u : HahnSeries.Nonpositive ℝ K) (hu : ordinalValue u < ω^ (alpha + 1)) : + principalComponentCoefficientExtendAddHom (algebraMap K E) alpha + (principalComponentMk alpha u hu) = + principalComponentMk alpha (nonpositiveCoefficientMap (algebraMap K E) u) + (by rw [ordinalValue_nonpositiveCoefficientMap]; exact hu) ∧ + principalComponentCoefficientExtend K E alpha (principalComponentMk alpha u hu) = + principalComponentMk alpha (nonpositiveCoefficientMap (algebraMap K E) u) + (by rw [ordinalValue_nonpositiveCoefficientMap]; exact hu) := + ⟨principalComponentCoefficientExtendAddHom_principalComponentMk _ alpha u hu, + principalComponentCoefficientExtend_principalComponentMk E alpha u hu⟩ + +/-- Componentwise base change evaluates on a pure tensor as the scalar multiple of the extended +class. -/ +theorem baseChange_layer_tmul [Algebra K E] (alpha : NatOrdinal) (e : E) + (A : PrincipalComponent K alpha) : + principalComponentBaseChange K E alpha (e ⊗ₜ[K] A) = + e • principalComponentCoefficientExtend K E alpha A := + principalComponentBaseChange_tmul alpha e A + +/-- Tensors with equal images are equal: componentwise base change reflects equality, for every +field extension `E / K`. -/ +theorem baseChange_layer_eq_of_image_eq [Algebra K E] + (alpha : NatOrdinal) {t₁ t₂ : E ⊗[K] PrincipalComponent K alpha} + (h : principalComponentBaseChange K E alpha t₁ = + principalComponentBaseChange K E alpha t₂) : t₁ = t₂ := + principalComponentBaseChange_injective K E alpha h + +/-- Applying a `K`-linear functional coefficientwise acts coefficientwise, does not enlarge the +support, and does not increase the ordinal value. -/ +theorem baseChange_linearCoeffMap_properties [Algebra K E] (r : E →ₗ[K] K) + (u : HahnSeries.Nonpositive ℝ E) (x : ℝ) : + ((nonpositiveLinearCoeffMap r u : HahnSeries.Nonpositive ℝ K) : K⟦ℝ⟧).coeff x = + r ((u : E⟦ℝ⟧).coeff x) ∧ + ((nonpositiveLinearCoeffMap r u : HahnSeries.Nonpositive ℝ K) : K⟦ℝ⟧).support ⊆ + (u : E⟦ℝ⟧).support ∧ + ordinalValue (nonpositiveLinearCoeffMap r u) ≤ ordinalValue u := + ⟨coe_nonpositiveLinearCoeffMap r u x, support_nonpositiveLinearCoeffMap_subset r u, + ordinalValue_nonpositiveLinearCoeffMap_le r u⟩ + +end Layer + +/-! ### Base change of `P̂` and the quotient `P̂/I` -/ + +section Graded + +variable [Algebra K E] + +/-- The graded base change evaluates on a homogeneous pure tensor as the scalar multiple of the +extended homogeneous class. -/ +theorem baseChange_graded_tmul_of (e : E) (alpha : NatOrdinal) + (A : PrincipalComponent K alpha) : + principalSubringBaseChange K E + (e ⊗ₜ[K] DirectSum.of (PrincipalComponent K) alpha A) = + e • DirectSum.of (PrincipalComponent E) alpha + (principalComponentCoefficientExtend K E alpha A) := + principalSubringBaseChange_tmul_of e alpha A + +/-- Coefficient extension of `P̂` is a ring homomorphism acting on a homogeneous element through +the component map, and the graded base change on any pure tensor `e ⊗ B` is `e` times the +coefficient +extension of `B`, whether or not `B` is homogeneous. -/ +theorem baseChange_graded_coefficientExtend (e : E) (alpha : NatOrdinal) + (A : PrincipalComponent K alpha) (B : PrincipalSubring K) : + principalSubringCoefficientExtend K E (DirectSum.of (PrincipalComponent K) alpha A) = + DirectSum.of (PrincipalComponent E) alpha + (principalComponentCoefficientExtend K E alpha A) ∧ + principalSubringBaseChangeLinear K E (e ⊗ₜ[K] B) = + e • principalSubringCoefficientExtend K E B := + ⟨principalSubringCoefficientExtend_of alpha A, principalSubringBaseChangeLinear_tmul e B⟩ + +/-- The graded base change is an injective `E`-algebra map, for every field extension. -/ +theorem baseChange_graded_injective : + Function.Injective (principalSubringBaseChange K E) := + principalSubringBaseChange_injective K E + +/-- Consequently `E ⊗[K] P̂` is a domain. -/ +theorem baseChange_graded_isDomain [CharZero E] : + IsDomain (E ⊗[K] PrincipalSubring K) := + isDomain_tensor_principalSubring K E + +end Graded + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/AlgebraicIndependence/CutoffConvolution.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/AlgebraicIndependence/CutoffConvolution.lean new file mode 100644 index 0000000000..dfd1ea0dc5 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/AlgebraicIndependence/CutoffConvolution.lean @@ -0,0 +1,120 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.OmegaSupport +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.TruncationPolynomial +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Tests.Fixtures.ApproachZero + +/-! +# Cutoff and convolution API checks + +These clients exercise finiteness below an arbitrary negative cutoff and polynomial convolution +under bounds imposed only on nonzero germ products. The cutoff client uses the nonconstant +approach-zero series, so its value and support order type are genuinely omega. The convolution +boundary checks include an empty sum for a zero factor and a nonzero term at the zero cutoff. +They check these strengthened interfaces, not new definitions of series or ordinal value. +-/ + +open scoped NatOrdinal HahnSeries +open Berarducci HahnSeries MvPolynomial OrdinalGraded + +public noncomputable section + +namespace Tests + +universe v w + +variable {K : Type v} [Field K] + +/-- The nonconstant approach-zero series has finitely many cutoffs of ordinal value at least one +below every negative real, without requiring that real to belong to the cutoff set. -/ +theorem approachZero_negative_cutoff_finite {ξ : ℝ} (hξ : ξ < 0) : + (cutoffsGE 0 approachZeroNonpositive ∩ Set.Iic ξ).Finite := by + have hv := ordinalValue_eq_wpow_of_isPrincipal + approachZero_isPrincipal approachZero_degree_eq_one + apply cutoffsGE_inter_Iic_finite_of_neg approachZeroNonpositive + (by simpa using hv) ?_ hξ + simp [coe_approachZeroNonpositive, approachZero_supportOrderType] + +/-- The original membership-based cutoff interface remains available. -/ +theorem cutoff_membership_interface {δ : NatOrdinal} (p : Series K) + (hv : ordinalValue p = ω^ (δ + 1)) + (hot : (p : K⟦ℝ⟧).supportOrderType = (ω^ (δ + 1)).val) + {ξ : ℝ} (hξ : ξ ∈ cutoffsGE δ p) : (cutoffsGE δ p ∩ Set.Iic ξ).Finite := + cutoffsGE_inter_Iic_finite p hv hot hξ + +/-- A zero factor needs no cutoff in the support-indexed germ convolution sum. -/ +theorem zero_germ_convolution_empty (γ : ℝ) : + germAt ((0 : K⟦ℝ⟧) * 1) γ = + ∑ ξ ∈ (∅ : Finset ℝ), germAt (0 : K⟦ℝ⟧) ξ * germAt (1 : K⟦ℝ⟧) (γ - ξ) := by + apply germAt_mul_of_support_subset (0 : Series K) 1 γ + intro ξ hξ + exact (hξ (by + rw [Subring.coe_zero, germAt_apply, translatedTruncation_zero_input, map_zero, zero_mul])).elim + +/-- At the zero cutoff the product of two units has the singleton convolution term. -/ +theorem one_germ_convolution_at_zero : + germAt ((1 : ℚ⟦ℝ⟧) * 1) 0 = + ∑ ξ ∈ ({0} : Finset ℝ), germAt (1 : ℚ⟦ℝ⟧) ξ * germAt (1 : ℚ⟦ℝ⟧) (0 - ξ) := by + apply germAt_mul_of_support_subset (1 : Series ℚ) 1 0 + intro ξ hξ + by_contra hnot + have hclosure : ξ ∉ closure (1 : ℚ⟦ℝ⟧).support := by + simpa [HahnSeries.support_one] using hnot + exact hξ (by rw [Subring.coe_one, germAt_eq_zero_of_not_mem_closure_support hclosure, zero_mul]) + +/-- The singleton boundary check is not a vacuous zero convolution. -/ +theorem one_germ_convolution_term_ne_zero : + (∑ ξ ∈ ({0} : Finset ℝ), + germAt (1 : ℚ⟦ℝ⟧) ξ * germAt (1 : ℚ⟦ℝ⟧) (0 - ξ)) ≠ 0 := by + have h : germAt (1 : ℚ⟦ℝ⟧) 0 = 1 := by + rw [germAt_apply] + change toGerm (translatedTruncation ((1 : Series ℚ) : ℚ⟦ℝ⟧) 0) = 1 + rw [translatedTruncation_zero, map_one] + have hg : (1 : Germ ℚ) ≠ 0 := by + intro hz + have heq : toGerm (1 : Series ℚ) = toGerm 0 := by simpa using hz + have hv := ordinalValue_eq_of_sub_mem_negativeMonomialIdeal + (toGerm_eq_toGerm_iff.mp heq) + simp [ordinalValue_one, ordinalValue_zero] at hv + simpa only [Finset.sum_singleton, sub_zero, h, one_mul] using hg + +variable {ι : Type w} {wt : ι → NatOrdinal} {x : ι → PrincipalSubring K} + +/-- Bounds only at nonzero germ products suffice: the finite sum uses exactly those cutoffs. -/ +theorem polynomial_convolution_from_nonzero_bounds (σ : Lifts wt x) + (hx : IsMinimalSystem (principalGrading K) wt x) {α : NatOrdinal} + (hinj : ∀ β < α, InjectiveAt K wt x β) {u v : Series K} {γ : ℝ} + (hprod : ordinalValue (translatedTruncation ((u * v : Series K) : K⟦ℝ⟧) γ) < ω^ α) + (hterm : ∀ ξ : ℝ, + germAt (u : K⟦ℝ⟧) ξ * germAt (v : K⟦ℝ⟧) (γ - ξ) ≠ 0 → + ordinalValue (translatedTruncation (u : K⟦ℝ⟧) ξ) < ω^ α ∧ + ordinalValue (translatedTruncation (v : K⟦ℝ⟧) (γ - ξ)) < ω^ α ∧ + DegreeLT wt (σ.pol hx α (translatedTruncation (u : K⟦ℝ⟧) ξ) * + σ.pol hx α (translatedTruncation (v : K⟦ℝ⟧) (γ - ξ))) α) : + ∃ S : Finset ℝ, + (∀ ξ : ℝ, ξ ∈ S ↔ + germAt (u : K⟦ℝ⟧) ξ * germAt (v : K⟦ℝ⟧) (γ - ξ) ≠ 0) ∧ + σ.pol hx α (translatedTruncation ((u * v : Series K) : K⟦ℝ⟧) γ) = + ∑ ξ ∈ S, σ.pol hx α (translatedTruncation (u : K⟦ℝ⟧) ξ) * + σ.pol hx α (translatedTruncation (v : K⟦ℝ⟧) (γ - ξ)) := by + classical + let S := (convolutionIndex (u : K⟦ℝ⟧) (v : K⟦ℝ⟧) γ).filter fun ξ ↦ + germAt (u : K⟦ℝ⟧) ξ * germAt (v : K⟦ℝ⟧) (γ - ξ) ≠ 0 + have hS : ∀ ξ : ℝ, germAt (u : K⟦ℝ⟧) ξ * germAt (v : K⟦ℝ⟧) (γ - ξ) ≠ 0 → ξ ∈ S := by + intro ξ hξ + refine Finset.mem_filter.mpr ⟨?_, hξ⟩ + by_contra hnot + rw [mem_convolutionIndex, not_and_or] at hnot + rcases hnot with h | h + · exact hξ (by rw [germAt_eq_zero_of_not_mem_closure_support h, zero_mul]) + · exact hξ (by rw [germAt_eq_zero_of_not_mem_closure_support h, mul_zero]) + refine ⟨S, fun ξ ↦ ⟨fun hξ ↦ (Finset.mem_filter.mp hξ).2, hS ξ⟩, ?_⟩ + exact σ.pol_translatedTruncation_mul_eq_sum_of_nonzero_terms hx hinj hS hprod + fun ξ hξ ↦ hterm ξ (Finset.mem_filter.mp hξ).2 + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/AlgebraicIndependence/DerivAt.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/AlgebraicIndependence/DerivAt.lean new file mode 100644 index 0000000000..5b16538302 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/AlgebraicIndependence/DerivAt.lean @@ -0,0 +1,109 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalComponent +public import LeanPool.ConwayRefinement.ConwayRefinement.Order.Filter.FunAtZeroMinus +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.LoweringDerivation +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.FinitePart + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Tests.Fixtures.ApproachZero +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.DerivAtInjective + +/-! +# API checks for `∂` on `P_α` + +The degree-one approach-zero series gives a nonzero class in the homogeneous component `P_1`. +Injectivity of `∂` +on `P_1` (D3) sends it to a nonzero element of `Fun_{0⁻}(P_0)`, and the derivation +`∂ : P̂ → Fun_{0⁻}(P̂)` sends its homogeneous inclusion to a nonzero function at `0⁻`. These +checks distinguish both maps from zero on a class represented by a series with infinite support +cofinal below zero. +-/ + +open Filter Topology +open scoped HahnSeries NatOrdinal TensorProduct + +public noncomputable section + +namespace Tests + +open Berarducci + +private theorem approachZero_ordinalValue_bound_for_lowering : + Berarducci.ordinalValue approachZeroNonpositive < + ω^ ((1 : NatOrdinal) + 1) := by + rw [Berarducci.ordinalValue_eq_wpow_of_isPrincipal approachZero_isPrincipal + approachZero_degree_eq_one] + exact NatOrdinal.wpow_lt_wpow.mpr (lt_add_one (1 : NatOrdinal)) + +private theorem one_constantCoeff_pos : + 0 < (1 : NatOrdinal).constantCoeff := by + have hcoeff : (1 : NatOrdinal).constantCoeff = 1 := by + simpa only [Nat.cast_one] using NatOrdinal.constantCoeff_natCast (1 : ℕ) + rw [hcoeff] + decide + +/-- `∂(B)` for the class `B ∈ P_1` of the degree-one approach-zero series. -/ +def approachZeroDerivAt : + FunAtZeroMinus (Berarducci.PrincipalComponent ℚ + ((1 : NatOrdinal).removeNat 1)) := + principalComponentDerivAt ℚ 1 one_constantCoeff_pos + (Berarducci.principalComponentMk 1 approachZeroNonpositive + approachZero_ordinalValue_bound_for_lowering) + +private theorem approachZeroPrincipalClass_ne_zero : + Berarducci.principalComponentMk 1 approachZeroNonpositive + approachZero_ordinalValue_bound_for_lowering ≠ 0 := by + intro hzero + have hlower := (Berarducci.principalComponentMk_eq_zero_iff 1 + approachZeroNonpositive approachZero_ordinalValue_bound_for_lowering).mp hzero + rw [Berarducci.ordinalValue_eq_wpow_of_isPrincipal approachZero_isPrincipal + approachZero_degree_eq_one] at hlower + exact lt_irrefl _ hlower + +private theorem approachZero_ordinalValue_bound_for_natCast_one : + Berarducci.ordinalValue approachZeroNonpositive < + ω^ (((1 : ℕ) : NatOrdinal) + 1) := by + simpa only [Nat.cast_one] using approachZero_ordinalValue_bound_for_lowering + +private theorem approachZeroPrincipalClassNatCast_ne_zero : + Berarducci.principalComponentMk ((1 : ℕ) : NatOrdinal) + approachZeroNonpositive approachZero_ordinalValue_bound_for_natCast_one ≠ 0 := by + intro hzero + have hlower := (Berarducci.principalComponentMk_eq_zero_iff + ((1 : ℕ) : NatOrdinal) approachZeroNonpositive + approachZero_ordinalValue_bound_for_natCast_one).mp hzero + rw [Berarducci.ordinalValue_eq_wpow_of_isPrincipal approachZero_isPrincipal + approachZero_degree_eq_one] at hlower + have : ω^ (1 : NatOrdinal) < ω^ (1 : NatOrdinal) := by + simpa only [Nat.cast_one] using hlower + exact lt_irrefl _ this + +/-- `∂(B) ≠ 0` for the approach-zero class `B`, because support cutoffs remain cofinal at +zero. -/ +theorem approachZeroDerivAt_ne_zero : + approachZeroDerivAt ≠ 0 := by + rw [approachZeroDerivAt] + exact principalComponentDerivAt_ne_zero 1 + one_constantCoeff_pos approachZeroPrincipalClass_ne_zero + +/-- The homogeneous inclusion of the approach-zero class in `P̂`. -/ +def approachZeroPrincipalElement : Berarducci.PrincipalSubring ℚ := + DirectSum.of (Berarducci.PrincipalComponent ℚ) 1 + (Berarducci.principalComponentMk 1 approachZeroNonpositive + approachZero_ordinalValue_bound_for_lowering) + +/-- The derivation `∂` of `P̂` detects the approach-zero element: `∂` is injective on `P_1`. -/ +theorem principalSubringDerivation_approachZero_ne_zero : + principalSubringDerivation ℚ approachZeroPrincipalElement ≠ 0 := by + intro hzero + have h := (principalSubringDerivation_isLoweringDerivation ℚ).injective + one_constantCoeff_pos (of_mem_principalGrading 1 _) hzero + exact approachZeroPrincipalClass_ne_zero + (DirectSum.of_injective 1 (h.trans (map_zero _).symm)) + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/AlgebraicIndependence/FinitePowerFamily.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/AlgebraicIndependence/FinitePowerFamily.lean new file mode 100644 index 0000000000..dc1b9534d9 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/AlgebraicIndependence/FinitePowerFamily.lean @@ -0,0 +1,81 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Support.FinitePowerFamilyProof + +/-! +# Boundary examples for the finite-power family + +At `n = 0`, the positive support consists of one exponent, and adjoining the constant term gives +a support of order type two. At `n = 1`, the first two positive exponents are `4 / 3` and +`4 / 9`. At `n = 2`, the first exponent is `13 / 9` and the support has order type `ω ^ 2 + 1`. +These values distinguish +the recursive lexicographic construction from a constant sequence or a one-dimensional +flattening. + +The constant coefficient is one before subtracting one and zero afterwards. The doubled family +has the same exponent support, showing directly that the support is insensitive to this change of +coefficients. +-/ + +public noncomputable section + +namespace Tests.HahnSeries.OrdinalValue.AlgebraicIndependence.FinitePowerFamily + +open Ordinal +open ConwayRefinement.Standalone.Oz.FinitePowerFamily + +example : finitePowerConwayExponent 0 () = 1 := by + rw [finitePowerConwayExponent_apply, finitePowerExponent_zero] + norm_num + +example : finitePowerConwayExponent 1 (toLex (0, ())) = 4 / 3 := by + rw [finitePowerConwayExponent_apply, finitePowerExponent_succ, + finitePowerExponent_zero, scale_eq_one_div_three] + norm_num + +example : finitePowerConwayExponent 1 (toLex (1, ())) = 4 / 9 := by + rw [finitePowerConwayExponent_apply, finitePowerExponent_succ, + finitePowerExponent_zero, scale_eq_one_div_three] + norm_num + +example : + finitePowerConwayExponent 2 (toLex (0, toLex (0, ()))) = 13 / 9 := by + rw [finitePowerConwayExponent_apply, finitePowerExponent_succ, + finitePowerExponent_succ, finitePowerExponent_zero, + scale_eq_one_div_three] + norm_num + +example : (finitePowerOz 0).1.length = 2 := by + rw [finitePowerOz_length] + norm_num + +example : (finitePowerOz 1).1.length = ω + 1 := by + simpa using finitePowerOz_length 1 + +example : (finitePowerOz 2).1.length = ω ^ (2 : Ordinal) + 1 := + finitePowerOz_length 2 + +example : finitePowerOz 1 ≠ finitePowerOz 2 := by + intro h + have := finitePowerOz_injective h + omega + +example (n : ℕ) : 0 ∉ ((finitePowerOz n).1 - 1).support := + zero_not_mem_finitePowerOz_sub_one_support n + +example (n : ℕ) : + (finitePowerFoil n).1.support = (finitePowerOz n).1.support := + finitePowerFoil_support n + +example (n : ℕ) : ¬ ConwayRefinement.Standalone.Oz.IsReduced (finitePowerFoil n) := + finitePowerFoil_not_isReduced n + +example (n : ℕ) : IsPrimal (finitePowerOz n) := + PrimalFamily.proof n + +end Tests.HahnSeries.OrdinalValue.AlgebraicIndependence.FinitePowerFamily diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/AlgebraicIndependence/LoweringDerivation.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/AlgebraicIndependence/LoweringDerivation.lean new file mode 100644 index 0000000000..86a0e1f50a --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/AlgebraicIndependence/LoweringDerivation.lean @@ -0,0 +1,64 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.LoweringDerivation +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Degree.Statements.Degree + +/-! +# API checks for the quotient `P̂/I` + +The quotient `P̂/I` satisfies two conclusions of different strength: the ideal `I` is prime, +equivalently `P̂/I` is a domain, and `P̂/I` is geometrically integral over `K`. + +Geometric integrality is strictly stronger than integrality over `K`: tensoring with every field +extension must give a domain, with no finiteness or separability hypothesis. + +The separate nontriviality statement matters because a quotient by the whole ring would satisfy +the no-zero-divisors condition vacuously, while `IsDomain` also requires `0 ≠ 1`. +-/ + +open scoped TensorProduct + +public noncomputable section + +namespace Tests + +open Berarducci +open Berarducci + +universe v + +variable {K : Type v} [Field K] + +variable (K) in +/-- The ideal `I = I_{≥1}` is proper, so the quotient `P̂/I` is nontrivial, over every field. -/ +theorem coefficientIdeal_ne_top : + principalFibreIdeal K ≠ ⊤ := + fun h ↦ LoweringDerivation.one_notMem_fibreIdeal _ (h ▸ Submodule.mem_top) + +variable [CharZero K] + +variable (K) in +/-- The quotient `P̂/I` is a domain. -/ +theorem coefficientQuotient_isDomain : + IsDomain (PrincipalFibre K) := + principalFibre_isDomain K + +variable (K) in +/-- Tensoring `P̂/I` with an arbitrary field extension gives a domain. -/ +theorem coefficientQuotient_isDomain_tensor (L : Type (max 1 v)) [Field L] [Algebra K L] : + IsDomain (PrincipalFibre K ⊗[K] L) := + Algebra.isGeometricallyIntegral_iff.mp + (principalFibre_isGeometricallyIntegral K) L + +variable (K) in +/-- The quotient `P̂/I` is geometrically integral over `K`. -/ +theorem coefficientQuotient_isGeometricallyIntegral : + Algebra.IsGeometricallyIntegral K (PrincipalFibre K) := + principalFibre_isGeometricallyIntegral K + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/AlgebraicIndependence/OmegaOmegaBoundary.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/AlgebraicIndependence/OmegaOmegaBoundary.lean new file mode 100644 index 0000000000..a617bffc9b --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/AlgebraicIndependence/OmegaOmegaBoundary.lean @@ -0,0 +1,62 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Support.OmegaOmegaBoundary + +/-! +# Concrete values at the `ω ^ ω` boundary + +The unique exponent in block zero is `7 / 9`, while the first exponent in block one is `25 / 81`. +Thus successive tuple blocks are genuinely rescaled and separated rather than superimposed. The +normal form has coefficient zero at exponent zero, distinguishing the purely infinite boundary +element from the finite-power family, whose normal forms include a constant term. +-/ + +public noncomputable section + +namespace Tests.HahnSeries.OrdinalValue.AlgebraicIndependence.OmegaOmegaBoundary + +open Ordinal +open ConwayRefinement.Standalone.Oz.FinitePowerFamily +open ConwayRefinement.Standalone.Oz.OmegaOmegaBoundary + +example : boundaryConwayExponent (toLex ⟨0, ()⟩) = 7 / 9 := by + rw [boundaryConwayExponent_apply, boundarySignedExponent_mk, + finitePowerExponent_zero, scale_eq_one_div_three] + norm_num + +example : boundaryConwayExponent (toLex ⟨1, toLex (0, ())⟩) = 25 / 81 := by + rw [boundaryConwayExponent_apply, boundarySignedExponent_mk, + finitePowerExponent_succ, finitePowerExponent_zero, scale_eq_one_div_three] + norm_num + +example : + boundaryConwayExponent (toLex ⟨1, toLex (0, ())⟩) < + boundaryConwayExponent (toLex ⟨0, ()⟩) := by + norm_num [boundaryConwayExponent_apply, boundarySignedExponent_mk, + finitePowerExponent_succ, finitePowerExponent_zero, scale_eq_one_div_three] + +example : + boundaryOz.1.coeff (boundaryExponentAtIndex (toLex ⟨0, ()⟩)) = 1 := + boundaryOz_coeff_exponent _ + +example : boundaryOz.1.coeff 0 = 0 := + boundaryOz_coeff_zero + +example : boundaryOz.1.length = ω ^ ω := + boundaryOz_length + +example : ¬ ConwayRefinement.Standalone.Oz.IsOrdinaryInteger boundaryOz := + boundaryOz_not_isOrdinaryInteger + +example : ConwayRefinement.Standalone.Oz.IsReduced boundaryOz := + boundaryOz_isReduced + +example : ¬ ConwayRefinement.Standalone.Oz.HasFiniteDegree boundaryOz := + boundaryOz_not_hasFiniteDegree + +end Tests.HahnSeries.OrdinalValue.AlgebraicIndependence.OmegaOmegaBoundary diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/AlgebraicIndependence/PrincipalGraded.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/AlgebraicIndependence/PrincipalGraded.lean new file mode 100644 index 0000000000..cf793631da --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/AlgebraicIndependence/PrincipalGraded.lean @@ -0,0 +1,213 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Tests.Fixtures.ApproachZero +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.PrincipalGraded + +/-! +# API checks for the finite-degree part `P̂_{<ω}` and the quotient `P̂/I` + +The approach-zero series supplies a nonzero class in `P_1`. Its homogeneous realization belongs +to `(P̂_{<ω})₊`, whereas a nonzero scalar in `P_0` belongs to `P̂_{<ω}` but not to `(P̂_{<ω})₊`. +These two examples separate the ideal of positive degree from both the zero ideal and all of +`P̂_{<ω}`. + +The same degree-one class remains nonzero modulo the decomposables because +`(P̂_{<ω})₊² ∩ P_1 = 0`. Its nonzero square belongs to `(P̂_{<ω})₊² ∩ P_2` and vanishes in +`P_2 / ((P̂_{<ω})₊² ∩ P_2)`. These examples distinguish the decomposables from both zero and the +whole component. They also show that the minimal system `𝓑` has a member of degree one, so the +polynomial evaluation statements are nonvacuous. Surjectivity is then exercised on an element +having both nonzero scalar and positive homogeneous parts. + +Finally, a nonzero homogeneous class in degree `ω` is excluded from `P̂_{<ω}`, distinguishing +`P̂_{<ω}` from `P̂`. +-/ + +public noncomputable section + +namespace Tests + +open scoped DirectSum HahnSeries NatOrdinal + +private theorem approachZero_ordinalValue_bound_for_finiteDegree : + Berarducci.ordinalValue approachZeroNonpositive < + ω^ (((1 : ℕ) : NatOrdinal) + 1) := by + rw [Berarducci.ordinalValue_eq_wpow_of_isPrincipal approachZero_isPrincipal + approachZero_degree_eq_one] + rw [Nat.cast_one] + exact NatOrdinal.wpow_lt_wpow.mpr (lt_add_one (1 : NatOrdinal)) + +/-- The nonzero degree-one principal class represented by the approach-zero series. -/ +def finiteDegreeApproachZeroComponent : + Berarducci.PrincipalComponent ℚ ((1 : ℕ) : NatOrdinal) := + Berarducci.principalComponentMk ((1 : ℕ) : NatOrdinal) approachZeroNonpositive + approachZero_ordinalValue_bound_for_finiteDegree + +theorem finiteDegreeApproachZeroComponent_ne_zero : + finiteDegreeApproachZeroComponent ≠ 0 := by + intro hzero + rw [finiteDegreeApproachZeroComponent] at hzero + have hlt := (Berarducci.principalComponentMk_eq_zero_iff + ((1 : ℕ) : NatOrdinal) approachZeroNonpositive + approachZero_ordinalValue_bound_for_finiteDegree).mp hzero + rw [Berarducci.ordinalValue_eq_wpow_of_isPrincipal approachZero_isPrincipal + approachZero_degree_eq_one] at hlt + rw [Nat.cast_one] at hlt + exact (lt_irrefl _) hlt + +/-- The approach-zero class regarded as a homogeneous element of `P̂_{<ω}`. -/ +def finiteDegreeApproachZeroElement : + Berarducci.principalFiniteDegreePart ℚ := + Berarducci.finiteDegreeOf ℚ 1 + finiteDegreeApproachZeroComponent + +/-- The degree-one fixture belongs to `(P̂_{<ω})₊` and remains nonzero in `P̂_{<ω}`. -/ +theorem finiteDegreeApproachZeroElement_positive_nonzero : + finiteDegreeApproachZeroElement ∈ + Berarducci.positiveFinitePrincipalIdeal ℚ ∧ + finiteDegreeApproachZeroElement ≠ 0 := by + constructor + · rw [Berarducci.mem_positiveFinitePrincipalIdeal_iff_component_zero, + finiteDegreeApproachZeroElement, + Berarducci.coe_finiteDegreeOf, + DirectSum.of_apply] + simp + · intro hzero + apply finiteDegreeApproachZeroComponent_ne_zero + apply Berarducci.finiteDegreeOf_injective ℚ 1 + rw [map_zero] + exact hzero + +private theorem principalComponentScalarOne_ne_zero : + Berarducci.principalComponentScalarHom ℚ (1 : ℚ) ≠ 0 := by + rw [Berarducci.principalComponentScalarHom_apply] + intro hzero + have hlt := (Berarducci.principalComponentMk_eq_zero_iff 0 + ((HahnSeries.Nonpositive.C : ℚ →+* Berarducci.Series ℚ) 1) + (Berarducci.ordinalValue_C_lt_wpow_one 1)).mp hzero + rw [Berarducci.ordinalValue_C_of_ne one_ne_zero, + NatOrdinal.wpow_zero] at hlt + exact (lt_irrefl _) hlt + +/-- The nonzero scalar one, represented homogeneously in degree zero of `P̂_{<ω}`. -/ +def finiteDegreeScalarOne : + Berarducci.principalFiniteDegreePart ℚ := + 1 + +/-- The scalar fixture belongs to `P̂_{<ω}` but not to its ideal `(P̂_{<ω})₊` of positive degree. -/ +theorem finiteDegreeScalarOne_not_mem_positive : + finiteDegreeScalarOne ∉ + Berarducci.positiveFinitePrincipalIdeal ℚ := by + rw [Berarducci.mem_positiveFinitePrincipalIdeal_iff_component_zero, + finiteDegreeScalarOne] + change (1 : Berarducci.PrincipalSubring ℚ) 0 ≠ 0 + rw [← map_one (algebraMap ℚ (Berarducci.PrincipalSubring ℚ)), + Berarducci.principalSubring_algebraMap_apply, DirectSum.of_apply] + simp + +/-- The nonzero degree-one class in the quotient `P_1 / ((P̂_{<ω})₊² ∩ P_1)`. -/ +def finiteDegreeApproachZeroIndecomposable : + Berarducci.PrincipalIndecomposableQuotient ℚ 1 := + Berarducci.principalIndecomposableMk ℚ 1 + finiteDegreeApproachZeroComponent + +/-- The approach-zero class survives modulo the decomposables, as `(P̂_{<ω})₊² ∩ P_1 = 0`. -/ +theorem finiteDegreeApproachZeroIndecomposable_ne_zero : + finiteDegreeApproachZeroIndecomposable ≠ 0 := by + rw [finiteDegreeApproachZeroIndecomposable, ne_eq, + Berarducci.principalIndecomposableMk_eq_zero_iff, + Berarducci.decomposablePrincipalComponent_one, Submodule.mem_bot] + exact finiteDegreeApproachZeroComponent_ne_zero + +/-- The square of the approach-zero principal class, in degree two. -/ +def finiteDegreeApproachZeroSquare : + Berarducci.PrincipalComponent ℚ ((2 : ℕ) : NatOrdinal) := + Berarducci.principalComponentMulNat ℚ 1 1 + finiteDegreeApproachZeroComponent + finiteDegreeApproachZeroComponent + +/-- The square is a nonzero decomposable vector: it lies in `(P̂_{<ω})₊² ∩ P_2`. -/ +theorem finiteDegreeApproachZeroSquare_mem_decomposable_ne_zero : + finiteDegreeApproachZeroSquare ∈ + Berarducci.decomposablePrincipalComponent ℚ 2 ∧ + finiteDegreeApproachZeroSquare ≠ 0 := by + constructor + · exact Berarducci.principalComponentMulNat_mem_decomposable + (i := 1) (j := 1) (Nat.zero_lt_succ 0) (Nat.zero_lt_succ 0) + finiteDegreeApproachZeroComponent + finiteDegreeApproachZeroComponent + · exact Berarducci.principalComponentMulNat_ne_zero + finiteDegreeApproachZeroComponent_ne_zero + finiteDegreeApproachZeroComponent_ne_zero + +/-- The same nonzero decomposable square vanishes in `P_2 / ((P̂_{<ω})₊² ∩ P_2)`. -/ +theorem finiteDegreeApproachZeroSquare_indecomposable_eq_zero : + Berarducci.principalIndecomposableMk ℚ 2 + finiteDegreeApproachZeroSquare = 0 := by + rw [Berarducci.principalIndecomposableMk_eq_zero_iff] + exact finiteDegreeApproachZeroSquare_mem_decomposable_ne_zero.1 + +/-- The quotient map `π : P̂ → P̂/I` kills the degree-one fixture. -/ +theorem finiteDegreeApproachZeroElement_quotient_eq_zero : + Berarducci.principalFibreMap ℚ + (finiteDegreeApproachZeroElement : + Berarducci.PrincipalSubring ℚ) = 0 := by + rw [Berarducci.principalFibreMap_eq_zero_iff] + exact Berarducci.coe_mem_principalFibreIdeal + finiteDegreeApproachZeroElement_positive_nonzero.1 + +/-- A nonzero homogeneous class in degree `ω` does not belong to `P̂_{<ω}`. -/ +theorem infiniteDegreeHomogeneous_not_mem_finite + (x : Berarducci.PrincipalComponent ℚ (NatOrdinal.of Ordinal.omega0)) + (hx : x ≠ 0) : + DirectSum.of (Berarducci.PrincipalComponent ℚ) + (NatOrdinal.of Ordinal.omega0) x ∉ + Berarducci.principalFiniteDegreePart ℚ := by + intro hmem + have hfinite := + (Berarducci.mem_principalFiniteDegreePart_iff _).mp hmem + have hcomponent : + (DirectSum.of (Berarducci.PrincipalComponent ℚ) + (NatOrdinal.of Ordinal.omega0) x) (NatOrdinal.of Ordinal.omega0) ≠ 0 := by + rw [DirectSum.of_apply] + simpa using hx + exact (lt_irrefl _) (hfinite (NatOrdinal.of Ordinal.omega0) hcomponent) + +/-- The minimal system `𝓑` has an element of degree one. -/ +theorem exists_minimalSystem_degree_one : + ∃ x : Berarducci.MinimalSystem ℚ, + Berarducci.minimalSystemDegree x = 1 := by + let q := finiteDegreeApproachZeroIndecomposable + have hq : q ≠ 0 := finiteDegreeApproachZeroIndecomposable_ne_zero + let : Nontrivial (Berarducci.PrincipalIndecomposableQuotient ℚ 1) := + ⟨⟨q, 0, hq⟩⟩ + obtain ⟨i⟩ := (Berarducci.principalIndecomposableBasis ℚ 1).index_nonempty + exact ⟨⟨⟨1, by decide⟩, i⟩, rfl⟩ + +/-- The evaluation `K[X_B : B ∈ 𝓑] → P̂_{<ω}` has a variable `X_B` with `deg B = 1` whose value is +nonzero and of positive degree. -/ +theorem exists_finiteDegreePolynomialVariable_degree_one : + ∃ x : Berarducci.MinimalSystem ℚ, + Berarducci.minimalSystemDegree x = 1 ∧ + Berarducci.finiteDegreePolynomialEval ℚ (MvPolynomial.X x) ≠ 0 ∧ + Berarducci.finiteDegreePolynomialEval ℚ (MvPolynomial.X x) ∈ + Berarducci.positiveFinitePrincipalIdeal ℚ := by + obtain ⟨x, hx⟩ := exists_minimalSystem_degree_one + refine ⟨x, hx, ?_, ?_⟩ + · rw [Berarducci.finiteDegreePolynomialEval_X] + exact Berarducci.minimalSystemElement_ne_zero x + · rw [Berarducci.finiteDegreePolynomialEval_X] + exact Berarducci.minimalSystemElement_mem_positive x + +/-- Polynomial evaluation reaches a target with nonzero degree-zero and degree-one parts. -/ +theorem exists_finiteDegreePolynomial_scalar_add_approachZero : + ∃ p : MvPolynomial (Berarducci.MinimalSystem ℚ) ℚ, + Berarducci.finiteDegreePolynomialEval ℚ p = + finiteDegreeScalarOne + finiteDegreeApproachZeroElement := + Berarducci.finiteDegreePolynomialEval_surjective ℚ _ + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/AlgebraicIndependence/PrincipalIdealGE.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/AlgebraicIndependence/PrincipalIdealGE.lean new file mode 100644 index 0000000000..634841cdbb --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/AlgebraicIndependence/PrincipalIdealGE.lean @@ -0,0 +1,131 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.PrincipalIdealGE + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Tests.Fixtures.ApproachZero +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.LoweringDerivation + +/-! +# API checks for the filtration `I_{≥•}` + +The approach-zero class gives a nonzero homogeneous element of degree one in `I_{≥1} \ I_{≥2}`; +its square gives one in `I_{≥2} \ I_{≥3}`. Adding a nonzero scalar component to the degree-one +element produces an element outside `I_{≥1}`, which distinguishes the filtration from a cutoff +determined by the largest visible homogeneous degree. +-/ + +open scoped DirectSum HahnSeries NatOrdinal + +public noncomputable section + +namespace Tests + +open Berarducci + +private theorem approachZero_ordinalValue_bound_for_idealGE : + Berarducci.ordinalValue approachZeroNonpositive < + ω^ (((1 : ℕ) : NatOrdinal) + 1) := by + rw [Berarducci.ordinalValue_eq_wpow_of_isPrincipal approachZero_isPrincipal + approachZero_degree_eq_one] + simpa only [Nat.cast_one] using + NatOrdinal.wpow_lt_wpow.mpr (lt_add_one (1 : NatOrdinal)) + +/-- The approach-zero series represented in the homogeneous component `P_1`. -/ +def idealGEApproachZeroLayer : + Berarducci.PrincipalComponent ℚ ((1 : ℕ) : NatOrdinal) := + Berarducci.principalComponentMk ((1 : ℕ) : NatOrdinal) + approachZeroNonpositive approachZero_ordinalValue_bound_for_idealGE + +/-- The approach-zero class used by the filtration fixture is nonzero. -/ +theorem idealGEApproachZeroLayer_ne_zero : + idealGEApproachZeroLayer ≠ 0 := by + intro hzero + have hlower := (Berarducci.principalComponentMk_eq_zero_iff + ((1 : ℕ) : NatOrdinal) approachZeroNonpositive + approachZero_ordinalValue_bound_for_idealGE).mp hzero + rw [Berarducci.ordinalValue_eq_wpow_of_isPrincipal approachZero_isPrincipal + approachZero_degree_eq_one] at hlower + have : ω^ (1 : NatOrdinal) < ω^ (1 : NatOrdinal) := by + simpa only [Nat.cast_one] using hlower + exact (lt_irrefl _) this + +/-- The approach-zero class placed homogeneously in `P̂`. -/ +def idealGEApproachZeroElement : Berarducci.PrincipalSubring ℚ := + DirectSum.of (Berarducci.PrincipalComponent ℚ) ((1 : ℕ) : NatOrdinal) + idealGEApproachZeroLayer + +/-- The degree-one fixture lies in `I_{≥1}` but not in `I_{≥2}`. -/ +theorem idealGEApproachZeroElement_mem_one_not_mem_two : + idealGEApproachZeroElement ∈ principalIdealGE ℚ 1 ∧ + idealGEApproachZeroElement ∉ principalIdealGE ℚ 2 := by + constructor + · exact principalIdealGEGenerator_mem (le_refl 1) + idealGEApproachZeroLayer + · intro hmem + apply idealGEApproachZeroLayer_ne_zero + apply eq_zero_of_homogeneous_mem_principalIdealGE + (j := 2) (δ := ((1 : ℕ) : NatOrdinal)) (by + rw [NatOrdinal.constantCoeff_natCast] + decide) + exact hmem + +/-- The square of the approach-zero class in the homogeneous component `P_2`. -/ +def idealGEApproachZeroSquare : + Berarducci.PrincipalComponent ℚ ((2 : ℕ) : NatOrdinal) := + principalComponentMulNat ℚ 1 1 + idealGEApproachZeroLayer idealGEApproachZeroLayer + +/-- The square of the approach-zero class is nonzero. -/ +theorem idealGEApproachZeroSquare_ne_zero : + idealGEApproachZeroSquare ≠ 0 := + principalComponentMulNat_ne_zero + idealGEApproachZeroLayer_ne_zero + idealGEApproachZeroLayer_ne_zero + +/-- The approach-zero square placed homogeneously in `P̂`. -/ +def idealGEApproachZeroSquareElement : Berarducci.PrincipalSubring ℚ := + DirectSum.of (Berarducci.PrincipalComponent ℚ) ((2 : ℕ) : NatOrdinal) + idealGEApproachZeroSquare + +/-- The degree-two fixture lies in `I_{≥2}` but not in `I_{≥3}`. -/ +theorem idealGEApproachZeroSquareElement_mem_two_not_mem_three : + idealGEApproachZeroSquareElement ∈ principalIdealGE ℚ 2 ∧ + idealGEApproachZeroSquareElement ∉ principalIdealGE ℚ 3 := by + constructor + · exact principalIdealGEGenerator_mem (le_refl 2) + idealGEApproachZeroSquare + · intro hmem + apply idealGEApproachZeroSquare_ne_zero + apply eq_zero_of_homogeneous_mem_principalIdealGE + (j := 3) (δ := ((2 : ℕ) : NatOrdinal)) (by + rw [NatOrdinal.constantCoeff_natCast] + decide) + exact hmem + +/-- The sum of scalar one and the homogeneous degree-one fixture. -/ +def idealGEScalarPlusApproachZero : Berarducci.PrincipalSubring ℚ := + 1 + idealGEApproachZeroElement + +/-- A nonzero scalar component prevents the mixed fixture from belonging to `I_{≥1}`. -/ +theorem idealGEScalarPlusApproachZero_not_mem_one : + idealGEScalarPlusApproachZero ∉ principalIdealGE ℚ 1 := by + intro hmem + have hzero := principalIdealGE_component_eq_zero + idealGEScalarPlusApproachZero hmem (δ := 0) (by simp) + have hscalar : (1 : Berarducci.PrincipalSubring ℚ) 0 ≠ 0 := by + intro hone + have hone' : GradedMonoid.GOne.one = + (0 : Berarducci.PrincipalComponent ℚ 0) := by + simpa only [DirectSum.one_def, DirectSum.of_apply, dite_true] using hone + apply (one_ne_zero : (1 : Berarducci.PrincipalSubring ℚ) ≠ 0) + rw [DirectSum.one_def, hone', map_zero] + apply hscalar + simpa [idealGEScalarPlusApproachZero, idealGEApproachZeroElement, + DirectSum.add_apply, DirectSum.of_apply] using hzero + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/AlgebraicIndependence/SuccessorLeibniz.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/AlgebraicIndependence/SuccessorLeibniz.lean new file mode 100644 index 0000000000..97a1a63d3c --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/AlgebraicIndependence/SuccessorLeibniz.lean @@ -0,0 +1,169 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.SuccessorLeibniz +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.LoweringDerivation +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Tests.Fixtures.ApproachZero + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.DerivAtInjective + +/-! +# API checks for the Leibniz identities on the spaces `P_α` + +The degree-one approach-zero series `a` has a nonzero class in `P_1`. Its +square exercises the two-term identity `eventually_of_derivAt_mul_of_pos`; the check +records that neither endpoint term is degenerate, because the class of `a` is nonzero and the +values `∂(a)(γ)` are not eventually zero. A nonzero constant `k`, of degree `0`, against +`a` exercises the one-term identity `eventually_of_derivAt_mul_of_eq_zero`, and the +Leibniz rule `principalSubringDerivation_mul` of `∂ : P̂ → Fun_{0⁻}(P̂)` then reads +`∂(a k) = k ∂(a)`, since `∂` vanishes on scalars. The zero series is the degenerate case. + +The nearest wrong statement is an unconditional two-term identity in which the factor of degree +`0` or a limit ordinal contributes `π_α(u) π_β(v^{|γ})` with `π_β(v^{|γ})` the class of the +translated truncation in `P_β` itself. At degree `β = 0` that class vanishes termwise, which the +last check records, so the present fixture certifies the branch where the degree is a limit ordinal +but does not separate it from the unconditional identity; the two differ only when `β ≥ ω` is a +limit ordinal, for which there +there is no fixture in the test suite. +-/ + +open Filter Topology +open scoped HahnSeries NatOrdinal + +public noncomputable section + +namespace Tests + +open Berarducci + +private theorem one_constantCoeff_pos : 0 < (1 : NatOrdinal).constantCoeff := by + have hcoeff : (1 : NatOrdinal).constantCoeff = 1 := by + simpa only [Nat.cast_one] using NatOrdinal.constantCoeff_natCast (1 : ℕ) + rw [hcoeff] + decide + +private theorem approachZero_ordinalValue_bound : + ordinalValue approachZeroNonpositive < ω^ ((1 : NatOrdinal) + 1) := by + rw [ordinalValue_eq_wpow_of_isPrincipal approachZero_isPrincipal approachZero_degree_eq_one] + exact NatOrdinal.wpow_lt_wpow.mpr (lt_add_one (1 : NatOrdinal)) + +/-- The degree-one class of the approach-zero series. -/ +def approachZeroClass : PrincipalComponent ℚ 1 := + principalComponentMk 1 approachZeroNonpositive approachZero_ordinalValue_bound + +/-- The approach-zero class is nonzero in `P_1`. -/ +theorem approachZeroClass_ne_zero : approachZeroClass ≠ 0 := by + intro hzero + have hlower := (principalComponentMk_eq_zero_iff 1 approachZeroNonpositive + approachZero_ordinalValue_bound).mp hzero + rw [ordinalValue_eq_wpow_of_isPrincipal approachZero_isPrincipal approachZero_degree_eq_one] + at hlower + exact lt_irrefl _ hlower + +/-! ### Both grades successors: two endpoint terms -/ + +/-- The Leibniz identity for `a · a` in `P_{(1+1)⁻}`: near zero, the cutoff class of `(a a)^{|γ}` +is `π_{1⁻}(a^{|γ}) π_1(a) + π_1(a) π_{1⁻}(a^{|γ})`. -/ +theorem approachZero_sq_leibniz : + ∀ᶠ γ in 𝓝[<] (0 : ℝ), + DirectSum.of (PrincipalComponent ℚ) (((1 : NatOrdinal) + 1).removeNat 1) + (derivAt (1 + 1) (approachZeroNonpositive * approachZeroNonpositive) γ) = + DirectSum.of (PrincipalComponent ℚ) ((1 : NatOrdinal).removeNat 1) + (derivAt 1 approachZeroNonpositive γ) * + DirectSum.of (PrincipalComponent ℚ) 1 approachZeroClass + + DirectSum.of (PrincipalComponent ℚ) 1 approachZeroClass * + DirectSum.of (PrincipalComponent ℚ) ((1 : NatOrdinal).removeNat 1) + (derivAt 1 approachZeroNonpositive γ) := + eventually_of_derivAt_mul_of_pos one_constantCoeff_pos one_constantCoeff_pos + approachZeroNonpositive approachZeroNonpositive approachZero_ordinalValue_bound + approachZero_ordinalValue_bound + +/-- Neither endpoint term of `approachZero_sq_leibniz` is degenerate: the values `∂(a)(γ)` are +not eventually zero, because `∂` of the class of `a` is nonzero. -/ +theorem approachZero_derivAt_not_eventually_zero : + ¬ ∀ᶠ γ in 𝓝[<] (0 : ℝ), derivAt 1 approachZeroNonpositive γ = 0 := by + intro h + apply principalComponentDerivAt_ne_zero 1 one_constantCoeff_pos + approachZeroClass_ne_zero + rw [approachZeroClass, principalComponentDerivAt_principalComponentMk, ← Filter.Germ.coe_zero, + Filter.Germ.coe_eq] + exact h + +/-! ### A limit-grade factor: one endpoint term -/ + +/-- The Leibniz identity for `a · k` with `k` a constant of limit grade `0`: near zero, the +cutoff class of `(a k)^{|γ}` in `P_{(1+0)⁻}` is the single term `π_{1⁻}(a^{|γ}) π_0(k)`. -/ +theorem approachZero_mul_C_leibniz (k : ℚ) : + ∀ᶠ γ in 𝓝[<] (0 : ℝ), + DirectSum.of (PrincipalComponent ℚ) (((1 : NatOrdinal) + 0).removeNat 1) + (derivAt (1 + 0) + (approachZeroNonpositive * HahnSeries.Nonpositive.C k) γ) = + DirectSum.of (PrincipalComponent ℚ) ((1 : NatOrdinal).removeNat 1) + (derivAt 1 approachZeroNonpositive γ) * + DirectSum.of (PrincipalComponent ℚ) 0 + (principalComponentMk 0 (HahnSeries.Nonpositive.C k) (ordinalValue_C_lt_wpow_one k)) := + eventually_of_derivAt_mul_of_eq_zero one_constantCoeff_pos + NatOrdinal.constantCoeff_zero approachZeroNonpositive _ approachZero_ordinalValue_bound + (ordinalValue_C_lt_wpow_one k) + +/-- The homogeneous inclusion of the approach-zero class in `P̂`. -/ +def approachZeroElement : PrincipalSubring ℚ := + DirectSum.of (PrincipalComponent ℚ) 1 approachZeroClass + +/-- The Leibniz rule of `Δ` against a scalar: `Δ(a k) = k • Δ(a)`, the scalar term vanishing +because `Δ` is zero on the limit grade `0`. -/ +theorem principalSubringDerivation_approachZero_mul_algebraMap (k : ℚ) : + principalSubringDerivation ℚ + (approachZeroElement * algebraMap ℚ (PrincipalSubring ℚ) k) = + k • principalSubringDerivation ℚ approachZeroElement := by + rw [principalSubringDerivation_mul, principalSubringDerivation_algebraMap, mul_zero, add_zero, + FunAtZeroMinus.mul_const_algebraMap] + +/-- At grade `0` the would-be second endpoint term vanishes termwise: for `γ < 0` the cutoff +class of a constant is zero, since its translated truncation at `γ` is the zero series. -/ +theorem derivAt_C_eq_zero (k : ℚ) {γ : ℝ} (hγ : γ < 0) : + derivAt 0 (HahnSeries.Nonpositive.C k) γ = 0 := by + have hzero : translatedTruncation ((HahnSeries.Nonpositive.C k : Series ℚ) : ℚ⟦ℝ⟧) γ = 0 := by + apply Subtype.ext + ext δ + rw [coeff_translatedTruncation, HahnSeries.Nonpositive.coe_C, HahnSeries.C_apply, + HahnSeries.coeff_single, ZeroMemClass.coe_zero, HahnSeries.coeff_zero] + split_ifs with hδ hsum + · exact absurd hsum (by linarith) + · rfl + · rfl + have hbound : ordinalValue (translatedTruncation ((HahnSeries.Nonpositive.C k : Series ℚ) : ℚ⟦ℝ⟧) + γ) < + ω^ ((0 : NatOrdinal).removeNat 1 + 1) := by + rw [hzero, ordinalValue_zero] + exact NatOrdinal.wpow_pos _ + rw [derivAt_eq 0 _ γ hbound, principalComponentMk_eq_zero_iff, hzero, ordinalValue_zero] + exact NatOrdinal.wpow_pos _ + +/-! ### The degenerate case -/ + +/-- The values `∂(0)(γ)` of the zero series are zero. -/ +theorem derivAt_zero (γ : ℝ) : + derivAt 1 (0 : Series ℚ) γ = 0 := by + have hbound : ordinalValue (translatedTruncation ((0 : Series ℚ) : ℚ⟦ℝ⟧) γ) < + ω^ ((1 : NatOrdinal).removeNat 1 + 1) := by + rw [ZeroMemClass.coe_zero, translatedTruncation_zero_input, ordinalValue_zero] + exact NatOrdinal.wpow_pos _ + rw [derivAt_eq 1 0 γ hbound, principalComponentMk_eq_zero_iff, ZeroMemClass.coe_zero, + translatedTruncation_zero_input, ordinalValue_zero] + exact NatOrdinal.wpow_pos _ + +/-- The Leibniz rule at the zero element: both sides of `principalSubringDerivation_mul` vanish. -/ +theorem principalSubringDerivation_zero_mul (x : PrincipalSubring ℚ) : + principalSubringDerivation ℚ (0 * x) = 0 ∧ + principalSubringDerivation ℚ 0 * (x : FunAtZeroMinus (PrincipalSubring ℚ)) + + ((0 : PrincipalSubring ℚ) : FunAtZeroMinus (PrincipalSubring ℚ)) * + principalSubringDerivation ℚ x = 0 := by + refine ⟨by rw [zero_mul, map_zero], ?_⟩ + rw [map_zero, zero_mul, FunAtZeroMinus.const_zero, zero_mul, add_zero] + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/BerarducciPrimitives.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/BerarducciPrimitives.lean new file mode 100644 index 0000000000..24f4403d53 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/BerarducciPrimitives.lean @@ -0,0 +1,133 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValue +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Truncation + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Tests.Fixtures.ApproachZero + +/-! +# API checks for Berarducci's germs and ordinal value + +The first certificates exercise all three defining branches of `Berarducci.ordinalValue`: a +nonzero strictly negative monomial has value zero, a nonconstant series in `J + K` has value one, +and a series with support cofinal in zero has value strictly greater than one. These examples +distinguish the source definition from both a two-branch function and a function whose value-one +fiber contains only literal constants. + +The germ certificates distinguish the closed interval `(η, γ]` from the incorrect open interval +`(η, γ)`: zero and the constant-one series agree at every exponent strictly below zero but have +different germs at zero. A monomial supported exactly at the cutoff becomes a nonzero constant +germ, which also distinguishes weak lower truncation from strict lower truncation. +-/ + +public noncomputable section + +namespace Tests + +open scoped HahnSeries + +/-- A coefficient-one monomial at a strictly negative exponent has Berarducci ordinal value zero. -/ +theorem ordinalValue_negative_monomial : + Berarducci.ordinalValue + (HahnSeries.Nonpositive.single (-1) (1 : ℚ) (by norm_num)) = 0 := by + apply Berarducci.ordinalValue_eq_zero_iff.mpr + exact HahnSeries.Nonpositive.single_one_mem_negativeMonomialIdeal (by norm_num) + +/-- The nonzero constant-one series has Berarducci ordinal value one. -/ +theorem ordinalValue_nonzero_constant : + Berarducci.ordinalValue (HahnSeries.Nonpositive.C (1 : ℚ)) = 1 := by + apply Berarducci.ordinalValue_eq_one_iff.mpr + constructor + · apply Berarducci.mem_nearConstantSubgroup_iff.mpr + exact ⟨0, (HahnSeries.Nonpositive.negativeMonomialIdeal ℚ).zero_mem, 1, by simp⟩ + · intro hmem + have hcoeff := Berarducci.constantCoeff_eq_zero_of_mem_negativeMonomialIdeal hmem + norm_num at hcoeff + +private theorem one_lt_ordinalValue_approachZero : + 1 < Berarducci.ordinalValue approachZeroNonpositive := by + apply Berarducci.one_lt_ordinalValue_of_constantCoeff_eq_zero_of_supportSup_eq_zero + · rw [HahnSeries.Nonpositive.constantCoeff_apply, coe_approachZeroNonpositive] + exact not_ne_iff.mp (by + simpa [HahnSeries.mem_support] using zero_not_mem_approachZero_support) + · exact approachZero_supportSup + +private theorem ordinalValue_nonconstant_nearConstant : + ∃ b : Berarducci.Series ℚ, + b ∉ Berarducci.constantSubgroup ℚ ∧ + Berarducci.ordinalValue b = 1 := by + let j : Berarducci.Series ℚ := + HahnSeries.Nonpositive.single (-1) 1 (by norm_num) + let b : Berarducci.Series ℚ := j + HahnSeries.Nonpositive.C 1 + have hj : j ∈ HahnSeries.Nonpositive.negativeMonomialIdeal ℚ := by + exact HahnSeries.Nonpositive.single_one_mem_negativeMonomialIdeal (by norm_num) + refine ⟨b, ?_, ?_⟩ + · intro hbConstant + obtain ⟨k, hk⟩ := Berarducci.mem_constantSubgroup_iff.mp hbConstant + have hcoeff := congrArg + (fun x : Berarducci.Series ℚ ↦ ((x : ℚ⟦ℝ⟧).coeff (-1))) hk + norm_num [b, j, HahnSeries.Nonpositive.coe_C, + HahnSeries.Nonpositive.coe_single] at hcoeff + · apply Berarducci.ordinalValue_eq_one_iff.mpr + constructor + · exact Berarducci.mem_nearConstantSubgroup_iff.mpr ⟨j, hj, 1, rfl⟩ + · intro hbJ + have hcoeff := Berarducci.constantCoeff_eq_zero_of_mem_negativeMonomialIdeal hbJ + norm_num [b, j, HahnSeries.Nonpositive.constantCoeff_apply, + HahnSeries.Nonpositive.coe_C, HahnSeries.Nonpositive.coe_single] at hcoeff + +/-- The three disjoint branches of Berarducci's ordinal value are all nonempty. -/ +theorem ordinalValue_three_branch_separator : + ∃ b₀ b₁ b₂ : Berarducci.Series ℚ, + b₀ ≠ 0 ∧ + Berarducci.ordinalValue b₀ = 0 ∧ + b₁ ∉ Berarducci.constantSubgroup ℚ ∧ + Berarducci.ordinalValue b₁ = 1 ∧ + 1 < Berarducci.ordinalValue b₂ := by + obtain ⟨b₁, hb₁Constant, hb₁Value⟩ := ordinalValue_nonconstant_nearConstant + let b₀ : Berarducci.Series ℚ := + HahnSeries.Nonpositive.single (-1) 1 (by norm_num) + refine ⟨b₀, b₁, approachZeroNonpositive, ?_, ordinalValue_negative_monomial, + hb₁Constant, hb₁Value, one_lt_ordinalValue_approachZero⟩ + intro hb₀ + have hb₀' := congrArg Subtype.val hb₀ + exact HahnSeries.single_ne_zero one_ne_zero (by + simpa only [b₀, HahnSeries.Nonpositive.coe_single, Subring.coe_zero] using hb₀') + +/-- Agreement strictly below a cutoff does not determine the germ when the cutoff coefficient is +omitted. -/ +theorem germAt_closed_endpoint_separator : + ∃ b c : ℚ⟦ℝ⟧, + (∀ δ : ℝ, δ < 0 → b.coeff δ = c.coeff δ) ∧ + Berarducci.germAt b 0 ≠ Berarducci.germAt c 0 := by + refine ⟨0, HahnSeries.C 1, ?_, ?_⟩ + · intro δ hδ + simp [hδ.ne] + · intro heq + rw [Berarducci.germAt_eq_germAt_iff_exists_coeff_eq] at heq + obtain ⟨η, hη, hcoeff⟩ := heq + have h := hcoeff 0 hη le_rfl + norm_num at h + +/-- A monomial at the cutoff becomes its coefficient as a constant germ. -/ +theorem germAt_single_cut (k : ℚ) (γ : ℝ) : + Berarducci.germAt (HahnSeries.single γ k) γ = + Berarducci.toGerm (HahnSeries.Nonpositive.C k) := by + rw [Berarducci.germAt_apply, Berarducci.translatedTruncation_single_cut] + +/-- The germ at its support exponent of a coefficient-one monomial is nonzero. -/ +theorem germAt_single_cut_ne_zero (γ : ℝ) : + Berarducci.germAt (HahnSeries.single γ (1 : ℚ)) γ ≠ 0 := by + rw [germAt_single_cut] + intro hzero + have hvalue := Berarducci.germOrdinalValue_eq_zero_iff.mpr hzero + simp only [Berarducci.toGerm_apply, Berarducci.germOrdinalValue_mk, + ordinalValue_nonzero_constant] at hvalue + exact one_ne_zero hvalue + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/ComplexityDecrease.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/ComplexityDecrease.lean new file mode 100644 index 0000000000..e3fc7a778e --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/ComplexityDecrease.lean @@ -0,0 +1,54 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.ComplexityDecrease + +/-! +# API checks for the complexity of formal expressions + +These certificates separate the complexity and its reduction step from three nearby wrong +readings: relevant values indexed with multiplicity rather than by distinct factors, a reduction +that carries the unselected factors over unchanged rather than doubling them, and one that deletes +the selected factor outright rather than lowering its exponent by one. +-/ + +universe v + +public noncomputable section + +namespace Tests + +open Berarducci Berarducci.FormalExpression + +variable {K : Type v} [Field K] + +/-- The relevant values are indexed by the distinct factors: adjoining another copy of a factor +already present leaves them unchanged. -/ +theorem relevantValues_cons_of_mem {w : FormalExpression K} (hw : w ≠ 0) + {y : SeriesWithOrdinalValueAboveOne K} (hy : y ∈ w) : + relevantValues (y ::ₘ w) Multiset.cons_ne_zero = relevantValues w hw := by + refine relevantValues_congr Multiset.cons_ne_zero hw (selected_cons_of_mem hw hy) fun z _ ↦ ?_ + rw [Multiset.mem_cons] + exact ⟨fun h ↦ h.elim (fun hz ↦ hz ▸ hy) id, Or.inr⟩ + +open Classical in +/-- The reduction doubles the unselected exponents rather than carrying them over. -/ +theorem count_reduced_eq_two_mul {w : FormalExpression K} {hw : w ≠ 0} + {y : SeriesWithOrdinalValueAboveOne K} (hy : y ≠ selected w hw) : + Multiset.count y (reduced w hw 0) = 2 * Multiset.count y w := + count_reduced_of_ne hy (Multiset.notMem_zero y) + +open Classical in +/-- The reduction lowers the selected exponent by exactly one, so a selected factor of exponent +above one survives it. -/ +theorem count_selected_reduced_add_one {w : FormalExpression K} (hw : w ≠ 0) + (hk : 1 < selectedExponent w hw) : + Multiset.count (selected w hw) (reduced w hw 0) + 1 = selectedExponent w hw := by + rw [count_selected_reduced (Multiset.notMem_zero _)] + omega + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/Convolution.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/Convolution.lean new file mode 100644 index 0000000000..e4b8153f3f --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/Convolution.lean @@ -0,0 +1,55 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Tests.Fixtures.ApproachZero +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Convolution + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.SupportSupremum +import Mathlib.Topology.Instances.Real.Lemmas +import Mathlib.Topology.Order.IsLUB + +/-! +# API checks for the convolution index + +The index set of Berarducci's convolution formula is built from the closed supports of the two +factors, not from the supports themselves. These certificates exhibit a series whose closed +support strictly contains its support, and an exponent that the index set therefore contains +although it lies in neither support. +-/ + +public noncomputable section + +namespace Tests + +open scoped HahnSeries + +private theorem isLUB_approachZero_support : IsLUB approachZero.support 0 := by + have h := (HahnSeries.Nonpositive.supportSup_eq_coe_iff.mp approachZero_supportSup).2 + rwa [coe_approachZeroNonpositive] at h + +private theorem zero_mem_closure_approachZero_support : + (0 : ℝ) ∈ closure approachZero.support := by + refine isLUB_approachZero_support.mem_closure (HahnSeries.support_nonempty_iff.mpr ?_) + intro hzero + exact approachZero_ne_zero (Subtype.ext (by rw [coe_approachZeroNonpositive, hzero]; rfl)) + +/-- The closed support of `approachZero` strictly contains its support. -/ +theorem closure_approachZero_support_ne : + closure approachZero.support ≠ approachZero.support := + fun h ↦ zero_not_mem_approachZero_support (h ▸ zero_mem_closure_approachZero_support) + +/-- The convolution index is computed from the closed supports: it contains an exponent lying in +the support of neither factor. -/ +theorem zero_mem_convolutionIndex_approachZero : + (0 : ℝ) ∈ Berarducci.convolutionIndex approachZero approachZero 0 ∧ + (0 : ℝ) ∉ approachZero.support := + ⟨Berarducci.mem_convolutionIndex.mpr + ⟨zero_mem_closure_approachZero_support, by + simpa using zero_mem_closure_approachZero_support⟩, + zero_not_mem_approachZero_support⟩ + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/ConvolutionList.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/ConvolutionList.lean new file mode 100644 index 0000000000..057f2ed2d6 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/ConvolutionList.lean @@ -0,0 +1,50 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.ConvolutionList + +/-! +# API checks for the multi-factor convolution formula + +These certificates separate the formula from two nearby wrong readings: an empty product that +would contribute at every cutoff rather than only at zero, and an index set that would not +constrain its exponent lists. A third check records that the exponent lists are positional, so +their length is the number of factors. +-/ + +public noncomputable section + +namespace Tests + +open scoped HahnSeries + +/-- The empty product contributes only at cutoff zero. -/ +theorem convolutionIndexList_nil_one : + Berarducci.convolutionIndexList ([] : List ℚ⟦ℝ⟧) 1 = ∅ := by + rw [Berarducci.convolutionIndexList_nil, ite_eq_right one_ne_zero] + +/-- Reading the formula at the empty list computes the germ of one away from zero. -/ +theorem germAt_one_at_one : Berarducci.germAt (1 : ℚ⟦ℝ⟧) 1 = 0 := by + have h := Berarducci.germAt_listProd ([] : List ℚ⟦ℝ⟧) 1 + rw [List.prod_nil, convolutionIndexList_nil_one, Finset.sum_empty] at h + exact h + +/-- Exponent lists in the index set are constrained: one that does not sum to the cutoff is +absent. -/ +theorem notMem_convolutionIndexList_of_sum_ne + (l : List ℚ⟦ℝ⟧) (γ : ℝ) (f : List ℝ) (h : f.sum ≠ γ) : + f ∉ Berarducci.convolutionIndexList l γ := + fun hf ↦ h (Berarducci.sum_of_mem_convolutionIndexList l γ hf) + +/-- Exponent lists are positional: their length is the number of factors. -/ +theorem length_eq_of_mem_convolutionIndexList + (l : List ℚ⟦ℝ⟧) (γ : ℝ) (f : List ℝ) + (hf : f ∈ Berarducci.convolutionIndexList l γ) : + f.length = l.length := + Berarducci.length_of_mem_convolutionIndexList l γ hf + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/ConvolutionRemainder.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/ConvolutionRemainder.lean new file mode 100644 index 0000000000..bb787c3337 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/ConvolutionRemainder.lean @@ -0,0 +1,42 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.ConvolutionRemainder + +/-! +# API check for the convolution remainder + +The paper uses the estimate for actual translated truncation series. The underlying proof first +establishes a germ-valued inequality, so it would be easy to expose only that nearby but weaker +interface. This check pins the public result to `ordinalValue` of the displayed series remainder and +to one left neighbourhood uniform in the cutoff. +-/ + +public noncomputable section + +namespace Tests + +open HahnSeries HahnSeries.Nonpositive Berarducci + +universe v + +variable {K : Type v} [Field K] + +/-- The remainder estimate holds for the translated truncation series, uniformly for every +cutoff in one left neighbourhood of zero. -/ +theorem convolutionRemainder_actualSeries + (b c : SeriesWithOrdinalValueAboveOne K) + (hp : b.principalValue ≤ c.principalValue) : + ∃ eta < (0 : ℝ), ∀ gamma : ℝ, eta < gamma → gamma < 0 → + ordinalValue + (translatedTruncation (((b.1 * c.1 : Series K) : K⟦ℝ⟧)) gamma + - translatedTruncation (b.1 : K⟦ℝ⟧) gamma * c.1 + - b.1 * translatedTruncation (c.1 : K⟦ℝ⟧) gamma) < + b.residualValue * ordinalValue c.1 := + exists_ordinalValue_convolution_remainder_lt b c hp + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/CriticalPoint.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/CriticalPoint.lean new file mode 100644 index 0000000000..96708e5b29 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/CriticalPoint.lean @@ -0,0 +1,111 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.CriticalPointExistence + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValueDegree +import Mathlib.Tactic.Linarith +import Mathlib.Tactic.NormNum + +/-! +# API checks for Berarducci critical points + +The monomial `t⁻¹` has critical point `-1`, not zero: truncating exactly at its support exponent +turns it into a nonzero constant germ, while truncating strictly earlier gives zero. Squaring it +then exercises Berarducci's critical-product formula at the genuinely negative point `-2`. +-/ + +open scoped HahnSeries NatOrdinal + +public noncomputable section + +namespace Tests + +/-- The coefficient-one monomial `t⁻¹` as a nonpositive real Hahn series. -/ +def criticalNegativeMonomial : Berarducci.Series ℚ := + HahnSeries.Nonpositive.single (-1) 1 (by norm_num) + +private theorem coe_criticalNegativeMonomial : + (criticalNegativeMonomial : ℚ⟦ℝ⟧) = HahnSeries.single (-1) 1 := by + rw [criticalNegativeMonomial, HahnSeries.Nonpositive.coe_single] + +private theorem criticalNegativeMonomial_ne_zero : criticalNegativeMonomial ≠ 0 := by + intro hzero + have hcoe := congrArg Subtype.val hzero + rw [coe_criticalNegativeMonomial] at hcoe + exact HahnSeries.single_ne_zero one_ne_zero hcoe + +private theorem criticalNegativeMonomial_value : + Berarducci.ordinalValue + (Berarducci.translatedTruncation (criticalNegativeMonomial : ℚ⟦ℝ⟧) (-1)) = 1 := by + rw [coe_criticalNegativeMonomial, Berarducci.translatedTruncation_single_cut, + Berarducci.ordinalValue_C_of_ne one_ne_zero] + +private theorem criticalNegativeMonomial_germ_zero_of_lt + {y : ℝ} (hy : y < -1) : + Berarducci.translatedTruncation (criticalNegativeMonomial : ℚ⟦ℝ⟧) y = 0 := by + apply Subtype.ext + ext d + rw [Berarducci.coeff_translatedTruncation] + by_cases hd : d ≤ 0 + · rw [ite_eq_left hd, coe_criticalNegativeMonomial] + have hne : y + d ≠ -1 := by linarith + rw [HahnSeries.coeff_single_of_ne hne] + simp + · simp [hd] + +/-- The exponent `-1` is the critical point of `t⁻¹`; this excludes a definition that +automatically chooses zero for every nonzero series. -/ +theorem criticalNegativeMonomial_isCriticalPoint : + Berarducci.IsCriticalPoint criticalNegativeMonomial (-1) := by + rw [Berarducci.isCriticalPoint_iff] + refine ⟨criticalNegativeMonomial_ne_zero, by norm_num, ?_, ?_⟩ + · intro y _hy + rw [criticalNegativeMonomial_value] + calc + Berarducci.ordinalValue + (Berarducci.translatedTruncation (criticalNegativeMonomial : ℚ⟦ℝ⟧) y) ≤ + NatOrdinal.of + ((Berarducci.translatedTruncation + (criticalNegativeMonomial : ℚ⟦ℝ⟧) y : Berarducci.Series ℚ) : + ℚ⟦ℝ⟧).supportOrderType := + Berarducci.ordinalValue_le_supportOrderType _ + _ ≤ NatOrdinal.of (criticalNegativeMonomial : ℚ⟦ℝ⟧).supportOrderType := by + apply NatOrdinal.of.monotone + rw [Berarducci.coe_translatedTruncation, HahnSeries.supportOrderType_translate] + apply HahnSeries.supportOrderType_mono + rw [HahnSeries.support_truncLE] + exact Set.sep_subset _ _ + _ = 1 := by + rw [coe_criticalNegativeMonomial, + HahnSeries.supportOrderType_single one_ne_zero] + simp + · intro y _hy hvalue + apply le_of_not_gt + intro hylt + have hzero := criticalNegativeMonomial_germ_zero_of_lt hylt + rw [hzero, Berarducci.ordinalValue_zero, + criticalNegativeMonomial_value] at hvalue + exact zero_ne_one hvalue + +/-- The general existence theorem produces a critical point for the nondegenerate fixture. -/ +theorem criticalNegativeMonomial_exists_isCriticalPoint : + ∃ x : ℝ, Berarducci.IsCriticalPoint criticalNegativeMonomial x := + Berarducci.exists_isCriticalPoint criticalNegativeMonomial_ne_zero + +/-- The product formula computes the critical value of `t⁻¹ * t⁻¹` at `-2`. -/ +theorem criticalNegativeMonomial_square_value : + Berarducci.ordinalValue + (Berarducci.translatedTruncation + (((criticalNegativeMonomial * criticalNegativeMonomial : + Berarducci.Series ℚ) : ℚ⟦ℝ⟧)) (-2)) = 1 := by + rw [show (-2 : ℝ) = -1 + -1 by norm_num] + rw [Berarducci.criticalPoint_product_value + criticalNegativeMonomial_isCriticalPoint criticalNegativeMonomial_isCriticalPoint, + criticalNegativeMonomial_value, one_mul] + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/OrdinalValueFinalSegment.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/OrdinalValueFinalSegment.lean new file mode 100644 index 0000000000..a1d6ea9764 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/OrdinalValueFinalSegment.lean @@ -0,0 +1,120 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValueFinalSegment +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Tests.Fixtures.ApproachZero +public import Mathlib.Order.UpperLower.Relative + +/-! +# API check for final support segments and Berarducci's ordinal value + +The approach-zero series with constant coefficient one has ordinal value greater than one and +support containing zero. Its strictly negative support is nonempty, so the final-segment theorem +gives the intended lower bound there. + +This fixture separates strict negative support from the nearby incorrect full-support statement. +The singleton containing zero is a nonempty final segment of the full support and has order type +one, strictly below the series' ordinal value. Thus including the exponent zero would make the +claimed lower bound false rather than merely change its presentation. +-/ + +open scoped HahnSeries NatOrdinal + +public noncomputable section + +namespace Tests + +open Ordinal + +/-- The approach-zero series with a nonzero constant coefficient. -/ +def approachZeroPlusOne : Berarducci.Series ℚ := + approachZeroNonpositive + HahnSeries.Nonpositive.C 1 + +private theorem approachZero_ordinalValue_one_lt : + 1 < Berarducci.ordinalValue approachZeroNonpositive := by + apply Berarducci.one_lt_ordinalValue_of_constantCoeff_eq_zero_of_supportSup_eq_zero + · rw [HahnSeries.Nonpositive.constantCoeff_apply, coe_approachZeroNonpositive] + exact not_ne_iff.mp (by + simpa [HahnSeries.mem_support] using zero_not_mem_approachZero_support) + · exact approachZero_supportSup + +/-- Adding a nonzero constant coefficient does not place the approach-zero series in `J + K`. -/ +theorem approachZeroPlusOne_ordinalValue_one_lt : + 1 < Berarducci.ordinalValue approachZeroPlusOne := by + apply Berarducci.one_lt_ordinalValue_iff.mpr + have happroach := + Berarducci.one_lt_ordinalValue_iff.mp approachZero_ordinalValue_one_lt + intro hsum + apply happroach + have hconstant : HahnSeries.Nonpositive.C (1 : ℚ) ∈ + Berarducci.nearConstantSubgroup ℚ := by + apply Berarducci.mem_nearConstantSubgroup_iff.mpr + exact ⟨0, (HahnSeries.Nonpositive.negativeMonomialIdeal ℚ).zero_mem, 1, by simp⟩ + have hdifference := + (Berarducci.nearConstantSubgroup ℚ).sub_mem hsum hconstant + simpa only [approachZeroPlusOne, add_sub_cancel_right] using hdifference + +private theorem approachZeroPlusOne_zero_mem_support : + (0 : ℝ) ∈ (approachZeroPlusOne : ℚ⟦ℝ⟧).support := by + rw [HahnSeries.mem_support] + have hzero : approachZero.coeff 0 = 0 := by + rw [← not_ne_iff, ← HahnSeries.mem_support] + exact zero_not_mem_approachZero_support + simp [approachZeroPlusOne, hzero] + +private theorem approachZeroPlusOne_neg_one_mem_support : + (-1 : ℝ) ∈ (approachZeroPlusOne : ℚ⟦ℝ⟧).support := by + rw [HahnSeries.mem_support] + have hcoeff : approachZero.coeff (-1) = 1 := by + rw [← show approachZeroEmbedding 0 = (-1 : ℝ) by norm_num] + exact approachZero_coeff_embedding 0 + simp [approachZeroPlusOne, hcoeff] + +/-- The public theorem bounds the ordinal value by the order type of the strictly negative +support in a concrete nonconstant example with nonzero constant coefficient. -/ +theorem approachZeroPlusOne_strictNegativeSupport_bound : + (Berarducci.ordinalValue approachZeroPlusOne).val ≤ + ((approachZeroPlusOne : ℚ⟦ℝ⟧).isPWO_support.mono + (s := (approachZeroPlusOne : ℚ⟦ℝ⟧).support ∩ Set.Iio 0) + Set.inter_subset_left).orderType := by + apply Berarducci.ordinalValue_le_orderType_of_isRelUpperSet_negativeSupport + (C := (approachZeroPlusOne : ℚ⟦ℝ⟧).support ∩ Set.Iio 0) + · exact isRelUpperSet_self + · exact ⟨-1, approachZeroPlusOne_neg_one_mem_support, by norm_num⟩ + +private theorem singletonZero_isRelUpperSet_approachZeroPlusOne_support : + IsRelUpperSet ({0} : Set ℝ) + (· ∈ (approachZeroPlusOne : ℚ⟦ℝ⟧).support) := by + intro x hx + rw [Set.mem_singleton_iff] at hx + subst x + refine ⟨approachZeroPlusOne_zero_mem_support, ?_⟩ + intro y h0y hy + rw [Set.mem_singleton_iff] + exact le_antisymm (HahnSeries.Nonpositive.support_subset approachZeroPlusOne hy) h0y + +/-- Including exponent zero would give a nonempty final segment of order type one, although the +series has ordinal value strictly greater than one. -/ +theorem approachZeroPlusOne_fullSupport_singleton_counterexample : + let hsingleton : ({0} : Set ℝ).IsPWO := Set.isPWO_singleton 0 + IsRelUpperSet ({0} : Set ℝ) + (· ∈ (approachZeroPlusOne : ℚ⟦ℝ⟧).support) ∧ + ({0} : Set ℝ).Nonempty ∧ + hsingleton.orderType = 1 ∧ + 1 < (Berarducci.ordinalValue approachZeroPlusOne).val := by + dsimp only + refine ⟨singletonZero_isRelUpperSet_approachZeroPlusOne_support, + Set.singleton_nonempty 0, ?_, ?_⟩ + · let hsingleton : ({0} : Set ℝ).IsPWO := Set.isPWO_singleton 0 + let : WellFoundedLT ({0} : Set ℝ) := hsingleton.isWF + calc + hsingleton.orderType = typeLT ({0} : Set ℝ) := + hsingleton.orderType_eq_typeLT_of_orderIso (OrderIso.refl _) + _ = 1 := Ordinal.type_eq_one_of_unique _ + · exact NatOrdinal.of_lt_iff.mp approachZeroPlusOne_ordinalValue_one_lt + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/OrdinalValueSubmultiplicative.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/OrdinalValueSubmultiplicative.lean new file mode 100644 index 0000000000..524e77bc8e --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/OrdinalValueSubmultiplicative.lean @@ -0,0 +1,109 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Tests.Fixtures.ApproachZero +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValue + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValueConstantMul +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValueDegree +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValueSubmultiplicative +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Statements.ProductValue + +/-! +# API checks for submultiplicativity of Berarducci's ordinal value + +These certificates separate the submultiplicative bound from three nearby wrong statements: the +same inequality read with ordinary ordinal multiplication instead of the Hessenberg product, +constant-factor invariance without the nonzero hypothesis, and a bound holding only on `J` and +`J + K` rather than in the third branch of the ordinal value. +-/ + +universe v + +public noncomputable section + +namespace Tests + +open scoped HahnSeries + +/-- The submultiplicative bound is stated with Hessenberg multiplication: on the very ordinals it +ranges over, ordinary ordinal multiplication gives a strictly smaller value. -/ +theorem naturalMul_ne_ordinalMul : + ∃ x y : NatOrdinal, NatOrdinal.of (x.val * y.val) ≠ x * y := by + refine ⟨2, NatOrdinal.of Ordinal.omega0, ?_⟩ + have hpos : (0 : NatOrdinal) < NatOrdinal.of Ordinal.omega0 := by + simpa using NatOrdinal.of.lt_iff_lt.mpr Ordinal.omega0_pos + have hval : NatOrdinal.of ((2 : NatOrdinal).val * (NatOrdinal.of Ordinal.omega0).val) = + NatOrdinal.of Ordinal.omega0 := by + rw [NatOrdinal.val_of] + congr 1 + have h2 : ((2 : NatOrdinal).val) = ((2 : ℕ) : Ordinal) := by + simpa using NatOrdinal.val_natCast 2 + rw [h2] + exact Ordinal.natCast_mul_omega0 (by norm_num) + rw [hval] + refine ne_of_lt ?_ + calc NatOrdinal.of Ordinal.omega0 + < NatOrdinal.of Ordinal.omega0 + NatOrdinal.of Ordinal.omega0 := lt_add_of_pos_left _ hpos + _ = 2 * NatOrdinal.of Ordinal.omega0 := (two_mul _).symm + +/-- Constant-factor invariance genuinely needs the constant to be nonzero. -/ +theorem ordinalValue_C_mul_needs_ne_zero : + ∃ b : Berarducci.Series ℚ, + Berarducci.ordinalValue (HahnSeries.Nonpositive.C (0 : ℚ) * b) ≠ + Berarducci.ordinalValue b := by + refine ⟨HahnSeries.Nonpositive.C (1 : ℚ), ?_⟩ + rw [map_zero, zero_mul, Berarducci.ordinalValue_zero, + Berarducci.ordinalValue_C_of_ne (one_ne_zero (α := ℚ))] + exact zero_ne_one + +/-- Multiplication by a nonzero constant preserves the ordinal value of a series whose value lies +in the third branch. -/ +theorem ordinalValue_C_mul_approachZero : + Berarducci.ordinalValue (HahnSeries.Nonpositive.C (2 : ℚ) * approachZeroNonpositive) = + Berarducci.ordinalValue approachZeroNonpositive := + Berarducci.ordinalValue_C_mul (by norm_num) _ + +private theorem one_lt_ordinalValue_approachZero : + 1 < Berarducci.ordinalValue approachZeroNonpositive := by + apply Berarducci.one_lt_ordinalValue_of_constantCoeff_eq_zero_of_supportSup_eq_zero + · rw [HahnSeries.Nonpositive.constantCoeff_apply, coe_approachZeroNonpositive] + exact not_ne_iff.mp (by + simpa [HahnSeries.mem_support] using zero_not_mem_approachZero_support) + · exact approachZero_supportSup + +/-- The submultiplicative bound applies in the third branch of the ordinal value, where both +factors lie outside `J + K`. -/ +theorem ordinalValue_mul_le_naturalMul_third_branch : + ∃ b : Berarducci.Series ℚ, + 1 < Berarducci.ordinalValue b ∧ + Berarducci.ordinalValue (b * b) ≤ Berarducci.ordinalValue b * Berarducci.ordinalValue b := + ⟨approachZeroNonpositive, one_lt_ordinalValue_approachZero, + Berarducci.ordinalValue_mul_le_naturalMul _ _⟩ + +/-- Berarducci, Theorem 9.7 applies to a nonconstant product in the third branch of the ordinal +value. -/ +theorem ordinalValue_mul_approachZero : + Berarducci.ordinalValue (approachZeroNonpositive * approachZeroNonpositive) = + Berarducci.ordinalValue approachZeroNonpositive * + Berarducci.ordinalValue approachZeroNonpositive := + Berarducci.ordinalValue_mul _ _ + +/-- In the ideal branch the submultiplicative bound is an equality with value zero. -/ +theorem ordinalValue_mul_negative_monomial : + Berarducci.ordinalValue + (HahnSeries.Nonpositive.single (-1) (1 : ℚ) (by norm_num) * approachZeroNonpositive) = + Berarducci.ordinalValue (HahnSeries.Nonpositive.single (-1) (1 : ℚ) (by norm_num)) * + Berarducci.ordinalValue approachZeroNonpositive := by + have hj : HahnSeries.Nonpositive.single (-1) (1 : ℚ) (by norm_num) ∈ + HahnSeries.Nonpositive.negativeMonomialIdeal ℚ := + HahnSeries.Nonpositive.single_one_mem_negativeMonomialIdeal (by norm_num) + rw [Berarducci.ordinalValue_of_mem_negativeMonomialIdeal + ((HahnSeries.Nonpositive.negativeMonomialIdeal ℚ).mul_mem_right _ hj), + Berarducci.ordinalValue_of_mem_negativeMonomialIdeal hj, zero_mul] + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/PrincipalComponent.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/PrincipalComponent.lean new file mode 100644 index 0000000000..0e4b658844 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/PrincipalComponent.lean @@ -0,0 +1,166 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalComponent +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Tests.Fixtures.ApproachZero + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValueImage + +/-! +# API checks for the spaces `P_α` + +The degree-zero fixture proves that a nonzero constant represents a nonzero class in `P_0`, while +a strictly negative monomial represents zero. This distinguishes the intrinsic quotient by `J` +from literal equality of representatives. + +The approach-zero series has ordinal value `ω` and represents a nonzero class in `P_1`. Its class +has a principal representative of exact degree one by LM24, Remark 7.2.4. Multiplication by the +degree-zero class of one agrees with multiplication of representatives. +-/ + +universe v + +public noncomputable section + +namespace Tests + +open HahnSeries +open scoped NatOrdinal + +variable {K : Type v} [Field K] + +section Generic + +theorem one_ordinalValue_bound : + Berarducci.ordinalValue (1 : Berarducci.Series K) < ω^ (0 + 1 : NatOrdinal) := by + rw [Berarducci.ordinalValue_one] + simpa using NatOrdinal.wpow_lt_wpow.mpr (zero_lt_one : (0 : NatOrdinal) < 1) + +variable (K) in +/-- A nonzero constant gives a nonzero class in the intrinsic degree-zero component. -/ +theorem principalComponent_zero_constant_ne_zero : + Berarducci.principalComponentMk 0 (1 : Berarducci.Series K) + (one_ordinalValue_bound (K := K)) ≠ 0 := by + rw [ne_eq, Berarducci.principalComponentMk_eq_zero_iff] + rw [Berarducci.ordinalValue_one] + simp + +/-- The negative monomial `t⁻¹`, whose class vanishes in the germ quotient. -/ +def principalComponentNegativeMonomial : Berarducci.Series K := + HahnSeries.Nonpositive.single (-1 : ℝ) 1 (by norm_num) + +theorem principalComponentNegativeMonomial_ordinalValue_eq_zero : + Berarducci.ordinalValue (principalComponentNegativeMonomial (K := K)) = 0 := by + apply Berarducci.ordinalValue_of_mem_negativeMonomialIdeal + exact HahnSeries.Nonpositive.single_one_mem_negativeMonomialIdeal (by norm_num) + +theorem principalComponentNegativeMonomial_ordinalValue_bound : + Berarducci.ordinalValue (principalComponentNegativeMonomial (K := K)) < + ω^ (0 + 1 : NatOrdinal) := by + rw [principalComponentNegativeMonomial_ordinalValue_eq_zero] + exact NatOrdinal.wpow_pos _ + +variable (K) in +/-- A nonzero series in `J` represents zero in `P_0`. -/ +theorem principalComponent_zero_negativeMonomial_eq_zero : + Berarducci.principalComponentMk 0 (principalComponentNegativeMonomial (K := K)) + (principalComponentNegativeMonomial_ordinalValue_bound (K := K)) = 0 := by + rw [Berarducci.principalComponentMk_eq_zero_iff, + principalComponentNegativeMonomial_ordinalValue_eq_zero] + exact NatOrdinal.wpow_pos _ + +end Generic + +section RationalFixture + +theorem approachZero_ordinalValue_eq_omega : + Berarducci.ordinalValue approachZeroNonpositive = NatOrdinal.of Ordinal.omega0 := by + apply le_antisymm + · simpa only [coe_approachZeroNonpositive, approachZero_supportOrderType] using + Berarducci.ordinalValue_le_supportOrderType approachZeroNonpositive + · have hone : 1 < Berarducci.ordinalValue approachZeroNonpositive := by + apply Berarducci.one_lt_ordinalValue_of_constantCoeff_eq_zero_of_supportSup_eq_zero + · rw [HahnSeries.Nonpositive.constantCoeff_apply, coe_approachZeroNonpositive] + exact not_ne_iff.mp (by + simpa [HahnSeries.mem_support] using zero_not_mem_approachZero_support) + · exact approachZero_supportSup + have hprincipal := + Berarducci.ordinalValue_isAdditivelyPrincipal_of_one_lt hone + have honeVal : (1 : Ordinal) < + (Berarducci.ordinalValue approachZeroNonpositive).val := + NatOrdinal.of_lt_iff.mp hone + apply NatOrdinal.of_le_iff.mpr + exact hprincipal.omega0_le_of_one_lt honeVal + +theorem approachZero_ordinalValue_bound : + Berarducci.ordinalValue approachZeroNonpositive < ω^ (1 + 1 : NatOrdinal) := by + rw [approachZero_ordinalValue_eq_omega] + have homega : NatOrdinal.of Ordinal.omega0 = ω^ (1 : NatOrdinal) := by + apply NatOrdinal.val.injective + simp only [NatOrdinal.val_of, NatOrdinal.val_wpow, NatOrdinal.val_one, + Ordinal.opow_one] + rw [homega] + exact NatOrdinal.wpow_lt_wpow.mpr (lt_add_one (1 : NatOrdinal)) + +/-- The genuine infinite-support fixture gives a nonzero class in `P_1`. -/ +theorem principalComponent_one_approachZero_ne_zero : + Berarducci.principalComponentMk 1 approachZeroNonpositive + approachZero_ordinalValue_bound ≠ 0 := by + rw [ne_eq, Berarducci.principalComponentMk_eq_zero_iff, + approachZero_ordinalValue_eq_omega] + have homega : NatOrdinal.of Ordinal.omega0 = ω^ (1 : NatOrdinal) := by + apply NatOrdinal.val.injective + simp only [NatOrdinal.val_of, NatOrdinal.val_wpow, NatOrdinal.val_one, + Ordinal.opow_one] + rw [homega] + exact lt_irrefl _ + +/-- The intrinsic class admits a principal representative of exact degree one. -/ +theorem principalComponent_one_has_exact_principal_representative : + ∃ (p : Berarducci.Series ℚ) + (hpBound : Berarducci.ordinalValue p < ω^ (1 + 1 : NatOrdinal)), + HahnSeries.Nonpositive.IsPrincipal p ∧ + (p : ℚ⟦ℝ⟧).degree = (1 : WithBot NatOrdinal) ∧ + Berarducci.principalComponentMk 1 p hpBound = + Berarducci.principalComponentMk 1 approachZeroNonpositive + approachZero_ordinalValue_bound := + Berarducci.exists_principal_representative_of_ne_zero 1 _ + principalComponent_one_approachZero_ne_zero + +/-- Scalar multiplication by two is represented by multiplication by the corresponding constant +Hahn series on the infinite-support class. -/ +theorem two_smul_principalComponent_one_approachZero : + (2 : ℚ) • Berarducci.principalComponentMk 1 approachZeroNonpositive + approachZero_ordinalValue_bound = + Berarducci.principalComponentMk 1 + ((HahnSeries.Nonpositive.C : ℚ →+* Berarducci.Series ℚ) 2 * + approachZeroNonpositive) + (by + simpa only [zero_add] using + Berarducci.ordinalValue_mul_lt_wpow_add_one + (Berarducci.ordinalValue_C_lt_wpow_one (2 : ℚ)) + approachZero_ordinalValue_bound) := + Berarducci.smul_principalComponentMk 1 2 approachZeroNonpositive + approachZero_ordinalValue_bound + +/-- Homogeneous multiplication sends the classes of `1` and the approach-zero series to the +class of their product in `P_1`. -/ +theorem principalComponent_zero_mul_one_representation : + Berarducci.principalComponentMul + (Berarducci.principalComponentMk 0 (1 : Berarducci.Series ℚ) + (one_ordinalValue_bound (K := ℚ))) + (Berarducci.principalComponentMk 1 approachZeroNonpositive + approachZero_ordinalValue_bound) = + Berarducci.principalComponentMk (0 + 1) approachZeroNonpositive + (by simpa using approachZero_ordinalValue_bound) := by + rw [Berarducci.principalComponentMul_mk] + rw [Berarducci.principalComponentMk_eq_iff] + simp + +end RationalFixture + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/PrincipalComponentDegree.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/PrincipalComponentDegree.lean new file mode 100644 index 0000000000..d49f66c124 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/PrincipalComponentDegree.lean @@ -0,0 +1,126 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Tests.PrincipalComponent +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalComponentDegree + +/-! +# API checks for the two presentations of `P_α` + +The approach-zero series supplies a nonzero principal class of exact Hahn degree one. This module +places that class in the source subspace of the degree-graded component and checks that +the canonical linear equivalence sends it to the same representative in the intrinsic quotient +`J_{ω²} / J_ω`. + +Multiplying the class by itself exercises two genuinely infinite principal representatives. The +compiled checks identify the underlying product in the degree-graded component and +verify that the equivalence commutes with homogeneous multiplication into degree `1 + 1`. +-/ + +public noncomputable section + +namespace Tests + +open HahnSeries +open scoped NatOrdinal + +/-- The source homogeneous class of the approach-zero series in degree one. -/ +def approachZeroPrincipalDegreeClass : + Berarducci.principalDegreeClasses ℚ 1 := by + refine ⟨Berarducci.degreeLayerMk 1 approachZeroNonpositive + approachZero_degree_eq_one.le, ?_⟩ + rw [Berarducci.mem_principalDegreeClasses_iff, + Berarducci.isPrincipalDegreeClass_iff] + exact Or.inr ⟨approachZeroNonpositive, approachZero_isPrincipal, + approachZero_degree_eq_one, rfl⟩ + +/-- The underlying class in the degree-graded ring has the expected representative. -/ +@[simp] +theorem coe_approachZeroPrincipalDegreeClass : + (approachZeroPrincipalDegreeClass : + (HahnSeries.Nonpositive.degreeValuation ℚ).Component 1) = + Berarducci.degreeLayerMk 1 approachZeroNonpositive + approachZero_degree_eq_one.le := + (rfl) + +/-- The approach-zero class is nonzero in the source degree-one component. -/ +theorem approachZeroPrincipalDegreeClass_ne_zero : + approachZeroPrincipalDegreeClass ≠ 0 := by + intro hzero + have hzero' := congrArg Subtype.val hzero + rw [coe_approachZeroPrincipalDegreeClass] at hzero' + have hlt := (Berarducci.degreeLayerMk_eq_zero_iff 1 + approachZeroNonpositive approachZero_degree_eq_one.le).mp hzero' + rw [approachZero_degree_eq_one] at hlt + exact lt_irrefl (1 : WithBot NatOrdinal) hlt + +/-- The canonical equivalence sends the source class to the same intrinsic representative. -/ +theorem approachZeroPrincipalDegreeClass_equiv : + Berarducci.principalDegreeClassesEquivPrincipalComponent ℚ 1 + approachZeroPrincipalDegreeClass = + Berarducci.principalComponentMk 1 approachZeroNonpositive + approachZero_ordinalValue_bound := by + rw [Berarducci.principalDegreeClassesEquivPrincipalComponent_apply, + coe_approachZeroPrincipalDegreeClass, + Berarducci.degreeLayerToPrincipalComponent_mk] + +/-- The canonical equivalence commutes with a nontrivial coefficient scalar on the infinite +approach-zero class. -/ +theorem approachZeroPrincipalDegreeClass_equiv_smul : + Berarducci.principalDegreeClassesEquivPrincipalComponent ℚ 1 + ((2 : ℚ) • approachZeroPrincipalDegreeClass) = + (2 : ℚ) • Berarducci.principalDegreeClassesEquivPrincipalComponent ℚ 1 + approachZeroPrincipalDegreeClass := + map_smul (Berarducci.principalDegreeClassesEquivPrincipalComponent ℚ 1) + (2 : ℚ) approachZeroPrincipalDegreeClass + +/-- On underlying degree classes, scalar multiplication by two is multiplication of the +infinite-support representative by the constant Hahn series `2`. -/ +theorem coe_two_smul_approachZeroPrincipalDegreeClass : + ((2 : ℚ) • approachZeroPrincipalDegreeClass : + (HahnSeries.Nonpositive.degreeValuation ℚ).Component 1) = + Berarducci.degreeLayerMk 1 + ((HahnSeries.Nonpositive.C : ℚ →+* Berarducci.Series ℚ) 2 * + approachZeroNonpositive) + (by + rw [HahnSeries.Nonpositive.degree_mul, + Berarducci.degree_C_eq_zero_of_ne (by norm_num), + approachZero_degree_eq_one, zero_add] + exact le_rfl) := by + rw [coe_approachZeroPrincipalDegreeClass, Berarducci.smul_degreeLayerMk] + +/-- Multiplication in the source component is represented by the square of the approach-zero series. +-/ +theorem approachZeroPrincipalDegreeClass_mul_coe : + (Berarducci.principalDegreeClassesMul + approachZeroPrincipalDegreeClass + approachZeroPrincipalDegreeClass : + (HahnSeries.Nonpositive.degreeValuation ℚ).Component (1 + 1)) = + Berarducci.degreeLayerMk (1 + 1) + (approachZeroNonpositive * approachZeroNonpositive) (by + rw [HahnSeries.Nonpositive.degree_mul, approachZero_degree_eq_one, + WithBot.coe_add] + exact le_rfl) := by + rw [Berarducci.coe_principalDegreeClassesMul] + exact Berarducci.degreeLayerMk_mul approachZeroNonpositive + approachZeroNonpositive approachZero_degree_eq_one.le + approachZero_degree_eq_one.le + +/-- The source-to-intrinsic equivalence commutes with the nonconstant degree-one product. -/ +theorem approachZeroPrincipalDegreeClass_mul_equiv : + Berarducci.principalDegreeClassesEquivPrincipalComponent ℚ (1 + 1) + (Berarducci.principalDegreeClassesMul + approachZeroPrincipalDegreeClass + approachZeroPrincipalDegreeClass) = + Berarducci.principalComponentMul + (Berarducci.principalDegreeClassesEquivPrincipalComponent ℚ 1 + approachZeroPrincipalDegreeClass) + (Berarducci.principalDegreeClassesEquivPrincipalComponent ℚ 1 + approachZeroPrincipalDegreeClass) := + Berarducci.principalDegreeClassesEquivPrincipalComponent_mul _ _ + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/PrincipalComponentTensor.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/PrincipalComponentTensor.lean new file mode 100644 index 0000000000..a7654d7c20 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/PrincipalComponentTensor.lean @@ -0,0 +1,139 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Tests.Fixtures.ApproachZero +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalComponentTensor +public import Mathlib.LinearAlgebra.TensorProduct.Basis + +import Mathlib.Tactic.NormNum + +/-! +# API checks for extension of scalars on a homogeneous component + +The fixture has two distinct finite-support exponents and a nonzero infinite-support coefficient +in `P_1`. Its two tensor coordinates are checked independently. The forward map agrees with +multiplication of representatives, and both inverse identities hold on the fixture. +-/ + +public noncomputable section + +namespace Tests + +open scoped HahnSeries NatOrdinal TensorProduct + +private theorem approachZero_ordinalValue_bound_for_tensor : + Berarducci.ordinalValue approachZeroNonpositive < ω^ (1 + 1 : NatOrdinal) := by + rw [Berarducci.ordinalValue_eq_wpow_of_isPrincipal approachZero_isPrincipal + approachZero_degree_eq_one] + exact NatOrdinal.wpow_lt_wpow.mpr (lt_add_one (1 : NatOrdinal)) + +/-- The intrinsic degree-one class of the approach-zero series. -/ +def approachZeroPrincipalComponent : Berarducci.PrincipalComponent ℚ 1 := + Berarducci.principalComponentMk 1 approachZeroNonpositive + approachZero_ordinalValue_bound_for_tensor + +private theorem approachZeroPrincipalComponent_ne_zero : + approachZeroPrincipalComponent ≠ 0 := by + rw [approachZeroPrincipalComponent, ne_eq, + Berarducci.principalComponentMk_eq_zero_iff, + Berarducci.ordinalValue_eq_wpow_of_isPrincipal approachZero_isPrincipal + approachZero_degree_eq_one] + exact lt_irrefl _ + +/-- The exponent zero in the nonpositive real cone. -/ +def tensorExponentZero : HahnSeries.Nonpositive.exponentMonoid ℝ := ⟨0, le_rfl⟩ + +/-- The exponent negative one in the nonpositive real cone. -/ +def tensorExponentNegOne : HahnSeries.Nonpositive.exponentMonoid ℝ := ⟨-1, show (-1 : ℝ) ≤ 0 by + norm_num⟩ + +/-- A tensor with nonzero coordinates at the two distinct exponents `0` and `-1`. -/ +def approachZeroTwoExponentTensor : + Berarducci.PrincipalComponent ℚ 1 ⊗[ℚ] + Berarducci.FiniteSupportRing (K := ℚ) := + approachZeroPrincipalComponent ⊗ₜ + HahnSeries.Nonpositive.finiteSupportMonomial (K := ℚ) tensorExponentZero + + ((2 : ℚ) • approachZeroPrincipalComponent) ⊗ₜ + HahnSeries.Nonpositive.finiteSupportMonomial (K := ℚ) tensorExponentNegOne + +/-- Both coordinates of the two-exponent fixture are retained by the canonical tensor-basis +presentation. -/ +theorem approachZeroTwoExponentTensor_coordinates : + TensorProduct.equivFinsuppOfBasisRight + (HahnSeries.Nonpositive.finiteSupportBasis (G := ℝ) (K := ℚ)) + approachZeroTwoExponentTensor tensorExponentZero = + approachZeroPrincipalComponent ∧ + TensorProduct.equivFinsuppOfBasisRight + (HahnSeries.Nonpositive.finiteSupportBasis (G := ℝ) (K := ℚ)) + approachZeroTwoExponentTensor tensorExponentNegOne = + (2 : ℚ) • approachZeroPrincipalComponent := by + constructor <;> + simp [approachZeroTwoExponentTensor, + HahnSeries.Nonpositive.finiteSupportBasis_repr_apply, + HahnSeries.Nonpositive.coe_finiteSupportMonomial, + tensorExponentZero, tensorExponentNegOne] + +/-- The two-exponent tensor is nonzero; in particular, it is not a one-term presentation in +which one of the two monomials has silently been discarded. -/ +theorem approachZeroTwoExponentTensor_ne_zero : + approachZeroTwoExponentTensor ≠ 0 := by + intro hzero + have hcoordinates := approachZeroTwoExponentTensor_coordinates.1 + rw [hzero, map_zero, Finsupp.zero_apply] at hcoordinates + exact approachZeroPrincipalComponent_ne_zero hcoordinates.symm + +/-- The public extension-of-scalars equivalence sends the two-exponent fixture to the sum of +the two corresponding homogeneous products. -/ +theorem approachZeroTwoExponentTensor_forward : + Berarducci.principalComponentTensorEquiv ℚ 1 + approachZeroTwoExponentTensor = + HahnSeries.Nonpositive.degreeFiniteSupportResidueEquiv ℚ + (HahnSeries.Nonpositive.finiteSupportMonomial + (K := ℚ) tensorExponentZero) • + Berarducci.principalComponentToHahnDegreeLayer ℚ 1 + approachZeroPrincipalComponent + + HahnSeries.Nonpositive.degreeFiniteSupportResidueEquiv ℚ + (HahnSeries.Nonpositive.finiteSupportMonomial + (K := ℚ) tensorExponentNegOne) • + Berarducci.principalComponentToHahnDegreeLayer ℚ 1 + ((2 : ℚ) • approachZeroPrincipalComponent) := by + rw [approachZeroTwoExponentTensor, map_add, + Berarducci.principalComponentTensorEquiv_tmul, + Berarducci.principalComponentTensorEquiv_tmul] + +/-- The representative formula sends the negative-one pure tensor to the degree-one class of +the translated approach-zero series. -/ +theorem approachZeroTensorNegOne_representative : + Berarducci.principalComponentTensorMap ℚ 1 + (approachZeroPrincipalComponent ⊗ₜ + HahnSeries.Nonpositive.finiteSupportMonomial + (K := ℚ) tensorExponentNegOne) = + Berarducci.degreeLayerMk 1 + (((HahnSeries.Nonpositive.finiteSupportMonomial + (K := ℚ) tensorExponentNegOne : + Berarducci.FiniteSupportRing (K := ℚ)) : Berarducci.Series ℚ) * + approachZeroNonpositive) (by + rw [HahnSeries.Nonpositive.degree_mul, approachZero_degree_eq_one] + exact (add_le_add (by + exact (HahnSeries.degree_eq_zero.mpr ⟨by simp, + (HahnSeries.Nonpositive.mem_finiteSupportSubring_iff _).mp + (HahnSeries.Nonpositive.finiteSupportMonomial + (K := ℚ) tensorExponentNegOne).2⟩).le) le_rfl).trans_eq + (zero_add _)) := by + exact Berarducci.principalComponentTensorMap_principal_monomial 1 approachZeroNonpositive + approachZero_isPrincipal + approachZero_degree_eq_one approachZero_ordinalValue_bound_for_tensor tensorExponentNegOne + +/-- The public inverse is a genuine inverse on the nontrivial two-exponent fixture. -/ +theorem approachZeroTwoExponentTensor_roundtrip : + (Berarducci.principalComponentTensorEquiv ℚ 1).symm + (Berarducci.principalComponentTensorEquiv ℚ 1 + approachZeroTwoExponentTensor) = + approachZeroTwoExponentTensor := + (Berarducci.principalComponentTensorEquiv ℚ 1).symm_apply_apply _ + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/PrincipalSubring.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/PrincipalSubring.lean new file mode 100644 index 0000000000..7c0b1c0a1a --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/PrincipalSubring.lean @@ -0,0 +1,208 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalSubring + +import Mathlib.Tactic.NormNum + +/-! +# API checks for `P̂` + +The two-grade fixture verifies that intrinsic `P̂` is an external direct sum rather than a single +space `P_α`: independently nonzero vectors in grades zero and one remain visible in exactly those +two homogeneous components. The embedding preserves both components and their grades. + +A strictly negative monomial gives the decisive range separator. Its nonzero degree-zero +class lies in `RV̂`, but its image in the intrinsic ordinal-value component `P_0` is zero. Hence it +does +not belong to the principal graded subalgebra. This distinguishes LM24, Definition 6.1.1 from the +nearby wrong definition in which `P̂` is all of `RV̂`. +-/ + +universe v + +public noncomputable section + +namespace Tests + +open scoped DirectSum HahnSeries NatOrdinal + +variable {K : Type v} [Field K] + +section TwoGrades + +/-- A principal graded element with prescribed components in grades zero and one. -/ +def principalTwoGradeElement (x₀ : Berarducci.PrincipalComponent K 0) + (x₁ : Berarducci.PrincipalComponent K 1) : + Berarducci.PrincipalSubring K := + DirectSum.of (Berarducci.PrincipalComponent K) 0 x₀ + + DirectSum.of (Berarducci.PrincipalComponent K) 1 x₁ + +/-- The two-grade fixture has the prescribed components and vanishes in every other grade. -/ +theorem principalTwoGradeElement_components (x₀ : Berarducci.PrincipalComponent K 0) + (x₁ : Berarducci.PrincipalComponent K 1) : + principalTwoGradeElement x₀ x₁ 0 = x₀ ∧ + principalTwoGradeElement x₀ x₁ 1 = x₁ ∧ + ∀ α, α ≠ 0 → α ≠ 1 → principalTwoGradeElement x₀ x₁ α = 0 := by + constructor + · simp [principalTwoGradeElement, DirectSum.of_apply] + constructor + · simp [principalTwoGradeElement, DirectSum.of_apply] + · intro α hα0 hα1 + have h0α : (0 : NatOrdinal) ≠ α := Ne.symm hα0 + have h1α : (1 : NatOrdinal) ≠ α := Ne.symm hα1 + simp [principalTwoGradeElement, DirectSum.of_apply, h0α, h1α] + +/-- Nonzero inputs remain independently visible in grades zero and one. -/ +theorem principalTwoGradeElement_nonzero_components (x₀ : Berarducci.PrincipalComponent K 0) + (x₁ : Berarducci.PrincipalComponent K 1) + (hx₀ : x₀ ≠ 0) (hx₁ : x₁ ≠ 0) : + principalTwoGradeElement x₀ x₁ 0 ≠ 0 ∧ + principalTwoGradeElement x₀ x₁ 1 ≠ 0 := by + rw [(principalTwoGradeElement_components x₀ x₁).1, + (principalTwoGradeElement_components x₀ x₁).2.1] + exact ⟨hx₀, hx₁⟩ + +section Embedding + +variable [CharZero K] + +/-- The graded embedding preserves both prescribed components and their grades. -/ +theorem principalTwoGradeElement_embedding_components (x₀ : Berarducci.PrincipalComponent K 0) + (x₁ : Berarducci.PrincipalComponent K 1) : + Berarducci.principalSubringEmbedding K + (principalTwoGradeElement x₀ x₁) 0 = + Berarducci.principalComponentToHahnDegreeLayer K 0 x₀ ∧ + Berarducci.principalSubringEmbedding K + (principalTwoGradeElement x₀ x₁) 1 = + Berarducci.principalComponentToHahnDegreeLayer K 1 x₁ ∧ + ∀ α, α ≠ 0 → α ≠ 1 → + Berarducci.principalSubringEmbedding K + (principalTwoGradeElement x₀ x₁) α = 0 := by + simp only [Berarducci.principalSubringEmbedding_apply] + rw [(principalTwoGradeElement_components x₀ x₁).1, + (principalTwoGradeElement_components x₀ x₁).2.1] + refine ⟨rfl, rfl, ?_⟩ + intro α hα0 hα1 + rw [(principalTwoGradeElement_components x₀ x₁).2.2 α hα0 hα1, + map_zero] + +/-- The public algebra equivalence exposes the embedding and projection without unfolding. -/ +theorem principalSubringEquiv_evaluation (x : Berarducci.PrincipalSubring K) + (y : Berarducci.principalSubringSubalgebra K) : + ((Berarducci.principalSubringEquivSubalgebra K x : + Berarducci.principalSubringSubalgebra K) : + Berarducci.DegreeGraded K) = + Berarducci.principalSubringEmbedding K x ∧ + (Berarducci.principalSubringEquivSubalgebra K).symm y = + Berarducci.rvProjection K y := by + exact ⟨Berarducci.principalSubringEquivSubalgebra_apply x, + Berarducci.principalSubringEquivSubalgebra_symm_apply y⟩ + +end Embedding + +end TwoGrades + +section ProperRange + +/-- The monomial `t⁻¹` used to separate the principal graded subring from the full degree-graded +ring. -/ +def negativeMonomialForPrincipalGraded : Berarducci.Series K := + HahnSeries.Nonpositive.single (-1 : ℝ) 1 (by norm_num) + +theorem negativeMonomialForPrincipalGraded_degree : + ((negativeMonomialForPrincipalGraded (K := K) : Berarducci.Series K) : + K⟦ℝ⟧).degree = (0 : WithBot NatOrdinal) := by + apply HahnSeries.degree_eq_zero.mpr + constructor + · simp [negativeMonomialForPrincipalGraded] + · rw [negativeMonomialForPrincipalGraded, + HahnSeries.Nonpositive.coe_single] + exact (Set.finite_singleton (-1 : ℝ)).subset + HahnSeries.support_single_subset + +theorem negativeMonomialForPrincipalGraded_ordinalValue : + Berarducci.ordinalValue (negativeMonomialForPrincipalGraded (K := K)) = 0 := by + apply Berarducci.ordinalValue_of_mem_negativeMonomialIdeal + exact HahnSeries.Nonpositive.single_one_mem_negativeMonomialIdeal (by norm_num) + +variable (K) in +/-- The nonzero degree-zero class of the strictly negative monomial in `RV̂`. -/ +def negativeMonomialDegreeClass : + (HahnSeries.Nonpositive.degreeValuation K).Component 0 := + Berarducci.degreeLayerMk 0 + (negativeMonomialForPrincipalGraded (K := K)) + (negativeMonomialForPrincipalGraded_degree (K := K)).le + +variable (K) in +theorem negativeMonomialDegreeClass_ne_zero : + negativeMonomialDegreeClass K ≠ 0 := by + rw [negativeMonomialDegreeClass, ne_eq, + Berarducci.degreeLayerMk_eq_zero_iff, + negativeMonomialForPrincipalGraded_degree] + exact (lt_irrefl (0 : WithBot NatOrdinal)) + +variable (K) in +/-- The homogeneous realization of the strictly negative monomial class in `RV̂`. -/ +def negativeMonomialDegreeGraded : Berarducci.DegreeGraded K := + DirectSum.of + (HahnSeries.Nonpositive.degreeValuation K).Component 0 + (negativeMonomialDegreeClass K) + +variable (K) in +theorem negativeMonomialDegreeGraded_ne_zero : + negativeMonomialDegreeGraded K ≠ 0 := by + rw [negativeMonomialDegreeGraded, + ← map_zero (DirectSum.of + (HahnSeries.Nonpositive.degreeValuation K).Component 0)] + exact (DirectSum.of_injective 0).ne + (negativeMonomialDegreeClass_ne_zero K) + +variable (K) in +theorem negativeMonomialDegreeClass_projection_eq_zero : + Berarducci.degreeLayerToPrincipalComponent K 0 + (negativeMonomialDegreeClass K) = 0 := by + rw [negativeMonomialDegreeClass, + Berarducci.degreeLayerToPrincipalComponent_mk] + rw [Berarducci.principalComponentMk_eq_zero_iff, + negativeMonomialForPrincipalGraded_ordinalValue] + exact NatOrdinal.wpow_pos 0 + +variable (K) in +theorem negativeMonomialDegreeGraded_projection_eq_zero : + Berarducci.rvProjection K + (negativeMonomialDegreeGraded K) = 0 := by + rw [negativeMonomialDegreeGraded, + Berarducci.rvProjection_of, + negativeMonomialDegreeClass_projection_eq_zero] + exact map_zero _ + +variable (K) [CharZero K] in +/-- The principal graded subalgebra is strictly smaller than the full degree-graded +graded ring. -/ +theorem negativeMonomialDegreeGraded_not_mem_principalGradedSubalgebra : + negativeMonomialDegreeGraded K ∉ + Berarducci.principalSubringSubalgebra K := by + intro hmem + have hprincipal := + (Berarducci.mem_principalGradedSubalgebra_iff + (negativeMonomialDegreeGraded K)).mp hmem + rw [Berarducci.isPrincipalGraded_iff] at hprincipal + have hprincipalZero := hprincipal 0 + rw [negativeMonomialDegreeGraded, DirectSum.of_apply] at hprincipalZero + have hprincipalZero' : Berarducci.IsPrincipalDegreeClass 0 + (negativeMonomialDegreeClass K) := by + simpa using hprincipalZero + have hinverse := + Berarducci.principalComponentToHahnDegreeLayer_degreeLayerToPrincipalComponent_of_isPrincipal 0 + (negativeMonomialDegreeClass K) hprincipalZero' + rw [negativeMonomialDegreeClass_projection_eq_zero, map_zero] at hinverse + exact negativeMonomialDegreeClass_ne_zero K hinverse.symm + +end ProperRange + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/PrincipalSubringFiniteSupport.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/PrincipalSubringFiniteSupport.lean new file mode 100644 index 0000000000..2cca44d744 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/PrincipalSubringFiniteSupport.lean @@ -0,0 +1,238 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalSubringFiniteSupport + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Tests.PrincipalSubringFraction + +/-! +# API checks for finite-support series over `Frac(P̂)` + +The first fixture verifies that coefficient extension preserves both the constant term and a term +at exponent `-1`. The second fixture uses the non-scalar positive-degree fraction from the +principal graded fraction-field client. A series having that fraction as its constant coefficient +does not belong to the embedded copy of `K(ℝ^{≤0})`. + +Finally, the non-scalar coefficient and its inverse are placed in opposite factors of a +nonconstant product. Multiplying the first factor by the inverse coefficient and the second by +its reciprocal puts both factors in `K(ℝ^{≤0})`. This checks the exact `B`/`B⁻¹` orientation +and the nonzero witness required in LM24, Lemma 6.3.4. +-/ + +open scoped HahnSeries + +namespace Tests.HahnSeries.OrdinalValue.PrincipalSubringFiniteSupport + +public noncomputable section + +/-- A nonzero element of `Frac(P̂)` outside the coefficient-field image. -/ +def outsideCoefficient : Berarducci.PrincipalSubringFractionField ℚ := + Tests.fractionPositiveDegreeImage + +/-- The chosen coefficient outside `ℚ` is nonzero. -/ +theorem outsideCoefficient_ne_zero : outsideCoefficient ≠ 0 := by + rw [outsideCoefficient] + exact Tests.fractionPositiveDegreeImage_ne_zero + +/-- The chosen coefficient does not belong to the image of the coefficient-field embedding. -/ +theorem outsideCoefficient_not_mem_coefficientMap_range : + outsideCoefficient ∉ + Set.range (Berarducci.principalSubringFractionCoefficientMap ℚ) := by + rintro ⟨k, hk⟩ + apply Tests.fractionPositiveDegreeImage_not_scalar + refine ⟨k, ?_⟩ + rw [Berarducci.principalSubringFraction_algebraMap_apply] + rw [Berarducci.principalSubringFractionCoefficientMap_apply, + outsideCoefficient] at hk + exact hk + +/-- The nonpositive real exponent `-1`. -/ +def negativeOne : HahnSeries.Nonpositive.exponentMonoid ℝ := + ⟨-1, show (-1 : ℝ) ≤ 0 by norm_num⟩ + +/-- A nonconstant finite-support series over `ℚ`, with coefficients one at `0` and `-1`. -/ +def sourceBinomial : + HahnSeries.Nonpositive.FiniteSupportRing (G := ℝ) (K := ℚ) := + 1 + HahnSeries.Nonpositive.finiteSupportMonomial (K := ℚ) negativeOne + +/-- The coefficient extension of `sourceBinomial` to `Frac(P̂)`. -/ +def extendedBinomial : Berarducci.PrincipalSubringFractionFiniteSupportRing ℚ := + Berarducci.principalSubringFractionScalarExtension ℚ sourceBinomial + +/-- The term at exponent `-1` survives coefficient extension. -/ +theorem extendedBinomial_negativeOne_coeff : + HahnSeries.Nonpositive.finiteSupportCoefficients + extendedBinomial negativeOne = 1 := by + rw [extendedBinomial, + Berarducci.principalSubringFractionScalarExtension_coeff] + simp [sourceBinomial, negativeOne, + HahnSeries.Nonpositive.finiteSupportCoefficients_apply] + +/-- The constant term survives coefficient extension. -/ +theorem extendedBinomial_zero_coeff : + HahnSeries.Nonpositive.finiteSupportCoefficients + extendedBinomial 0 = 1 := by + rw [extendedBinomial, + Berarducci.principalSubringFractionScalarExtension_coeff] + simp [sourceBinomial, negativeOne, Subtype.ext_iff, + HahnSeries.Nonpositive.finiteSupportCoefficients_apply] + +/-- The extended binomial lies in the embedded coefficient-series subring. -/ +theorem extendedBinomial_mem_coefficientSubring : + extendedBinomial ∈ + Berarducci.principalSubringFractionCoefficientSubring ℚ := + (Berarducci.mem_principalGradedFractionCoefficientSubring_iff _).mpr + ⟨sourceBinomial, rfl⟩ + +/-- The positive-degree fraction, regarded as a constant finite-support series. -/ +def outsideConstant : Berarducci.PrincipalSubringFractionFiniteSupportRing ℚ := + HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℝ) + outsideCoefficient + +/-- The constant coefficient of `outsideConstant` is the chosen non-scalar fraction. -/ +theorem outsideConstant_zero_coeff : + HahnSeries.Nonpositive.finiteSupportCoefficients outsideConstant 0 = + outsideCoefficient := by + rw [outsideConstant] + simp [HahnSeries.Nonpositive.finiteSupportCoefficients_apply] + +/-- The positive-degree constant series is not in the coefficient-series subring. -/ +theorem outsideConstant_not_mem_coefficientSubring : + outsideConstant ∉ + Berarducci.principalSubringFractionCoefficientSubring ℚ := by + rw [Berarducci.mem_principalGradedFractionCoefficientSubring_iff_coeff] + push Not + refine ⟨0, ?_⟩ + rw [outsideConstant_zero_coeff] + exact outsideCoefficient_not_mem_coefficientMap_range + +/-- The first redistribution factor has a non-scalar coefficient and nonconstant support. -/ +def redistributionLeft : Berarducci.PrincipalSubringFractionFiniteSupportRing ℚ := + outsideConstant * extendedBinomial + +/-- The second redistribution factor is the inverse non-scalar constant. -/ +def redistributionRight : Berarducci.PrincipalSubringFractionFiniteSupportRing ℚ := + HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℝ) + outsideCoefficient⁻¹ + +/-- The coefficient of the first redistribution factor at `-1` is the non-scalar coefficient. -/ +theorem redistributionLeft_negativeOne_coeff : + HahnSeries.Nonpositive.finiteSupportCoefficients + redistributionLeft negativeOne = outsideCoefficient := by + rw [redistributionLeft, outsideConstant, + ← HahnSeries.Nonpositive.smul_finiteSupport_eq_scalar_mul, + map_smul, Finsupp.smul_apply, extendedBinomial_negativeOne_coeff] + simp + +/-- The constant coefficient of the second redistribution factor is the inverse coefficient. -/ +theorem redistributionRight_zero_coeff : + HahnSeries.Nonpositive.finiteSupportCoefficients + redistributionRight 0 = outsideCoefficient⁻¹ := by + rw [redistributionRight] + simp [HahnSeries.Nonpositive.finiteSupportCoefficients_apply] + +private theorem finiteSupportCoefficients_zero (g : HahnSeries.Nonpositive.exponentMonoid ℝ) : + HahnSeries.Nonpositive.finiteSupportCoefficients + (0 : Berarducci.PrincipalSubringFractionFiniteSupportRing ℚ) g = 0 := by + have hmap := congrArg + (fun f : HahnSeries.Nonpositive.exponentMonoid ℝ →₀ + Berarducci.PrincipalSubringFractionField ℚ ↦ f g) + ((HahnSeries.Nonpositive.finiteSupportCoefficients + (G := ℝ) (K := Berarducci.PrincipalSubringFractionField ℚ)).map_zero) + simpa only [Finsupp.zero_apply] using hmap + +/-- The first redistribution factor is nonzero. -/ +theorem redistributionLeft_ne_zero : redistributionLeft ≠ 0 := by + intro hzero + have hcoeff := congrArg + (fun b : Berarducci.PrincipalSubringFractionFiniteSupportRing ℚ ↦ + HahnSeries.Nonpositive.finiteSupportCoefficients b negativeOne) hzero + rw [redistributionLeft_negativeOne_coeff] at hcoeff + rw [finiteSupportCoefficients_zero] at hcoeff + exact outsideCoefficient_ne_zero hcoeff + +/-- The second redistribution factor is nonzero. -/ +theorem redistributionRight_ne_zero : redistributionRight ≠ 0 := by + intro hzero + have hcoeff := congrArg + (fun b : Berarducci.PrincipalSubringFractionFiniteSupportRing ℚ ↦ + HahnSeries.Nonpositive.finiteSupportCoefficients b 0) hzero + rw [redistributionRight_zero_coeff] at hcoeff + rw [finiteSupportCoefficients_zero] at hcoeff + exact inv_ne_zero outsideCoefficient_ne_zero hcoeff + +/-- The two redistribution factors multiply to the extended nonconstant binomial. -/ +theorem redistributionLeft_mul_right : + redistributionLeft * redistributionRight = + extendedBinomial := by + rw [redistributionLeft, redistributionRight, outsideConstant] + calc + _ = + (HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℝ) + outsideCoefficient * + HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℝ) + outsideCoefficient⁻¹) * + extendedBinomial := by ring + _ = extendedBinomial := by + rw [← (HahnSeries.Nonpositive.finiteSupportScalarHom + (G := ℝ) (K := Berarducci.PrincipalSubringFractionField ℚ)).map_mul] + simp [outsideCoefficient_ne_zero] + +/-- The product of the redistribution factors belongs to the coefficient-series subring. -/ +theorem redistributionLeft_mul_right_mem_coefficientSubring : + redistributionLeft * redistributionRight ∈ + Berarducci.principalSubringFractionCoefficientSubring ℚ := by + rw [redistributionLeft_mul_right] + exact extendedBinomial_mem_coefficientSubring + +/-- The non-scalar constant factor divides the first redistribution factor in the ordinary +finite-support ring sense, with the nonconstant extended binomial as quotient. -/ +theorem outsideConstant_dvd_redistributionLeft : + outsideConstant ∣ redistributionLeft := by + exact dvd_mul_right _ _ + +/-- The inverse positive-degree coefficient is an explicit valid redistribution witness. -/ +theorem inversePositiveDegree_is_redistributionWitness : + let B := outsideCoefficient⁻¹ + B ≠ 0 ∧ + redistributionLeft * + HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℝ) B ∈ + Berarducci.principalSubringFractionCoefficientSubring ℚ ∧ + redistributionRight * + HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℝ) B⁻¹ ∈ + Berarducci.principalSubringFractionCoefficientSubring ℚ := by + dsimp only + have hX := outsideCoefficient_ne_zero + refine ⟨inv_ne_zero hX, ?_, ?_⟩ + · rw [redistributionLeft, outsideConstant] + have hleft : + HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℝ) + outsideCoefficient * extendedBinomial * + HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℝ) + outsideCoefficient⁻¹ = + extendedBinomial := by + calc + _ = + (HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℝ) + outsideCoefficient * + HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℝ) + outsideCoefficient⁻¹) * + extendedBinomial := by ring + _ = extendedBinomial := by + rw [← (HahnSeries.Nonpositive.finiteSupportScalarHom + (G := ℝ) (K := Berarducci.PrincipalSubringFractionField ℚ)).map_mul] + simp [hX] + rw [hleft] + exact extendedBinomial_mem_coefficientSubring + · rw [redistributionRight] + rw [inv_inv, ← (HahnSeries.Nonpositive.finiteSupportScalarHom + (G := ℝ) (K := Berarducci.PrincipalSubringFractionField ℚ)).map_mul] + simp [hX] + +end + +end Tests.HahnSeries.OrdinalValue.PrincipalSubringFiniteSupport diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/PrincipalSubringFraction.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/PrincipalSubringFraction.lean new file mode 100644 index 0000000000..018c5ea9bd --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/PrincipalSubringFraction.lean @@ -0,0 +1,172 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalSubringFraction + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Tests.Fixtures.ApproachZero + +/-! +# API checks for the principal graded fraction field + +The positive-degree fixture is the grade-one class of the approach-zero series. Its image in +`Frac(P̂)` is nonzero and does not belong to the image of the coefficient field. This separates +relative algebraic closure from the incorrect assertion that `Frac(P̂) = K`. + +The inverse identity is also verified on a nonconstant fraction, rather than only on elements of +the underlying ring `P̂`. +-/ + +open scoped DirectSum HahnSeries NatOrdinal + +namespace Tests + +public noncomputable section + +/-- The principal-subring scalar action on its fraction field in the rational client fixtures. -/ +local instance principalSubringFractionClientSelfSMul : + SMul (Berarducci.PrincipalSubring ℚ) + (Berarducci.PrincipalSubringFractionField ℚ) := + (Berarducci.principalSubringFractionSelfAlgebra ℚ).toSMul + +/-- The principal-subring algebra structure on its fraction field in the rational client +fixtures. -/ +local instance principalSubringFractionClientSelfAlgebra : + Algebra (Berarducci.PrincipalSubring ℚ) + (Berarducci.PrincipalSubringFractionField ℚ) := + Berarducci.principalSubringFractionSelfAlgebra ℚ + +/-- The rational scalar action on the principal-subring fraction field in the client fixtures. -/ +local instance principalSubringFractionClientSMul : + SMul ℚ (Berarducci.PrincipalSubringFractionField ℚ) := + (Berarducci.principalSubringFractionAlgebra ℚ).toSMul + +/-- The rational algebra structure on the principal-subring fraction field in the client +fixtures. -/ +local instance principalSubringFractionClientAlgebra : + Algebra ℚ (Berarducci.PrincipalSubringFractionField ℚ) := + Berarducci.principalSubringFractionAlgebra ℚ + +local instance principalSubringFractionClientIsScalarTower : + IsScalarTower ℚ (Berarducci.PrincipalSubring ℚ) + (Berarducci.PrincipalSubringFractionField ℚ) := + Berarducci.principalSubringFraction_isScalarTower ℚ + +private theorem fractionApproachZero_ordinalValue_bound : + Berarducci.ordinalValue approachZeroNonpositive < ω^ (1 + 1 : NatOrdinal) := by + rw [Berarducci.ordinalValue_eq_wpow_of_isPrincipal approachZero_isPrincipal + approachZero_degree_eq_one] + exact NatOrdinal.wpow_lt_wpow.mpr (lt_add_one (1 : NatOrdinal)) + +/-- The intrinsic degree-one class represented by the approach-zero series. -/ +def fractionApproachZeroLayer : Berarducci.PrincipalComponent ℚ 1 := + Berarducci.principalComponentMk 1 approachZeroNonpositive + fractionApproachZero_ordinalValue_bound + +/-- The approach-zero degree-one class is nonzero. -/ +theorem fractionApproachZeroLayer_ne_zero : + fractionApproachZeroLayer ≠ 0 := by + rw [fractionApproachZeroLayer, ne_eq, + Berarducci.principalComponentMk_eq_zero_iff, + Berarducci.ordinalValue_eq_wpow_of_isPrincipal approachZero_isPrincipal + approachZero_degree_eq_one] + exact lt_irrefl _ + +/-- The homogeneous principal graded element represented by the approach-zero series. -/ +def fractionPositiveDegree : Berarducci.PrincipalSubring ℚ := + DirectSum.of _ 1 fractionApproachZeroLayer + +@[simp] +theorem fractionPositiveDegree_apply_one : + fractionPositiveDegree 1 = fractionApproachZeroLayer := by + simp [fractionPositiveDegree] + +/-- The positive-degree fixture is nonzero in `P̂`. -/ +theorem fractionPositiveDegree_ne_zero : + fractionPositiveDegree ≠ 0 := by + rw [fractionPositiveDegree, + ← map_zero (DirectSum.of (Berarducci.PrincipalComponent ℚ) 1)] + exact (DirectSum.of_injective 1).ne + fractionApproachZeroLayer_ne_zero + +/-- No coefficient scalar equals the positive-degree fixture. -/ +theorem fractionPositiveDegree_not_scalar (k : ℚ) : + fractionPositiveDegree ≠ + algebraMap ℚ (Berarducci.PrincipalSubring ℚ) k := by + intro hscalar + have hscalarZero : + (algebraMap ℚ (Berarducci.PrincipalSubring ℚ) k) 1 = 0 := by + rw [Berarducci.principalSubring_algebraMap_apply, + DirectSum.of_apply] + simp + have hcomponent := + congrArg (fun x : Berarducci.PrincipalSubring ℚ ↦ x 1) hscalar + rw [fractionPositiveDegree_apply_one, hscalarZero] at hcomponent + exact fractionApproachZeroLayer_ne_zero hcomponent + +/-- The image of the positive-degree fixture in the principal graded fraction field. -/ +def fractionPositiveDegreeImage : + Berarducci.PrincipalSubringFractionField ℚ := + Berarducci.principalSubringToFraction ℚ fractionPositiveDegree + +/-- The positive-degree fixture remains nonzero in the fraction field. -/ +theorem fractionPositiveDegreeImage_ne_zero : + fractionPositiveDegreeImage ≠ 0 := by + intro hzero + apply fractionPositiveDegree_ne_zero + apply Berarducci.principalSubringToFraction_injective ℚ + simpa only [fractionPositiveDegreeImage, map_zero] using hzero + +/-- The nonzero fixture admits the localization representation used at the start of LM24, +Lemma 6.3.3. -/ +theorem fractionPositiveDegreeImage_exists_mk : + ∃ (B : Berarducci.PrincipalSubring ℚ) + (C : nonZeroDivisors (Berarducci.PrincipalSubring ℚ)), + B ≠ 0 ∧ fractionPositiveDegreeImage = + Berarducci.principalSubringFractionMk B C := + Berarducci.principalSubringFraction_exists_mk_of_ne_zero + fractionPositiveDegreeImage_ne_zero + +/-- The public localization-map equation identifies the fixture with its fraction `B / 1`. -/ +theorem fractionPositiveDegree_toFraction_eq_mk : + Berarducci.principalSubringToFraction ℚ + fractionPositiveDegree = + Berarducci.principalSubringFractionMk + fractionPositiveDegree + (1 : nonZeroDivisors (Berarducci.PrincipalSubring ℚ)) := + Berarducci.principalSubringToFraction_apply_eq_mk _ + +/-- The exposed scalar tower makes the two scalar actions on the fraction field compatible. -/ +theorem fractionScalarTower_smul_assoc (k : ℚ) (B : Berarducci.PrincipalSubring ℚ) + (x : Berarducci.PrincipalSubringFractionField ℚ) : + (k • B) • x = k • (B • x) := + smul_assoc k B x + +/-- The principal graded fraction field strictly contains the image of the coefficient field. -/ +theorem fractionPositiveDegreeImage_not_scalar : + fractionPositiveDegreeImage ∉ + (algebraMap ℚ + (Berarducci.PrincipalSubringFractionField ℚ)).range := by + rintro ⟨k, hk⟩ + apply fractionPositiveDegree_not_scalar k + apply Berarducci.principalSubringToFraction_injective ℚ + calc + Berarducci.principalSubringToFraction ℚ fractionPositiveDegree = + fractionPositiveDegreeImage := rfl + _ = algebraMap ℚ (Berarducci.PrincipalSubringFractionField ℚ) k := hk.symm + _ = Berarducci.principalSubringToFraction ℚ + (algebraMap ℚ (Berarducci.PrincipalSubring ℚ) k) := + Berarducci.principalSubringFraction_algebraMap_apply k + +/-- The nonzero positive-degree element has a multiplicative inverse in `Frac(P̂)`. -/ +theorem fractionPositiveDegreeImage_mul_inv : + fractionPositiveDegreeImage * + fractionPositiveDegreeImage⁻¹ = 1 := + mul_inv_cancel₀ fractionPositiveDegreeImage_ne_zero + +end + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/PrincipalSubringTensor.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/PrincipalSubringTensor.lean new file mode 100644 index 0000000000..85df89565b --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/PrincipalSubringTensor.lean @@ -0,0 +1,159 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalSubringTensor + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Tests.Fixtures.ApproachZero +import Mathlib.Tactic.NormNum + +/-! +# API checks for the principal graded tensor decomposition + +The two-grade fixture has independently visible components in grades zero and one. Its image +therefore distinguishes the graded tensor equivalence from a construction that retains only the +degree-zero summand. The finite-support fixture is the monomial at exponent `-1`; proving that its +image is not a coefficient scalar distinguishes the factor `K(ℝ^{≤ 0})` from `K` itself. + +The final round trip verifies both inverse identities on this nondegenerate element. +-/ + +public noncomputable section + +namespace Tests + +open scoped DirectSum HahnSeries NatOrdinal TensorProduct + +private theorem gradedTensorApproachZero_ordinalValue_bound : + Berarducci.ordinalValue approachZeroNonpositive < ω^ (1 + 1 : NatOrdinal) := by + rw [Berarducci.ordinalValue_eq_wpow_of_isPrincipal approachZero_isPrincipal + approachZero_degree_eq_one] + exact NatOrdinal.wpow_lt_wpow.mpr (lt_add_one (1 : NatOrdinal)) + +/-- The intrinsic degree-one class represented by the approach-zero series. -/ +def gradedTensorApproachZeroLayer : Berarducci.PrincipalComponent ℚ 1 := + Berarducci.principalComponentMk 1 approachZeroNonpositive + gradedTensorApproachZero_ordinalValue_bound + +/-- The approach-zero degree-one class is nonzero. -/ +theorem gradedTensorApproachZeroLayer_ne_zero : + gradedTensorApproachZeroLayer ≠ 0 := by + rw [gradedTensorApproachZeroLayer, ne_eq, + Berarducci.principalComponentMk_eq_zero_iff, + Berarducci.ordinalValue_eq_wpow_of_isPrincipal approachZero_isPrincipal + approachZero_degree_eq_one] + exact lt_irrefl _ + +/-- The grade-zero class of the coefficient one. -/ +def gradedTensorScalarLayer : Berarducci.PrincipalComponent ℚ 0 := + Berarducci.principalComponentScalarHom ℚ 1 + +/-- A principal graded element with nontrivial data in grades zero and one. -/ +def gradedTensorTwoGradeElement : Berarducci.PrincipalSubring ℚ := + DirectSum.of _ 0 gradedTensorScalarLayer + + DirectSum.of _ 1 gradedTensorApproachZeroLayer + +/-- The two prescribed homogeneous components remain distinct in the direct sum. -/ +theorem gradedTensorTwoGradeElement_components : + gradedTensorTwoGradeElement 0 = gradedTensorScalarLayer ∧ + gradedTensorTwoGradeElement 1 = gradedTensorApproachZeroLayer := by + simp [gradedTensorTwoGradeElement, DirectSum.of_apply] + +/-- Tensoring the two-grade fixture with one preserves both homogeneous components through the +homogeneous-component equivalences. -/ +theorem gradedTensorTwoGrade_components : + Berarducci.principalSubringTensorEquiv ℚ + (gradedTensorTwoGradeElement ⊗ₜ (1 : Berarducci.FiniteSupportRing)) 0 = + Berarducci.principalComponentToHahnDegreeLayer ℚ 0 + gradedTensorScalarLayer ∧ + Berarducci.principalSubringTensorEquiv ℚ + (gradedTensorTwoGradeElement ⊗ₜ (1 : Berarducci.FiniteSupportRing)) 1 = + Berarducci.principalComponentToHahnDegreeLayer ℚ 1 + gradedTensorApproachZeroLayer := by + constructor + · rw [Berarducci.principalSubringTensorEquiv_tmul_apply, + gradedTensorTwoGradeElement_components.1, + Berarducci.principalComponentTensorEquiv_tmul, map_one, one_smul] + · rw [Berarducci.principalSubringTensorEquiv_tmul_apply, + gradedTensorTwoGradeElement_components.2, + Berarducci.principalComponentTensorEquiv_tmul, map_one, one_smul] + +/-- The positive-degree component survives; a degree-zero-only assembly fails this check. -/ +theorem gradedTensorTwoGrade_positive_component_ne_zero : + Berarducci.principalSubringTensorEquiv ℚ + (gradedTensorTwoGradeElement ⊗ₜ (1 : Berarducci.FiniteSupportRing)) 1 ≠ 0 := by + rw [gradedTensorTwoGrade_components.2] + intro hzero + apply gradedTensorApproachZeroLayer_ne_zero + apply Berarducci.principalComponentToHahnDegreeLayer_injective ℚ 1 + simpa only [map_zero] using hzero + +/-- The nonpositive exponent `-1` used by the finite-support factor fixture. -/ +def gradedTensorExponentNegOne : HahnSeries.Nonpositive.exponentMonoid ℝ := ⟨-1, show (-1 : ℝ) ≤ + 0 by + norm_num⟩ + +/-- The finite-support monomial at exponent `-1`. -/ +def gradedTensorFiniteMonomial : Berarducci.FiniteSupportRing (K := ℚ) := + HahnSeries.Nonpositive.finiteSupportMonomial (K := ℚ) gradedTensorExponentNegOne + +/-- The negative-exponent monomial is not a constant finite-support series. -/ +theorem gradedTensorFiniteMonomial_not_scalar (k : ℚ) : + gradedTensorFiniteMonomial ≠ + HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℝ) k := by + intro h + have hcoeff := congrArg + (fun p : Berarducci.FiniteSupportRing (K := ℚ) ↦ + (((p : Berarducci.Series ℚ) : ℚ⟦ℝ⟧).coeff (-1))) h + simp [gradedTensorFiniteMonomial, gradedTensorExponentNegOne, + HahnSeries.Nonpositive.coe_finiteSupportMonomial, + HahnSeries.Nonpositive.coe_finiteSupportScalarHom, + HahnSeries.C_apply] at hcoeff + +/-- The global equivalence retains the full finite-support factor rather than only coefficient +scalars. -/ +theorem gradedTensorFiniteSupportFactor_not_scalar (k : ℚ) : + Berarducci.principalSubringTensorEquiv ℚ + (1 ⊗ₜ gradedTensorFiniteMonomial) ≠ + algebraMap ℚ (Berarducci.DegreeGraded ℚ) k := by + rw [Berarducci.principalSubringTensorEquiv_one_tmul] + intro h + apply gradedTensorFiniteMonomial_not_scalar k + apply Berarducci.finiteSupportGradedEmbedding_injective ℚ + calc + Berarducci.finiteSupportGradedEmbedding ℚ gradedTensorFiniteMonomial = + algebraMap ℚ (Berarducci.DegreeGraded ℚ) k := h + _ = Berarducci.finiteSupportGradedEmbedding ℚ + (algebraMap ℚ (Berarducci.FiniteSupportRing (K := ℚ)) k) := + ((Berarducci.finiteSupportGradedEmbedding ℚ).commutes k).symm + _ = Berarducci.finiteSupportGradedEmbedding ℚ + (HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℝ) k) := rfl + +/-- The inverse equivalence recovers the positive-degree tensor component through the +homogeneous-component +inverse, without unfolding either equivalence. -/ +theorem gradedTensor_inverse_positive_component : + Berarducci.principalSubringTensorComponent ℚ 1 + ((Berarducci.principalSubringTensorEquiv ℚ).symm + (Berarducci.principalSubringTensorEquiv ℚ + (gradedTensorTwoGradeElement ⊗ₜ gradedTensorFiniteMonomial))) = + gradedTensorApproachZeroLayer ⊗ₜ gradedTensorFiniteMonomial := by + rw [Berarducci.principalSubringTensorComponent_symm_apply, + Berarducci.principalSubringTensorEquiv_component, + LinearEquiv.symm_apply_apply, + Berarducci.principalSubringTensorComponent_tmul, + gradedTensorTwoGradeElement_components.2] + +/-- The opaque global equivalence is invertible on the nondegenerate two-grade, +negative-exponent fixture. -/ +theorem gradedTensor_roundtrip : + (Berarducci.principalSubringTensorEquiv ℚ).symm + (Berarducci.principalSubringTensorEquiv ℚ + (gradedTensorTwoGradeElement ⊗ₜ gradedTensorFiniteMonomial)) = + gradedTensorTwoGradeElement ⊗ₜ gradedTensorFiniteMonomial := + (Berarducci.principalSubringTensorEquiv ℚ).symm_apply_apply _ + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/PrincipalValue.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/PrincipalValue.lean new file mode 100644 index 0000000000..bdebe13fef --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/PrincipalValue.lean @@ -0,0 +1,105 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalValue +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Tests.Fixtures.ApproachZero + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalComponentDegree + +/-! +# API checks for principal and residual ordinal values + +The approach-zero Hahn series supplies a concrete nonzero input whose ordinal value is strictly +greater than one. The first certificate checks both ordinary and Hessenberg reconstruction on +that input, as well as the defining classes of the two factors. The constant-one certificate +checks that a nonzero series of ordinal value one is outside the exact domain. + +The companion ordinal-factor client distinguishes the final principal factor from the first +factor by an asymmetric computation and checks the singleton residual convention. Together these +clients test the factorisation primitives and their application to Berarducci's ordinal value. +-/ + +public noncomputable section + +namespace Tests + +open scoped HahnSeries NatOrdinal + +/-- The approach-zero series, packaged in the exact domain of principal and residual values. -/ +def approachZeroWithOrdinalValueAboveOne : + Berarducci.SeriesWithOrdinalValueAboveOne ℚ := + ⟨approachZeroNonpositive, by + apply Berarducci.one_lt_ordinalValue_of_constantCoeff_eq_zero_of_supportSup_eq_zero + · rw [HahnSeries.Nonpositive.constantCoeff_apply, coe_approachZeroNonpositive] + exact not_ne_iff.mp (by + simpa [HahnSeries.mem_support] using zero_not_mem_approachZero_support) + · exact approachZero_supportSup⟩ + +/-- Principal and residual values satisfy all source characteristics on a concrete nonzero input +whose support is cofinal in zero. -/ +theorem approachZero_principalResidualValue_certificate : + (approachZeroWithOrdinalValueAboveOne : Berarducci.Series ℚ) ≠ 0 ∧ + Ordinal.IsInfiniteMultiplicativelyPrincipal + approachZeroWithOrdinalValueAboveOne.principalValue.val ∧ + Ordinal.IsAdditivelyPrincipal + approachZeroWithOrdinalValueAboveOne.residualValue.val ∧ + approachZeroWithOrdinalValueAboveOne.residualValue.val * + approachZeroWithOrdinalValueAboveOne.principalValue.val = + (Berarducci.ordinalValue approachZeroNonpositive).val ∧ + approachZeroWithOrdinalValueAboveOne.residualValue * + approachZeroWithOrdinalValueAboveOne.principalValue = + Berarducci.ordinalValue approachZeroNonpositive := by + exact ⟨approachZero_ne_zero, + approachZeroWithOrdinalValueAboveOne.principalValue_isInfiniteMultiplicativelyPrincipal, + approachZeroWithOrdinalValueAboveOne.residualValue_isAdditivelyPrincipal, + approachZeroWithOrdinalValueAboveOne.residualValue_val_mul_principalValue_val, + approachZeroWithOrdinalValueAboveOne.residualValue_mul_principalValue⟩ + +private theorem approachZero_ordinalValue_eq_wpow_one : + Berarducci.ordinalValue approachZeroNonpositive = ω^ (1 : NatOrdinal) := + Berarducci.ordinalValue_eq_wpow_of_isPrincipal + approachZero_isPrincipal approachZero_degree_eq_one + +/-- The successor-exponent formulas identify the two factors of the concrete degree-one +principal series. -/ +theorem approachZero_successor_principalResidualValue : + approachZeroWithOrdinalValueAboveOne.principalValue = ω^ (1 : NatOrdinal) ∧ + approachZeroWithOrdinalValueAboveOne.residualValue = 1 := by + have hone : 0 < (1 : NatOrdinal).constantCoeff := by + have h : (1 : NatOrdinal) = ((1 : ℕ) : NatOrdinal) := by norm_num + rw [h, NatOrdinal.constantCoeff_natCast] + norm_num + constructor + · exact approachZeroWithOrdinalValueAboveOne.principalValue_eq_wpow_one_of_ordinalValue_eq_wpow + 1 hone approachZero_ordinalValue_eq_wpow_one + · have hremove : (1 : NatOrdinal).removeNat 1 = 0 := by + symm + apply (NatOrdinal.eq_removeNat_iff_add_natCast_eq + (a := (1 : NatOrdinal)) (eta := 0) (n := 1) + (Nat.succ_le_iff.mpr hone)).mpr + simp + simpa [hremove] using + approachZeroWithOrdinalValueAboveOne.residualValue_eq_wpow_removeNat_of_ordinalValue_eq_wpow + 1 hone approachZero_ordinalValue_eq_wpow_one + +/-- The nonzero constant-one series is excluded from the domain because its ordinal value is one. -/ +theorem not_one_lt_ordinalValue_constant_one : + ¬1 < Berarducci.ordinalValue (HahnSeries.Nonpositive.C (1 : ℚ)) := by + have hvalue : + Berarducci.ordinalValue (HahnSeries.Nonpositive.C (1 : ℚ)) = 1 := by + apply Berarducci.ordinalValue_eq_one_iff.mpr + constructor + · apply Berarducci.mem_nearConstantSubgroup_iff.mpr + exact ⟨0, (HahnSeries.Nonpositive.negativeMonomialIdeal ℚ).zero_mem, 1, by simp⟩ + · intro hmem + have hcoeff := Berarducci.constantCoeff_eq_zero_of_mem_negativeMonomialIdeal hmem + norm_num at hcoeff + intro hlt + rw [hvalue] at hlt + exact lt_irrefl 1 hlt + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/ResidualPoint.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/ResidualPoint.lean new file mode 100644 index 0000000000..ac09cdf283 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/ResidualPoint.lean @@ -0,0 +1,176 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.ResidualPointTail +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Tests.Fixtures.ApproachZero + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.ResidualPointCofinality +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValueImage + +/-! +# API checks for Berarducci residual points + +The approach-zero series has ordinal value `ω`, hence principal value `ω` and residual value one. +Its least support exponent is `-1`. Closed truncation at that exponent retains the coefficient-one +monomial, and translation turns it into the constant-one series, so `-1` belongs to `X(b)`. + +This example separates Definition 6.6 from two nearby errors. Replacing residual value by +principal value would reject `-1`, while using strict rather than closed truncation would give the +zero series at `-1`. The endpoint zero is also excluded, but this is not a semantic separator for +the printed strict inequality: on the domain `1 < v_J(b)`, the value equation itself already +excludes zero, as proved in the definition module. + +The final test uses the same residual point to distinguish the strict tail cutoff `(η, 0)` from +the nearby closed cutoff `[η, 0)`: the point `-1` lies above `-2`, but not strictly above itself. + +The cofinality certificate produces a residual point strictly between `-1/1000` and zero. It +therefore distinguishes the proved conclusion of Lemma 6.8 from the nearby false assertion that +the residual-point set of this series consists only of its least exponent `-1`. +-/ + +open scoped HahnSeries NatOrdinal + +public noncomputable section + +namespace Tests + +open Ordinal +open Berarducci.SeriesWithOrdinalValueAboveOne + +/-- The approach-zero series in the exact domain of principal, residual, and residual-point +operations. -/ +def approachZeroResidualInput : + Berarducci.SeriesWithOrdinalValueAboveOne ℚ := + ⟨approachZeroNonpositive, by + apply Berarducci.one_lt_ordinalValue_of_constantCoeff_eq_zero_of_supportSup_eq_zero + · rw [HahnSeries.Nonpositive.constantCoeff_apply, coe_approachZeroNonpositive] + exact not_ne_iff.mp (by + simpa [HahnSeries.mem_support] using zero_not_mem_approachZero_support) + · exact approachZero_supportSup⟩ + +/-- The packaged residual-point input has the intended underlying Hahn series. -/ +@[simp] +theorem coe_approachZeroResidualInput : + (approachZeroResidualInput : Berarducci.Series ℚ) = approachZeroNonpositive := + (rfl) + +/-- The Berarducci ordinal value of the approach-zero series is `ω`. -/ +theorem approachZero_ordinalValue_eq_omega : + Berarducci.ordinalValue approachZeroNonpositive = NatOrdinal.of omega0 := by + apply le_antisymm + · simpa only [coe_approachZeroNonpositive, approachZero_supportOrderType] using + Berarducci.ordinalValue_le_supportOrderType approachZeroNonpositive + · apply NatOrdinal.of_le_iff.mpr + rw [← coe_approachZeroResidualInput] + have hprincipal := + Berarducci.ordinalValue_isAdditivelyPrincipal_of_one_lt + approachZeroResidualInput.2 + have hone : (1 : Ordinal) < + (Berarducci.ordinalValue approachZeroResidualInput.1).val := + NatOrdinal.of_lt_iff.mp approachZeroResidualInput.2 + exact hprincipal.omega0_le_of_one_lt hone + +private theorem approachZero_ordinalValue_isMultiplicativelyPrincipal : + Ordinal.IsMultiplicativelyPrincipal + (Berarducci.ordinalValue approachZeroResidualInput.1).val := by + rw [coe_approachZeroResidualInput, approachZero_ordinalValue_eq_omega] + simp only [NatOrdinal.val_of] + simpa [opow_zero, opow_one] using + Ordinal.isMultiplicativelyPrincipal_omega0_opow_opow 0 + +/-- The approach-zero series has principal value `ω` and residual value one. -/ +theorem approachZero_principalValue_eq_omega_and_residualValue_eq_one : + approachZeroResidualInput.principalValue = NatOrdinal.of omega0 ∧ + approachZeroResidualInput.residualValue = 1 := by + constructor + · rw [principalValue_eq_ordinalValue_of_isMultiplicativelyPrincipal + approachZeroResidualInput approachZero_ordinalValue_isMultiplicativelyPrincipal, + coe_approachZeroResidualInput, approachZero_ordinalValue_eq_omega] + · exact residualValue_eq_one_of_isMultiplicativelyPrincipal + approachZeroResidualInput approachZero_ordinalValue_isMultiplicativelyPrincipal + +private theorem approachZeroEmbedding_zero : + approachZeroEmbedding 0 = -1 := by + norm_num + +private theorem approachZero_coeff_neg_one : + approachZero.coeff (-1) = 1 := by + rw [← approachZeroEmbedding_zero, approachZero_coeff_embedding] + +private theorem approachZero_coeff_eq_zero_of_lt_neg_one {x : ℝ} (hx : x < -1) : + approachZero.coeff x = 0 := by + apply not_ne_iff.mp + rw [← HahnSeries.mem_support, approachZero_support] + rintro ⟨n, hn⟩ + have hmin : (-1 : ℝ) ≤ approachZeroEmbedding n := by + rw [← approachZeroEmbedding_zero] + exact approachZeroEmbedding.monotone (Nat.zero_le n) + linarith + +/-- Closed truncation of the approach-zero series at its least exponent, translated to zero, is +the constant-one series. -/ +theorem translatedTruncation_approachZero_neg_one : + Berarducci.translatedTruncation approachZero (-1) = + HahnSeries.Nonpositive.C (1 : ℚ) := by + apply Subtype.ext + ext δ + rw [Berarducci.coeff_translatedTruncation] + by_cases hδ : δ = 0 + · subst δ + simp [approachZero_coeff_neg_one] + · by_cases hδNonpositive : δ ≤ 0 + · have hδNeg : δ < 0 := lt_of_le_of_ne hδNonpositive hδ + have hlt : -1 + δ < -1 := by linarith + rw [ite_eq_left hδNonpositive, + approachZero_coeff_eq_zero_of_lt_neg_one hlt] + simp [hδ] + · rw [ite_eq_right hδNonpositive] + simp [hδ] + +/-- The least exponent is a residual point, whereas zero fails the value equation and is +excluded. -/ +theorem approachZero_residualPointSet_boundary : + (-1 : ℝ) ∈ Berarducci.residualPointSet approachZeroResidualInput ∧ + (0 : ℝ) ∉ Berarducci.residualPointSet approachZeroResidualInput := by + constructor + · rw [Berarducci.mem_residualPointSet_iff, + approachZero_principalValue_eq_omega_and_residualValue_eq_one.2] + constructor + · norm_num + · rw [coe_approachZeroResidualInput, coe_approachZeroNonpositive, + translatedTruncation_approachZero_neg_one] + apply Berarducci.ordinalValue_eq_one_iff.mpr + constructor + · apply Berarducci.mem_nearConstantSubgroup_iff.mpr + exact ⟨0, (HahnSeries.Nonpositive.negativeMonomialIdeal ℚ).zero_mem, + 1, by simp⟩ + · intro hmem + have hcoeff := + Berarducci.constantCoeff_eq_zero_of_mem_negativeMonomialIdeal hmem + norm_num at hcoeff + · exact Berarducci.zero_not_mem_residualPointSet approachZeroResidualInput + +/-- The residual-point set contains a point strictly between `-1/1000` and zero. -/ +theorem approachZero_residualPointSet_cofinal_near_zero : + ∃ γ ∈ Berarducci.residualPointSet approachZeroResidualInput, + -(1 : ℝ) / 1000 < γ ∧ γ < 0 := by + have hLUB := Berarducci.residualPointSet_isLUB_zero approachZeroResidualInput + obtain ⟨γ, hγ, hcutoff, _⟩ := hLUB.exists_between (by norm_num : -(1 : ℝ) / 1000 < 0) + exact ⟨γ, hγ, hcutoff, Berarducci.residualPointSet_subset_Iio _ hγ⟩ + +/-- The least exponent belongs to the tail cut at `-2` but not to the tail cut at `-1`. This +separates the strict cutoff in `residualPointTail` from a closed cutoff. -/ +theorem approachZero_residualPointTail_strict_cutoff : + (-1 : ℝ) ∈ Berarducci.residualPointTail approachZeroResidualInput (-2) ∧ + (-1 : ℝ) ∉ Berarducci.residualPointTail approachZeroResidualInput (-1) := by + constructor + · rw [Berarducci.mem_residualPointTail_iff] + exact ⟨approachZero_residualPointSet_boundary.1, by norm_num⟩ + · rw [Berarducci.mem_residualPointTail_iff] + exact fun h ↦ (lt_irrefl (-1)) h.2 + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/SectionSixThree.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/SectionSixThree.lean new file mode 100644 index 0000000000..0d2646bdba --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Tests/SectionSixThree.lean @@ -0,0 +1,183 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalSubringFiniteSupport +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.NormalizedSeriesMaximalFinite + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.MaximalFiniteMultiplicativity +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.PrincipalSubringPrimality +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.SeriesMaximalMultiplicativity +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.SeriesPrimality +import Mathlib.Tactic.NormNum + +/-! +# API checks for LM24, Corollaries 6.3.6--6.3.9 + +These checks compose the reductions underlying the final four results of LM24, +Section 6.3. The factor-witness checks retain both factors in the finite-support ring; they would +not follow from the weaker bare `IsPrimal` conclusions. The three-factor checks require literal +multiplicativity of the normalized maximal finite-support divisor, rather than the previously +proved one-sided divisibility. + +The zero test preserves the absence of a nonzero hypothesis in Corollary 6.3.9. The final fixture +uses two genuinely nonconstant finite-support series, each with a nonzero coefficient at exponent +`-1`, to exercise Proposition 6.3.8 away from the constant and zero cases. The unresolved +mathematical prerequisites (gcd existence, scalar redistribution, unit classification) are +explicit parameters; the coefficient field has characteristic zero. +-/ + +open scoped HahnSeries + +universe v + +namespace Tests + +public noncomputable section + +open HahnSeries.Nonpositive + +variable {K : Type v} [Field K] [CharZero K] +variable (hgcdK : ∀ p q : Berarducci.FiniteSupportRing (K := K), + ∃ d : Berarducci.FiniteSupportRing (K := K), + ∀ e : Berarducci.FiniteSupportRing (K := K), e ∣ p ∧ e ∣ q ↔ e ∣ d) +variable (hgcdL : ∀ p q : Berarducci.PrincipalSubringFractionFiniteSupportRing K, + ∃ d : Berarducci.PrincipalSubringFractionFiniteSupportRing K, + ∀ e : Berarducci.PrincipalSubringFractionFiniteSupportRing K, + e ∣ p ∧ e ∣ q ↔ e ∣ d) +variable (hredistribute : Berarducci.PrincipalSubringFractionScalarRedistribution K) +variable (hunits : ∀ u : Berarducci.FiniteSupportRing (K := K), + IsUnit u ↔ ∃ k : K, k ≠ 0 ∧ + u = finiteSupportScalarHom (G := ℝ) k) + +include hgcdK hgcdL hredistribute in +/-- The generic reduction for Corollary 6.3.6 retains both factors in the finite-support +ring, rather than merely producing factors in the ambient associated graded ring. -/ +theorem sectionSixThree_gradedFactorWitness (p : Berarducci.FiniteSupportRing (K := K)) + (B C : Berarducci.DegreeGraded K) + (hp : Berarducci.finiteSupportGradedEmbedding K p ∣ B * C) : + ∃ p₁ p₂ : Berarducci.FiniteSupportRing (K := K), + p = p₁ * p₂ ∧ + Berarducci.finiteSupportGradedEmbedding K p₁ ∣ B ∧ + Berarducci.finiteSupportGradedEmbedding K p₂ ∣ C := + Berarducci.finiteSupportGradedEmbedding_exists_factor_dvd_of_scalarRedistribution hgcdK hgcdL + hredistribute p B C hp + +include hgcdK hgcdL hredistribute hunits in +/-- Iterated multiplication verifies that Corollary 6.3.7 supplies an equality, not merely +one-sided divisibility. -/ +theorem sectionSixThree_gradedMaximal_three_mul (B C D : Berarducci.DegreeGraded K) : + Berarducci.gradedNormalizedMaximalFiniteSupportDivisor ((B * C) * D) = + (Berarducci.gradedNormalizedMaximalFiniteSupportDivisor B * + Berarducci.gradedNormalizedMaximalFiniteSupportDivisor C) * + Berarducci.gradedNormalizedMaximalFiniteSupportDivisor D := by + have hfactor := sectionSixThree_gradedFactorWitness hgcdK hgcdL hredistribute + have hmax := Berarducci.gradedNormalizedMaximalFiniteSupportDivisor_mul_of_factorization hgcdK + hunits hfactor + rw [hmax (B * C) D, hmax B C] + +include hgcdK hgcdL hredistribute hunits in +/-- Iterated multiplication verifies the exact equality in Proposition 6.3.8 at the series +level. -/ +theorem sectionSixThree_seriesMaximal_three_mul (b c d : Berarducci.Series K) : + Berarducci.seriesNormalizedMaximalFiniteSupportDivisor ((b * c) * d) = + (Berarducci.seriesNormalizedMaximalFiniteSupportDivisor b * + Berarducci.seriesNormalizedMaximalFiniteSupportDivisor c) * + Berarducci.seriesNormalizedMaximalFiniteSupportDivisor d := by + have hfactor := sectionSixThree_gradedFactorWitness hgcdK hgcdL hredistribute + have hgraded := + Berarducci.gradedNormalizedMaximalFiniteSupportDivisor_mul_of_factorization hgcdK hunits hfactor + have hseries := Berarducci.seriesNormalizedMaximalFiniteSupportDivisor_mul_of_graded hgcdK hunits + hgraded + rw [hseries (b * c) d, hseries b c] + +include hgcdK hgcdL hredistribute hunits in +/-- The stronger form of Corollary 6.3.9 retains finite-support factors and asserts their +product equality in the ambient Hahn-series ring. -/ +theorem sectionSixThree_seriesFactorWitness + (p : Berarducci.FiniteSupportRing (K := K)) (b c : Berarducci.Series K) + (hp : (p : Berarducci.Series K) ∣ b * c) : + ∃ p₁ p₂ : Berarducci.FiniteSupportRing (K := K), + (p : Berarducci.Series K) = + (p₁ : Berarducci.Series K) * (p₂ : Berarducci.Series K) ∧ + (p₁ : Berarducci.Series K) ∣ b ∧ + (p₂ : Berarducci.Series K) ∣ c := by + have hfactor := sectionSixThree_gradedFactorWitness hgcdK hgcdL hredistribute + have hgraded := + Berarducci.gradedNormalizedMaximalFiniteSupportDivisor_mul_of_factorization hgcdK hunits hfactor + have hseries := Berarducci.seriesNormalizedMaximalFiniteSupportDivisor_mul_of_graded hgcdK hunits + hgraded + obtain ⟨p₁, p₂, hpFactor, hp₁, hp₂⟩ := + Berarducci.finiteSupportSeries_exists_factor_dvd_of_maximalMultiplicative hgcdK hseries p b c hp + refine ⟨p₁, p₂, ?_, hp₁, hp₂⟩ + exact congrArg + (finiteSupportSubring (G := ℝ) (K := K)).subtype hpFactor + +include hgcdK hgcdL hredistribute hunits in +/-- The zero finite-support element is included in the witness theorem, so no hidden +nonzeroness hypothesis has entered the reduction. -/ +theorem sectionSixThree_zeroSeriesFactorWitness (b c : Berarducci.Series K) (hbc : b * c = 0) : + ∃ p₁ p₂ : Berarducci.FiniteSupportRing (K := K), + (0 : Berarducci.Series K) = + (p₁ : Berarducci.Series K) * (p₂ : Berarducci.Series K) ∧ + (p₁ : Berarducci.Series K) ∣ b ∧ + (p₂ : Berarducci.Series K) ∣ c := by + apply sectionSixThree_seriesFactorWitness hgcdK hgcdL hredistribute hunits 0 b c + rw [hbc] + exact dvd_refl 0 + +/-- The finite-support monomial `t⁻¹` used in the nonconstant multiplicativity fixture. -/ +def sectionSixThreeNegativeMonomial : Berarducci.FiniteSupportRing (K := ℚ) := + finiteSupportMonomial (K := ℚ) ⟨-1, show (-1 : ℝ) ≤ 0 by norm_num⟩ + +/-- The first nonconstant factor `t⁻¹ + 1`. -/ +def sectionSixThreeLeftSeries : Berarducci.Series ℚ := + ((sectionSixThreeNegativeMonomial + 1 : Berarducci.FiniteSupportRing (K := ℚ)) : + Berarducci.Series ℚ) + +/-- The second nonconstant factor `t⁻¹ - 1`. -/ +def sectionSixThreeRightSeries : Berarducci.Series ℚ := + ((sectionSixThreeNegativeMonomial - 1 : Berarducci.FiniteSupportRing (K := ℚ)) : + Berarducci.Series ℚ) + +/-- Both concrete factors have coefficient one at exponent `-1`; their constant coefficients +are respectively one and negative one. In particular, neither factor is zero or constant. -/ +theorem sectionSixThree_nonconstantFactors_coefficients : + (sectionSixThreeLeftSeries : ℚ⟦ℝ⟧).coeff (-1) = 1 ∧ + (sectionSixThreeRightSeries : ℚ⟦ℝ⟧).coeff (-1) = 1 ∧ + (sectionSixThreeLeftSeries : ℚ⟦ℝ⟧).coeff 0 = 1 ∧ + (sectionSixThreeRightSeries : ℚ⟦ℝ⟧).coeff 0 = -1 := by + simp [sectionSixThreeLeftSeries, sectionSixThreeRightSeries, + sectionSixThreeNegativeMonomial] + +/-- Proposition 6.3.8 applies as a literal equality to two concrete nonzero, nonconstant +finite-support series. -/ +theorem sectionSixThree_nonconstantSeriesMaximal_mul + (hgcdK : ∀ p q : Berarducci.FiniteSupportRing (K := ℚ), + ∃ d : Berarducci.FiniteSupportRing (K := ℚ), + ∀ e : Berarducci.FiniteSupportRing (K := ℚ), e ∣ p ∧ e ∣ q ↔ e ∣ d) + (hgcdL : ∀ p q : Berarducci.PrincipalSubringFractionFiniteSupportRing ℚ, + ∃ d : Berarducci.PrincipalSubringFractionFiniteSupportRing ℚ, + ∀ e : Berarducci.PrincipalSubringFractionFiniteSupportRing ℚ, + e ∣ p ∧ e ∣ q ↔ e ∣ d) + (hredistribute : Berarducci.PrincipalSubringFractionScalarRedistribution ℚ) + (hunits : ∀ u : Berarducci.FiniteSupportRing (K := ℚ), + IsUnit u ↔ ∃ k : ℚ, k ≠ 0 ∧ + u = finiteSupportScalarHom (G := ℝ) k) : + Berarducci.seriesNormalizedMaximalFiniteSupportDivisor + (sectionSixThreeLeftSeries * sectionSixThreeRightSeries) = + Berarducci.seriesNormalizedMaximalFiniteSupportDivisor sectionSixThreeLeftSeries * + Berarducci.seriesNormalizedMaximalFiniteSupportDivisor + sectionSixThreeRightSeries := by + have hfactor := sectionSixThree_gradedFactorWitness hgcdK hgcdL hredistribute + have hgraded := + Berarducci.gradedNormalizedMaximalFiniteSupportDivisor_mul_of_factorization hgcdK hunits hfactor + exact Berarducci.seriesNormalizedMaximalFiniteSupportDivisor_mul_of_graded hgcdK hunits hgraded _ + _ + +end + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Truncation.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Truncation.lean new file mode 100644 index 0000000000..5e97cf344b --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/Truncation.lean @@ -0,0 +1,228 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Germ +public import Mathlib.Topology.MetricSpace.Pseudo.Defs + +import Mathlib.Tactic.Linarith + +/-! +# Berarducci germs at a real exponent + +For a real Hahn series `b` and an exponent `γ`, `Berarducci.translatedTruncation b γ` restricts +`b` to exponents at most `γ` and translates `γ` to zero. Its image in +`Berarducci.Germ K` is `Berarducci.germAt b γ`. + +Two series have the same germ at `γ` exactly when their coefficients agree on an interval +`(η, γ]`. The right endpoint is essential: after translation, a discrepancy at `γ` is a +nonzero constant and therefore does not belong to Berarducci's ideal `J`. + +Berarducci, Remark 6.3: the translated truncation `b^{|γ}` lies in `J` unless `γ` belongs to the +closure of the support of `b`. + +-/ + +universe v + +public noncomputable section + +namespace Berarducci + +open HahnSeries + +variable {K : Type v} [Field K] + +/-- Restrict a real Hahn series at `γ` and translate `γ` to zero, obtaining a nonpositive +series. -/ +def translatedTruncation (b : K⟦ℝ⟧) (γ : ℝ) : Series K := + ⟨HahnSeries.translate (-γ) (HahnSeries.truncLE γ b), by + rw [HahnSeries.mem_nonpositiveSubring] + rw [HahnSeries.support_translate] + rintro δ ⟨x, hx, rfl⟩ + rw [HahnSeries.support_truncLE] at hx + change -γ + x ≤ 0 + linarith [hx.2]⟩ + +/-- The underlying Hahn series of the translated closed truncation. -/ +theorem coe_translatedTruncation (b : K⟦ℝ⟧) (γ : ℝ) : + ((translatedTruncation b γ : Series K) : K⟦ℝ⟧) = + HahnSeries.translate (-γ) (HahnSeries.truncLE γ b) := + (rfl) + +/-- The support of the translated truncation is the translated closed lower support. -/ +theorem support_translatedTruncation (b : K⟦ℝ⟧) (γ : ℝ) : + ((translatedTruncation b γ : Series K) : K⟦ℝ⟧).support = + (-γ + ·) '' {x ∈ b.support | x ≤ γ} := by + simp only [translatedTruncation, HahnSeries.support_translate, HahnSeries.support_truncLE] + +/-- The coefficient at `δ ≤ 0` is the original coefficient at `γ + δ`; all positive +coefficients vanish. -/ +@[simp] +theorem coeff_translatedTruncation (b : K⟦ℝ⟧) (γ δ : ℝ) : + ((translatedTruncation b γ : Series K) : K⟦ℝ⟧).coeff δ = + if δ ≤ 0 then b.coeff (γ + δ) else 0 := by + simp only [translatedTruncation, HahnSeries.coeff_translate, HahnSeries.coeff_truncLE] + have hindex : δ - -γ = γ + δ := by + simp [add_comm] + rw [hindex] + by_cases hδ : δ ≤ 0 + · have hle : γ + δ ≤ γ := by linarith + simp [hδ, hle] + · have hnot : ¬γ + δ ≤ γ := by linarith + simp [hδ, hnot] + +/-- Translated closed truncation preserves addition. -/ +theorem translatedTruncation_add (b c : K⟦ℝ⟧) (γ : ℝ) : + translatedTruncation (b + c) γ = translatedTruncation b γ + translatedTruncation c γ := by + apply Subtype.ext + ext δ + change + ((translatedTruncation (b + c) γ : Series K) : K⟦ℝ⟧).coeff δ = + ((translatedTruncation b γ : Series K) : K⟦ℝ⟧).coeff δ + + ((translatedTruncation c γ : Series K) : K⟦ℝ⟧).coeff δ + rw [coeff_translatedTruncation, coeff_translatedTruncation, coeff_translatedTruncation] + by_cases hδ : δ ≤ 0 <;> simp [hδ] + +/-- Translated closed truncation commutes with multiplication by a constant Hahn series. -/ +theorem translatedTruncation_C_mul (k : K) (b : K⟦ℝ⟧) (γ : ℝ) : + translatedTruncation (HahnSeries.C k * b) γ = + (HahnSeries.Nonpositive.C : K →+* Series K) k * translatedTruncation b γ := by + apply Subtype.ext + ext δ + rw [coeff_translatedTruncation, Subring.coe_mul, HahnSeries.Nonpositive.coe_C] + simp only [HahnSeries.C_mul_eq_smul, HahnSeries.coeff_smul, + coeff_translatedTruncation] + by_cases hδ : δ ≤ 0 <;> simp [hδ] + +/-- Translated closed truncation sends the zero series to zero. -/ +@[simp] +theorem translatedTruncation_zero_input (γ : ℝ) : + translatedTruncation (0 : K⟦ℝ⟧) γ = 0 := by + apply Subtype.ext + ext δ + rw [coeff_translatedTruncation] + simp + +/-- Translated closed truncation at a fixed exponent as an additive homomorphism. -/ +def translatedTruncationAddMonoidHom (γ : ℝ) : K⟦ℝ⟧ →+ Series K where + toFun b := translatedTruncation b γ + map_zero' := translatedTruncation_zero_input γ + map_add' b c := translatedTruncation_add b c γ + +/-- Evaluation of the additive translated-truncation map. -/ +@[simp] +theorem translatedTruncationAddMonoidHom_apply (γ : ℝ) (b : K⟦ℝ⟧) : + translatedTruncationAddMonoidHom γ b = translatedTruncation b γ := + by + rw [translatedTruncationAddMonoidHom] + rfl + +/-- Truncation and translation at zero leave a nonpositive series unchanged. -/ +@[simp] +theorem translatedTruncation_zero (b : Series K) : + translatedTruncation (b : K⟦ℝ⟧) 0 = b := by + apply Subtype.ext + ext δ + rw [coeff_translatedTruncation] + by_cases hδ : δ ≤ 0 + · simp [hδ] + · rw [ite_eq_right hδ] + apply Eq.symm + apply not_ne_iff.mp + rw [← HahnSeries.mem_support] + exact fun hmem ↦ hδ (HahnSeries.Nonpositive.support_subset b hmem) + +/-- The germ at `γ` of the monomial supported at `γ` is represented by its coefficient as a +constant series. -/ +theorem translatedTruncation_single_cut (k : K) (γ : ℝ) : + translatedTruncation (HahnSeries.single γ k) γ = HahnSeries.Nonpositive.C k := by + apply Subtype.ext + ext δ + rw [coeff_translatedTruncation] + by_cases hδ : δ = 0 + · subst δ + simp + · by_cases hδ0 : δ ≤ 0 + · have hsum : γ + δ ≠ γ := by + intro h + apply hδ + exact add_left_cancel (a := γ) (by simpa using h) + simp [hδ0, hsum, hδ] + · simp [hδ0, hδ] + +/-- A translated truncation of a translated truncation is the translated truncation at the sum +of the exponents, when the second exponent is nonpositive: `(b^{|γ})^{|γ'} = b^{|γ + γ'}`. -/ +theorem translatedTruncation_translatedTruncation (b : K⟦ℝ⟧) (γ : ℝ) {γ' : ℝ} (hγ' : γ' ≤ 0) : + translatedTruncation ((translatedTruncation b γ : Series K) : K⟦ℝ⟧) γ' = + translatedTruncation b (γ + γ') := by + apply Subtype.ext + ext δ + simp only [coeff_translatedTruncation] + by_cases hδ : δ ≤ 0 + · simp [hδ, add_nonpos hγ' hδ, add_assoc] + · simp [hδ] + +/-- The Berarducci germ at the real exponent `γ`. -/ +def germAt (b : K⟦ℝ⟧) (γ : ℝ) : Germ K := + toGerm (translatedTruncation b γ) + +/-- Evaluation of the germ at `γ` through the quotient map. -/ +@[simp] +theorem germAt_apply (b : K⟦ℝ⟧) (γ : ℝ) : + germAt b γ = toGerm (translatedTruncation b γ) := + (rfl) + +/-- Two real Hahn series have the same germ at `γ` exactly when their coefficients agree on +some interval `(η, γ]`. -/ +theorem germAt_eq_germAt_iff_exists_coeff_eq {b c : K⟦ℝ⟧} {γ : ℝ} : + germAt b γ = germAt c γ ↔ + ∃ η < γ, ∀ δ : ℝ, η < δ → δ ≤ γ → b.coeff δ = c.coeff δ := by + rw [germAt_apply, germAt_apply, toGerm_eq_toGerm_iff_exists_coeff_eq] + constructor + · rintro ⟨ε, hε, heq⟩ + refine ⟨γ + ε, by linarith, fun δ hεδ hδγ ↦ ?_⟩ + have hshiftLower : ε < δ - γ := by linarith + have hshiftUpper : δ - γ ≤ 0 := by linarith + have h := heq (δ - γ) hshiftLower hshiftUpper + rw [coeff_translatedTruncation, coeff_translatedTruncation, ite_eq_left hshiftUpper, + ite_eq_left hshiftUpper] at h + simpa [sub_eq_add_neg, add_assoc, add_comm, add_left_comm] using h + · rintro ⟨η, hη, heq⟩ + refine ⟨η - γ, by linarith, fun δ hεδ hδ0 ↦ ?_⟩ + have hLower : η < γ + δ := by linarith + have hUpper : γ + δ ≤ γ := by linarith + rw [coeff_translatedTruncation, coeff_translatedTruncation, ite_eq_left hδ0, ite_eq_left hδ0] + exact heq (γ + δ) hLower hUpper + +/-- A germ taken at a point outside the closure of the support vanishes. -/ +theorem germAt_eq_zero_of_not_mem_closure_support {b : K⟦ℝ⟧} {γ : ℝ} + (h : γ ∉ closure b.support) : germAt b γ = 0 := by + rw [Metric.mem_closure_iff] at h + push Not at h + obtain ⟨ε, hε, hall⟩ := h + have hzero : (0 : Germ K) = toGerm 0 := by simp + rw [germAt_apply, hzero, toGerm_eq_toGerm_iff_exists_coeff_eq] + refine ⟨-ε, by linarith, fun δ hδlow hδ0 ↦ ?_⟩ + rw [coeff_translatedTruncation, ite_eq_left hδ0] + simp only [Subring.coe_zero, HahnSeries.coeff_zero] + by_contra hcoeff + have hmem : γ + δ ∈ b.support := (HahnSeries.mem_support _ _).mpr hcoeff + have hdist := hall (γ + δ) hmem + rw [Real.dist_eq] at hdist + have habs : |γ - (γ + δ)| = -δ := by + rw [show γ - (γ + δ) = -δ by ring, abs_of_nonneg (by linarith)] + rw [habs] at hdist + linarith + +/-- A translated truncation taken at a point outside the closure of the support lies in `J`. -/ +theorem translatedTruncation_mem_negativeMonomialIdeal_of_not_mem_closure_support + {b : K⟦ℝ⟧} {γ : ℝ} (h : γ ∉ closure b.support) : + translatedTruncation b γ ∈ HahnSeries.Nonpositive.negativeMonomialIdeal K := by + have hzero := germAt_eq_zero_of_not_mem_closure_support h + rwa [germAt_apply, toGerm_apply, Ideal.Quotient.eq_zero_iff_mem] at hzero + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/TruncationDrop.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/TruncationDrop.lean new file mode 100644 index 0000000000..cb04802cb3 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/OrdinalValue/TruncationDrop.lean @@ -0,0 +1,169 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Truncation +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValueDegree +public import LeanPool.ConwayRefinement.ConwayRefinement.Topology.Order.LeftNeighborhood +public import Mathlib.Topology.Instances.Real.Lemmas + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.StableInterval +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValueFinalSegment +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValueImage +public import Mathlib.Topology.MetricSpace.Pseudo.Lemmas + +/-! +# Truncation drop + +If `v_J(a) ≤ ω^β`, then the translated truncations `a^{|γ}` at all cutoffs `γ < 0` +sufficiently close to zero have ordinal value strictly below `ω^β`. + +The proof reads the ordinal value from a sufficiently short support tail. If `a ∈ J + K`, the +translated truncations near zero lie in `J`. Otherwise `1 < v_J(a)`, so `β ≥ 1`, and for a cutoff +`γ` in a tail `(η, 0)` that computes the ordinal value, the support of `a` strictly between `η` +and `γ` is a proper initial segment of the full tail, whose order type is therefore below `ω^β`; +it is also a final segment of the support below `γ`, and bounds the ordinal value of `a^{|γ}`. +-/ + +open Filter Topology +open scoped HahnSeries NatOrdinal + +universe v + +public noncomputable section + +namespace Berarducci + +open HahnSeries + +variable {K : Type v} [Field K] + +/-- A translated truncation whose support has a gap immediately below the cutoff lies in +`J + K`, hence has ordinal value at most one. -/ +theorem ordinalValue_translatedTruncation_le_one_of_eq_empty + (b : Series K) {η γ : ℝ} (hηγ : η < γ) + (hempty : (b : K⟦ℝ⟧).support ∩ Set.Ioo η γ = ∅) : + ordinalValue (translatedTruncation (b : K⟦ℝ⟧) γ) ≤ 1 := by + by_contra hlt + have hLUB := isLUB_negativeSupport_zero_of_one_lt_ordinalValue (lt_of_not_ge hlt) + obtain ⟨x, ⟨hxSupport, hx0⟩, hηx, _⟩ := hLUB.exists_between (sub_neg.mpr hηγ) + rw [support_translatedTruncation] at hxSupport + obtain ⟨y, ⟨hySupport, hyγ⟩, rfl⟩ := hxSupport + have hy : y ∈ (b : K⟦ℝ⟧).support ∩ Set.Ioo η γ := + ⟨hySupport, by linarith, lt_of_le_of_ne hyγ (by intro h; subst h; simp at hx0)⟩ + rw [hempty] at hy + exact hy + +/-- **Truncation drop.** If `v_J(a) ≤ ω^β`, then `v_J(a^{|γ}) < ω^β` for every cutoff +`γ < 0` sufficiently close to zero. -/ +@[blueprint "lem:truncation-drop" + (phase := "Ordinal value and degree") + (title := "Decrease of the ordinal value under translated truncation") + (statement := /-- + Let $\beta<\omega_1$ and $b\in K((\mathbb R^{\le0}))$. If + $v_J(b)\le\omega^\beta$, then + \[ + v_J(b^{|\gamma})<\omega^\beta + \] + for all $\gamma<0$ sufficiently close to $0$. + -/) + (proof := /-- + If $b\in J+K$, all sufficiently late translated truncations lie in $J$. + Otherwise $1 (cantorBendixsonDegreeValuation (G := G) (R := K)) +local notation "J" => Valuation.supp (cantorBendixsonValuation (G := G) (R := K)) + +variable {ι : Type w} {wt : ι → NatOrdinal.{u}} + {xg : ι → (cantorBendixsonDegreeValuation (G := G) (R := K)).AssociatedGraded} +variable (σ : LiftFamily wt xg) + +/-- Evaluation at representatives, followed by passage to the quotient by bounded series. -/ +def germAlgHom : MvPolynomial ι K →ₐ[K] Nonpositive G K ⧸ J := + (Ideal.Quotient.mkₐ K J).comp (aeval σ.lift) + +theorem germAlgHom_apply (F : MvPolynomial ι K) : + germAlgHom σ F = Ideal.Quotient.mk J (aeval σ.lift F) := by + rfl + +/-- Generation of the associated graded ring makes evaluation at the lifts surjective on germs. -/ +theorem germAlgHom_surjective + (hgenerate : Function.Surjective + (aeval xg : MvPolynomial ι K →ₐ[K] (ν).AssociatedGraded)) : + Function.Surjective (germAlgHom σ) := by + intro g + obtain ⟨u, rfl⟩ := Ideal.Quotient.mk_surjective g + obtain ⟨α, huα⟩ : ∃ α : NatOrdinal.{u}, ν u < (α : WithBot NatOrdinal) := by + cases hν : ν u with + | bot => exact ⟨0, WithBot.bot_lt_coe 0⟩ + | coe β => exact ⟨β + 1, WithBot.coe_lt_coe.mpr (lt_add_one β)⟩ + obtain ⟨F, -, -, hF⟩ := exists_forall_weight_lt_and_degree_sub_aeval_eq_bot + xg σ.represents α (fun β _ y hy ↦ by + obtain ⟨P, hP⟩ := hgenerate y + exact ⟨weightedHomogeneousComponent wt β P, + weightedHomogeneousComponent_isWeightedHomogeneous (w := wt) (n := β) (φ := P), + (OrdinalGraded.decompose_aeval (𝒜 := DirectSum.rangeLof K (ν).Component) + (fun i ↦ HahnSeries.Nonpositive.Represents.mem_rangeLof (σ.represents i)) P β).symm.trans + (by + rw [hP] + exact DirectSum.decompose_of_mem_same _ hy)⟩) u huα + refine ⟨F, ?_⟩ + rw [germAlgHom_apply, Ideal.Quotient.eq] + rw [mem_cantorBendixsonValuation_supp, + ← cantorBendixsonDegreeValuation_eq_bot_iff] + rw [← neg_sub, MaxAddDegree.map_neg] + exact hF + +/-- Graded injectivity makes evaluation at the lifts injective after passage to germs. -/ +theorem germAlgHom_injective + (hinj : Function.Injective (aeval xg : MvPolynomial ι K →ₐ[K] (ν).AssociatedGraded)) : + Function.Injective (germAlgHom σ) := by + classical + rw [injective_iff_map_eq_zero] + intro F hF + by_contra hF0 + let β := F.support.sup (Finsupp.weight wt) + obtain ⟨d, hd, hβ⟩ := Finset.exists_mem_eq_sup F.support + (MvPolynomial.support_nonempty.mpr hF0) (Finsupp.weight wt) + have hcomponent : weightedHomogeneousComponent wt β F ≠ 0 := by + rw [MvPolynomial.ne_zero_iff] + refine ⟨d, ?_⟩ + rw [coeff_weightedHomogeneousComponent, ite_eq_left hβ.symm] + exact MvPolynomial.mem_support_iff.mp hd + have hgraded : aeval xg (weightedHomogeneousComponent wt β F) ≠ 0 := by + intro h + apply hcomponent + apply hinj + simpa using h + have hdegree : ν (aeval σ.lift F) = (β : WithBot NatOrdinal) := + degree_aeval_eq_of_aeval_weightedHomogeneousComponent_ne_zero xg σ.represents + (fun _ hd' ↦ Finset.le_sup hd') hgraded + rw [germAlgHom_apply, Ideal.Quotient.eq_zero_iff_mem, + mem_cantorBendixsonValuation_supp, + ← cantorBendixsonDegreeValuation_eq_bot_iff] at hF + exact WithBot.coe_ne_bot (hdegree.symm.trans hF) + +/-- Under graded polynomiality and generation, the quotient by series bounded strictly below zero +is a polynomial algebra on the chosen representatives. -/ +def germAlgEquiv + (hindependent : AlgebraicIndependent K xg) + (hgenerate : Function.Surjective + (aeval xg : MvPolynomial ι K →ₐ[K] (ν).AssociatedGraded)) : + MvPolynomial ι K ≃ₐ[K] Nonpositive G K ⧸ J := + AlgEquiv.ofBijective (germAlgHom σ) + ⟨germAlgHom_injective σ (algebraicIndependent_iff_injective_aeval.mp hindependent), + germAlgHom_surjective σ hgenerate⟩ + +/-- The quotient by series bounded strictly below zero is a polynomial ring, hence refines +products, when homogeneous generators are algebraically independent and have representatives. -/ +theorem hasFourFactorRefinement_of_algebraicIndependent_generators + (σ : LiftFamily wt xg) + (hindependent : AlgebraicIndependent K xg) + (hgenerate : Function.Surjective + (aeval xg : MvPolynomial ι K →ₐ[K] (ν).AssociatedGraded)) : + HasFourFactorRefinement (Nonpositive G K ⧸ J) := by + let : DecompositionMonoid (Nonpositive G K ⧸ J) := + MulEquiv.decompositionMonoid (germAlgEquiv σ hindependent hgenerate).symm.toMulEquiv + exact hasFourFactorRefinement_of_decompositionMonoid + +end HahnSeries.Germ + +end diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/PolynomialAlgebra/CompleteGermOfCauchyComplete.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/PolynomialAlgebra/CompleteGermOfCauchyComplete.lean new file mode 100644 index 0000000000..98724e0124 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/PolynomialAlgebra/CompleteGermOfCauchyComplete.lean @@ -0,0 +1,83 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.PolynomialAlgebra.CompleteGerm + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint + +/-! +# Polynomial presentation of a germ ring + +For a Cauchy-complete exponent group, a minimal homogeneous generating system for the +Cantor--Bendixson degree is algebraically independent. Representatives of the generators identify +the quotient by series bounded strictly below zero with a polynomial ring. +-/ + +open Set +open scoped HahnSeries + +universe u v + +public noncomputable section + +namespace HahnSeries.Nonpositive + +variable {G : Type u} {K : Type v} +variable [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [UniformSpace G] [IsUniformAddGroup G] [OrderTopology G] [Nontrivial G] [CompleteSpace G] + [DenselyOrdered G] [NoMinOrder G] [NoMaxOrder G] + [NoMaxOrder (FiniteArchimedeanClass G)] + [Field K] [CharZero K] + +/-- For an ordered exponent group that is Cauchy complete and has no smallest nonzero magnitude, +the quotient by series supported away from zero is a polynomial algebra. -/ +@[blueprint "thm:complete-hahn-germ-polynomial-algebra" + (phase := "Polynomial presentations") + (title := "Polynomial presentation of the germ ring over a Cauchy-complete exponent group") + (statement := /-- + Let $K$ be a field of characteristic zero and let $G$ be a nontrivial, + densely ordered abelian group with no least or greatest element and with + no least nonzero Archimedean class in the magnitude order. Assume that + $G$ is Cauchy complete for its additive uniformity. If $J$ is the ideal + of series in $K((G^{\le 0}))$ whose support is bounded strictly below zero, + then for some set $I$ there is a $K$-algebra isomorphism + \[ + K[X_i:i\in I]\simeq K((G^{\le 0}))/J. + \] + -/) + (proof := /-- + Applying \ref{lem:extend-to-minimal-system} to the empty family gives a + minimal homogeneous generating system of the associated graded ring of the + Cantor--Bendixson degree. Well-order the nonzero Archimedean classes and + retain each class that is smaller in magnitude than every earlier class. + The resulting family is coinitial in the magnitude order and well-founded + when ordered by reverse magnitude. Its groups $G_{\prec\sigma}$ therefore + form a decreasing neighbourhood basis at zero. Choose + series representing the generators. By + \ref{thm:cantor-bendixson-minimal-generators-independent}, these generators + are algebraically independent. Minimality makes homogeneous evaluation + surjective. Evaluation at the representatives is therefore surjective + modulo $J$, while its highest nonzero weighted-homogeneous component proves + injectivity modulo $J$. + -/)] +theorem exists_mvPolynomial_algEquiv_germ : + ∃ ι : Type (max (u + 1) v), Nonempty + (MvPolynomial ι K ≃ₐ[K] + Nonpositive G K ⧸ (cantorBendixsonValuation (G := G) (R := K)).supp) := by + let ν := cantorBendixsonDegreeValuation (G := G) (R := K) + obtain ⟨ι, weight, generators, hminimal⟩ := OrdinalGraded.exists_isMinimalSystem + (DirectSum.rangeLof K (ν).Component) + obtain ⟨lifts, hlower⟩ := exists_liftFamily_hasLowerTruncationDegrees hminimal.mem + have hindependent : AlgebraicIndependent K generators := + HahnSeries.Germ.algebraicIndependent_of_minimal_system + lifts hminimal hlower + have hgenerate : Function.Surjective (MvPolynomial.aeval generators : + MvPolynomial ι K →ₐ[K] (ν).AssociatedGraded) := + cantorBendixson_ordinalMinimalSystem_aeval_surjective weight generators hminimal + exact ⟨ι, ⟨HahnSeries.Germ.germAlgEquiv lifts hindependent hgenerate⟩⟩ + +end HahnSeries.Nonpositive diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/PolynomialAlgebra/InitialForms.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/PolynomialAlgebra/InitialForms.lean new file mode 100644 index 0000000000..e198e6e457 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/PolynomialAlgebra/InitialForms.lean @@ -0,0 +1,119 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.FiniteSupport +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Nonpositive +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.PrincipalGraded +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalSubringTensor +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Degree.Statements.Degree +public import LeanPool.ConwayRefinement.ConwayRefinement.LinearAlgebra.TensorProduct.SubalgebraBasis +public import Mathlib.RingTheory.MvPolynomial.WeightedHomogeneous +public import Mathlib.Data.Finsupp.Weight +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.DegreeWeightedPolynomial +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MvPolynomial.BaseChange + +import Mathlib.Algebra.MvPolynomial.Rename +import Mathlib.RingTheory.MvPolynomial.Tower +import Mathlib.Algebra.MvPolynomial.Basic + +/-! +# The series ring over the finite-support series and `RV̂ ≅ P̂ ⊗_K K_fin` + +Let `K((ℝ^{≤0}))` be the series ring, with the finite-support series `K_fin = K(ℝ^{≤0})`. The +degree is a separated multiplicative degree on `K((ℝ^{≤0}))`, and +`RV̂ = gr_deg K((ℝ^{≤0})) ≅ P̂ ⊗_K K_fin`. This file records the structure map +`K_fin → K((ℝ^{≤0}))`, its degree, and the compatibility of the identification +`RV̂ ≅ P̂ ⊗_K K_fin` with initial forms: `1 ⊗ c` is the initial form of the finite-support series +`c`, and `B ⊗ 1` is the initial form of any series of degree `α` whose class is `B ∈ P_α`. The +lifts of a minimal system of homogeneous generators and the degree formula for polynomials in them +are in `Berarducci.PolynomialRing`. +-/ + +open HahnSeries HahnSeries.Nonpositive Berarducci + +open scoped TensorProduct MaxAddDegree + +universe v + +public noncomputable section + +namespace Berarducci + +variable {K : Type v} [Field K] [CharZero K] + +omit [CharZero K] in +/-- The structure map `K_fin → K((ℝ^{≤0}))` is the subring inclusion. -/ +theorem algebraMap_finiteSupportRing_apply (c : Berarducci.FiniteSupportRing (K := K)) : + algebraMap (Berarducci.FiniteSupportRing (K := K)) (Nonpositive ℝ K) c = + (c : Nonpositive ℝ K) := (rfl) + +omit [CharZero K] in +/-- A nonzero finite-support series has degree zero, stated for the structure map +`K_fin → K((ℝ^{≤0}))`. -/ +theorem degreeValuation_algebraMap_eq_zero (c : Berarducci.FiniteSupportRing (K := K)) + (hc : c ≠ 0) : + degreeValuation K (algebraMap (Berarducci.FiniteSupportRing (K := K)) (Nonpositive ℝ K) c) = + 0 := + degreeValuation_finiteSupport_eq_zero c hc + +/-- The right tensor factor gives `P̂ ⊗_K K_fin` its canonical `K_fin`-algebra structure. -/ +instance principalSubringTensorFiniteSupportAlgebra : + Algebra (Berarducci.FiniteSupportRing (K := K)) + (PrincipalSubring K ⊗[K] Berarducci.FiniteSupportRing (K := K)) := + Algebra.TensorProduct.rightAlgebra + +/-- The identification `P̂ ⊗_K K_fin ≅ RV̂` sends a finite-support scalar to its initial form. -/ +theorem principalSubringTensorEquiv_one_tmul_eq_initialForm + (c : Berarducci.FiniteSupportRing (K := K)) : + principalSubringTensorEquiv K (1 ⊗ₜ[K] c) = + (degreeValuation K).initialForm + (algebraMap (Berarducci.FiniteSupportRing (K := K)) (Nonpositive ℝ K) c) := by + rw [principalSubringTensorEquiv_one_tmul, finiteSupportGradedEmbedding_eq_initialForm] + rfl + +/-- The identification `P̂ ⊗_K K_fin ≅ RV̂` on a homogeneous pure tensor: `rv(b) ⊗ 1`, for `b` a +principal series of exact degree `α`, maps to the initial form of `b`. -/ +theorem principalSubringTensorEquiv_of_tmul_one_eq_initialForm + {α : NatOrdinal} (b : Nonpositive ℝ K) + (hb : Berarducci.ordinalValue b < ω^ (α + 1)) + (hprin : IsPrincipal b) + (hdeg : ((b : Nonpositive ℝ K) : K⟦ℝ⟧).degree = (α : WithBot NatOrdinal)) : + principalSubringTensorEquiv K + ((DirectSum.of (Berarducci.PrincipalComponent K) α + (Berarducci.principalComponentMk α b hb)) ⊗ₜ 1) = + (degreeValuation K).initialForm b := by + classical + have hbLe : ((b : Nonpositive ℝ K) : K⟦ℝ⟧).degree ≤ (α : WithBot NatOrdinal) := hdeg.le + -- The homogeneous class corresponds to the degree-graded class of the same representative. + have hclassPrin : Berarducci.IsPrincipalDegreeClass α + (Berarducci.degreeLayerMk α b hbLe) := by + rw [Berarducci.isPrincipalDegreeClass_iff] + exact Or.inr ⟨b, hprin, hdeg, rfl⟩ + have hA : Berarducci.principalComponentToHahnDegreeLayer K α + (Berarducci.principalComponentMk α b hb) = + Berarducci.degreeLayerMk α b hbLe := by + have hproj : Berarducci.degreeLayerToPrincipalComponent K α + (Berarducci.degreeLayerMk α b hbLe) = + Berarducci.principalComponentMk α b hb := + Berarducci.degreeLayerToPrincipalComponent_mk α b hbLe + rw [← hproj] + exact + Berarducci.principalComponentToHahnDegreeLayer_degreeLayerToPrincipalComponent_of_isPrincipal + α _ hclassPrin + change principalSubringTensorEquiv K (_ ⊗ₜ[K] 1) = _ + rw [principalSubringTensorEquiv_tmul_one, Berarducci.principalSubringEmbedding_of, hA] + -- The degree-graded class of the representative is its initial form. + rw [Berarducci.degreeLayerMk_eq_componentMk, ← MaxAddDegree.homogeneousMk_apply, + ← MaxAddDegree.initialForm_eq_homogeneousMk_of_componentMk_ne_zero] + intro h0 + rw [MaxAddDegree.componentMk_eq_zero_iff] at h0 + have hvalue : degreeValuation K b = ((b : Nonpositive ℝ K) : K⟦ℝ⟧).degree := + degreeValuation_apply b + rw [hvalue, hdeg] at h0 + exact lt_irrefl _ h0 + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/PolynomialAlgebra/PolynomialPresentation.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/PolynomialAlgebra/PolynomialPresentation.lean new file mode 100644 index 0000000000..d39dfea88f --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/PolynomialAlgebra/PolynomialPresentation.lean @@ -0,0 +1,352 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.PolynomialAlgebra.InitialForms +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrderType +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Statements.SeriesPrimality +public import Mathlib.RingTheory.Localization.FractionRing +public import Mathlib.Algebra.Prime.Defs + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.DegreeValuation +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Statements.ProductValue +import Mathlib.RingTheory.MvPolynomial.Localization +import Mathlib.RingTheory.Polynomial.UniqueFactorization +import Mathlib.RingTheory.Ideal.Quotient.Operations + +/-! +# Polynomial presentations of the series ring and primality + +Let `K((ℝ^{≤0}))` be the series ring, `K_fin = K(ℝ^{≤0})` its series with finite support, and +`L = Frac(K_fin)`. The argument of this file is stated for a *polynomial presentation* +(`IsPolynomialPresentation`) of a `K_fin`-subalgebra `K_fin[b_i : i ∈ ι]` of `K((ℝ^{≤0}))`: +evaluation `K_fin[X_i] → K((ℝ^{≤0})))`, `X_i ↦ b_i`, is injective, a polynomial whose value has +degree at most zero is a constant, and the subalgebra is saturated under the nonzero scalars of +`K_fin`. An irreducible `a = F(b) ∈ K((ℝ^{≤0}))` with `0 < deg a` then generates a prime ideal of +`K_fin[X_i]`: + +* a finite-support divisor of `a` is a unit, since its cofactor would otherwise be a unit and + force `deg a = 0`; +* `F` is irreducible in `L[X_i]`: a factorisation is cleared of denominators, the finite-support + denominator is primal in `K((ℝ^{≤0}))` with finite-support factors, and the degree formula + forces one factor to be a constant; +* `D = K_fin[X_i]/(F)` embeds in `L[X_i]/(F)`, by the same clearing of denominators together with + the saturation of the presented subalgebra; +* `L[X_i]` is a unique factorisation domain, so `L[X_i]/(F)` and hence `D` are domains. + +The presentation used is that of the whole series ring by the lifts of a minimal system of +homogeneous generators of `P̂` (`Berarducci.PolynomialRing`), which rests on the polynomiality +of `P̂`; the primality of every series follows (`Berarducci.Primality`). +-/ + +open HahnSeries HahnSeries.Nonpositive Berarducci +open scoped TensorProduct MaxAddDegree + +universe v w + +public noncomputable section + +namespace Berarducci + +variable {K : Type v} [Field K] [CharZero K] + +/-! ### Degrees of divisors and units -/ + +/-- The degree of a divisor of a nonzero series is at most the degree of the series. -/ +theorem seriesDegree_le_of_dvd {a c : Nonpositive ℝ K} (hdvd : c ∣ a) (ha : a ≠ 0) : + degreeValuation K c ≤ degreeValuation K a := by + obtain ⟨d, rfl⟩ := hdvd + have hd : d ≠ 0 := fun h ↦ ha (by rw [h, mul_zero]) + rw [(degreeValuation K).map_mul] + calc degreeValuation K c = degreeValuation K c + 0 := (add_zero _).symm + _ ≤ degreeValuation K c + degreeValuation K d := + add_le_add le_rfl ((degreeValuation K).zero_le_degree (degreeValuation_isSeparated K) + (fun _ ↦ bot_le) hd) + +/-- A unit of the series ring has degree zero. -/ +theorem seriesDegree_eq_zero_of_isUnit {b : Nonpositive ℝ K} (hb : IsUnit b) : + degreeValuation K b = 0 := by + rw [degreeValuation_apply, degree_eq_zero_of_isUnit degree_mul hb] + +/-- A divisor of degree at most zero of an irreducible series of positive degree is a unit. -/ +theorem isUnit_of_dvd_of_seriesDegree_le_zero {a u : Nonpositive ℝ K} (ha : Irreducible a) + (haDegree : 0 < degreeValuation K a) (hu : degreeValuation K u ≤ 0) (hdvd : u ∣ a) : + IsUnit u := by + obtain ⟨w, rfl⟩ := hdvd + rcases ha.isUnit_or_isUnit rfl with h | h + · exact h + · exfalso + rw [(degreeValuation K).map_mul, + seriesDegree_eq_zero_of_isUnit h, add_zero] at haDegree + exact absurd (lt_of_lt_of_le haDegree hu) (lt_irrefl _) + +/-! ### Clearing denominators -/ + +/-- The fraction field `L = Frac(K_fin)` of the finite-support series. -/ +abbrev FiniteSupportFractionField : Type v := + FractionRing (Berarducci.FiniteSupportRing (K := K)) + +variable {ι : Type w} + +variable (K ι) in +/-- Extension of coefficients `K_fin[X_i] → L[X_i]`. -/ +abbrev coordinatePolynomialMap : + MvPolynomial ι (Berarducci.FiniteSupportRing (K := K)) →+* + MvPolynomial ι (FiniteSupportFractionField (K := K)) := + MvPolynomial.map (algebraMap (Berarducci.FiniteSupportRing (K := K)) + (FiniteSupportFractionField (K := K))) + +omit [CharZero K] in +variable (K ι) in +/-- Extension of coefficients to the fraction field is injective. -/ +theorem coordinatePolynomialMap_injective : + Function.Injective (coordinatePolynomialMap K ι) := + MvPolynomial.map_injective _ (IsFractionRing.injective _ _) + +omit [CharZero K] in +/-- Every polynomial over `L` becomes a polynomial over `K_fin` after multiplication by a nonzero +finite-support denominator. -/ +theorem exists_C_mul_eq_coordinatePolynomialMap + (q : MvPolynomial ι (FiniteSupportFractionField (K := K))) : + ∃ (u : Berarducci.FiniteSupportRing (K := K)) + (h : MvPolynomial ι (Berarducci.FiniteSupportRing (K := K))), + u ≠ 0 ∧ MvPolynomial.C (algebraMap (Berarducci.FiniteSupportRing (K := K)) + (FiniteSupportFractionField (K := K)) u) * q = coordinatePolynomialMap K ι h := by + let := MvPolynomial.algebraMvPolynomial (σ := ι) + (R := Berarducci.FiniteSupportRing (K := K)) (S := FiniteSupportFractionField (K := K)) + obtain ⟨⟨h, m⟩, hm⟩ := IsLocalization.surj + ((nonZeroDivisors (Berarducci.FiniteSupportRing (K := K))).map + (MvPolynomial.C (σ := ι))) q + obtain ⟨u, hu, hum⟩ := Submonoid.mem_map.mp m.2 + refine ⟨u, h, nonZeroDivisors.ne_zero hu, ?_⟩ + simp only at hm + rw [MvPolynomial.algebraMap_def, ← hum, MvPolynomial.map_C, mul_comm] at hm + exact hm + +/-! ### Polynomial presentations -/ + +omit [CharZero K] in +/-- A constant `c ∈ K_fin` evaluates to itself under `K_fin[X_i] → K((ℝ^{≤0}))`. -/ +theorem aeval_C_finiteSupport (b : ι → Nonpositive ℝ K) + (c : Berarducci.FiniteSupportRing (K := K)) : + MvPolynomial.aeval b (MvPolynomial.C c) = (c : Nonpositive ℝ K) := + MvPolynomial.aeval_C _ _ + +/-- A family `b : ι → K((ℝ^{≤0}))` is a *polynomial presentation* of the `K_fin`-subalgebra +`K_fin[b_i : i ∈ ι]` it generates: evaluation `K_fin[X_i] → K((ℝ^{≤0}))`, `X_i ↦ b_i`, is +injective, a polynomial whose value has degree at most zero is a constant, and the subalgebra is +saturated under the nonzero scalars of `K_fin`: if `u t ∈ K_fin[b_i]` with `0 ≠ u ∈ K_fin`, then +`t ∈ K_fin[b_i]`. The paper's presentation `S = K_fin[b_B : B ∈ 𝓑]` of the ring of series of +finite degree is one, and so is any presentation of the whole series ring. -/ +structure IsPolynomialPresentation (b : ι → Nonpositive ℝ K) : Prop where + /-- Evaluation `F ↦ F(b)` is injective. -/ + injective : Function.Injective (MvPolynomial.aeval b : MvPolynomial ι + (Berarducci.FiniteSupportRing (K := K)) →ₐ[Berarducci.FiniteSupportRing (K := K)] + Nonpositive ℝ K) + /-- A polynomial whose value has degree at most zero is a constant. -/ + eq_C_of_degree_le_zero : ∀ G : MvPolynomial ι (Berarducci.FiniteSupportRing (K := K)), + degreeValuation K (MvPolynomial.aeval b G) ≤ 0 → G = MvPolynomial.C (G.coeff 0) + /-- `K_fin[b_i]` is saturated under the nonzero scalars of `K_fin`. -/ + mem_range_of_mul_mem_range : ∀ (u : Berarducci.FiniteSupportRing (K := K)) (t : Nonpositive ℝ K), + u ≠ 0 → (u : Nonpositive ℝ K) * t ∈ (MvPolynomial.aeval b : MvPolynomial ι + (Berarducci.FiniteSupportRing (K := K)) →ₐ[Berarducci.FiniteSupportRing (K := K)] + Nonpositive ℝ K).range → + t ∈ (MvPolynomial.aeval b : MvPolynomial ι + (Berarducci.FiniteSupportRing (K := K)) →ₐ[Berarducci.FiniteSupportRing (K := K)] + Nonpositive ℝ K).range + +namespace IsPolynomialPresentation + +variable {b : ι → Nonpositive ℝ K} (hb : IsPolynomialPresentation b) +include hb + +/-! ### Constant polynomials -/ + +omit [CharZero K] in +/-- If a nonzero finite-support multiple of `G ∈ L[X_i]` comes from a polynomial over `K_fin` +whose value has degree at most zero, and `G ≠ 0`, then `G` is a unit of `L[X_i]`. -/ +theorem isUnit_of_C_mul_eq_coordinatePolynomialMap + {u : Berarducci.FiniteSupportRing (K := K)} (hu : u ≠ 0) + {G : MvPolynomial ι (FiniteSupportFractionField (K := K))} (hG : G ≠ 0) + {G' : MvPolynomial ι (Berarducci.FiniteSupportRing (K := K))} + (hGG' : MvPolynomial.C (algebraMap (Berarducci.FiniteSupportRing (K := K)) + (FiniteSupportFractionField (K := K)) u) * G = coordinatePolynomialMap K ι G') + (hdeg : degreeValuation K (MvPolynomial.aeval b G') ≤ 0) : IsUnit G := by + rw [hb.eq_C_of_degree_le_zero G' hdeg, coordinatePolynomialMap, MvPolynomial.map_C] at hGG' + have hc : G'.coeff 0 ≠ 0 := by + intro hc + rw [hc, map_zero, MvPolynomial.C_0, mul_eq_zero, MvPolynomial.C_eq_zero, + map_eq_zero_iff _ (IsFractionRing.injective _ _)] at hGG' + exact hGG'.elim hu hG + have hunit : IsUnit (MvPolynomial.C (algebraMap (Berarducci.FiniteSupportRing (K := K)) + (FiniteSupportFractionField (K := K)) (G'.coeff 0)) : + MvPolynomial ι (FiniteSupportFractionField (K := K))) := + (isUnit_iff_ne_zero.mpr ((map_ne_zero_iff _ (IsFractionRing.injective _ _)).mpr hc)).map + MvPolynomial.C + rw [← hGG'] at hunit + exact isUnit_of_mul_isUnit_right hunit + +omit hb in +/-- The image of a degree-zero finite-support factor times a unit has degree at most zero. -/ +private theorem seriesDegree_le_zero_of_eq_mul {w u₁ g₁ : Nonpositive ℝ K} + (hw : w = u₁ * g₁) {d : Nonpositive ℝ K} (hd : d ≠ 0) (hd0 : degreeValuation K d = 0) + (hu₁ : u₁ ∣ d) (hg₁ : IsUnit g₁) : degreeValuation K w ≤ 0 := by + rw [hw, (degreeValuation K).map_mul, + seriesDegree_eq_zero_of_isUnit hg₁, add_zero, ← hd0] + exact seriesDegree_le_of_dvd hu₁ hd + +/-! ### Irreducibility over the fraction field -/ + +/-- If `F(b)` is irreducible of positive degree, then `F` is irreducible in `L[X_i]`. -/ +theorem irreducible_coordinatePolynomialMap_of_irreducible_aeval + {F : MvPolynomial ι (Berarducci.FiniteSupportRing (K := K))} + (ha : Irreducible (MvPolynomial.aeval b F)) + (haDegree : 0 < degreeValuation K (MvPolynomial.aeval b F)) : + Irreducible (coordinatePolynomialMap K ι F) := by + have hinj := coordinatePolynomialMap_injective K ι + have hF0 : F ≠ 0 := fun h ↦ ha.ne_zero (by rw [h, map_zero]) + refine ⟨fun hunit ↦ ?_, fun G H hGH ↦ ?_⟩ + · -- a unit would make `a` divide a finite-support series + obtain ⟨G, hG⟩ := hunit.exists_right_inv + obtain ⟨v, h, hv, hvh⟩ := exists_C_mul_eq_coordinatePolynomialMap G + have hmap : coordinatePolynomialMap K ι (MvPolynomial.C v) = + coordinatePolynomialMap K ι (F * h) := by + rw [coordinatePolynomialMap, MvPolynomial.map_C, map_mul, ← hvh, ← mul_assoc, + mul_right_comm, hG, one_mul] + have heq := hinj hmap + have heval : (v : Nonpositive ℝ K) = + MvPolynomial.aeval b F * MvPolynomial.aeval b h := by + rw [← aeval_C_finiteSupport b v, heq, map_mul] + have hdvd : MvPolynomial.aeval b F ∣ (v : Nonpositive ℝ K) := ⟨MvPolynomial.aeval b h, heval⟩ + have hv' : (v : Nonpositive ℝ K) ≠ 0 := fun h0 ↦ hv (Subtype.ext h0) + have hle := seriesDegree_le_of_dvd hdvd hv' + rw [degreeValuation_finiteSupport_eq_zero v hv] at hle + exact absurd (lt_of_lt_of_le haDegree hle) (lt_irrefl _) + · -- clear denominators in a factorisation and use primality of the denominator + obtain ⟨u, G', hu, huG⟩ := exists_C_mul_eq_coordinatePolynomialMap G + obtain ⟨v, H', hv, hvH⟩ := exists_C_mul_eq_coordinatePolynomialMap H + have hmap : coordinatePolynomialMap K ι (MvPolynomial.C (u * v) * F) = + coordinatePolynomialMap K ι (G' * H') := by + rw [map_mul (coordinatePolynomialMap K ι), map_mul (coordinatePolynomialMap K ι), ← huG, + ← hvH, hGH, coordinatePolynomialMap, MvPolynomial.map_C, map_mul, MvPolynomial.C_mul] + ring + have heq := hinj hmap + have heval : ((u * v : Berarducci.FiniteSupportRing (K := K)) : Nonpositive ℝ K) * + MvPolynomial.aeval b F = MvPolynomial.aeval b G' * MvPolynomial.aeval b H' := by + rw [← aeval_C_finiteSupport b (u * v), ← map_mul, heq, map_mul] + have huv : u * v ≠ 0 := mul_ne_zero hu hv + have huv' : ((u * v : Berarducci.FiniteSupportRing (K := K)) : Nonpositive ℝ K) ≠ 0 := + fun h0 ↦ huv (Subtype.ext h0) + have huvdeg : degreeValuation K ((u * v : Berarducci.FiniteSupportRing (K := K)) : + Nonpositive ℝ K) = 0 := degreeValuation_finiteSupport_eq_zero _ huv + obtain ⟨u₁, u₂, hu₁, hu₂, huv₁₂⟩ := + isPrimal_of_mem_finiteSupportSubring (u * v).2 ⟨MvPolynomial.aeval b F, heval.symm⟩ + obtain ⟨g₁, hg₁⟩ := hu₁ + obtain ⟨h₁, hh₁⟩ := hu₂ + have hprod : MvPolynomial.aeval b F = g₁ * h₁ := by + refine mul_left_cancel₀ huv' ?_ + rw [heval, hg₁, hh₁, huv₁₂] + ring + have hu₁dvd : u₁ ∣ ((u * v : Berarducci.FiniteSupportRing (K := K)) : + Nonpositive ℝ K) := ⟨u₂, huv₁₂⟩ + have hu₂dvd : u₂ ∣ ((u * v : Berarducci.FiniteSupportRing (K := K)) : + Nonpositive ℝ K) := ⟨u₁, by rw [huv₁₂, mul_comm]⟩ + have hG0 : G ≠ 0 := fun h0 ↦ hF0 (hinj (by rw [hGH, h0, zero_mul, map_zero])) + have hH0 : H ≠ 0 := fun h0 ↦ hF0 (hinj (by rw [hGH, h0, mul_zero, map_zero])) + rcases ha.isUnit_or_isUnit hprod with h | h + · exact Or.inl (hb.isUnit_of_C_mul_eq_coordinatePolynomialMap hu hG0 huG + (seriesDegree_le_zero_of_eq_mul hg₁ huv' huvdeg hu₁dvd h)) + · exact Or.inr (hb.isUnit_of_C_mul_eq_coordinatePolynomialMap hv hH0 hvH + (seriesDegree_le_zero_of_eq_mul hh₁ huv' huvdeg hu₂dvd h)) + +/-! ### The embedding `K_fin[X_i]/(F) → L[X_i]/(F)` -/ + +/-- If `F(b)` is irreducible of positive degree and a polynomial over `K_fin` becomes a multiple +of `F` over `L`, then it is already a multiple of `F` over `K_fin`. -/ +theorem mem_span_of_coordinatePolynomialMap_mem_span + {F : MvPolynomial ι (Berarducci.FiniteSupportRing (K := K))} + (ha : Irreducible (MvPolynomial.aeval b F)) + (haDegree : 0 < degreeValuation K (MvPolynomial.aeval b F)) + {g : MvPolynomial ι (Berarducci.FiniteSupportRing (K := K))} + (hg : coordinatePolynomialMap K ι g ∈ Ideal.span {coordinatePolynomialMap K ι F}) : + g ∈ Ideal.span {F} := by + have hinj := coordinatePolynomialMap_injective K ι + rw [Ideal.mem_span_singleton] at hg ⊢ + obtain ⟨q, hq⟩ := hg + obtain ⟨u, h, hu, huh⟩ := exists_C_mul_eq_coordinatePolynomialMap q + have hmap : coordinatePolynomialMap K ι (MvPolynomial.C u * g) = + coordinatePolynomialMap K ι (F * h) := by + rw [map_mul, map_mul, coordinatePolynomialMap, MvPolynomial.map_C, ← huh, hq] + ring + have heq := hinj hmap + have heval : (u : Nonpositive ℝ K) * MvPolynomial.aeval b g = + MvPolynomial.aeval b F * MvPolynomial.aeval b h := by + rw [← aeval_C_finiteSupport b u, ← map_mul, heq, map_mul] + have hu' : (u : Nonpositive ℝ K) ≠ 0 := fun h0 ↦ hu (Subtype.ext h0) + -- primality of `u` and the unit property of finite-support divisors of `a` + obtain ⟨u₁, u₂, hu₁, hu₂, hu₁₂⟩ := + isPrimal_of_mem_finiteSupportSubring u.2 ⟨MvPolynomial.aeval b g, heval.symm⟩ + have hu₁unit : IsUnit u₁ := by + refine isUnit_of_dvd_of_seriesDegree_le_zero ha haDegree ?_ hu₁ + rw [← degreeValuation_finiteSupport_eq_zero u hu] + exact seriesDegree_le_of_dvd ⟨u₂, hu₁₂⟩ hu' + obtain ⟨t', ht'⟩ := hu₂ + -- `h(b) = u * t` with `t ∈ K_fin[b_i]`, by saturation + set t : Nonpositive ℝ K := (hu₁unit.unit⁻¹ : Units (Nonpositive ℝ K)) * t' with ht + have hht : MvPolynomial.aeval b h = (u : Nonpositive ℝ K) * t := by + have hinv : u₁ * (hu₁unit.unit⁻¹ : Units (Nonpositive ℝ K)) = 1 := + hu₁unit.mul_val_inv + rw [ht, ht', hu₁₂] + calc u₂ * t' = (u₁ * (hu₁unit.unit⁻¹ : Units (Nonpositive ℝ K))) * (u₂ * t') := by + rw [hinv, one_mul] + _ = u₁ * u₂ * ((hu₁unit.unit⁻¹ : Units (Nonpositive ℝ K)) * t') := by ring + obtain ⟨t'', ht''⟩ := (AlgHom.mem_range _).mp + (hb.mem_range_of_mul_mem_range u t hu (hht ▸ (MvPolynomial.aeval b).mem_range_self h)) + have hh' : h = MvPolynomial.C u * t'' := by + apply hb.injective + rw [map_mul, aeval_C_finiteSupport, ht'', hht] + refine ⟨t'', mul_left_cancel₀ (MvPolynomial.C_ne_zero.mpr hu) ?_⟩ + rw [heq, hh'] + ring + +/-- The ideal `(F) ⊆ K_fin[X_i]` is the contraction of the ideal `(F) ⊆ L[X_i]`. -/ +theorem span_singleton_eq_comap + {F : MvPolynomial ι (Berarducci.FiniteSupportRing (K := K))} + (ha : Irreducible (MvPolynomial.aeval b F)) + (haDegree : 0 < degreeValuation K (MvPolynomial.aeval b F)) : + Ideal.span {F} = + (Ideal.span {coordinatePolynomialMap K ι F}).comap (coordinatePolynomialMap K ι) := by + refine le_antisymm ?_ fun g hg ↦ ?_ + · rw [Ideal.span_le, Set.singleton_subset_iff, SetLike.mem_coe, Ideal.mem_comap] + exact Ideal.subset_span rfl + · exact hb.mem_span_of_coordinatePolynomialMap_mem_span ha haDegree (Ideal.mem_comap.mp hg) + +/-- `D = K_fin[X_i]/(F)` is a domain when `F(b)` is irreducible of positive degree: it embeds in +`L[X_i]/(F)`, and `L[X_i]` is a unique factorisation domain. -/ +theorem quotient_span_singleton_isDomain + {F : MvPolynomial ι (Berarducci.FiniteSupportRing (K := K))} + (ha : Irreducible (MvPolynomial.aeval b F)) + (haDegree : 0 < degreeValuation K (MvPolynomial.aeval b F)) : + IsDomain (MvPolynomial ι (Berarducci.FiniteSupportRing (K := K)) ⧸ Ideal.span {F}) := by + have hirr := hb.irreducible_coordinatePolynomialMap_of_irreducible_aeval ha haDegree + have : (Ideal.span {coordinatePolynomialMap K ι F}).IsPrime := + (Ideal.span_singleton_prime hirr.ne_zero).mpr hirr.prime + rw [hb.span_singleton_eq_comap ha haDegree] + exact Ideal.Quotient.isDomain _ + +/-- `F` is prime in `K_fin[X_i]` when `F(b)` is irreducible of positive degree. -/ +theorem prime_of_irreducible_aeval + {F : MvPolynomial ι (Berarducci.FiniteSupportRing (K := K))} + (ha : Irreducible (MvPolynomial.aeval b F)) + (haDegree : 0 < degreeValuation K (MvPolynomial.aeval b F)) : Prime F := by + have hF0 : F ≠ 0 := fun h ↦ ha.ne_zero (by rw [h, map_zero]) + have := hb.quotient_span_singleton_isDomain ha haDegree + exact (Ideal.span_singleton_prime hF0).mp + ((Ideal.Quotient.isDomain_iff_prime (Ideal.span {F})).mp inferInstance) + +end IsPolynomialPresentation + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/PolynomialAlgebra/PolynomialRing.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/PolynomialAlgebra/PolynomialRing.lean new file mode 100644 index 0000000000..2dfad1252b --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/PolynomialAlgebra/PolynomialRing.lean @@ -0,0 +1,427 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.PolynomialAlgebra.InitialForms +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.Polynomiality +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.GradedRing.Extension +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.BasisOver +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MvPolynomial.BaseChange + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Degree.Statements.DegreeValuation + +/-! +# The series ring is a polynomial ring over the series with finite support + +Let `K((ℝ^{≤0}))` be the series ring and `K(ℝ^{≤0})` its subring of series with finite support +[LM24, Not. 2.1.5], written `K_fin` below. Let `𝓑` be a minimal system of homogeneous generators +of `P̂` — in Lean the classes `x i`, of degrees `wt i` — and choose series `b_i` with +initial form `x i ⊗ 1` and `deg b_i = wt i` (`GeneratorLifts`): the lifts `b_B` of the minimal +system. +Then evaluation `K_fin[X_i] → K((ℝ^{≤0}))`, `X_i ↦ b_i`, is an isomorphism of `K_fin`-algebras +(`polynomialRingEquiv`), and for a non-zero polynomial `F`, `deg F(b) = deg F` for the grading +`deg X_i = wt i`, with initial form the evaluation in `RV̂` of the homogeneous component of `F` of +largest degree. + +This is the theorem `S = K_fin[b_B : B ∈ 𝓑]` of `FiniteDegreePolynomialRing`, with the ring `S` +of series of finite degree replaced by the whole series ring and the finite-degree part `P̂_{<ω}` +by `P̂`: injectivity is the degree formula, which rests on the polynomiality of `P̂` +(`Berarducci.aeval_injective_of_isMinimalSystem`) through the identification +`RV̂ ≅ P̂ ⊗_K K_fin`, and surjectivity is well-founded induction on the degree, the generators +spanning `P̂` (`OrdinalGraded.IsMinimalSystem.aeval_surjective`). +-/ + +open HahnSeries HahnSeries.Nonpositive Berarducci MvPolynomial OrdinalGraded + +open scoped TensorProduct MaxAddDegree NatOrdinal + +universe v w + +public noncomputable section + +namespace Berarducci + +variable {K : Type v} [Field K] [CharZero K] +variable {ι : Type w} {wt : ι → NatOrdinal} {x : ι → PrincipalSubring K} + +/-! ### The lifts `b_i` of the minimal system -/ + +variable (wt x) in +/-- The lifts `b_i` of a family `x i ∈ P_{wt i}` of homogeneous elements of `P̂`: series `b_i` +with `deg b_i = wt i` whose initial form is `x i ⊗ 1` under `P̂ ⊗_K K_fin ≅ RV̂`, that is, +`rv(b_i) = x i`. This is `Berarducci.GeneratorLifts` for an arbitrary family of +homogeneous elements of `P̂` in place of the minimal system `𝓑` of `P̂_{<ω}`. -/ +structure GeneratorLifts where + /-- The series `b_i` lifting `x i`. -/ + lift : ι → Series K + /-- `deg b_i = wt i`. -/ + degree_lift : ∀ i, ((lift i : Series K) : K⟦ℝ⟧).degree = (wt i : WithBot NatOrdinal) + /-- `rv(b_i) = x i`: the initial form of `b_i` is `x i ⊗ 1` under `P̂ ⊗_K K_fin ≅ RV̂`. -/ + initialForm_lift : ∀ i, + principalSubringTensorEquiv K (x i ⊗ₜ[K] 1) = (degreeValuation K).initialForm (lift i) + +/-- Every non-zero homogeneous element of `P_α` is `rv(b)` for a principal series `b` of degree +`α` (Berarducci's principal representatives), so lifts exist for every family of non-zero +homogeneous elements. -/ +theorem exists_generatorLifts (hmem : ∀ i, x i ∈ Berarducci.principalGrading K (wt i)) + (hne : ∀ i, x i ≠ 0) : Nonempty (GeneratorLifts wt x) := by + have h : ∀ i, ∃ b : Series K, ((b : Series K) : K⟦ℝ⟧).degree = (wt i : WithBot NatOrdinal) ∧ + principalSubringTensorEquiv K (x i ⊗ₜ[K] 1) = (degreeValuation K).initialForm b := fun i ↦ by + obtain ⟨a, ha⟩ := (DirectSum.mem_rangeLof_iff K _ _ _).mp (hmem i) + rw [DirectSum.lof_eq_of] at ha + have ha0 : a ≠ 0 := fun h0 ↦ hne i (by rw [← ha, h0, map_zero]) + obtain ⟨b, hb, hprin, hdeg, hmk⟩ := exists_principal_representative_of_ne_zero (wt i) a ha0 + refine ⟨b, hdeg, ?_⟩ + rw [← ha, ← hmk] + exact Berarducci.principalSubringTensorEquiv_of_tmul_one_eq_initialForm b hb hprin hdeg + choose b hdeg hin using h + exact ⟨⟨b, hdeg, hin⟩⟩ + +namespace GeneratorLifts + +variable (σ : GeneratorLifts wt x) + +/-- `deg b_i = wt i`, for the degree as a `MaxAddDegree`. -/ +theorem degreeValuation_lift (i : ι) : + degreeValuation K (σ.lift i) = (wt i : WithBot NatOrdinal) := by + rw [degreeValuation_apply] + exact σ.degree_lift i + +end GeneratorLifts + +/-! ### The evaluation `K_fin[X_i] → P̂ ⊗_K K_fin ≅ RV̂` -/ + +variable (x) in +/-- The evaluation `K_fin[X_i] → P̂ ⊗_K K_fin`, `X_i ↦ x i ⊗ 1`. -/ +def coordinateTensorEval : + MvPolynomial ι (FiniteSupportRing (K := K)) →ₐ[FiniteSupportRing (K := K)] + (PrincipalSubring K ⊗[K] FiniteSupportRing (K := K)) := + aeval fun i ↦ x i ⊗ₜ[K] 1 + +omit [CharZero K] in +/-- The evaluation into `P̂ ⊗_K K_fin` on a variable: `X_i ↦ x i ⊗ 1`. -/ +theorem coordinateTensorEval_X (i : ι) : coordinateTensorEval x (X i) = x i ⊗ₜ[K] 1 := + aeval_X _ _ + +omit [CharZero K] in +/-- The evaluation into `P̂ ⊗_K K_fin` of a constant `c ∈ K_fin` is `1 ⊗ c`. -/ +theorem coordinateTensorEval_C (c : FiniteSupportRing (K := K)) : + coordinateTensorEval x (C c) = (1 : PrincipalSubring K) ⊗ₜ[K] c := by + rw [coordinateTensorEval, aeval_C, Algebra.TensorProduct.right_algebraMap_apply] + +omit [CharZero K] in +/-- The evaluation `K_fin[X_i] → P̂ ⊗_K K_fin` is, as a function, the evaluation at the `x i ⊗ 1` +of `K[X_i] → P̂` after extending scalars to `K_fin`. -/ +theorem coe_coordinateTensorEval : + ⇑(coordinateTensorEval x) = ⇑(aevalTmulOne K (FiniteSupportRing (K := K)) x) := by + funext F + induction F using MvPolynomial.induction_on with + | C c => rw [coordinateTensorEval_C, aevalTmulOne_C] + | add p q hp hq => rw [map_add, map_add, hp, hq] + | mul_X p i hp => rw [map_mul, map_mul, hp, coordinateTensorEval_X, aevalTmulOne_X] + +variable (hx : IsMinimalSystem (Berarducci.principalGrading K) wt x) +include hx + +/-- **The polynomiality of `P̂` over `K_fin`.** The evaluation `K_fin[X_i] → P̂ ⊗_K K_fin` at a +minimal system of homogeneous generators is injective: the generators `x i` remain algebraically +independent after extending scalars to `K_fin`. -/ +theorem coordinateTensorEval_injective : Function.Injective (coordinateTensorEval x) := by + rw [coe_coordinateTensorEval] + exact aevalTmulOne_injective (aeval_injective_of_isMinimalSystem hx) + +omit [CharZero K] in +/-- The evaluation `K_fin[X_i] → P̂ ⊗_K K_fin` at a minimal system of homogeneous generators is +surjective: the generators `x i` generate `P̂` over `K`. -/ +theorem coordinateTensorEval_surjective : Function.Surjective (coordinateTensorEval x) := by + rw [coe_coordinateTensorEval] + exact aevalTmulOne_surjective + (hx.aeval_surjective (Berarducci.principalGrading_gradeZeroScalars K)) + +omit hx + +variable (x) in +/-- The evaluation `K_fin[X_i] → RV̂`, `X_i ↦ rv(b_i) = x i`: the evaluation into `P̂ ⊗_K K_fin` +followed by the identification `P̂ ⊗_K K_fin ≅ RV̂`, as a ring homomorphism. -/ +def gradedCoordinateEval : + MvPolynomial ι (FiniteSupportRing (K := K)) →+* (degreeValuation K).AssociatedGraded := + (principalSubringTensorEquiv K).toRingEquiv.toRingHom.comp (coordinateTensorEval x).toRingHom + +theorem gradedCoordinateEval_apply (F : MvPolynomial ι (FiniteSupportRing (K := K))) : + gradedCoordinateEval x F = principalSubringTensorEquiv K (coordinateTensorEval x F) := + (rfl) + +/-! ### Evaluation at the lifts `b_i` and the degree formula -/ + +variable (σ : GeneratorLifts wt x) + +/-- Evaluation `K_fin[X_i] → K((ℝ^{≤0}))`, `F ↦ F(b)`, at the lifts `b_i`. -/ +def evalAtLifts : + MvPolynomial ι (FiniteSupportRing (K := K)) →ₐ[FiniteSupportRing (K := K)] Series K := + aeval σ.lift + +/-- The evaluation `F ↦ F(b)` unfolded. -/ +theorem evalAtLifts_eq : evalAtLifts σ = aeval σ.lift := (rfl) + +/-- `X_i(b) = b_i`. -/ +theorem evalAtLifts_X (i : ι) : evalAtLifts σ (X i) = σ.lift i := + aeval_X _ _ + +/-- A constant `c ∈ K_fin` evaluates to itself: `c(b) = c`. -/ +theorem evalAtLifts_C (c : FiniteSupportRing (K := K)) : evalAtLifts σ (C c) = (c : Series K) := + aeval_C _ _ + +include hx + +/-- The lifts `b_i` are initial-form coordinates of `K((ℝ^{≤0}))` over `K_fin`: `deg b_i = wt i`, +the non-zero scalars of `K_fin` have degree zero, and the evaluation into `RV̂` is an injective ring +homomorphism sending a constant `c` to `in(c)` and `X_i` to `in(b_i) = rv(b_i)`. -/ +theorem isInitialFormCoordinates : + MaxAddDegree.IsInitialFormCoordinates (degreeValuation K) wt σ.lift + (gradedCoordinateEval x) where + degree_algebraMap := Berarducci.degreeValuation_algebraMap_eq_zero + degree_x := σ.degreeValuation_lift + injective := (principalSubringTensorEquiv K).injective.comp (coordinateTensorEval_injective hx) + map_C c := by + rw [gradedCoordinateEval_apply, coordinateTensorEval_C, + Berarducci.principalSubringTensorEquiv_one_tmul_eq_initialForm] + map_X i := by + rw [gradedCoordinateEval_apply, coordinateTensorEval_X] + exact σ.initialForm_lift i + +/-- `deg F(b) ≤ deg F`, the degree of `F` taken for the grading `deg X_i = wt i` (Mathlib's +`weightedTotalDegree`). -/ +theorem degree_evalAtLifts_le (F : MvPolynomial ι (FiniteSupportRing (K := K))) : + degreeValuation K (evalAtLifts σ F) ≤ + ((weightedTotalDegree wt F : NatOrdinal) : WithBot NatOrdinal) := + (isInitialFormCoordinates hx σ).degree_aeval_le F + +/-- For non-zero `F`, `deg F(b) = deg F` for the grading `deg X_i = wt i`, and the initial form +of `F(b)` is the evaluation in `RV̂` of the homogeneous component of `F` of largest degree. -/ +theorem degree_evalAtLifts_eq_and_initialForm {F : MvPolynomial ι (FiniteSupportRing (K := K))} + (hF : F ≠ 0) : + degreeValuation K (evalAtLifts σ F) = + ((weightedTotalDegree wt F : NatOrdinal) : WithBot NatOrdinal) ∧ + (degreeValuation K).initialForm (evalAtLifts σ F) = + principalSubringTensorEquiv K + (coordinateTensorEval x (weightedHomogeneousComponent wt (weightedTotalDegree wt F) F)) := + (isInitialFormCoordinates hx σ).degree_aeval_eq_and_initialForm hF + +/-- For `G` homogeneous for the grading `deg X_i = wt i`, the initial form of `G(b)` is the +evaluation of `G` in `RV̂`; both sides vanish for `G = 0`. -/ +theorem initialForm_evalAtLifts_of_isWeightedHomogeneous + {G : MvPolynomial ι (FiniteSupportRing (K := K))} {d : NatOrdinal} + (hG : G.IsWeightedHomogeneous wt d) : + (degreeValuation K).initialForm (evalAtLifts σ G) = + principalSubringTensorEquiv K (coordinateTensorEval x G) := + (isInitialFormCoordinates hx σ).initialForm_aeval_of_isWeightedHomogeneous hG + +/-- For non-zero `F`, `deg F(b) = deg F` for the grading `deg X_i = wt i`. -/ +@[blueprint "thm:series-polynomial-degree" + (phase := "Polynomial presentations") + (title := "Weighted degree under evaluation at series lifts") + (statement := /-- + Let $K$ be a field of characteristic zero, and let $(x_i)_{i\in I}$ be a + minimal homogeneous generating system of $\widehat{\mathrm P}$, with + $x_i\in\mathrm P_{w_i}$. For each $i$, choose a series + $b_i\in K((\mathbb R^{\le0}))$ of degree $w_i$ whose initial form is the + image of $x_i\otimes1$ under + $\widehat{\mathrm P}\otimes_KK(\mathbb R^{\le0}) + \simeq\widehat{\mathrm{RV}}$. + + If $0\ne F\in K(\mathbb R^{\le0})[X_i:i\in I]$, then the degree of + $F(b_i)$ equals the weighted total degree of $F$ for + $\deg(X_i)=w_i$. + -/) + (proof := /-- + By \ref{fact:principal-subring-tensor-decomposition}, the associated graded + ring is + $\widehat{\mathrm P}\otimes_KK(\mathbb R^{\le0})$. + \ref{thm:polynomial} makes evaluation at + $(x_i\otimes1)$ injective after scalar extension. The hypotheses on $b_i$ + therefore make their initial forms an initial-form coordinate system. The + top weighted homogeneous component of a non-zero $F$ has non-zero initial + form after evaluation, so the degree of $F(b_i)$ is its weighted degree. + -/)] +theorem degree_evalAtLifts_eq {F : MvPolynomial ι (FiniteSupportRing (K := K))} (hF : F ≠ 0) : + degreeValuation K (evalAtLifts σ F) = + ((weightedTotalDegree wt F : NatOrdinal) : WithBot NatOrdinal) := + (degree_evalAtLifts_eq_and_initialForm hx σ hF).1 + +/-- Evaluation `F ↦ F(b)` is injective: the lifts `b_i` are algebraically independent over +`K_fin`. -/ +@[blueprint "thm:series-lifts-algebraically-independent" + (phase := "Polynomial presentations") + (title := "Algebraic independence of series lifts") + (statement := /-- + Let $K$ be a field of characteristic zero, and let $(x_i)_{i\in I}$ be a + minimal homogeneous generating system of $\widehat{\mathrm P}$, with + $x_i\in\mathrm P_{w_i}$. For each $i$, choose a series + $b_i\in K((\mathbb R^{\le0}))$ of degree $w_i$ whose initial form is the + image of $x_i\otimes1$ under + $\widehat{\mathrm P}\otimes_KK(\mathbb R^{\le0}) + \simeq\widehat{\mathrm{RV}}$. Then evaluation + \[ + K(\mathbb R^{\le0})[X_i:i\in I]\longrightarrow + K((\mathbb R^{\le0})),\qquad X_i\longmapsto b_i, + \] + is injective. + -/) + (proof := /-- + \ref{fact:principal-subring-tensor-decomposition} identifies the associated + graded ring with + $\widehat{\mathrm P}\otimes_KK(\mathbb R^{\le0})$. + By \ref{thm:polynomial}, evaluation at the minimal homogeneous generating + system is injective, and it remains injective after scalar extension. Hence + a non-zero polynomial in the $b_i$ has a non-zero initial form and cannot + evaluate to zero. + -/)] +theorem evalAtLifts_injective : Function.Injective (evalAtLifts σ) := + (isInitialFormCoordinates hx σ).aeval_injective + +/-- A polynomial `G` whose value `G(b)` has degree at most zero is constant: its weighted total +degree is zero, and every generator has positive degree. -/ +theorem eq_C_of_degree_evalAtLifts_le_zero {G : MvPolynomial ι (FiniteSupportRing (K := K))} + (hG : degreeValuation K (evalAtLifts σ G) ≤ 0) : G = C (G.coeff 0) := by + classical + by_cases hzero : G = 0 + · rw [hzero, AddMonoidAlgebra.coeff_zero, Finsupp.zero_apply, C_0] + rw [degree_evalAtLifts_eq hx σ hzero, ← WithBot.coe_zero, WithBot.coe_le_coe] at hG + refine MvPolynomial.ext _ _ fun d ↦ ?_ + rw [coeff_C] + split_ifs with hd + · rw [hd] + · by_contra h + have hw : Finsupp.weight wt d = 0 := + le_antisymm ((le_weightedTotalDegree wt (mem_support_iff.mpr h)).trans hG) bot_le + exact hd (eq_zero_of_weight_eq_zero hx.ne_zero hw).symm + +/-! ### Surjectivity: `K((ℝ^{≤0})) = K_fin[b_i]` -/ + +/-- Every element of `RV̂` is a finite sum of initial forms of values `F(b)`: it is the image of a +polynomial under `K_fin[X_i] → P̂ ⊗_K K_fin ≅ RV̂`, and the homogeneous components of that +polynomial evaluate to series whose initial forms are their images. -/ +theorem exists_eq_sum_initialForm_evalAtLifts (g : (degreeValuation K).AssociatedGraded) : + ∃ (κ : Type 1) (_ : Fintype κ) (p : κ → (evalAtLifts σ).range), + g = ∑ k, (degreeValuation K).initialForm (p k : Series K) := by + classical + obtain ⟨F, hF⟩ := coordinateTensorEval_surjective hx ((principalSubringTensorEquiv K).symm g) + set W : Finset NatOrdinal := F.support.image fun s ↦ Finsupp.weight wt s with hW + refine ⟨{m // m ∈ W}, inferInstance, + fun k ↦ ⟨evalAtLifts σ (weightedHomogeneousComponent wt k.1 F), + (evalAtLifts σ).mem_range_self _⟩, ?_⟩ + have hg : g = principalSubringTensorEquiv K (coordinateTensorEval x F) := by + rw [hF, AlgEquiv.apply_symm_apply] + rw [hg] + conv_lhs => rw [eq_sum_weightedHomogeneousComponent wt F] + rw [map_sum, map_sum, ← Finset.sum_coe_sort W] + exact Finset.sum_congr rfl fun (k : {m // m ∈ W}) _ ↦ + (initialForm_evalAtLifts_of_isWeightedHomogeneous hx σ + (weightedHomogeneousComponent_isWeightedHomogeneous k.1 F)).symm + +/-- Evaluation `F ↦ F(b)` is surjective: every series is a polynomial in the lifts `b_i` with +coefficients in `K_fin`, by well-founded induction on the degree. -/ +@[blueprint "thm:series-lifts-generate-series-ring" + (phase := "Polynomial presentations") + (title := "Generation of the series ring by series lifts") + (statement := /-- + Let $K$ be a field of characteristic zero, and let $(x_i)_{i\in I}$ be a + minimal homogeneous generating system of $\widehat{\mathrm P}$, with + $x_i\in\mathrm P_{w_i}$. For each $i$, choose a series + $b_i\in K((\mathbb R^{\le0}))$ of degree $w_i$ whose initial form is the + image of $x_i\otimes1$ under + $\widehat{\mathrm P}\otimes_KK(\mathbb R^{\le0}) + \simeq\widehat{\mathrm{RV}}$. Then every element of + $K((\mathbb R^{\le0}))$ is the value at $(b_i)$ of a polynomial in + $K(\mathbb R^{\le0})[X_i:i\in I]$. + -/) + (proof := /-- + By \ref{fact:principal-subring-tensor-decomposition}, every element of the + associated graded ring comes from a polynomial over + $K(\mathbb R^{\le0})$ in the $x_i\otimes1$. By \ref{thm:polynomial}, its + weighted homogeneous components are the initial forms of the corresponding + values at the $b_i$. Thus every + associated-graded element is a finite sum of initial forms of elements in + the range of evaluation. Apply + \ref{lem:initial-forms-generate-subalgebra} to that range and the separated + degree to conclude that evaluation is surjective. + -/)] +theorem evalAtLifts_surjective : Function.Surjective (evalAtLifts σ) := fun t ↦ + (AlgHom.mem_range _).mp + (MaxAddDegree.mem_of_forall_exists_sum_initialForm (degreeValuation_isSeparated K) + (exists_eq_sum_initialForm_evalAtLifts hx σ) t) + +/-- The polynomial presentation of the series ring: evaluation `X_i ↦ b_i` on `K_fin[X_i]` has +image the whole ring, `K((ℝ^{≤0})) = K_fin[b_i]`. -/ +theorem range_evalAtLifts_eq_top : (evalAtLifts σ).range = ⊤ := + eq_top_iff.mpr fun t _ ↦ (AlgHom.mem_range _).mpr (evalAtLifts_surjective hx σ t) + +/-- **The series ring is a polynomial ring over the series with finite support.** +`K_fin[X_i] ≅ K((ℝ^{≤0}))`, `X_i ↦ b_i`, for the lifts `b_i` of a minimal system of homogeneous +generators of `P̂`. -/ +@[blueprint "thm:hahn-series-polynomial-algebra" + (phase := "Polynomial presentations") + (title := "Polynomial presentation of the series ring") + (statement := /-- + Let $K$ be a field of characteristic zero, and let $(x_i)_{i\in I}$ be a + minimal homogeneous generating system of $\widehat{\mathrm P}$, with + $x_i\in\mathrm P_{w_i}$. For each $i$, choose a series + $b_i\in K((\mathbb R^{\le0}))$ of degree $w_i$ whose initial form is the + image of $x_i\otimes1$ under + $\widehat{\mathrm P}\otimes_KK(\mathbb R^{\le0}) + \simeq\widehat{\mathrm{RV}}$. Evaluation at the $b_i$ is an isomorphism + of $K(\mathbb R^{\le0})$-algebras + \[ + K(\mathbb R^{\le0})[X_i:i\in I]\simeq K((\mathbb R^{\le0})), + \] + sending $X_i$ to $b_i$. + -/) + (proof := /-- + Evaluation is injective by + \ref{thm:series-lifts-algebraically-independent} and surjective by + \ref{thm:series-lifts-generate-series-ring}; hence it defines the stated + algebra isomorphism. + -/) + (highlight)] +def polynomialRingEquiv : + MvPolynomial ι (FiniteSupportRing (K := K)) ≃ₐ[FiniteSupportRing (K := K)] Series K := + AlgEquiv.ofBijective (evalAtLifts σ) ⟨evalAtLifts_injective hx σ, evalAtLifts_surjective hx σ⟩ + +/-- The isomorphism `K_fin[X_i] ≅ K((ℝ^{≤0}))` is `F ↦ F(b)`. -/ +theorem polynomialRingEquiv_apply (F : MvPolynomial ι (FiniteSupportRing (K := K))) : + polynomialRingEquiv hx σ F = evalAtLifts σ F := + (rfl) + +/-- `K((ℝ^{≤0})) ≅ K_fin[X_i]`: the series ring is a polynomial ring over `K_fin` on variables +indexed by a minimal system of homogeneous generators of `P̂`, the inverse of +`polynomialRingEquiv`. -/ +def seriesPolynomialRingEquiv : + Series K ≃ₐ[FiniteSupportRing (K := K)] MvPolynomial ι (FiniteSupportRing (K := K)) := + (polynomialRingEquiv hx σ).symm + +/-- The inverse isomorphism sends `F(b)` back to `F`. -/ +theorem seriesPolynomialRingEquiv_evalAtLifts (F : MvPolynomial ι (FiniteSupportRing (K := K))) : + seriesPolynomialRingEquiv hx σ (evalAtLifts σ F) = F := + (polynomialRingEquiv hx σ).symm_apply_apply F + +omit hx + +/-! ### Existence of a minimal system and of its lifts -/ + +variable (K) in +/-- `P̂` has a minimal system of homogeneous generators, and any such system has lifts: there are +series `b_i` of degrees `wt i` forming a polynomial presentation `K((ℝ^{≤0})) = K_fin[b_i]`. -/ +theorem exists_isMinimalSystem_and_generatorLifts : + ∃ (ι' : Type (max v 1)) (wt' : ι' → NatOrdinal) (x' : ι' → PrincipalSubring K), + IsMinimalSystem (Berarducci.principalGrading K) wt' x' ∧ + Nonempty (GeneratorLifts wt' x') := by + obtain ⟨ι', wt', x', hx⟩ := + exists_isMinimalSystem (Berarducci.principalGrading K) + exact ⟨ι', wt', x', hx, exists_generatorLifts hx.mem hx.apply_ne_zero⟩ + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/PolynomialAlgebra/Tests.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/PolynomialAlgebra/Tests.lean new file mode 100644 index 0000000000..f0846e981a --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/PolynomialAlgebra/Tests.lean @@ -0,0 +1,12 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.PolynomialAlgebra.Tests.GCDMonoid +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.PolynomialAlgebra.Tests.PolynomialRing + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/PolynomialAlgebra/Tests/GCDMonoid.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/PolynomialAlgebra/Tests/GCDMonoid.lean new file mode 100644 index 0000000000..58f866fde6 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/PolynomialAlgebra/Tests/GCDMonoid.lean @@ -0,0 +1,44 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Primality.GCDMonoid + +/-! +# API checks for greatest common divisors in the series ring + +Pre-Schreier refinement alone does not provide a greatest common divisor for each pair. The first +check extracts exactly that stronger conclusion from the public GCD-domain theorem. The second +specializes it to `(0, a)` and checks both the zero boundary and the orientation of the universal +property: the chosen gcd is associated to `a`. +-/ + +public noncomputable section + +namespace Tests + +open Berarducci + +universe v + +variable {K : Type v} [Field K] [CharZero K] + +/-- Every pair of series has a greatest common divisor. -/ +theorem series_pairwise_gcd_exists (a b : Series K) : + ∃ d : Series K, ∀ e : Series K, e ∣ a ∧ e ∣ b ↔ e ∣ d := by + obtain ⟨inst⟩ := Berarducci.nonemptyGCDMonoid (K := K) + let : GCDMonoid (Series K) := inst + exact ⟨gcd a b, fun e ↦ (dvd_gcd_iff e a b).symm⟩ + +/-- A gcd of `(0, a)` is associated to `a` and has the expected universal property. -/ +theorem series_gcd_zero_left (a : Series K) : + ∃ d : Series K, (d ∣ a ∧ a ∣ d) ∧ ∀ e : Series K, e ∣ 0 ∧ e ∣ a ↔ e ∣ d := by + obtain ⟨d, hd⟩ := series_pairwise_gcd_exists (0 : Series K) a + refine ⟨d, ⟨?_, ?_⟩, hd⟩ + · exact ((hd d).mpr dvd_rfl).2 + · exact (hd a).mp ⟨dvd_zero _, dvd_rfl⟩ + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/PolynomialAlgebra/Tests/PolynomialRing.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/PolynomialAlgebra/Tests/PolynomialRing.lean new file mode 100644 index 0000000000..bcfd91a809 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/PolynomialAlgebra/Tests/PolynomialRing.lean @@ -0,0 +1,85 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Primality.Primality + +/-! +# API checks for the polynomial presentation of the series ring + +The polynomial presentation `K((ℝ^{≤0})) = K_fin[b_i]` of the whole series ring over its subring +`K_fin = K(ℝ^{≤0})` of series with finite support [LM24, Not. 2.1.5], on the lifts `b_i` of a +minimal system of homogeneous generators of `P̂`, differs from the presentation +`S = K_fin[b_B : B ∈ 𝓑]` of the ring of series of finite degree in its scope: there every value +`F(b_𝓑)` has degree below `ω`, here every series, of whatever degree, is a value `F(b)`. The +checks record this separation, the two directions of the isomorphism on the variables, and that +the lifts are not scalars: `b_i` has the positive degree `wt i`, hence infinite support. The +factorisation consequences are recorded on an arbitrary series: every series is primal, and an +irreducible series is prime with no hypothesis on its degree or support. +-/ + +public noncomputable section + +namespace Tests + +open HahnSeries HahnSeries.Nonpositive Berarducci OrdinalGraded + +open scoped MaxAddDegree + +universe v w + +variable {K : Type v} [Field K] [CharZero K] +variable {ι : Type w} {wt : ι → NatOrdinal} {x : ι → PrincipalSubring K} +variable (hx : IsMinimalSystem (Berarducci.principalGrading K) wt x) + (σ : GeneratorLifts wt x) +include hx + +/-- Every series of degree at least `ω` is a value `F(b)`: the presentation covers what the +presentation of `S` leaves out. -/ +theorem exists_evalAtLifts_eq_of_omega_le_degree {t : Series K} + (_ : (NatOrdinal.of Ordinal.omega0 : WithBot NatOrdinal) ≤ (t : K⟦ℝ⟧).degree) : + ∃ F : MvPolynomial ι (FiniteSupportRing (K := K)), evalAtLifts σ F = t := + evalAtLifts_surjective hx σ t + +/-- The isomorphism `K_fin[X_i] ≅ K((ℝ^{≤0}))` sends `X_i` to `b_i`. -/ +theorem polynomialRingEquiv_X (i : ι) : polynomialRingEquiv hx σ (MvPolynomial.X i) = σ.lift i := by + rw [polynomialRingEquiv_apply, evalAtLifts_X] + +/-- The inverse isomorphism `K((ℝ^{≤0})) ≅ K_fin[X_i]` sends `b_i` to `X_i`. -/ +theorem seriesPolynomialRingEquiv_lift (i : ι) : + seriesPolynomialRingEquiv hx σ (σ.lift i) = MvPolynomial.X i := by + rw [← evalAtLifts_X σ i, seriesPolynomialRingEquiv_evalAtLifts] + +omit hx in +/-- `deg b_i = wt i`, and `wt i` is positive. -/ +theorem degree_lift_pos (hwt : ∀ i, wt i ≠ 0) (i : ι) : + degreeValuation K (σ.lift i) = (wt i : WithBot NatOrdinal) ∧ + 0 < degreeValuation K (σ.lift i) := by + refine ⟨σ.degreeValuation_lift i, ?_⟩ + rw [σ.degreeValuation_lift i, ← WithBot.coe_zero, WithBot.coe_lt_coe] + exact pos_iff_ne_zero.mpr (hwt i) + +/-- A lift `b_i` has infinite support: the presentation is not the scalar ring `K_fin`. -/ +theorem lift_support_infinite (i : ι) : ¬ ((σ.lift i : Series K) : K⟦ℝ⟧).support.Finite := by + intro hfin + have hle : degreeValuation K (σ.lift i) ≤ 0 := by + rw [degreeValuation_apply] + exact HahnSeries.degree_le_zero_iff.mpr hfin + exact absurd (lt_of_lt_of_le (degree_lift_pos σ hx.ne_zero i).2 hle) (lt_irrefl _) + +omit hx + +/-- Every series is primal, with no hypothesis on its degree or support. -/ +theorem isPrimal' (a : Series K) : IsPrimal a := + Berarducci.isPrimal a + +/-- An irreducible series of degree at least `ω` is prime: the hypothesis `deg a < ω` of the +finite-degree theorem is gone. -/ +theorem prime_of_irreducible_of_omega_le_degree {a : Series K} (ha : Irreducible a) + (_ : (NatOrdinal.of Ordinal.omega0 : WithBot NatOrdinal) ≤ (a : K⟦ℝ⟧).degree) : Prime a := + prime_of_irreducible ha + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Primality.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Primality.lean new file mode 100644 index 0000000000..47de785620 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Primality.lean @@ -0,0 +1,17 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Primality.Consequences +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Primality.DegreeOne +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Primality.GCDMonoid +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Primality.OrdinalValueQuotient +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Primality.Primality +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Primality.Random +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Primality.SupportOrderTypeFactorization + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Primality/Consequences.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Primality/Consequences.lean new file mode 100644 index 0000000000..58e7cd8e32 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Primality/Consequences.lean @@ -0,0 +1,227 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.Polynomiality +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.GradedRing.Extension +public import Mathlib.RingTheory.Polynomial.UniqueFactorization + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.PrincipalGraded +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalSubringFraction + +/-! +# Consequences of the polynomiality of `P̂` + +By the polynomiality of `P̂`, evaluation `K[X_B : B ∈ 𝓑] → P̂` at a minimal system `𝓑` of +homogeneous generators is injective (`Berarducci.aeval_injective_of_isMinimalSystem`), and it +is surjective since the generators span. Hence: + +* `P̂` is a polynomial algebra over `K` on any minimal system of homogeneous generators + (`algEquivOfIsMinimalSystem`), so `P̂` is a unique factorisation domain; +* every family of homogeneous elements of positive degrees whose members of each degree `β` are + linearly independent modulo `(P̂_+)² ∩ P_β` (the decomposable elements, `decomposableAt`) is + algebraically independent: it extends to a minimal system of homogeneous generators + (`OrdinalGraded.exists_isMinimalSystem_extension`); +* at an additively principal degree `ω^γ` the space `(P̂_+)² ∩ P_{ω^γ}` is zero — no two nonzero + degrees have natural sum `ω^γ` — so every `K`-linearly independent family in `P_{ω^γ}`, in + particular every `K`-basis of `P_ω`, is algebraically independent in `P̂`; +* every nonzero element of `P_{ω^γ}` is prime in `P̂`, being a variable of a polynomial + presentation: the analogue at every additively principal degree of [LM24, Cor. 7.2.8], principal + elements of degree one are prime. +-/ + +universe u v w o + +open scoped NatOrdinal +open MvPolynomial OrdinalGraded Berarducci + +public noncomputable section + +namespace OrdinalGraded + +variable {E : Type u} {R : Type v} [Field E] [CommRing R] [Algebra E R] +variable (𝒜 : NatOrdinal.{o} → Submodule E R) + +/-- At an additively principal degree `ω^γ` the square of the ideal of positive degree has zero +component, `(A_+)² ∩ A_{ω^γ} = 0`: two nonzero degrees have natural sum below `ω^γ` or above it. -/ +theorem decomposableAt_wpow_eq_bot (γ : NatOrdinal.{o}) : decomposableAt 𝒜 (ω^ γ) = ⊥ := by + refine le_bot_iff.mp (decomposableAt_le 𝒜 fun i j hi hj hij ↦ ?_) + exfalso + have hi' : i < ω^ γ := by + rw [← hij]; exact lt_add_of_pos_right i (pos_iff_ne_zero.mpr hj) + have hj' : j < ω^ γ := by + rw [← hij]; exact lt_add_of_pos_left j (pos_iff_ne_zero.mpr hi) + exact (NatOrdinal.add_lt_wpow hi' hj').ne hij + +end OrdinalGraded + +namespace MvPolynomial + +variable {σ : Type*} {R : Type*} [CommRing R] [IsDomain R] + +/-- A variable is prime in a polynomial ring over a domain: separating it, the ring is +`R[X_j : j ≠ i][X_i]`, where `X_i` is prime. -/ +theorem prime_X (i : σ) : Prime (X i : MvPolynomial σ R) := by + classical + let e : MvPolynomial σ R ≃ₐ[R] Polynomial (MvPolynomial {j // j ≠ i} R) := + (renameEquiv R (Equiv.optionSubtypeNe i).symm).trans (optionEquivLeft R {j // j ≠ i}) + have he : e (X i) = Polynomial.X := by + simp only [e, AlgEquiv.trans_apply, renameEquiv_apply, rename_X, + Equiv.optionSubtypeNe_symm_self, optionEquivLeft_X_none] + rw [← MulEquiv.prime_iff e, he] + exact Polynomial.prime_X + +end MvPolynomial + +namespace Berarducci + +variable {K : Type v} [Field K] [CharZero K] {ι : Type w} {wt : ι → NatOrdinal} + {x : ι → PrincipalSubring K} + +/-! ### `P̂` is a polynomial algebra -/ + +/-- Evaluation at any minimal homogeneous generating system gives a polynomial presentation of +`P̂` over `K`. -/ +@[expose, blueprint "cor:principal-subring-polynomial-algebra" + (phase := "Polynomial presentations") + (title := "Polynomial presentation of $\\Ph$") + (statement := /-- + Let $K$ be a field of characteristic $0$, and let + $\calB=(B_i)_{i\in I}$ be a minimal homogeneous generating system of + $\Ph$. Evaluation $X_i\mapsto B_i$ is a $K$-algebra isomorphism + $K[X_i:i\in I]\simeq\Ph$. + -/) + (proof := /-- + Principal representatives identify $\Prin_0$ with $K$. The homogeneous + generation theorem then makes evaluation at $\calB$ surjective, while + \ref{thm:polynomial} makes it injective. Hence + evaluation is a $K$-algebra isomorphism. + -/)] +def algEquivOfIsMinimalSystem (hx : IsMinimalSystem (principalGrading K) wt x) : + MvPolynomial ι K ≃ₐ[K] PrincipalSubring K := + AlgEquiv.ofBijective (aeval x) + ⟨aeval_injective_of_isMinimalSystem hx, + hx.aeval_surjective (principalGrading_gradeZeroScalars K)⟩ + +theorem algEquivOfIsMinimalSystem_apply (hx : IsMinimalSystem (principalGrading K) wt x) + (F : MvPolynomial ι K) : algEquivOfIsMinimalSystem hx F = aeval x F := + rfl + +/-- `P̂` is a unique factorisation domain: it is a polynomial algebra over the field `K`. -/ +instance : UniqueFactorizationMonoid (PrincipalSubring K) := by + obtain ⟨ι', wt', x', hx⟩ := exists_isMinimalSystem (principalGrading K) + exact (algEquivOfIsMinimalSystem hx).toMulEquiv.uniqueFactorizationMonoid inferInstance + +/-! ### Algebraic independence of independent homogeneous families -/ + +/-- An indexed homogeneous family of positive degrees that is linearly independent degree by +degree modulo `(P̂_+)²` is algebraically independent. -/ +@[blueprint "cor:independent-homogeneous-family" + (phase := "Polynomial presentations") + (title := "Algebraic independence of homogeneous families in $\\Ph$") + (statement := /-- + Let $K$ be a field of characteristic $0$, and let $(x_i)_{i\in I}$ be a + family in $\Ph$ with positive weights $w_i$ and + $x_i\in\Prin_{w_i}$. Suppose that for every $\beta$, the images of the + indexed subfamily $(x_i)_{w_i=\beta}$ in + $\Prin_\beta/((\Ph_+)^2\cap\Prin_\beta)$ are $K$-linearly independent. + Then evaluation $X_i\mapsto x_i$ is injective; equivalently, $(x_i)$ is + algebraically independent over $K$. + -/) + (proof := /-- + \ref{lem:extend-to-minimal-system} enlarges the given + indexed family, degree by degree, to a minimal homogeneous generating system. + \ref{thm:polynomial} makes this extended system + algebraically independent. Algebraic independence passes to the original + indexed subfamily. + -/)] +theorem aeval_injective_of_independent_mod_decomposableAt (hwt : ∀ i, wt i ≠ 0) + (hmem : ∀ i, x i ∈ principalGrading K (wt i)) + (hind : ∀ (β : NatOrdinal) (c : ι →₀ K), (∀ i ∈ c.support, wt i = β) → + Finsupp.linearCombination K x c ∈ decomposableAt (principalGrading K) β → c = 0) : + Function.Injective (aeval x : MvPolynomial ι K →ₐ[K] PrincipalSubring K) := by + obtain ⟨ι', wt', x', e, he, -, hx', hmin⟩ := + exists_isMinimalSystem_extension (principalGrading K) hwt hmem hind + intro F G hFG + apply rename_injective e he + apply aeval_injective_of_isMinimalSystem hmin + have hxe : x' ∘ e = x := funext hx' + rw [aeval_rename, aeval_rename, hxe] + exact hFG + +/-- Every `K`-linearly independent family in an additively principal degree `P_{ω^γ}` is +algebraically independent in `P̂`. -/ +@[blueprint "cor:principal-degree-linear-independence" + (phase := "Polynomial presentations") + (title := "Algebraic independence in additively principal degree") + (statement := /-- + Let $K$ be a field of characteristic $0$ and $\gamma<\omega_1$. Every + $K$-linearly independent family $(x_i)_{i\in I}$ in + $\Prin_{\omega^\gamma}$ is algebraically independent over $K$ in $\Ph$. + -/) + (proof := /-- + No two positive degrees have Hessenberg's natural sum $\omega^\gamma$, so the + decomposable subspace in that degree is zero. Linear independence therefore + gives independence modulo $(\Ph_+)^2$. Then + \ref{cor:independent-homogeneous-family} gives algebraic independence. + -/)] +theorem aeval_injective_of_linearIndependent_of_mem_principalGrading_wpow + (γ : NatOrdinal) + (hmem : ∀ i, x i ∈ principalGrading K (ω^ γ)) (hli : LinearIndependent K x) : + Function.Injective (aeval x : MvPolynomial ι K →ₐ[K] PrincipalSubring K) := + aeval_injective_of_independent_mod_decomposableAt + (wt := fun _ ↦ ω^ γ) (fun _ ↦ (NatOrdinal.wpow_pos γ).ne') hmem fun β c hc hdec ↦ by + rcases c.support.eq_empty_or_nonempty with h | ⟨i, hi⟩ + · exact Finsupp.support_eq_empty.mp h + · obtain rfl : β = ω^ γ := (hc i hi).symm + rw [decomposableAt_wpow_eq_bot, Submodule.mem_bot] at hdec + exact linearIndependent_iff.mp hli c hdec + +/-! ### Homogeneous elements of an additively principal degree are prime -/ + +/-- Every nonzero element of an additively principal degree `P_{ω^γ}` is prime in `P̂`. This is +the analogue at every additively principal degree of [LM24, Cor. 7.2.8], which treats degree one. -/ +@[blueprint "cor:prime-at-principal-degree" + (phase := "Polynomial presentations") + (title := "Prime elements of additively principal degree") + (statement := /-- + Let $K$ be a field of characteristic $0$ and $\gamma<\omega_1$. Every + nonzero element of $\Prin_{\omega^\gamma}$ is prime in $\Ph$. + -/) + (proof := /-- + No two positive degrees have Hessenberg's natural sum $\omega^\gamma$, so the + decomposable subspace in that degree is zero and the nonzero singleton $y$ + is independent modulo it. By \ref{lem:extend-to-minimal-system}, this + singleton extends to a minimal homogeneous generating system. By + \ref{cor:principal-subring-polynomial-algebra}, $y$ corresponds to one of the + polynomial variables, which is prime; the isomorphism therefore makes $y$ prime + in $\Ph$. + -/)] +theorem prime_of_mem_principalGrading_wpow {γ : NatOrdinal} {y : PrincipalSubring K} + (hy : y ∈ principalGrading K (ω^ γ)) (hy0 : y ≠ 0) : Prime y := by + obtain ⟨ι', wt', x', e, -, -, hx', hmin⟩ := + exists_isMinimalSystem_extension (principalGrading K) (wt := fun _ : Unit ↦ ω^ γ) + (x := fun _ ↦ y) (fun _ ↦ (NatOrdinal.wpow_pos γ).ne') (fun _ ↦ hy) fun β c hc hdec ↦ by + rcases c.support.eq_empty_or_nonempty with h | ⟨i, hi⟩ + · exact Finsupp.support_eq_empty.mp h + · obtain rfl : β = ω^ γ := (hc i hi).symm + rw [decomposableAt_wpow_eq_bot, Submodule.mem_bot, Finsupp.linearCombination_unique, + smul_eq_zero] at hdec + have h0 : c default = 0 := hdec.resolve_right hy0 + exact Finsupp.ext fun u ↦ by rw [Subsingleton.elim u default, h0, Finsupp.zero_apply] + have hX : algEquivOfIsMinimalSystem hmin (X (e ())) = y := by + rw [algEquivOfIsMinimalSystem_apply, aeval_X, hx'] + rw [← hX] + exact (MulEquiv.prime_iff (algEquivOfIsMinimalSystem hmin)).mpr (MvPolynomial.prime_X _) + +/-- Every nonzero element of `P_{ω^γ}` is irreducible in `P̂`. -/ +theorem irreducible_of_mem_principalGrading_wpow {γ : NatOrdinal} {y : PrincipalSubring K} + (hy : y ∈ principalGrading K (ω^ γ)) (hy0 : y ≠ 0) : Irreducible y := + (prime_of_mem_principalGrading_wpow hy hy0).irreducible + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Primality/DegreeOne.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Primality/DegreeOne.lean new file mode 100644 index 0000000000..6efab445ca --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Primality/DegreeOne.lean @@ -0,0 +1,116 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Germ +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrderType + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Primality.Primality +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.PolynomialAlgebra.PolynomialPresentation + +/-! +# Primes of degree one + +A series of degree one is prime exactly when it has no non-unit divisor with finite support. +Primality below degree `ω` makes such a series primal, and a factorisation into two non-units +would, by the degree formula, give one factor of degree zero, that is, of finite support; an +irreducible primal element is prime. Conversely a prime is irreducible, so in `b = p q` with `p` +of finite support one factor is a unit, and it is not `q`: that would force `deg b = deg p = 0`. +-/ + +open scoped HahnSeries NatOrdinal + +universe v + +public section + +namespace Berarducci + +open Berarducci HahnSeries HahnSeries.Nonpositive + +variable {K : Type v} [Field K] [CharZero K] + +/-- An ordinal (in `NatOrdinal`) at most `1` is `0` or `1`. -/ +private theorem natOrdinal_eq_zero_or_one_of_le_one {a : NatOrdinal} (h : a ≤ 1) : + a = 0 ∨ a = 1 := + Order.le_one_iff.mp h + +/-- A series of degree one is prime if and only if every finite-support divisor of it is a unit. -/ +@[blueprint "cor:degree-one" + (phase := "Primality and factorisation for real exponents") + (title := "Primality criterion for series of degree one") + (statement := /-- + Let $K$ be a field of characteristic $0$ and + $b\in K((\mathbb R^{\le 0}))$ a series with $\deg(b)=1$. Then $b$ is prime + in $K((\mathbb R^{\le 0}))$ if and only if every divisor of $b$ with finite + support is a unit. + -/) + (proof := /-- + Suppose first that $b$ is prime and write $b=pq$ with $p$ of finite support. + Irreducibility makes $p$ or $q$ a unit. If $q$ were a unit, multiplicativity + of the degree would give $\deg(p)=1$, contradicting the finite support of $p$; + hence $p$ is a unit. Conversely, assume that every finite-support divisor of + $b$ is a unit. In a factorisation $b=cd$ into nonzero factors, degree + multiplicativity gives $\deg(c)+\deg(d)=1$, so one factor has degree $0$ and + therefore finite support. The hypothesis makes that factor a unit, proving + that $b$ is irreducible. Every series is primal by + \ref{thm:hahn-series-primality}, so $b$ is prime. + -/)] +theorem prime_iff_of_degree_eq_one {b : Series K} + (hb : (b : K⟦ℝ⟧).degree = (1 : NatOrdinal)) : + Prime b ↔ ∀ p : Series K, p ∣ b → (p : K⟦ℝ⟧).support.Finite → IsUnit p := by + have hb0 : b ≠ 0 := fun h ↦ by + rw [h] at hb; simp at hb + have hbdeg : degreeValuation K b = (1 : NatOrdinal) := by rw [degreeValuation_apply, hb] + constructor + · -- a prime is irreducible, so in `b = p q` one factor is a unit; it is not `q`, since then + -- `deg b = deg p = 0` + intro hprime p hpb hpfin + obtain ⟨q, rfl⟩ := hpb + refine (hprime.irreducible.isUnit_or_isUnit rfl).resolve_right fun hq ↦ ?_ + have hpdeg : degreeValuation K p ≤ 0 := by + rw [degreeValuation_apply]; exact degree_le_zero_iff.mpr hpfin + have hmul := (degreeValuation K).map_mul p q + rw [hbdeg, seriesDegree_eq_zero_of_isUnit hq, add_zero] at hmul + exact absurd (hmul ▸ hpdeg) (by simp) + · intro hdiv + have hprimal : IsPrimal b := Berarducci.isPrimal b + refine Irreducible.prime_of_isPrimal ⟨fun hu ↦ ?_, fun c d hcd ↦ ?_⟩ hprimal + · have := seriesDegree_eq_zero_of_isUnit hu + rw [hbdeg] at this + exact absurd this (by simp) + · -- a factorisation `b = c d` into non-units has a factor of degree zero + by_contra hnot + push Not at hnot + have hc0 : c ≠ 0 := fun h ↦ hb0 (by rw [hcd, h, zero_mul]) + have hd0 : d ≠ 0 := fun h ↦ hb0 (by rw [hcd, h, mul_zero]) + have hsum : degreeValuation K c + degreeValuation K d = (1 : NatOrdinal) := by + rw [← (degreeValuation K).map_mul, ← hcd, hbdeg] + obtain ⟨γ, hγ⟩ := WithBot.ne_bot_iff_exists.mp + ((degreeValuation K).map_ne_bot_of_ne_zero (degreeValuation_isSeparated K) hc0) + obtain ⟨δ, hδ⟩ := WithBot.ne_bot_iff_exists.mp + ((degreeValuation K).map_ne_bot_of_ne_zero (degreeValuation_isSeparated K) hd0) + rw [← hγ, ← hδ, ← WithBot.coe_add, WithBot.coe_inj] at hsum + have hγle : γ ≤ 1 := hsum ▸ (NatOrdinal.le_add_right : γ ≤ γ + δ) + have hδle : δ ≤ 1 := hsum ▸ (NatOrdinal.le_add_left : δ ≤ γ + δ) + -- the factor of degree zero has finite support, hence is a unit by hypothesis + have hfin : ∀ {x : Series K}, degreeValuation K x = (0 : NatOrdinal) → + (x : K⟦ℝ⟧).support.Finite := fun hx ↦ by + rw [degreeValuation_apply] at hx + exact degree_le_zero_iff.mp hx.le + rcases natOrdinal_eq_zero_or_one_of_le_one hγle with hγ0 | hγ1 + · exact hnot.1 (hdiv c (Dvd.intro d hcd.symm) (hfin (by rw [← hγ, hγ0]))) + · rcases natOrdinal_eq_zero_or_one_of_le_one hδle with hδ0 | hδ1 + · exact hnot.2 (hdiv d (Dvd.intro_left c hcd.symm) (hfin (by rw [← hδ, hδ0]))) + · rw [hγ1, hδ1] at hsum + exact absurd (add_left_cancel (a := (1 : NatOrdinal)) (hsum.trans (add_zero 1).symm)) + one_ne_zero + +end Berarducci + +end diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Primality/GCDMonoid.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Primality/GCDMonoid.lean new file mode 100644 index 0000000000..2fb6f4ace8 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Primality/GCDMonoid.lean @@ -0,0 +1,74 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.PolynomialAlgebra.PolynomialRing +public import Mathlib.Algebra.GCDMonoid.Basic + +import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.MvPolynomial.GCDMonoid +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.FiniteSupportNormalizedGCD + +/-! +# Greatest common divisors in the series ring + +The polynomial presentation identifies `K((ℝ^{≤0}))` with an arbitrary-variable polynomial +ring over its finite-support subring `K_fin`. LM24, Fact 2.5.2 makes `K_fin` a GCD domain, and +the multivariate Gauss theorem in +`ConwayRefinement.Algebra.MvPolynomial.GCDMonoid` transfers greatest common divisors +to the polynomial ring. The presentation then transports them to the +series ring. +-/ + +open HahnSeries HahnSeries.Nonpositive Berarducci MvPolynomial OrdinalGraded + +universe v w + +public noncomputable section + +namespace Berarducci + +variable {K : Type v} [Field K] [CharZero K] +variable {ι : Type w} {wt : ι → NatOrdinal} {x : ι → PrincipalSubring K} + +/-- A polynomial presentation supplied by a particular minimal system and its lifts transports +greatest common divisors from the corresponding polynomial ring to the series ring. -/ +theorem GeneratorLifts.nonemptyGCDMonoid + (hx : IsMinimalSystem (principalGrading K) wt x) (σ : GeneratorLifts wt x) : + Nonempty (GCDMonoid (Series K)) := by + let : Nonempty (NormalizedGCDMonoid (FiniteSupportRing (K := K))) := + nonemptyNormalizedGCDMonoid_finiteSupport + let : Nonempty (GCDMonoid (MvPolynomial ι (FiniteSupportRing (K := K)))) := + MvPolynomial.nonemptyGCDMonoid + exact MulEquiv.nonemptyGCDMonoid (polynomialRingEquiv hx σ).symm.toMulEquiv + +/-- The nonpositive real series ring over a characteristic-zero field is a GCD domain. The result +is stated through `Nonempty` because `GCDMonoid` contains a choice of gcd operation. -/ +@[blueprint "thm:hahn-series-gcd-domain" + (phase := "Primality and factorisation for real exponents") + (title := "Greatest common divisors in $K((\\mathbb R^{\\le 0}))$") + (statement := /-- + Let $K$ be a field of characteristic $0$. The ring + $K((\mathbb R^{\le 0}))$ of generalised power series with nonpositive real + exponents is a GCD domain. + -/) + (proof := /-- + By \ref{lem:extend-to-minimal-system}, choose a minimal homogeneous generating + system of $\widehat{\mathrm P}$ together with principal-series representatives + of its generators. By \ref{thm:hahn-series-polynomial-algebra}, + $K((\mathbb R^{\le 0}))$ is a polynomial ring over the finite-support + subring $K(\mathbb R^{\le 0})$. By \ref{fact:finite-support-hahn-gcd}, + the coefficient ring is a GCD domain. Normalising each nonzero greatest + common divisor by the coefficient of $t^{\sup(p)}$ supplies the hypothesis + required by \ref{lem:multivariate-polynomial-gcd}. Transport the + resulting gcd operation across the isomorphism. + -/) + (highlight)] +theorem nonemptyGCDMonoid : Nonempty (GCDMonoid (Series K)) := by + obtain ⟨ι, wt, x, hx, ⟨σ⟩⟩ := exists_isMinimalSystem_and_generatorLifts K + exact σ.nonemptyGCDMonoid hx + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Primality/OrdinalValueQuotient.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Primality/OrdinalValueQuotient.lean new file mode 100644 index 0000000000..1b2efde687 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Primality/OrdinalValueQuotient.lean @@ -0,0 +1,253 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Primality.Consequences +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Statements.ProductValue + +/-! +# The ordinal-value quotient by `J` is a polynomial algebra + +Let `K((ℝ^{≤0}))/J` be Berarducci's quotient ring (`Berarducci.Germ`). For a minimal system of +homogeneous generators `Y` of `P̂` with lifts `b_B`, the map `K[X_B] → K((ℝ^{≤0}))/J`, +`F ↦ F(b_𝓑) + J`, is a homomorphism of `K`-algebras. It is surjective: every series `u` is +congruent modulo `J` to a value `F(b_𝓑)`, namely to that of its polynomial `pol(u)` +(`Lifts.exists_degreeLT_toGerm_aeval_eq`). It is injective: for `F ≠ 0` the ordinal value of +`F(b_𝓑)` is `ω^{deg F}`, the degree formula, which rests on Conjecture (P); so `F(b_𝓑) ∉ J`. +Hence `K((ℝ^{≤0}))/J ≃ K[X_B] ≃ P̂` (`Lifts.ordinalValueQuotientAlgEquiv`), the class of a series +`u` of ordinal value below `ω^α` going to `pol(u)`, and the quotient admits unique factorisation. +This is the conjecture of Berarducci as stated in [LM17, Conjecture 1.5]: every nonzero germ +admits a unique factorisation into irreducibles. + +The classes of the series of ordinal value below `ω^α` are the classes of the values `F(b_𝓑)` with +every monomial of `F` of degree below `α` (`Lifts.toGerm_image_ordinalValue_lt_eq`). +-/ + +universe v w + +open scoped NatOrdinal +open MvPolynomial OrdinalGraded Berarducci HahnSeries.Nonpositive + +public noncomputable section + +namespace NatOrdinal + +/-- Every ordinal lies below `ω^(α + 1)`. -/ +theorem lt_wpow_add_one_self (a : NatOrdinal) : a < ω^ (a + 1) := by + have h : a ≤ ω^ a := + NatOrdinal.of.le_iff_le.mpr (Ordinal.right_le_opow a.val Ordinal.one_lt_omega0) + exact h.trans_lt (wpow_lt_wpow.mpr (lt_add_one a)) + +end NatOrdinal + +namespace Berarducci + +variable {K : Type v} [Field K] [CharZero K] {ι : Type w} {wt : ι → NatOrdinal} + {x : ι → PrincipalSubring K} + +namespace Lifts + +variable (σ : Lifts wt x) (hx : IsMinimalSystem (principalGrading K) wt x) + +/-- Evaluation at the lifts, read in the quotient by `J`: `F ↦ F(b_𝓑) + J`. -/ +def ordinalValueQuotientAlgHom : MvPolynomial ι K →ₐ[K] Germ K := + (Ideal.Quotient.mkₐ K (negativeMonomialIdeal K)).comp (aeval σ.lift) + +omit [CharZero K] in +theorem ordinalValueQuotientAlgHom_apply (F : MvPolynomial ι K) : + σ.ordinalValueQuotientAlgHom F = toGerm (aeval σ.lift F) := by + change Ideal.Quotient.mkₐ K _ (aeval σ.lift F) = _ + rw [Ideal.Quotient.mkₐ_eq_mk, toGerm_apply] + +include hx + +omit [CharZero K] in +/-- Every class modulo `J` is represented by a value `F(b_𝓑)`. -/ +@[blueprint "lem:ordinal-value-quotient-evaluation-surjective" + (phase := "Polynomial presentations") + (title := "Surjectivity of evaluation modulo $J$") + (statement := /-- + Let $K$ be a field. Let $(x_i)$ be a minimal homogeneous generating system + of $\widehat{\mathrm P}$, with $x_i\in\mathrm P_{w_i}$, and choose + $b_i\in K((\mathbb R^{\le0}))$ representing $x_i$ in degree $w_i$. + Every class in $K((\mathbb R^{\le0}))/J$ is the class of $F(b_i)$ for some + polynomial $F\in K[X_i:i\in I]$. + -/) + (proof := /-- + For a representative $u$ of the class, choose + $\alpha>v_J(u)$. By + \ref{prop:polynomial-representative-exists}, there is a polynomial $F$ + of weighted degree below $\alpha$ such that $F(b_i)\equiv u\pmod J$. + -/)] +theorem ordinalValueQuotientAlgHom_surjective : + Function.Surjective σ.ordinalValueQuotientAlgHom := by + intro g + obtain ⟨u, rfl⟩ := Ideal.Quotient.mk_surjective g + obtain ⟨F, -, hF⟩ := σ.exists_degreeLT_toGerm_aeval_eq hx (ordinalValue u + 1) u + (NatOrdinal.lt_wpow_add_one_self _) + refine ⟨F, ?_⟩ + rw [ordinalValueQuotientAlgHom_apply, hF, toGerm_apply] + +/-- A nonzero polynomial has a value `F(b_𝓑)` outside `J`: its ordinal value is `ω^{deg F}`, the +degree formula, by Conjecture (P). -/ +@[blueprint "lem:ordinal-value-quotient-evaluation-injective" + (phase := "Polynomial presentations") + (title := "Injectivity of evaluation modulo $J$") + (statement := /-- + Let $K$ be a field of characteristic zero. Let $(x_i)$ be a minimal + homogeneous generating system of $\widehat{\mathrm P}$, with + $x_i\in\mathrm P_{w_i}$, and choose + $b_i\in K((\mathbb R^{\le0}))$ representing $x_i$ in degree $w_i$. + If the class of $F(b_i)$ is zero in $K((\mathbb R^{\le0}))/J$, then + $F=0$. + -/) + (proof := /-- + By \ref{lem:principal-representatives-cantor-bendixson}, the chosen representatives + give a minimal homogeneous generating system for the Cantor--Bendixson + associated graded ring. The two relation hypotheses of + \ref{thm:cantor-bendixson-polynomiality} are supplied by + \ref{lem:linear-occurrence} and + \ref{lem:real-translated-truncation-partials}. Thus evaluation at $(x_i)$ + is injective. If $F\ne0$, its top + homogeneous component therefore evaluates nontrivially, so the + ordinal-value calculation gives + $v_J(F(b_i))=\omega^{\deg_w(F)}\ne0$. Hence $F(b_i)\notin J$, contrary to + the vanishing of its class. + -/)] +theorem ordinalValueQuotientAlgHom_injective : Function.Injective σ.ordinalValueQuotientAlgHom := by + rw [injective_iff_map_eq_zero] + intro F hF + by_contra hF0 + have hval := σ.ordinalValue_aeval_eq_wpow_weightedTotalDegree + (injectiveAt_of_isMinimalSystem hx _) hF0 + rw [ordinalValueQuotientAlgHom_apply, toGerm_apply, Ideal.Quotient.eq_zero_iff_mem, + ← ordinalValue_eq_zero_iff, hval] at hF + exact NatOrdinal.wpow_ne_zero _ hF + +/-- **The quotient by `J` is a polynomial algebra**: `K((ℝ^{≤0}))/J ≃ K[X_B]`, with the +class of `F(b_𝓑)` mapping to `F`. -/ +@[blueprint "thm:ordinal-value-quotient" + (phase := "Polynomial presentations") + (title := "Polynomial presentation of the quotient by $J$") + (statement := /-- + Let $K$ be a field of characteristic $0$. Let $(x_i)_{i\in\iota}$ be a + minimal homogeneous generating system of $\widehat{\mathrm P}$, with + $x_i\in\mathrm P_{w_i}$, and choose + $b_i\in K((\mathbb R^{\le0}))$ representing $x_i$ in degree $w_i$. + There is a $K$-algebra isomorphism + \[ + K((\mathbb R^{\le 0}))/J \longrightarrow K[X_i:i\in\iota] + \] + whose inverse sends $F$ to the class of $F(b_i)$ modulo $J$. + -/) + (proof := /-- + Evaluation followed by passage to the quotient is surjective by + \ref{lem:ordinal-value-quotient-evaluation-surjective} and injective by + \ref{lem:ordinal-value-quotient-evaluation-injective}. Its inverse is the + stated $K$-algebra isomorphism. + -/)] +def ordinalValueQuotientAlgEquiv : Germ K ≃ₐ[K] MvPolynomial ι K := + (AlgEquiv.ofBijective σ.ordinalValueQuotientAlgHom + ⟨σ.ordinalValueQuotientAlgHom_injective hx, + σ.ordinalValueQuotientAlgHom_surjective hx⟩).symm + +theorem ordinalValueQuotientAlgEquiv_symm_apply (F : MvPolynomial ι K) : + (σ.ordinalValueQuotientAlgEquiv hx).symm F = toGerm (aeval σ.lift F) := by + have h := (AlgEquiv.ofBijective_apply σ.ordinalValueQuotientAlgHom + ⟨σ.ordinalValueQuotientAlgHom_injective hx, + σ.ordinalValueQuotientAlgHom_surjective hx⟩ F).trans + (σ.ordinalValueQuotientAlgHom_apply F) + simpa only [ordinalValueQuotientAlgEquiv, AlgEquiv.symm_symm] using h + +theorem ordinalValueQuotientAlgEquiv_toGerm_aeval (F : MvPolynomial ι K) : + σ.ordinalValueQuotientAlgEquiv hx (toGerm (aeval σ.lift F)) = F := by + rw [← σ.ordinalValueQuotientAlgEquiv_symm_apply hx F] + exact (σ.ordinalValueQuotientAlgEquiv hx).apply_symm_apply F + +/-- The class of a series `u` of ordinal value below `ω^α` goes to its polynomial `pol(u)` +modulo `J`. -/ +@[blueprint "thm:ordinal-value-quotient-polynomial-representative" + (phase := "Polynomial presentations") + (title := "Polynomial representative of a germ") + (statement := /-- + Let $K$ be a field of characteristic $0$. Let $(x_i)_{i\in\iota}$ be a + minimal homogeneous generating system of $\widehat{\mathrm P}$, with + $x_i\in\mathrm P_{w_i}$, and choose + $b_i\in K((\mathbb R^{\le0}))$ representing $x_i$ in degree $w_i$. + For every $\alpha<\omega_1$ and every $u\in K((\mathbb R^{\le 0}))$ with + $v_J(u)<\omega^\alpha$, the polynomial presentation of the quotient by $J$ + sends the class of $u$ to its polynomial representative + $\operatorname{pol}_\alpha(u)$. + -/) + (proof := /-- + By definition, $\operatorname{pol}_\alpha(u)$ has value congruent to $u$ + modulo $J$. The inverse description in + \ref{thm:ordinal-value-quotient} therefore sends this polynomial to the class + of $u$; applying the isomorphism gives the stated formula. + -/)] +theorem ordinalValueQuotientAlgEquiv_toGerm {α : NatOrdinal} {u : Series K} + (hu : ordinalValue u < ω^ α) : + σ.ordinalValueQuotientAlgEquiv hx (toGerm u) = σ.pol hx α u := by + rw [← σ.toGerm_aeval_pol hx hu] + exact σ.ordinalValueQuotientAlgEquiv_toGerm_aeval hx _ + +/-- `K((ℝ^{≤0}))/J ≃ P̂`: the composite with the polynomial presentation of `P̂`. -/ +def ordinalValueQuotientAlgEquivPrincipalSubring : Germ K ≃ₐ[K] PrincipalSubring K := + (σ.ordinalValueQuotientAlgEquiv hx).trans (algEquivOfIsMinimalSystem hx) + +omit [CharZero K] in +/-- The classes modulo `J` of series of ordinal value below `ω^α` are exactly the classes of +values `F(b_𝓑)` whose monomials all have weighted degree below `α`. -/ +@[blueprint "thm:ordinal-value-quotient-filtration" + (phase := "Polynomial presentations") + (title := "Polynomial representatives below an ordinal-value bound") + (statement := /-- + Let $K$ be a field. Let $(x_i)_{i\in\iota}$ be a minimal homogeneous + generating system of $\widehat{\mathrm P}$, with + $x_i\in\mathrm P_{w_i}$, and choose + $b_i\in K((\mathbb R^{\le0}))$ representing $x_i$ in degree $w_i$. + For every $\alpha<\omega_1$, + \[ + \{u+J:v_J(u)<\omega^\alpha\} + =\{F(b_i)+J:\text{every monomial of }F\text{ has weighted degree}<\alpha\}. + \] + -/) + (proof := /-- + The forward inclusion follows from + \ref{prop:polynomial-representative-exists}. Conversely, if every monomial + of $F$ has weighted degree below $\alpha$, then + $v_J(F(b_i))<\omega^\alpha$, so the class of $F(b_i)$ belongs to the + left-hand set. + -/)] +theorem toGerm_image_ordinalValue_lt_eq (α : NatOrdinal) : + toGerm '' {u : Series K | ordinalValue u < ω^ α} = + (fun F ↦ toGerm (aeval σ.lift F)) '' {F : MvPolynomial ι K | DegreeLT wt F α} := by + ext g + constructor + · rintro ⟨u, hu, rfl⟩ + obtain ⟨F, hF, h⟩ := σ.exists_degreeLT_toGerm_aeval_eq hx α u hu + exact ⟨F, hF, h⟩ + · rintro ⟨F, hF, rfl⟩ + exact ⟨_, σ.ordinalValue_aeval_lt_of_degreeLT hF, rfl⟩ + +end Lifts + +/-! ### Unique factorisation in the quotient by `J` -/ + +/-- The quotient by `J` is a domain: `J` is prime (Berarducci, Corollary 9.8). -/ +instance : IsDomain (Germ K) := + (Ideal.Quotient.isDomain_iff_prime _).mpr negativeMonomialIdeal_isPrime + +/-- **Berarducci's conjecture [LM17, Conjecture 1.5].** The quotient +`K((ℝ^{≤0}))/J` admits unique factorisation: it is a polynomial algebra over `K`. -/ +instance : UniqueFactorizationMonoid (Germ K) := by + obtain ⟨ι', wt', x', hx⟩ := exists_isMinimalSystem (principalGrading K) + obtain ⟨σ⟩ := exists_lifts hx.mem + exact (σ.ordinalValueQuotientAlgEquiv hx).toMulEquiv.symm.uniqueFactorizationMonoid inferInstance + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Primality/Primality.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Primality/Primality.lean new file mode 100644 index 0000000000..e34f9dd35c --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Primality/Primality.lean @@ -0,0 +1,84 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Primality.GCDMonoid +public import Mathlib.Algebra.Prime.Defs + +import Mathlib.RingTheory.UniqueFactorizationDomain.Basic + +/-! +# Factorisation in the series ring + +Let `K((ℝ^{≤0}))` be the series ring over a field `K` of characteristic zero and `K(ℝ^{≤0})` its +subring of series with finite support [LM24, Not. 2.1.5], written `K_fin` below. The polynomial +presentation identifies `K((ℝ^{≤0}))` with an arbitrary-variable polynomial ring over `K_fin`. +The GCD-domain structure established in `ConwayRefinement.HahnSeries.Primality.GCDMonoid` therefore +gives Mathlib's `DecompositionMonoid` structure on the series ring. Thus every series is primal, +every +irreducible series is prime, and factorisations into irreducibles are unique up to order and +units. +-/ + +open Berarducci + +universe v + +public noncomputable section + +namespace Berarducci + +variable {K : Type v} [Field K] [CharZero K] + +/-! ### Pre-Schreier consequences of greatest common divisors -/ + +/-- `K((ℝ^{≤0}))` is pre-Schreier (Mathlib's `DecompositionMonoid`) because it is a GCD +domain. -/ +instance decompositionMonoid : DecompositionMonoid (Series K) := by + let : GCDMonoid (Series K) := Classical.choice nonemptyGCDMonoid + infer_instance + +/-- Every series is primal in `K((ℝ^{≤0}))`. -/ +@[blueprint "thm:hahn-series-primality" + (phase := "Primality and factorisation for real exponents") + (title := "Primality of generalised power series") + (statement := /-- + Let $K$ be a field of characteristic $0$. Every element of + $K((\mathbb R^{\le 0}))$ is primal in $K((\mathbb R^{\le 0}))$. + -/) + (proof := /-- + By \ref{thm:hahn-series-gcd-domain}, the series ring is a GCD domain. Every + GCD domain is pre-Schreier [LM24, Fact 2.5.1], and every element of a + pre-Schreier domain is primal [LM24, §2.5]. + -/)] +theorem isPrimal (a : Series K) : IsPrimal a := + DecompositionMonoid.primal a + +/-- Every irreducible series is prime in `K((ℝ^{≤0}))`. -/ +@[blueprint "cor:hahn-series-irreducible-is-prime" + (phase := "Primality and factorisation for real exponents") + (title := "Irreducible series are prime") + (statement := /-- + Let $K$ be a field of characteristic $0$. Every irreducible element of + $K((\mathbb R^{\le 0}))$ is prime in $K((\mathbb R^{\le 0}))$. + -/) + (proof := /-- + Every series is primal by \ref{thm:hahn-series-primality}, and an irreducible + primal element is prime. + -/)] +theorem prime_of_irreducible {a : Series K} (ha : Irreducible a) : Prime a := + ha.prime_of_isPrimal (isPrimal a) + +/-- Unique factorisation in `K((ℝ^{≤0}))`: two factorisations of a series into irreducibles agree +up to order and units, that is, the two multisets of factors are related by association. -/ +theorem factorization_unique {f g : Multiset (Series K)} (hf : ∀ x ∈ f, Irreducible x) + (hg : ∀ x ∈ g, Irreducible x) (hfg : Associated f.prod g.prod) : + Multiset.Rel Associated f g := + prime_factors_unique (fun x hx ↦ prime_of_irreducible (hf x hx)) + (fun x hx ↦ prime_of_irreducible (hg x hx)) hfg + +end Berarducci diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Primality/Random.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Primality/Random.lean new file mode 100644 index 0000000000..aba5cff467 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Primality/Random.lean @@ -0,0 +1,156 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Primality.Primality +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Random.MainTheorem + +/-! +# Random series of finite degree are prime + +Fornasiero, Lavi, L'Innocente and Mantova prove that a random series `b` with `sup(b) = 0` and +`ot(b) = ω^n · m + β`, `1 ≤ m, n < ω`, `β < ω^n`, is irreducible, as is `b + r` for every `r` +with `ot(r) < ω^n` and `sup(b + r) = 0` (FLLM24, Theorem 1.8), and that a random principal +series of finite degree `n ≥ 1` is irreducible (FLLM24, Corollary 1.5). These series have +degree below `ω`, so the finite-degree theorem makes them prime. +-/ + +open scoped HahnSeries NatOrdinal + +universe v + +public noncomputable section + +namespace Berarducci + +open Berarducci HahnSeries HahnSeries.Nonpositive FLLM24 + +variable {K : Type v} [Field K] + +/-- `ω^n · m + β < ω^(n + 1)` when `β < ω^n`. -/ +theorem omega0_opow_mul_add_lt_opow_succ {n m : ℕ} {β : Ordinal} + (hβ : β < Ordinal.omega0 ^ (n : Ordinal)) : + Ordinal.omega0 ^ (n : Ordinal) * m + β < Ordinal.omega0 ^ ((n + 1 : ℕ) : Ordinal) := by + calc Ordinal.omega0 ^ (n : Ordinal) * m + β + < Ordinal.omega0 ^ (n : Ordinal) * m + Ordinal.omega0 ^ (n : Ordinal) := + (add_lt_add_iff_left _).mpr hβ + _ = Ordinal.omega0 ^ (n : Ordinal) * ((m + 1 : ℕ) : Ordinal) := by + rw [Nat.cast_succ, mul_add_one] + _ ≤ Ordinal.omega0 ^ (n : Ordinal) * Ordinal.omega0 := + mul_le_mul_right (Ordinal.natCast_lt_omega0 (m + 1)).le _ + _ = Ordinal.omega0 ^ ((n + 1 : ℕ) : Ordinal) := by + rw [Nat.cast_succ, Ordinal.opow_add, Ordinal.opow_one] + +/-- A series of order type `ω^n · m + β` with `β < ω^n` has degree below `n + 1`. -/ +theorem degree_lt_succ_of_supportOrderType_eq {n m : ℕ} {β : Ordinal} + (hβ : β < Ordinal.omega0 ^ (n : Ordinal)) {b : Series K} + (hot : (b : K⟦ℝ⟧).supportOrderType = Ordinal.omega0 ^ (n : Ordinal) * m + β) : + (b : K⟦ℝ⟧).degree < (((n + 1 : ℕ) : NatOrdinal) : WithBot NatOrdinal) := by + rw [degree_lt_coe_iff_supportOrderType_lt_wpow, NatOrdinal.val_wpow, NatOrdinal.val_natCast, hot] + exact omega0_opow_mul_add_lt_opow_succ hβ + +/-- Degree below a natural number is degree below `ω`. -/ +theorem degree_lt_omega_of_lt_natCast {x : K⟦ℝ⟧} {n : ℕ} + (h : x.degree < ((n : NatOrdinal) : WithBot NatOrdinal)) : + x.degree < (NatOrdinal.of Ordinal.omega0 : WithBot NatOrdinal) := + h.trans (WithBot.coe_lt_coe.mpr (NatOrdinal.lt_omega0.mpr ⟨n, rfl⟩)) + +variable [CharZero K] + +/-- A random series `b` with `sup(b) = 0` and `ot(b) = ω^n · m + β`, `1 ≤ m, n < ω`, +`β < ω^n`, is prime: irreducible by FLLM24 Theorem 1.8, of degree `n < ω`. -/ +@[blueprint "cor:random-series-prime" + (phase := "Primality and factorisation for real exponents") + (title := "Random series of finite Cantor degree are prime") + (statement := /-- + Let $K$ be a field of characteristic $0$. Let $m,n\ge1$, let + $\beta<\omega^n$, and let $b\in K((\mathbb R^{\le0}))$ be random. If + \[ + \sup(b)=0, + \qquad + \operatorname{ot}(\operatorname{supp}(b))=\omega^n\cdot m+\beta, + \] + then $b$ is prime in $K((\mathbb R^{\le0}))$. + -/) + (proof := /-- + \cite[Theorem~1.8]{FLLM} makes $b$ irreducible. By + \ref{cor:hahn-series-irreducible-is-prime}, every irreducible series in + $K((\mathbb R^{\le0}))$ is prime. + -/)] +theorem prime_of_isRandom {n m : ℕ} (hn : 1 ≤ n) (hm : 1 ≤ m) {β : Ordinal} + (hβ : β < Ordinal.omega0 ^ (n : Ordinal)) {b : Series K} (hb : IsRandom b) + (hsup : supportSup b = 0) + (hot : (b : K⟦ℝ⟧).supportOrderType = Ordinal.omega0 ^ (n : Ordinal) * m + β) : + Prime b := + Berarducci.prime_of_irreducible (irreducible_of_isRandom hn hm hβ hb hsup hot) + +/-- For `b` as in `prime_of_isRandom`, `b + r` is prime for every `r` with `ot(r) < ω^n` and +`sup(b + r) = 0`. -/ +@[blueprint "cor:random-series-small-perturbation" + (phase := "Primality and factorisation for real exponents") + (title := "Lower-order perturbations of random series are prime") + (statement := /-- + Let $K$ be a field of characteristic $0$. Let $m,n\ge1$ and + $\beta<\omega^n$. Suppose that $b\in K((\mathbb R^{\le0}))$ is random and + \[ + \operatorname{ot}(\operatorname{supp}(b))=\omega^n\cdot m+\beta. + \] + If $r\in K((\mathbb R^{\le0}))$ satisfies + \[ + \operatorname{ot}(\operatorname{supp}(r))<\omega^n, + \qquad + \sup(b+r)=0, + \] + then $b+r$ is prime in $K((\mathbb R^{\le0}))$. + -/) + (proof := /-- + \cite[Theorem~1.8]{FLLM} makes $b+r$ irreducible. Apply + \ref{cor:hahn-series-irreducible-is-prime}. + -/)] +theorem prime_add_of_isRandom {n m : ℕ} (hn : 1 ≤ n) (hm : 1 ≤ m) {β : Ordinal} + (hβ : β < Ordinal.omega0 ^ (n : Ordinal)) {b : Series K} (hb : IsRandom b) + (hot : (b : K⟦ℝ⟧).supportOrderType = Ordinal.omega0 ^ (n : Ordinal) * m + β) + {r : Series K} (hr : (r : K⟦ℝ⟧).supportOrderType < Ordinal.omega0 ^ (n : Ordinal)) + (hsup : supportSup (b + r) = 0) : + Prime (b + r) := + Berarducci.prime_of_irreducible (irreducible_add_of_isRandom hn hm hβ hb hot hr hsup) + +/-- A random principal series of positive finite degree is prime: irreducible by FLLM24 +Corollary 1.5, of degree below `ω`. -/ +@[blueprint "cor:random-principal-series-prime" + (phase := "Primality and factorisation for real exponents") + (title := "Random principal series of positive finite degree are prime") + (statement := /-- + Let $K$ be a field of characteristic $0$. Every random principal series + $b\in K((\mathbb R^{\le0}))$ with + \[ + 0<\deg(b)<\omega + \] + is prime in $K((\mathbb R^{\le0}))$. + -/) + (proof := /-- + Write $\deg(b)=n$ with $1\le n<\omega$. \cite[Corollary~1.5]{FLLM} makes $b$ + irreducible, so \ref{cor:hahn-series-irreducible-is-prime} makes it prime. + -/)] +theorem prime_of_isRandom_of_isPrincipal {b : Series K} (hb : IsRandom b) (hp : IsPrincipal b) + (hpos : 0 < (b : K⟦ℝ⟧).degree) + (hfin : (b : K⟦ℝ⟧).degree < (NatOrdinal.of Ordinal.omega0 : WithBot NatOrdinal)) : + Prime b := by + obtain ⟨d, hd⟩ := WithBot.ne_bot_iff_exists.mp (ne_bot_of_gt hpos) + have hfin' := hfin + have hpos' := hpos + rw [← hd] at hfin' hpos' + obtain ⟨n, rfl⟩ := NatOrdinal.lt_omega0.mp (WithBot.coe_lt_coe.mp hfin') + have hn : 1 ≤ n := Nat.one_le_iff_ne_zero.mpr fun h ↦ by + subst h + simp at hpos' + exact Berarducci.prime_of_irreducible (irreducible_of_isRandom_of_isPrincipal hn hb hp hd.symm) + +end Berarducci + +end diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Primality/SupportOrderTypeFactorization.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Primality/SupportOrderTypeFactorization.lean new file mode 100644 index 0000000000..48792c5459 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Primality/SupportOrderTypeFactorization.lean @@ -0,0 +1,85 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Primality.Primality +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.GermLike + +import Mathlib.RingTheory.UniqueFactorizationDomain.Basic + +/-! +# Unique factorisation under the LM17 support-order alternatives + +L'Innocente--Mantova, Theorem 4.8 gives existence of irreducible factorisations for nonzero +series whose support order type is their ordinal value, or is their ordinal value plus one when +that value is greater than one. Polynomiality makes every irreducible series prime, so any two +such factorisations agree up to order and units. This proves LM17, Conjecture 1.6 without carrying +the paper's auxiliary predicate into the current API. + +## References + +* S. L'Innocente, V. Mantova, *Factorisation of germ-like series*, J. Log. Anal. 9 (2017), + paper no. 3, cited as [LM17]. +-/ + +universe v + +open scoped HahnSeries + +public noncomputable section + +namespace LM17 + +open Berarducci + +variable {K : Type v} [Field K] [CharZero K] + +/-- LM17, Conjecture 1.6: a nonzero series satisfying either support-order alternative in +LM17, Definition 4.1 admits an irreducible factorisation, unique up to order and association of +the factors. -/ +@[blueprint "cor:lm17-support-order" + (phase := "Primality and factorisation for real exponents") + (title := "Unique factorisation under support-order conditions") + (statement := /-- + Let $K$ be a field of characteristic $0$ and + $a\in K((\mathbb R^{\le 0}))$ a non-zero series. Suppose that + $\operatorname{ot}(a)=v_J(a)$, or that $v_J(a)>1$ and + $\operatorname{ot}(a)=v_J(a)+1$. Then $a$ admits a factorisation into + irreducibles, unique up to reordering and up to multiplication of the + factors by non-zero elements of $K$. These are the two alternatives of + \cite[Definition~4.1]{LM17}. + -/) + (proof := /-- + Under either support-order hypothesis, \cite[Theorem~4.8]{LM17} gives a finite + factorisation into irreducibles. By + \ref{cor:hahn-series-irreducible-is-prime}, every such irreducible is prime. + Uniqueness of finite prime factorisations then shows that any two multisets of + factors are related, after reordering, by association. + -/)] +theorem exists_unique_factorization_of_supportOrderType_eq_ordinalValue_or_add_one + {a : Series K} + (ha : (a : K⟦ℝ⟧).supportOrderType = (ordinalValue a).val ∨ + (1 < ordinalValue a ∧ + (a : K⟦ℝ⟧).supportOrderType = (ordinalValue a).val + 1)) + (ha0 : a ≠ 0) : + (∃ f : Multiset (Series K), + (∀ b ∈ f, Irreducible b) ∧ Associated f.prod a) ∧ + ∀ f g : Multiset (Series K), + (∀ b ∈ f, Irreducible b) → + (∀ b ∈ g, Irreducible b) → + Associated f.prod a → Associated g.prod a → + Multiset.Rel Associated f g := by + have haLM17 : IsGermLike a := isGermLike_iff.mpr ha + refine ⟨haLM17.exists_factorization ha0, ?_⟩ + intro f g hf hg hfa hga + exact prime_factors_unique + (fun b hb ↦ Berarducci.prime_of_irreducible (hf b hb)) + (fun b hb ↦ Berarducci.prime_of_irreducible (hg b hb)) + (hfa.trans hga.symm) + +end LM17 diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/PrincipalAddition.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/PrincipalAddition.lean new file mode 100644 index 0000000000..b11a1c1f13 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/PrincipalAddition.lean @@ -0,0 +1,340 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.NormalForm + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Multiplicativity +import Mathlib.Tactic.Abel + +/-! +# Addition of principal series + +This module proves the corrected form of LM24, Proposition 3.6.2. The printed proposition assumes +only that `b`, `c` are principal and `deg (b + c) = deg b`. That statement is false: if `b` is a +principal series of positive degree and `c = 1`, then `deg (b + c) = deg b`, but the terminal +constant makes `b + c` nonprincipal. +`ConwayRefinement.HahnSeries.Tests.PrincipalAddition` preserves this counterexample. + +After being shown the counterexample, Mantova confirmed in correspondence that imposing +`deg b = deg c` repairs the proposition. He also suggested the potentially more general +hypothesis that the two degrees are either both zero or both nonzero. This module proves and +uses only the equal-degree version; the broader version is not treated as established. + +Both later uses in LM24 have the additional equality `deg c = deg b`. Under the proved +hypotheses + +`deg b = deg c = deg (b + c)`, + +the source argument is valid. Every proper negative truncation of each summand has degree below +the common degree, so the same holds for the sum. This forces the support supremum of the sum to +be zero and bounds each closed initial segment of its support below the corresponding power of +`ω`. The generic initial-segment criterion then identifies the full support order type with that +power. +-/ + +universe v + +open scoped HahnSeries NatOrdinal + +public noncomputable section + +namespace HahnSeries.Nonpositive + +open HahnSeries + +variable {K : Type v} [Field K] + +/-- Negation preserves principality. -/ +@[simp] +theorem IsPrincipal.neg {p : Nonpositive ℝ K} (hp : IsPrincipal p) : + IsPrincipal (-p) := by + rw [isPrincipal_iff] + constructor + · change HahnSeries.IsWeaklyPrincipal (-(p : K⟦ℝ⟧)) + rw [HahnSeries.isWeaklyPrincipal_iff, HahnSeries.supportOrderType_neg] + exact HahnSeries.isWeaklyPrincipal_iff.mp hp.isWeaklyPrincipal + · simpa only [supportSup_neg] using hp.supportSup_eq_zero + +/-- Multiplication by a nonzero coefficient, embedded as a constant Hahn series, preserves +principality. -/ +theorem IsPrincipal.const_mul {p : Nonpositive ℝ K} (hp : IsPrincipal p) + {k : K} (hk : k ≠ 0) : + IsPrincipal ((C : K →+* Nonpositive ℝ K) k * p) := by + have hsupport : + ((((C : K →+* Nonpositive ℝ K) k * p : Nonpositive ℝ K) : + K⟦ℝ⟧).support) = (p : K⟦ℝ⟧).support := by + rw [Subring.coe_mul, coe_C, HahnSeries.C_mul_eq_smul] + ext x + simp [HahnSeries.mem_support, HahnSeries.coeff_smul, hk] + have htype : + HahnSeries.supportOrderType + (↑((C : K →+* Nonpositive ℝ K) k * p) : K⟦ℝ⟧) = + (p : K⟦ℝ⟧).supportOrderType := by + rw [HahnSeries.supportOrderType_eq_setOrderType, + HahnSeries.supportOrderType_eq_setOrderType] + exact Set.IsPWO.orderType_congr _ _ hsupport + rw [isPrincipal_iff] + constructor + · rw [HahnSeries.isWeaklyPrincipal_iff, htype] + exact HahnSeries.isWeaklyPrincipal_iff.mp hp.isWeaklyPrincipal + · have hproductNe : (C : K →+* Nonpositive ℝ K) k * p ≠ 0 := + mul_ne_zero (isPrincipal_C hk).ne_zero hp.ne_zero + calc + supportSup ((C : K →+* Nonpositive ℝ K) k * p) = supportSup p := by + rw [supportSup_of_ne hproductNe, supportSup_of_ne hp.ne_zero, hsupport] + _ = 0 := hp.supportSup_eq_zero + +/-- A principal series of degree `α` has support order type `ω^α`. -/ +theorem IsPrincipal.supportOrderType_eq_wpow_of_degree_eq + {p : Nonpositive ℝ K} (hp : IsPrincipal p) {α : NatOrdinal} + (hpDegree : (p : K⟦ℝ⟧).degree = (α : WithBot NatOrdinal)) : + (p : K⟦ℝ⟧).supportOrderType = (ω^ α).val := by + obtain ⟨e, he⟩ := Ordinal.isAdditivelyPrincipal_iff.mp + (HahnSeries.isWeaklyPrincipal_iff.mp hp.isWeaklyPrincipal) + have hdegree : (NatOrdinal.of e : WithBot NatOrdinal) = α := by + rw [HahnSeries.degree_eq_cantorDegree, he, + Ordinal.cantorDegree_of_ne_zero + (Ordinal.opow_ne_zero e Ordinal.omega0_ne_zero), + Ordinal.log_opow Ordinal.one_lt_omega0] at hpDegree + exact hpDegree + have hdegree' : NatOrdinal.of e = α := WithBot.coe_eq_coe.mp hdegree + rw [he, ← hdegree'] + simp + +/-- A principal series of positive degree has zero constant coefficient. -/ +theorem IsPrincipal.constantCoeff_eq_zero_of_degree_pos + {p : Nonpositive ℝ K} (hp : IsPrincipal p) {α : NatOrdinal} + (hpDegree : (p : K⟦ℝ⟧).degree = (α : WithBot NatOrdinal)) + (hα : 0 < α) : + constantCoeff p = 0 := by + have hpType := hp.supportOrderType_eq_wpow_of_degree_eq hpDegree + rw [constantCoeff_apply] + apply not_ne_iff.mp + intro hcoeff + have hzeroSupport : 0 ∈ (p : K⟦ℝ⟧).support := + (HahnSeries.mem_support _ _).mpr hcoeff + have hlimit : Order.IsSuccLimit (p : K⟦ℝ⟧).isPWO_support.orderType := by + rw [← supportOrderType_eq_setOrderType, hpType, NatOrdinal.val_wpow] + exact Ordinal.isSuccLimit_opow_left Ordinal.isSuccLimit_omega0 + (NatOrdinal.val.strictMono hα).ne' + obtain ⟨y, hy, hypos⟩ := + (p : K⟦ℝ⟧).isPWO_support.exists_gt_of_isSuccLimit_orderType + hlimit hzeroSupport + exact (not_lt_of_ge (support_subset p hy)) hypos + +private theorem truncLE_ne_self_of_isPrincipal + {p : Nonpositive ℝ K} (hp : IsPrincipal p) {x : ℝ} (hx : x < 0) : + truncLE x (p : K⟦ℝ⟧) ≠ p := by + have hpLUB : IsLUB (p : K⟦ℝ⟧).support 0 := + (supportSup_eq_coe_iff.mp hp.supportSup_eq_zero).2 + obtain ⟨y, hy, hxy, -⟩ := hpLUB.exists_between hx + intro heq + have hyTrunc : y ∈ (truncLE x (p : K⟦ℝ⟧)).support := by + rw [heq] + exact hy + rw [support_truncLE] at hyTrunc + exact (not_lt_of_ge hyTrunc.2) hxy + +/-- Every negative weak truncation of a principal series has degree below its degree. -/ +theorem IsPrincipal.degree_truncLE_lt_of_degree_eq + {p : Nonpositive ℝ K} (hp : IsPrincipal p) {α : NatOrdinal} + (hpDegree : (p : K⟦ℝ⟧).degree = (α : WithBot NatOrdinal)) + {x : ℝ} (hx : x < 0) : + (truncLE x (p : K⟦ℝ⟧)).degree < (α : WithBot NatOrdinal) := by + rw [← hpDegree] + exact degree_lt_of_supportOrderType_lt_of_isWeaklyPrincipal + hp.isWeaklyPrincipal + (supportOrderType_truncLE_lt x (truncLE_ne_self_of_isPrincipal hp hx)) + +private theorem support_subsingleton_of_supportOrderType_eq_one + {p : K⟦ℝ⟧} (hpType : p.supportOrderType = 1) : + p.support.Subsingleton := by + intro x hx y hy + apply le_antisymm + · apply le_of_not_gt + intro hyx + let hbelow := p.isPWO_support.mono + (s := p.support ∩ Set.Iio x) Set.inter_subset_left + have hbelowLt := p.isPWO_support.orderType_inter_Iio_lt hx + rw [← supportOrderType_eq_setOrderType, hpType] at hbelowLt + have hbelowZero : hbelow.orderType = 0 := by simpa using hbelowLt + have hbelowEmpty := hbelow.orderType_eq_zero.mp hbelowZero + have : y ∈ p.support ∩ Set.Iio x := ⟨hy, hyx⟩ + rw [hbelowEmpty] at this + exact this + · apply le_of_not_gt + intro hxy + let hbelow := p.isPWO_support.mono + (s := p.support ∩ Set.Iio y) Set.inter_subset_left + have hbelowLt := p.isPWO_support.orderType_inter_Iio_lt hy + rw [← supportOrderType_eq_setOrderType, hpType] at hbelowLt + have hbelowZero : hbelow.orderType = 0 := by simpa using hbelowLt + have hbelowEmpty := hbelow.orderType_eq_zero.mp hbelowZero + have : x ∈ p.support ∩ Set.Iio y := ⟨hx, hxy⟩ + rw [hbelowEmpty] at this + exact this + +/-- A principal series of degree zero is exactly its constant coefficient. -/ +theorem IsPrincipal.eq_C_constantCoeff_of_degree_zero + {p : Nonpositive ℝ K} (hp : IsPrincipal p) + (hpDegree : (p : K⟦ℝ⟧).degree = (0 : WithBot NatOrdinal)) : + p = C (constantCoeff p) := by + have hpType : (p : K⟦ℝ⟧).supportOrderType = 1 := by + simpa using hp.supportOrderType_eq_wpow_of_degree_eq hpDegree + have hpSubsingleton := support_subsingleton_of_supportOrderType_eq_one hpType + have hpNe : (p : K⟦ℝ⟧) ≠ 0 := by simpa using hp.ne_zero + obtain ⟨z, hz⟩ := HahnSeries.support_nonempty_iff.mpr hpNe + have hpSupport : (p : K⟦ℝ⟧).support = {z} := by + ext y + constructor + · intro hy + exact Set.mem_singleton_iff.mpr (hpSubsingleton hy hz) + · intro hy + exact Set.mem_singleton_iff.mp hy ▸ hz + have hpLUB : IsLUB (p : K⟦ℝ⟧).support 0 := + (supportSup_eq_coe_iff.mp hp.supportSup_eq_zero).2 + have hz0 : z = 0 := by + rw [hpSupport] at hpLUB + exact isLUB_singleton.unique hpLUB + apply Subtype.ext + ext x + by_cases hx : x = 0 + · subst x + simp [constantCoeff_apply] + · have hxSupport : x ∉ (p : K⟦ℝ⟧).support := by + rw [hpSupport, hz0, Set.mem_singleton_iff] + exact hx + have hxCoeff : (p : K⟦ℝ⟧).coeff x = 0 := by + rwa [← not_ne_iff, ← HahnSeries.mem_support] + simp [coe_C, hx, hxCoeff] + +private theorem add_of_same_degree_coe + {b c : Nonpositive ℝ K} (hb : IsPrincipal b) (hc : IsPrincipal c) + {α : NatOrdinal} + (hbDegree : (b : K⟦ℝ⟧).degree = (α : WithBot NatOrdinal)) + (hcDegree : (c : K⟦ℝ⟧).degree = (α : WithBot NatOrdinal)) + (hsumDegree : ((b + c : Nonpositive ℝ K) : K⟦ℝ⟧).degree = + (α : WithBot NatOrdinal)) : + IsPrincipal (b + c) := by + have hsumNe : b + c ≠ 0 := by + intro hzero + have : ((b + c : Nonpositive ℝ K) : K⟦ℝ⟧).degree = ⊥ := by + rw [hzero] + exact degree_zero + exact WithBot.bot_ne_coe (this.symm.trans hsumDegree) + rcases eq_or_ne α 0 with rfl | hα + · have hbC := hb.eq_C_constantCoeff_of_degree_zero hbDegree + have hcC := hc.eq_C_constantCoeff_of_degree_zero hcDegree + rw [hbC, hcC, ← map_add] + apply isPrincipal_C + intro hcoeff + apply hsumNe + rw [hbC, hcC, ← map_add, hcoeff, map_zero] + · have hαpos : 0 < α := bot_lt_iff_ne_bot.mpr hα + have hbZeroCoeff := hb.constantCoeff_eq_zero_of_degree_pos hbDegree hαpos + have hcZeroCoeff := hc.constantCoeff_eq_zero_of_degree_pos hcDegree hαpos + have hsumZeroCoeff : constantCoeff (b + c) = 0 := by + rw [map_add, hbZeroCoeff, hcZeroCoeff, add_zero] + have htruncDegree : ∀ x : ℝ, x < 0 → + (truncLE x (((b + c : Nonpositive ℝ K) : K⟦ℝ⟧))).degree < + (α : WithBot NatOrdinal) := by + intro x hx + change (truncLE x ((b : K⟦ℝ⟧) + (c : K⟦ℝ⟧))).degree < + (α : WithBot NatOrdinal) + rw [truncLE_add] + apply (degree_add_le _ _).trans_lt + exact max_lt + (hb.degree_truncLE_lt_of_degree_eq hbDegree hx) + (hc.degree_truncLE_lt_of_degree_eq hcDegree hx) + have hsumSup : supportSup (b + c) = 0 := by + apply le_antisymm (supportSup_le_zero (b + c)) + apply le_of_not_gt + intro hsupLt + rw [supportSup_of_ne hsumNe] at hsupLt + have hsupLtReal : sSup (((b + c : Nonpositive ℝ K) : K⟦ℝ⟧).support) < 0 := + WithBot.coe_lt_coe.mp hsupLt + obtain ⟨x, hsx, hx0⟩ := exists_between hsupLtReal + have hsupportLE : (((b + c : Nonpositive ℝ K) : K⟦ℝ⟧).support) ⊆ + Set.Iic x := by + intro y hy + exact (le_csSup (bddAbove_support (b + c)) hy).trans hsx.le + have htruncSelf : + truncLE x (((b + c : Nonpositive ℝ K) : K⟦ℝ⟧)) = b + c := + truncLE_eq_self_of_support_subset_Iic hsupportLE + have hsumDegree' : ((b : K⟦ℝ⟧) + (c : K⟦ℝ⟧)).degree = + (α : WithBot NatOrdinal) := by + simpa using hsumDegree + have hlt := htruncDegree x hx0 + rw [htruncSelf, hsumDegree'] at hlt + exact (lt_irrefl _ hlt) + rw [isPrincipal_iff] + refine ⟨?_, hsumSup⟩ + rw [HahnSeries.isWeaklyPrincipal_iff] + have htypeLE : (((b + c : Nonpositive ℝ K) : K⟦ℝ⟧).supportOrderType) ≤ + (ω^ α).val := by + rw [supportOrderType_eq_setOrderType] + apply Set.IsPWO.orderType_le_of_forall_inter_Iic_lt + (((b + c : Nonpositive ℝ K) : K⟦ℝ⟧).isPWO_support) + intro x hx + have hx0 : x < 0 := by + have hxle := support_subset (b + c) hx + exact lt_of_le_of_ne hxle fun hxzero ↦ by + subst x + exact (HahnSeries.mem_support _ _).mp hx (by + simpa [constantCoeff_apply] using hsumZeroCoeff) + have hsupportTrunc : + (truncLE x (((b + c : Nonpositive ℝ K) : K⟦ℝ⟧))).support = + (((b + c : Nonpositive ℝ K) : K⟦ℝ⟧).support ∩ Set.Iic x) := by + rw [support_truncLE] + rfl + let hInter := + (((b + c : Nonpositive ℝ K) : K⟦ℝ⟧).isPWO_support).mono + (s := ((b + c : Nonpositive ℝ K) : K⟦ℝ⟧).support ∩ Set.Iic x) + Set.inter_subset_left + let hTrunc := + (truncLE x (((b + c : Nonpositive ℝ K) : K⟦ℝ⟧))).isPWO_support + change hInter.orderType < (ω^ α).val + calc + hInter.orderType = hTrunc.orderType := + hInter.orderType_congr hTrunc hsupportTrunc.symm + _ = (truncLE x (((b + c : Nonpositive ℝ K) : K⟦ℝ⟧))).supportOrderType := + (supportOrderType_eq_setOrderType _).symm + _ < (ω^ α).val := + (degree_lt_coe_iff_supportOrderType_lt_wpow _ α).mp + (htruncDegree x hx0) + have htypeGE : (ω^ α).val ≤ + (((b + c : Nonpositive ℝ K) : K⟦ℝ⟧).supportOrderType) := by + have hsumNe' : (((b + c : Nonpositive ℝ K) : K⟦ℝ⟧)) ≠ 0 := by + intro hzero + exact hsumNe (Subtype.ext hzero) + have h := (coe_le_degree_iff (x := + ((b + c : Nonpositive ℝ K) : K⟦ℝ⟧)) (a := α.val) hsumNe').mp + (by rw [hsumDegree]; simp) + simpa only [NatOrdinal.val_wpow] using h + rw [le_antisymm htypeLE htypeGE] + exact Ordinal.isAdditivelyPrincipal_omega0_opow α.val + +/-- Corrected LM24, Proposition 3.6.2: a sum of two principal series of the same degree is +principal if the degree of the sum is unchanged. -/ +theorem IsPrincipal.add_of_degree_eq + {b c : Nonpositive ℝ K} (hb : IsPrincipal b) (hc : IsPrincipal c) + (hcDegree : (c : K⟦ℝ⟧).degree = (b : K⟦ℝ⟧).degree) + (hsumDegree : ((b + c : Nonpositive ℝ K) : K⟦ℝ⟧).degree = + (b : K⟦ℝ⟧).degree) : + IsPrincipal (b + c) := by + have hbDegreeNe : (b : K⟦ℝ⟧).degree ≠ ⊥ := by + intro hbot + have hbZero : (b : K⟦ℝ⟧) = 0 := degree_eq_bot.mp hbot + exact hb.ne_zero (Subtype.ext hbZero) + let α := (b : K⟦ℝ⟧).degree.unbot hbDegreeNe + have hbDegree : (b : K⟦ℝ⟧).degree = (α : WithBot NatOrdinal) := by + exact (WithBot.coe_unbot _ hbDegreeNe).symm + apply add_of_same_degree_coe hb hc hbDegree + · exact hcDegree.trans hbDegree + · exact hsumDegree.trans hbDegree + +end HahnSeries.Nonpositive diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/RealSupportSupremum.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/RealSupportSupremum.lean new file mode 100644 index 0000000000..3fd2c13171 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/RealSupportSupremum.lean @@ -0,0 +1,118 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.DomainEmbedding +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.SupportSupremum +public import Mathlib.Algebra.Order.Monoid.Submonoid + +/-! +# Real support supremum for subgroup-exponent Hahn series + +For an additive subgroup `H ⊆ ℝ`, LM24, Section 6.5 uses the supremum in `ℝ` of the +support of a series in `K((H^{≤ 0}))`. We first embed the exponent domain into `ℝ`, and then +apply the existing real Hahn-series support supremum. Thus the value is `⊥` exactly at zero and +otherwise is characterized intrinsically as the least upper bound in `ℝ` of the coerced +support. +-/ + +open scoped HahnSeries + +universe v + +public noncomputable section + +namespace HahnSeries.Nonpositive + +variable (H : AddSubgroup ℝ) {K : Type v} [Field K] + +/-- Regard a nonpositive Hahn series over `H ⊆ ℝ` as a real-exponent Hahn series. -/ +def mapDomainToReal : Nonpositive H K →+* Nonpositive ℝ K := + mapDomain H.subtype H.subtype_injective fun _ _ ↦ ⟨fun h ↦ h, fun h ↦ h⟩ + +/-- The underlying series of `mapDomainToReal` is Mathlib's exponent-domain embedding. -/ +@[simp] +theorem coe_mapDomainToReal (b : Nonpositive H K) : + (mapDomainToReal H b : K⟦ℝ⟧) = HahnSeries.embDomain + (⟨⟨H.subtype, H.subtype_injective⟩, by + intro a b + exact Subtype.coe_le_coe⟩ : H ↪o ℝ) + (b : K⟦H⟧) := + coe_mapDomain H.subtype H.subtype_injective (fun _ _ ↦ ⟨fun h ↦ h, fun h ↦ h⟩) b + +/-- The real-domain embedding maps support by the subgroup inclusion. -/ +theorem support_mapDomainToReal (b : Nonpositive H K) : + (mapDomainToReal H b : K⟦ℝ⟧).support = + ((fun h : H ↦ (h : ℝ)) '' (b : K⟦H⟧).support) := + support_mapDomain H.subtype H.subtype_injective (fun _ _ ↦ ⟨fun h ↦ h, fun h ↦ h⟩) b + +/-- The real-domain embedding is injective. -/ +theorem mapDomainToReal_injective : + Function.Injective (mapDomainToReal (K := K) H) := + mapDomain_injective H.subtype H.subtype_injective fun _ _ ↦ ⟨fun h ↦ h, fun h ↦ h⟩ + +/-- The real-domain embedding preserves the constant coefficient. -/ +theorem constantCoeff_mapDomainToReal (b : Nonpositive H K) : + constantCoeff (mapDomainToReal H b) = constantCoeff b := by + have hmap : mapDomainToReal H b = + mapDomain H.subtype H.subtype_injective (fun _ _ ↦ ⟨fun h ↦ h, fun h ↦ h⟩) b := by + apply Subtype.ext + rw [coe_mapDomainToReal, coe_mapDomain] + rw [hmap] + exact constantCoeff_mapDomain H.subtype H.subtype_injective + (fun _ _ ↦ ⟨fun h ↦ h, fun h ↦ h⟩) b + +/-- The supremum in `ℝ` of the support of a nonpositive series with exponents in `H`. -/ +def realSupportSup (b : Nonpositive H K) : WithBot ℝ := + supportSup (mapDomainToReal H b) + +/-- The real support supremum of zero is `⊥`. -/ +@[simp] +theorem realSupportSup_zero : + realSupportSup H (0 : Nonpositive H K) = ⊥ := by + rw [realSupportSup, map_zero, supportSup_zero] + +/-- The real support supremum is `⊥` exactly at zero. -/ +@[simp] +theorem realSupportSup_eq_bot {b : Nonpositive H K} : + realSupportSup H b = ⊥ ↔ b = 0 := by + rw [realSupportSup, supportSup_eq_bot] + constructor + · intro hb + exact mapDomainToReal_injective H (hb.trans (map_zero _).symm) + · rintro rfl + exact map_zero _ + +/-- A finite real support supremum is precisely a least upper bound of the coerced support. -/ +theorem realSupportSup_eq_coe_iff {b : Nonpositive H K} {a : ℝ} : + realSupportSup H b = (a : WithBot ℝ) ↔ + b ≠ 0 ∧ IsLUB ((fun h : H ↦ (h : ℝ)) '' (b : K⟦H⟧).support) a := by + rw [realSupportSup, supportSup_eq_coe_iff, support_mapDomainToReal] + constructor + · rintro ⟨hb, hlub⟩ + exact ⟨fun hzero ↦ hb (hzero ▸ map_zero _), hlub⟩ + · rintro ⟨hb, hlub⟩ + exact ⟨fun hzero ↦ + hb (mapDomainToReal_injective H (hzero.trans (map_zero _).symm)), hlub⟩ + +/-- The real support supremum of a nonzero monomial is its real exponent. -/ +theorem realSupportSup_single {g : H} {k : K} (hk : k ≠ 0) (hg : g ≤ 0) : + realSupportSup H (single g k hg) = (g : ℝ) := by + rw [realSupportSup, mapDomainToReal, mapDomain_single] + exact supportSup_single hk (by exact_mod_cast hg) + +/-- The multiplicative identity has real support supremum zero. -/ +@[simp] +theorem realSupportSup_one : + realSupportSup H (1 : Nonpositive H K) = 0 := by + rw [realSupportSup, map_one] + rw [show (1 : Nonpositive ℝ K) = single 0 1 le_rfl by + apply Subtype.ext + rw [coe_single] + rfl] + exact supportSup_single one_ne_zero le_rfl + +end HahnSeries.Nonpositive diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/SeparatedPieceSum.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/SeparatedPieceSum.lean new file mode 100644 index 0000000000..91afba40e1 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/SeparatedPieceSum.lean @@ -0,0 +1,171 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.IncreasingSequenceUnion +public import Mathlib.RingTheory.HahnSeries.Summable + +/-! +# Hahn sums of order-separated families + +A family of Hahn series whose supports are strictly separated along a partially well-ordered +index is summable: the support union is partially well ordered by the ordered-union lemma, and +each exponent meets at most one member. This drops the half-open interval bookkeeping of the +ordered interval sums; any family carried by pairwise disjoint ordered convex pieces qualifies. +The support of the sum is exactly the union of the member supports, and each coefficient is read +off its unique contributing member. +-/ + +universe u v w + +open Set + +public noncomputable section + +namespace HahnSeries + +variable {Γ : Type u} {R : Type v} {ι : Type w} + [LinearOrder Γ] [AddCommMonoid R] [LinearOrder ι] + +/-- Hahn series with strictly separated supports along a partially well-ordered index form a +summable family. -/ +def separatedSummableFamily (hι : (Set.univ : Set ι).IsPWO) + (f : ι → R⟦Γ⟧) + (hsep : ∀ i j, i < j → ∀ a ∈ (f i).support, ∀ b ∈ (f j).support, a < b) : + SummableFamily Γ R ι where + toFun := f + isPWO_iUnion_support' := + Set.IsPWO.iUnion_of_ordered_index hι (fun i ↦ (f i).support) + (fun i ↦ (f i).isPWO_support) fun i j hij x hx y hy ↦ hsep i j hij x hx y hy + finite_co_support' x := by + refine Set.Subsingleton.finite fun i hi j hj ↦ ?_ + by_contra hne + have hix : x ∈ (f i).support := (mem_support _ _).mpr hi + have hjx : x ∈ (f j).support := (mem_support _ _).mpr hj + rcases lt_or_gt_of_ne hne with hij | hji + · exact lt_irrefl x (hsep i j hij x hix x hjx) + · exact lt_irrefl x (hsep j i hji x hjx x hix) + +/-- The separated family evaluates to the original series at each index. -/ +@[simp] +theorem separatedSummableFamily_apply (hι : (Set.univ : Set ι).IsPWO) + (f : ι → R⟦Γ⟧) + (hsep : ∀ i j, i < j → ∀ a ∈ (f i).support, ∀ b ∈ (f j).support, a < b) (i : ι) : + separatedSummableFamily hι f hsep i = f i := (rfl) + +/-- The Hahn sum of an order-separated family. -/ +def separatedHsum (hι : (Set.univ : Set ι).IsPWO) + (f : ι → R⟦Γ⟧) + (hsep : ∀ i j, i < j → ∀ a ∈ (f i).support, ∀ b ∈ (f j).support, a < b) : R⟦Γ⟧ := + (separatedSummableFamily hι f hsep).hsum + +/-- Order separation prevents coefficient cancellation, so the support of the sum is exactly the +union of the member supports. -/ +theorem support_separatedHsum (hι : (Set.univ : Set ι).IsPWO) + (f : ι → R⟦Γ⟧) + (hsep : ∀ i j, i < j → ∀ a ∈ (f i).support, ∀ b ∈ (f j).support, a < b) : + (separatedHsum hι f hsep).support = ⋃ i, (f i).support := by + apply Set.Subset.antisymm SummableFamily.support_hsum_subset + intro g hg + rw [Set.mem_iUnion] at hg + obtain ⟨i, hi⟩ := hg + rw [mem_support] at hi ⊢ + rw [SummableFamily.coeff_hsum, finsum_eq_single _ i] + · exact hi + · intro j hji + by_contra hj + have hjx : g ∈ (f j).support := (mem_support _ _).mpr fun h ↦ hj (by + rw [separatedSummableFamily_apply, h]) + rcases lt_or_gt_of_ne hji with hji' | hij' + · exact lt_irrefl g (hsep j i hji' g hjx g hi) + · exact lt_irrefl g (hsep i j hij' g hi g hjx) + +/-- Each coefficient of an order-separated sum is the coefficient of its unique contributing +member. -/ +theorem coeff_separatedHsum_eq (hι : (Set.univ : Set ι).IsPWO) + (f : ι → R⟦Γ⟧) + (hsep : ∀ i j, i < j → ∀ a ∈ (f i).support, ∀ b ∈ (f j).support, a < b) + (i : ι) (g : Γ) (hg : ∀ j, j ≠ i → g ∉ (f j).support) : + (separatedHsum hι f hsep).coeff g = (f i).coeff g := by + have hsingle := finsum_eq_single + (fun j ↦ ((separatedSummableFamily hι f hsep) j).coeff g) i fun j hji ↦ by + rw [separatedSummableFamily_apply] + by_contra hj + exact hg j hji ((mem_support _ _).mpr hj) + rw [separatedHsum, SummableFamily.coeff_hsum, hsingle, separatedSummableFamily_apply] + +/-- A coefficient outside every member support vanishes in an order-separated sum. -/ +theorem coeff_separatedHsum_eq_zero (hι : (Set.univ : Set ι).IsPWO) + (f : ι → R⟦Γ⟧) + (hsep : ∀ i j, i < j → ∀ a ∈ (f i).support, ∀ b ∈ (f j).support, a < b) + (g : Γ) (hg : ∀ j, g ∉ (f j).support) : + (separatedHsum hι f hsep).coeff g = 0 := by + by_contra hne + have hmem : g ∈ (separatedHsum hι f hsep).support := (mem_support _ _).mpr hne + rw [support_separatedHsum, Set.mem_iUnion] at hmem + obtain ⟨j, hj⟩ := hmem + exact hg j hj + +/-- The restriction of a Hahn series to a set of exponents. -/ +def setRestrict (s : Set Γ) [DecidablePred (· ∈ s)] (b : R⟦Γ⟧) : R⟦Γ⟧ where + coeff g := if g ∈ s then b.coeff g else 0 + isPWO_support' := b.isPWO_support.mono fun g hg ↦ by + by_contra hgb + apply hg + change (if g ∈ s then b.coeff g else 0) = 0 + rcases Classical.em (g ∈ s) with hgs | hgs + · rw [ite_eq_left hgs] + exact of_not_not fun h ↦ hgb ((mem_support _ _).mpr h) + · rw [ite_eq_right hgs] + +@[simp] +theorem coeff_setRestrict (s : Set Γ) [DecidablePred (· ∈ s)] (b : R⟦Γ⟧) (g : Γ) : + (setRestrict s b).coeff g = if g ∈ s then b.coeff g else 0 := (rfl) + +theorem support_setRestrict (s : Set Γ) [DecidablePred (· ∈ s)] (b : R⟦Γ⟧) : + (setRestrict s b).support = b.support ∩ s := by + ext g + simp only [mem_support, coeff_setRestrict, Set.mem_inter_iff] + constructor + · intro h + rcases Classical.em (g ∈ s) with hgs | hgs + · rw [ite_eq_left hgs] at h + exact ⟨(mem_support _ _).mpr h, hgs⟩ + · rw [ite_eq_right hgs] at h + exact absurd rfl h + · rintro ⟨hb, hgs⟩ + rw [ite_eq_left hgs] + exact (mem_support _ _).mp hb + +open Classical in +/-- A Hahn series whose support is covered by the pairwise disjoint ordered pieces of a +separated family is the sum of its restrictions to the pieces. -/ +theorem separatedHsum_setRestrict_eq (hι : (Set.univ : Set ι).IsPWO) + (C : ι → Set Γ) (b : R⟦Γ⟧) + (hcov : b.support ⊆ ⋃ i, C i) + (hdisj : ∀ i j, i ≠ j → Disjoint (C i) (C j)) + (hord : ∀ i j, i < j → ∀ a ∈ C i, ∀ c ∈ C j, a < c) : + separatedHsum hι (fun i ↦ setRestrict (C i) b) + (fun i j hij a ha c hc ↦ hord i j hij a + ((support_setRestrict (C i) b ▸ ha : a ∈ b.support ∩ C i)).2 c + ((support_setRestrict (C j) b ▸ hc : c ∈ b.support ∩ C j)).2) = b := by + ext g + by_cases hgb : g ∈ b.support + · obtain ⟨i, hgi⟩ := Set.mem_iUnion.mp (hcov hgb) + rw [coeff_separatedHsum_eq _ _ _ i g ?_, coeff_setRestrict, ite_eq_left hgi] + intro j hji + rw [support_setRestrict] + rintro ⟨-, hgj⟩ + exact Set.disjoint_left.mp (hdisj j i hji) hgj hgi + · have hz : ∀ j, g ∉ (setRestrict (C j) b).support := by + intro j + rw [support_setRestrict] + rintro ⟨hb, -⟩ + exact hgb hb + rw [coeff_separatedHsum_eq_zero _ _ _ g hz] + exact (not_not.mp fun h ↦ hgb ((mem_support _ _).mpr h)).symm + +end HahnSeries diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/SeparatedSupport.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/SeparatedSupport.lean new file mode 100644 index 0000000000..6437d37834 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/SeparatedSupport.lean @@ -0,0 +1,150 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import Mathlib.Data.List.Chain +public import Mathlib.RingTheory.HahnSeries.Addition + +/-! +# Strictly separated supports of Hahn series + +`HahnSeries.SupportBelow x y` means that every exponent in the support of `x` is strictly below +every exponent in the support of `y`. This is the support orientation used in LM24, Proposition +3.2.1 and Definition 3.3.2. The generic lemmas below show that such supports cannot cancel under +addition and propagate the relation through finite sums. + +The generic declarations follow Mathlib's Hahn-series namespace and assumptions. Adjacent and +pairwise separation of finite lists are expressed with `List.IsChain` and `List.Pairwise.isChain`. +-/ + +universe u v + +public noncomputable section + +namespace HahnSeries + +variable {R : Type v} {G : Type u} [PartialOrder G] + +section Zero + +variable [Zero R] + +/-- Every exponent in the support of `x` is strictly below every exponent in the support of `y`. -/ +def SupportBelow (x y : R⟦G⟧) : Prop := + ∀ i ∈ x.support, ∀ j ∈ y.support, i < j + +/-- Elementwise characterization of strict support separation. -/ +theorem supportBelow_iff {x y : R⟦G⟧} : + SupportBelow x y ↔ ∀ i ∈ x.support, ∀ j ∈ y.support, i < j := + (Iff.rfl) + +/-- Extract the strict inequality between two supported exponents. -/ +theorem SupportBelow.lt {x y : R⟦G⟧} (h : SupportBelow x y) {i j : G} + (hi : i ∈ x.support) (hj : j ∈ y.support) : i < j := + supportBelow_iff.mp h i hi j hj + +/-- Strict support separation is transitive when the intermediate series is nonzero. -/ +theorem supportBelow_trans_of_ne_zero {x y z : R⟦G⟧} (hy : y ≠ 0) + (hxy : SupportBelow x y) (hyz : SupportBelow y z) : SupportBelow x z := by + have hsupport : y.support.Nonempty := by + rw [Set.nonempty_iff_ne_empty] + exact fun h ↦ hy (support_eq_empty_iff.mp h) + obtain ⟨j, hj⟩ := hsupport + rw [supportBelow_iff] + intro i hi k hk + exact (hxy.lt hi hj).trans (hyz.lt hj hk) + +/-- An adjacent chain of nonzero series with strictly separated supports is pairwise separated. -/ +theorem pairwise_supportBelow_of_isChain {l : List R⟦G⟧} + (hne : ∀ x ∈ l, x ≠ 0) (hchain : l.IsChain SupportBelow) : + l.Pairwise SupportBelow := by + induction l with + | nil => exact List.Pairwise.nil + | cons a l ih => + cases l with + | nil => exact List.Pairwise.cons (by simp) List.Pairwise.nil + | cons b l => + have htail : (b :: l).IsChain SupportBelow := hchain.tail + have hpair : (b :: l).Pairwise SupportBelow := + ih (fun x hx ↦ hne x (by simp [hx])) htail + rw [List.pairwise_cons] + refine ⟨?_, hpair⟩ + intro c hc + simp only [List.mem_cons] at hc + rcases hc with rfl | hc + · exact hchain.rel + · exact supportBelow_trans_of_ne_zero (hne b (by simp)) hchain.rel + ((List.pairwise_cons.mp hpair).1 c hc) + +end Zero + +section AddMonoid + +variable [AddMonoid R] + +/-- Strict support separation prevents cancellation in the support of a sum. -/ +theorem support_add_eq_union_of_supportBelow (x y : R⟦G⟧) (hxy : SupportBelow x y) : + (x + y).support = x.support ∪ y.support := by + have hdisjoint : Disjoint x.support y.support := by + rw [Set.disjoint_left] + intro i hi hj + exact (hxy.lt hi hj).false + apply Set.Subset.antisymm (support_add_subset x y) + rintro i (hi | hi) + · rw [mem_support, coeff_add] + have hy : y.coeff i = 0 := by + rw [← not_ne_iff, ← mem_support] + exact Set.disjoint_left.mp hdisjoint hi + simpa [hy] using (mem_support x i).mp hi + · rw [mem_support, coeff_add] + have hx : x.coeff i = 0 := by + rw [← not_ne_iff, ← mem_support] + exact Set.disjoint_left.mp hdisjoint.symm hi + simpa [hx] using (mem_support y i).mp hi + +/-- A series below every member of a list is below the sum of that list. -/ +theorem supportBelow_list_sum {x : R⟦G⟧} {l : List R⟦G⟧} + (h : ∀ y ∈ l, SupportBelow x y) : SupportBelow x l.sum := by + rw [supportBelow_iff] + intro i hi j hj + induction l with + | nil => simp at hj + | cons y ys ih => + rw [List.sum_cons] at hj + rcases support_add_subset y ys.sum hj with hj | hj + · exact (h y (by simp)).lt hi hj + · exact ih (fun z hz ↦ h z (by simp [hz])) hj + +/-- A sum of series each below `y` is itself below `y`. -/ +theorem list_sum_supportBelow {l : List R⟦G⟧} {y : R⟦G⟧} + (h : ∀ x ∈ l, SupportBelow x y) : SupportBelow l.sum y := by + rw [supportBelow_iff] + intro i hi j hj + induction l with + | nil => simp at hi + | cons x xs ih => + rw [List.sum_cons] at hi + rcases support_add_subset x xs.sum hi with hi | hi + · exact (h x (by simp)).lt hi hj + · exact ih (fun z hz ↦ h z (by simp [hz])) hi + +/-- In a pairwise support-separated list, every summand support is contained in the sum support. -/ +theorem support_subset_list_sum_of_mem {x : R⟦G⟧} {l : List R⟦G⟧} + (hpair : l.Pairwise SupportBelow) (hx : x ∈ l) : x.support ⊆ l.sum.support := by + induction l with + | nil => simp at hx + | cons y ys ih => + rw [List.pairwise_cons] at hpair + have hbelow : SupportBelow y ys.sum := supportBelow_list_sum hpair.1 + rw [List.sum_cons, support_add_eq_union_of_supportBelow y ys.sum hbelow] + simp only [List.mem_cons] at hx + rcases hx with rfl | hx + · exact Set.subset_union_left + · exact (ih hpair.2 hx).trans Set.subset_union_right + +end AddMonoid + +end HahnSeries diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/SourceStatements.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/SourceStatements.lean new file mode 100644 index 0000000000..2a02ab10e3 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/SourceStatements.lean @@ -0,0 +1,31 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Statements.MainLemma +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Statements.OrdinalValueDegree +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Statements.ProductValue +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Statements.ResidualPoint +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Degree.Statements.Degree +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Degree.Statements.DegreeResidue +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Statements.Factorization +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Statements.FiniteSupportFactorUniqueness +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Statements.MaximalFiniteSupportDivisor +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Statements.MaximalFiniteMultiplicativity +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Statements.PrincipalDivisibilityReflection +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Statements.PrincipalSubringFraction +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Statements.PrincipalSubringPrimality +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Statements.PrincipalScalarRedistribution +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Statements.PrincipalMaximalDivisor +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Statements.SeriesMaximalFiniteSupportDivisor +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Statements.SeriesPrimality + +/-! +# Published statements from LM24 and its prerequisites + +This root exposes the theorem declarations with the hypotheses, quantifiers, and conclusions used +in LM24, together with explicit prerequisites where a proof depends on them. +-/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/SubgroupAlgebra.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/SubgroupAlgebra.lean new file mode 100644 index 0000000000..b02e3096b1 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/SubgroupAlgebra.lean @@ -0,0 +1,159 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.EPrimitive +public import Mathlib.Algebra.MonoidAlgebra.Basic + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.SubgroupSupport + +/-! +# Series supported in a subgroup as a group ring + +The finite-support series supported in a subgroup `H` of the exponents are the group ring of `H`. +The identification is the algebra map sending a group element to its monomial, so multiplication +is matched by the monomial rule and no convolution computation is needed. + +This is what carries unique factorisation, and with it least common multiples, from the group ring +of a free abelian group of finite rank into the series ring. +-/ + +open scoped HahnSeries + +universe u v + +public noncomputable section + +namespace HahnSeries + +variable {G : Type u} {K : Type v} +variable [LinearOrder G] [AddCommGroup G] [IsOrderedAddMonoid G] +variable [Field K] + +/-- Monomials with exponent in a subgroup, as a monoid homomorphism. -/ +def subgroupMonomialHom (H : AddSubgroup G) : Multiplicative H →* K⟦G⟧ where + toFun h := single ((Multiplicative.toAdd h : H) : G) (1 : K) + map_one' := by simp + map_mul' a b := by + rw [HahnSeries.single_mul_single, one_mul] + rfl + +/-- The group ring of a subgroup of the exponents, mapped into the series ring. -/ +def subgroupAlgebraHom (H : AddSubgroup G) : AddMonoidAlgebra K H →ₐ[K] K⟦G⟧ := + AddMonoidAlgebra.lift K (K⟦G⟧) H (subgroupMonomialHom H) + +@[simp] +theorem subgroupAlgebraHom_single (H : AddSubgroup G) (a : H) (b : K) : + subgroupAlgebraHom H (AddMonoidAlgebra.single a b) = single (a : G) b := by + rw [subgroupAlgebraHom, AddMonoidAlgebra.lift_single] + ext g + simp [subgroupMonomialHom, HahnSeries.coeff_single] + +open Classical in +/-- The coefficients of a monomial image. -/ +private theorem coeff_subgroupAlgebraHom_single (H : AddSubgroup G) (a : H) (b : K) (g : G) : + (subgroupAlgebraHom H (AddMonoidAlgebra.single a b)).coeff g + = if hg : g ∈ H then (Finsupp.single a b : H →₀ K) ⟨g, hg⟩ else 0 := by + rw [subgroupAlgebraHom_single, HahnSeries.coeff_single] + by_cases hg : g ∈ H + · rw [dite_eq_left hg, Finsupp.single_apply] + by_cases hga : g = (a : G) + · rw [ite_eq_left hga, ite_eq_left (Subtype.ext hga.symm : a = ⟨g, hg⟩)] + · rw [ite_eq_right hga, ite_eq_right (fun h : a = ⟨g, hg⟩ ↦ hga (congrArg Subtype.val h).symm)] + · rw [dite_eq_right hg, ite_eq_right] + rintro rfl + exact hg a.2 + +open Classical in +/-- The coefficients of the image are the coefficients of the group-ring element. -/ +theorem coeff_subgroupAlgebraHom (H : AddSubgroup G) (f : AddMonoidAlgebra K H) (g : G) : + (subgroupAlgebraHom H f).coeff g = if hg : g ∈ H then f.coeff ⟨g, hg⟩ else 0 := by + induction f using AddMonoidAlgebra.induction_on with + | of m => + have hof : (AddMonoidAlgebra.of K H (Multiplicative.ofAdd m) : AddMonoidAlgebra K H) + = AddMonoidAlgebra.single m 1 := rfl + rw [hof] + exact coeff_subgroupAlgebraHom_single H m 1 g + | add x y hx hy => + rw [map_add, HahnSeries.coeff_add, hx, hy] + by_cases hg : g ∈ H <;> simp [hg] + | smul r x hx => + rw [map_smul, HahnSeries.coeff_smul, hx] + by_cases hg : g ∈ H <;> simp [hg] + +open Classical in +theorem subgroupAlgebraHom_injective (H : AddSubgroup G) : + Function.Injective (subgroupAlgebraHom H (K := K)) := by + intro f₁ f₂ h + ext a + have hc := congrArg (fun x : K⟦G⟧ ↦ x.coeff (a : G)) h + simp only [coeff_subgroupAlgebraHom, dite_eq_left a.2] at hc + simpa using hc + +open Classical in +theorem support_subgroupAlgebraHom_subset (H : AddSubgroup G) (f : AddMonoidAlgebra K H) : + (subgroupAlgebraHom H f).support ⊆ (H : Set G) := by + intro g hg + rw [HahnSeries.mem_support, coeff_subgroupAlgebraHom] at hg + by_cases hgH : g ∈ H + · exact hgH + · rw [dite_eq_right hgH] at hg + exact absurd rfl hg + +open Classical in +theorem support_subgroupAlgebraHom_finite (H : AddSubgroup G) (f : AddMonoidAlgebra K H) : + (subgroupAlgebraHom H f).support.Finite := by + refine Set.Finite.subset ((f.coeff.support : Finset H).finite_toSet.image ((↑) : H → G)) ?_ + intro g hg + rw [HahnSeries.mem_support, coeff_subgroupAlgebraHom] at hg + by_cases hgH : g ∈ H + · rw [dite_eq_left hgH] at hg + exact ⟨⟨g, hgH⟩, Finsupp.mem_support_iff.mpr hg, rfl⟩ + · rw [dite_eq_right hgH] at hg + exact absurd rfl hg + +open Classical in +/-- Every finite-support series supported in `H` comes from the group ring of `H`. -/ +theorem exists_subgroupAlgebraHom_eq + (H : AddSubgroup G) {x : K⟦G⟧} (hfin : x.support.Finite) + (hsub : x.support ⊆ (H : Set G)) : + ∃ f : AddMonoidAlgebra K H, subgroupAlgebraHom H f = x := by + set xf : G →₀ K := Finsupp.onFinset hfin.toFinset x.coeff + (fun a ha ↦ hfin.mem_toFinset.mpr ha) with hxf + have hinj : Set.InjOn ((↑) : H → G) (((↑) : H → G) ⁻¹' xf.support) := + fun a _ b _ hab ↦ Subtype.ext hab + refine ⟨AddMonoidAlgebra.ofCoeff (Finsupp.comapDomain ((↑) : H → G) xf hinj), ?_⟩ + ext g + rw [coeff_subgroupAlgebraHom] + by_cases hgH : g ∈ H + · rw [dite_eq_left hgH, AddMonoidAlgebra.coeff_ofCoeff, Finsupp.comapDomain_apply, + hxf, Finsupp.onFinset_apply] + · rw [dite_eq_right hgH] + by_contra hne + exact hgH (hsub ((HahnSeries.mem_support _ _).mpr (Ne.symm hne))) + +/-- Divisibility in the group ring of `H` matches divisibility of the images. -/ +theorem dvd_iff_dvdFS_subgroupAlgebraHom (H : AddSubgroup G) (a b : AddMonoidAlgebra K H) : + a ∣ b ↔ DvdFS (subgroupAlgebraHom H a) (subgroupAlgebraHom H b) := by + constructor + · rintro ⟨c, rfl⟩ + exact dvdFS_iff.mpr ⟨subgroupAlgebraHom H c, support_subgroupAlgebraHom_finite H c, + by rw [map_mul]⟩ + · intro h + obtain ⟨w, hwf, hw⟩ := dvdFS_iff.mp h + rcases eq_or_ne (subgroupAlgebraHom H a) 0 with h0 | h0 + · have ha : a = 0 := subgroupAlgebraHom_injective H (by rw [h0, map_zero]) + refine ⟨0, ?_⟩ + refine subgroupAlgebraHom_injective H ?_ + rw [map_mul, map_zero, mul_zero, hw, h0, zero_mul] + · have hwsub : w.support ⊆ (H : Set G) := + support_subset_of_mul_eq (support_subgroupAlgebraHom_subset H a) h0 + (support_subgroupAlgebraHom_subset H b) hw + obtain ⟨c, hc⟩ := exists_subgroupAlgebraHom_eq H hwf hwsub + refine ⟨c, subgroupAlgebraHom_injective H ?_⟩ + rw [map_mul, hc, hw] + +end HahnSeries diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/SubgroupGCD.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/SubgroupGCD.lean new file mode 100644 index 0000000000..7b313c53e8 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/SubgroupGCD.lean @@ -0,0 +1,161 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.EPrimitive + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.SubgroupSupport + +/-! +# Transferring least common multiples out of a subgroup of the exponents + +Gilmer and Parker, Theorem 5.2 computes a least common multiple inside a finitely generated +subgroup of the exponents and observes that it stays one in the whole ring, because the ring is a +free module over the subring on coset representatives. + +The same conclusion is reached here without modules. A common multiple is peeled one coset at a +time: multiplying by a factor supported in the subgroup commutes with restricting to a coset, so +each restriction is again a common multiple, and translating it back into the subgroup puts it in +the range of the hypothesis. The remaining part has strictly smaller support, which drives the +induction. +-/ + +open scoped HahnSeries + +universe u v + +public noncomputable section + +namespace HahnSeries + +variable {G : Type u} {K : Type v} +variable [LinearOrder G] [AddCommGroup G] [IsOrderedAddMonoid G] +variable [Field K] + +theorem dvdFS_zero (e : K⟦G⟧) : DvdFS e 0 := dvdFS_iff.mpr ⟨0, by simp, by simp⟩ + +theorem DvdFS.add {e a b : K⟦G⟧} (ha : DvdFS e a) (hb : DvdFS e b) : DvdFS e (a + b) := by + obtain ⟨u, huf, hu⟩ := dvdFS_iff.mp ha + obtain ⟨v, hvf, hv⟩ := dvdFS_iff.mp hb + exact dvdFS_iff.mpr ⟨u + v, (huf.union hvf).subset (HahnSeries.support_add_subset u v), + by rw [hu, hv, mul_add]⟩ + +theorem DvdFS.trans {e a b : K⟦G⟧} (h1 : DvdFS e a) (h2 : DvdFS a b) : DvdFS e b := by + obtain ⟨u, huf, hu⟩ := dvdFS_iff.mp h1 + obtain ⟨v, hvf, hv⟩ := dvdFS_iff.mp h2 + refine dvdFS_iff.mpr ⟨u * v, ?_, by rw [hv, hu, mul_assoc]⟩ + exact (huf.add hvf).subset HahnSeries.support_mul_subset + +theorem DvdFS.sub {e a b : K⟦G⟧} (ha : DvdFS e a) (hb : DvdFS e b) : DvdFS e (a - b) := by + obtain ⟨u, huf, hu⟩ := dvdFS_iff.mp ha + obtain ⟨v, hvf, hv⟩ := dvdFS_iff.mp hb + refine dvdFS_iff.mpr ⟨u - v, ?_, by rw [hu, hv, mul_sub]⟩ + refine (huf.union hvf).subset ?_ + rw [sub_eq_add_neg] + refine (HahnSeries.support_add_subset u (-v)).trans ?_ + rw [HahnSeries.support_neg] + +omit [LinearOrder G] [IsOrderedAddMonoid G] in +/-- Membership in a fixed coset is invariant under translation by the subgroup. -/ +private theorem coset_invariant (H : AddSubgroup G) (s : G) : + ∀ i ∈ H, ∀ j : G, (i + j - s ∈ H ↔ j - s ∈ H) := by + intro i hi j + constructor + · intro hij + have hrw : j - s = i + j - s - i := by abel + rw [hrw] + exact H.sub_mem hij hi + · intro hj + have hrw : i + j - s = i + (j - s) := by abel + rw [hrw] + exact H.add_mem hi hj + +open Classical in +/-- Gilmer and Parker, Theorem 5.2: a common multiple property verified inside a subgroup of the +exponents holds against every finite-support common multiple. -/ +theorem dvdFS_of_forall_subgroup {H : AddSubgroup G} {f g h : K⟦G⟧} + (hf : f.support ⊆ (H : Set G)) (hg : g.support ⊆ (H : Set G)) + (hlcm : ∀ m : K⟦G⟧, m.support.Finite → m.support ⊆ (H : Set G) → + DvdFS f m → DvdFS g m → DvdFS h m) + {m : K⟦G⟧} (hmfin : m.support.Finite) (h1 : DvdFS f m) (h2 : DvdFS g m) : DvdFS h m := by + suffices key : ∀ (n : ℕ) (S : Finset G) (w : K⟦G⟧), + S.card ≤ n → w.support ⊆ (S : Set G) → DvdFS f w → DvdFS g w → DvdFS h w by + exact key hmfin.toFinset.card hmfin.toFinset m le_rfl (by simp) h1 h2 + intro n + induction n with + | zero => + intro S w hcard hsub _ _ + have hS : S = ∅ := Finset.card_eq_zero.mp (Nat.le_zero.mp hcard) + rw [hS] at hsub + have hw : w = 0 := by + rw [← HahnSeries.support_eq_empty_iff] + exact Set.subset_empty_iff.mp (by simpa using hsub) + rw [hw] + exact dvdFS_zero h + | succ n ih => + intro S w hcard hsub hfw hgw + rcases eq_or_ne w 0 with rfl | hw0 + · exact dvdFS_zero h + obtain ⟨s, hs⟩ := HahnSeries.support_nonempty_iff.mpr hw0 + have hsS : s ∈ S := by simpa using hsub hs + have hwfin : w.support.Finite := (S.finite_toSet).subset hsub + have hinv := coset_invariant H s + -- restrict to the coset of `s`; the rest is the difference + have hdvd : ∀ e : K⟦G⟧, e.support ⊆ (H : Set G) → DvdFS e w → + DvdFS e (filter (fun g ↦ g - s ∈ H) w) := by + intro e he hew + obtain ⟨u, huf, rfl⟩ := dvdFS_iff.mp hew + exact dvdFS_iff.mpr ⟨filter (fun g ↦ g - s ∈ H) u, + huf.subset (HahnSeries.support_filter_subset _ u), + filter_mul_of_invariant he (fun g ↦ g - s ∈ H) hinv⟩ + have hf₀ := hdvd f hf hfw + have hg₀ := hdvd g hg hgw + have hcoeff : ∀ x : G, + (w - filter (fun g ↦ g - s ∈ H) w).coeff x = if x - s ∈ H then 0 else w.coeff x := by + intro x + rw [HahnSeries.coeff_sub, HahnSeries.coeff_filter] + by_cases hx : x - s ∈ H <;> simp [hx] + -- the remaining part misses `s`, so its support fits in a smaller finset + have hrest : DvdFS h (w - filter (fun g ↦ g - s ∈ H) w) := by + refine ih (S.erase s) _ ?_ ?_ (hfw.sub hf₀) (hgw.sub hg₀) + · have := Finset.card_erase_of_mem hsS + omega + · intro x hx + rw [HahnSeries.mem_support, hcoeff x] at hx + by_cases hxp : x - s ∈ H + · exact absurd (ite_eq_left hxp) hx + · rw [ite_eq_right hxp] at hx + refine Finset.mem_coe.mpr (Finset.mem_erase.mpr ⟨?_, ?_⟩) + · rintro rfl + exact hxp (by simp) + · simpa using hsub ((HahnSeries.mem_support _ _).mpr hx) + -- the coset part translates into the subgroup, where the hypothesis applies + have hcoset : DvdFS h (filter (fun g ↦ g - s ∈ H) w) := by + set w₀ := filter (fun g ↦ g - s ∈ H) w with hw₀ + have hback : translate s (translate (-s) w₀) = w₀ := by + rw [HahnSeries.translate_add_apply] + simp + have hsupp : (translate (-s) w₀).support ⊆ (H : Set G) := by + rw [HahnSeries.support_translate] + rintro _ ⟨x, hx, rfl⟩ + rw [hw₀, HahnSeries.support_filter] at hx + change -s + x ∈ (H : Set G) + rw [show -s + x = x - s from by abel] + exact hx.2 + have hfin : (translate (-s) w₀).support.Finite := by + rw [HahnSeries.support_translate] + exact (hwfin.subset (hw₀ ▸ HahnSeries.support_filter_subset _ w)).image _ + have hkey := hlcm _ hfin hsupp + (by rw [← hback] at hf₀; exact dvdFS_translate_iff.mp hf₀) + (by rw [← hback] at hg₀; exact dvdFS_translate_iff.mp hg₀) + rw [← hback] + exact dvdFS_translate_iff.mpr hkey + have hsum : filter (fun g ↦ g - s ∈ H) w + (w - filter (fun g ↦ g - s ∈ H) w) = w := by + abel + rw [← hsum] + exact hcoset.add hrest + +end HahnSeries diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/SubgroupSupport.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/SubgroupSupport.lean new file mode 100644 index 0000000000..14b49e87a9 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/SubgroupSupport.lean @@ -0,0 +1,143 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Truncation +public import Mathlib.RingTheory.HahnSeries.Multiplication + +/-! +# Series supported in a subgroup of the exponents + +Splitting a series into the part supported in a subgroup `H` and the rest is compatible with +multiplication by a series supported in `H`, because `H` and its complement are separated by +translation: adding an element of `H` cannot move an exponent into `H` from outside it. + +The consequence recorded here is that divisibility descends: if a series supported in `H` divides +another one in the whole ring, the quotient is again supported in `H`. This is the reason a +finitely generated subgroup of the exponents may be fixed once and for all when computing +divisors, and it replaces the free-module argument of Gilmer and Parker, Proposition 5.1 for the +purpose of comparing divisibility. +-/ + +open scoped HahnSeries + +universe u v + +public noncomputable section + +namespace HahnSeries + +variable {G : Type u} {K : Type v} +variable [LinearOrder G] [AddCommGroup G] [IsOrderedAddMonoid G] +variable [Field K] + +omit [AddCommGroup G] [IsOrderedAddMonoid G] in +open Classical in +/-- Restricting to the exponents satisfying a predicate and to those failing it splits a +series. -/ +theorem filter_add_filter_not (p : G → Prop) (x : K⟦G⟧) : + filter p x + filter (fun g ↦ ¬ p g) x = x := by + ext g + rw [HahnSeries.coeff_add, HahnSeries.coeff_filter, HahnSeries.coeff_filter] + by_cases hg : p g <;> simp [hg] + +/-- A product of a series supported in `H` with one supported outside `H` is supported outside +`H`. -/ +private theorem support_mul_subset_compl {H : AddSubgroup G} {e y : K⟦G⟧} + (he : e.support ⊆ (H : Set G)) (hy : ∀ g ∈ y.support, g ∉ H) : + ∀ g ∈ (e * y).support, g ∉ H := by + intro g hg + obtain ⟨i, hi, j, hj, rfl⟩ := HahnSeries.support_mul_subset hg + intro hmem + exact hy j hj (by simpa using H.sub_mem hmem (he hi)) + +/-- Divisibility descends to a subgroup of the exponents: a quotient of two series supported in +`H` is again supported in `H`. -/ +theorem support_subset_of_mul_eq {H : AddSubgroup G} {e u f : K⟦G⟧} + (he : e.support ⊆ (H : Set G)) (he0 : e ≠ 0) + (hf : f.support ⊆ (H : Set G)) (hmul : f = e * u) : + u.support ⊆ (H : Set G) := by + classical + set u₀ := filter (fun g ↦ g ∈ H) u with hu₀ + set u₁ := filter (fun g ↦ g ∉ H) u with hu₁ + have hsplit : u₀ + u₁ = u := filter_add_filter_not _ u + have h₀ : u₀.support ⊆ (H : Set G) := by + rw [hu₀, HahnSeries.support_filter] + exact fun g hg ↦ hg.2 + have h₁ : ∀ g ∈ u₁.support, g ∉ H := by + rw [hu₁] + intro g hg + rw [HahnSeries.support_filter] at hg + exact hg.2 + have hprod₀ : (e * u₀).support ⊆ (H : Set G) := by + intro g hg + obtain ⟨i, hi, j, hj, rfl⟩ := HahnSeries.support_mul_subset hg + exact H.add_mem (he hi) (h₀ hj) + have hprod₁ := support_mul_subset_compl he h₁ + have hzero : e * u₁ = 0 := by + ext g + by_cases hg : g ∈ H + · by_contra hne + exact hprod₁ g ((HahnSeries.mem_support _ _).mpr hne) hg + · have hfg : f.coeff g = 0 := by + by_contra hne + exact hg (hf ((HahnSeries.mem_support _ _).mpr hne)) + have h₀g : (e * u₀).coeff g = 0 := by + by_contra hne + exact hg (hprod₀ ((HahnSeries.mem_support _ _).mpr hne)) + have hexp : f = e * u₀ + e * u₁ := by rw [hmul, ← mul_add, hsplit] + have := congrArg (fun s : K⟦G⟧ ↦ s.coeff g) hexp + simp only [HahnSeries.coeff_add, hfg, h₀g, zero_add] at this + simpa using this.symm + have hu₁zero : u₁ = 0 := by + rcases mul_eq_zero.mp hzero with h | h + · exact absurd h he0 + · exact h + intro g hg + rw [← hsplit, hu₁zero, add_zero] at hg + exact h₀ hg + +open Classical in +/-- Multiplying by a series supported in `H` commutes with restricting to the exponents satisfying +a predicate that is invariant under translation by `H`. -/ +theorem filter_mul_of_invariant {H : AddSubgroup G} {f u : K⟦G⟧} + (hf : f.support ⊆ (H : Set G)) + (p : G → Prop) + (hp : ∀ i ∈ H, ∀ j : G, p (i + j) ↔ p j) : + filter p (f * u) = f * filter p u := by + ext c + rw [HahnSeries.coeff_filter, HahnSeries.coeff_mul, HahnSeries.coeff_mul] + have hsub : Finset.antidiagonal f.isPWO_support (filter p u).isPWO_support c + ⊆ Finset.antidiagonal f.isPWO_support u.isPWO_support c := by + intro b hb + rw [Finset.mem_antidiagonal] at hb ⊢ + exact ⟨hb.1, HahnSeries.support_filter_subset _ u hb.2.1, hb.2.2⟩ + have hrestrict : ∀ b ∈ Finset.antidiagonal f.isPWO_support (filter p u).isPWO_support c, + f.coeff b.1 * (filter p u).coeff b.2 = f.coeff b.1 * u.coeff b.2 := by + intro b hb + rw [Finset.mem_antidiagonal] at hb + rw [HahnSeries.support_filter] at hb + rw [HahnSeries.coeff_filter, ite_eq_left hb.2.1.2] + by_cases hc : p c + · rw [ite_eq_left hc] + refine Finset.sum_congr ?_ (fun b hb ↦ (hrestrict b hb).symm) + refine Finset.Subset.antisymm (fun b hb ↦ ?_) hsub + rw [Finset.mem_antidiagonal] at hb ⊢ + obtain ⟨hb1, hb2, hb0⟩ := hb + refine ⟨hb1, ?_, hb0⟩ + rw [HahnSeries.support_filter] + refine ⟨hb2, ?_⟩ + exact (hp b.1 (hf hb1) b.2).mp (by rw [hb0]; exact hc) + · rw [ite_eq_right hc] + refine (Finset.sum_eq_zero fun b hb ↦ ?_).symm + rw [Finset.mem_antidiagonal] at hb + rw [HahnSeries.support_filter] at hb + refine absurd ?_ hc + have hb0 := hb.2.2 + rw [← hb0] + exact (hp b.1 (hf hb.1) b.2).mpr hb.2.1.2 + +end HahnSeries diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/SupportArchimedeanClasses.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/SupportArchimedeanClasses.lean new file mode 100644 index 0000000000..6d2f19a346 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/SupportArchimedeanClasses.lean @@ -0,0 +1,196 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Nonpositive +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.SetOrderType +public import Mathlib.Algebra.Order.Archimedean.Class +public import Mathlib.Order.WellFounded +public import Mathlib.RingTheory.HahnSeries.Basic + +import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.FinitePWOUnion +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint + +/-! +# Archimedean classes met by a nonpositive Hahn support + +The Archimedean-class order puts elements of smaller magnitude in higher classes. Consequently, +on nonpositive exponents the class map is monotone: moving an exponent toward zero moves its class +up. The Archimedean classes met by a well-founded nonpositive support are therefore well ordered +in the ascending class order. + +This orientation is the one needed by the Conway induction. Restriction to the closed class ball at +`c` keeps classes at least `c`; its complement consists of classes strictly below `c`, a proper +initial segment when the support meets `c`. +-/ + +universe u + +open Set + +namespace ArchimedeanClass + +variable {G : Type u} [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + +public section + +/-- On nonpositive elements, the Archimedean-class map is monotone. -/ +theorem mk_le_mk_of_le_of_nonpos {a b : G} (hab : a ≤ b) (hb : b ≤ 0) : + ArchimedeanClass.mk a ≤ ArchimedeanClass.mk b := by + refine ArchimedeanClass.mk_le_mk_of_abs ?_ + rw [abs_of_nonpos hb, abs_of_nonpos (hab.trans hb)] + exact neg_le_neg hab + +/-- An element outside the closed class ball at `c` has class strictly below `c`. -/ +theorem mk_lt_of_not_mem_closedBallAddSubgroup {c : ArchimedeanClass G} {g : G} + (hg : g ∉ closedBallAddSubgroup c) : ArchimedeanClass.mk g < c := by + rw [mem_closedBallAddSubgroup_iff] at hg + exact lt_of_not_ge hg + +end + +end ArchimedeanClass + +namespace HahnSeries + +variable {G : Type u} [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + +public section + +/-- The Archimedean classes of the nonzero exponents in a nonpositive Hahn series. Exponent zero +is excluded because the complementary factor has constant coefficient one; including its class +would prevent the induction rank from decreasing. -/ +def Nonpositive.nonzeroSupportArchimedeanClasses + {R : Type*} [Ring R] (x : Nonpositive G R) : Set (ArchimedeanClass G) := + ArchimedeanClass.mk '' ((x : R⟦G⟧).support \ {0}) + +/-- Membership among the Archimedean classes of the nonzero support. -/ +theorem Nonpositive.mem_nonzeroSupportArchimedeanClasses_iff + {R : Type*} [Ring R] {x : Nonpositive G R} {c : ArchimedeanClass G} : + c ∈ x.nonzeroSupportArchimedeanClasses ↔ + ∃ g ∈ (x : R⟦G⟧).support, g ≠ 0 ∧ ArchimedeanClass.mk g = c := by + rw [nonzeroSupportArchimedeanClasses] + constructor + · rintro ⟨g, ⟨hg, hg0⟩, hgc⟩ + exact ⟨g, hg, by simpa only [Set.mem_singleton_iff] using hg0, hgc⟩ + · rintro ⟨g, hg, hg0, hgc⟩ + exact ⟨g, ⟨hg, by simpa only [Set.mem_singleton_iff] using hg0⟩, hgc⟩ + +/-- The Archimedean classes met by a well-founded nonpositive set are well ordered ascending. -/ +theorem exists_min_mem_image_mk_of_isWF {S : Set G} (hS : S.IsWF) (hS0 : S ⊆ Set.Iic 0) + {T : Set (ArchimedeanClass G)} (hT : T ⊆ ArchimedeanClass.mk '' S) (hne : T.Nonempty) : + ∃ c ∈ T, ∀ d ∈ T, c ≤ d := by + classical + let P : Set G := {g ∈ S | ArchimedeanClass.mk g ∈ T} + have hPS : P ⊆ S := fun _ hg ↦ hg.1 + have hPne : P.Nonempty := by + obtain ⟨c, hc⟩ := hne + obtain ⟨g, hgS, hgc⟩ := hT hc + exact ⟨g, hgS, by rw [hgc]; exact hc⟩ + have hPwf : P.IsWF := hS.subset hPS + refine ⟨ArchimedeanClass.mk (hPwf.min hPne), (hPwf.min_mem hPne).2, fun d hd ↦ ?_⟩ + obtain ⟨g, hgS, rfl⟩ := hT hd + exact ArchimedeanClass.mk_le_mk_of_le_of_nonpos + (hPwf.min_le hPne ⟨hgS, hd⟩) (hS0 hgS) + +/-- The Archimedean classes met by a nonpositive Hahn support are well ordered ascending. -/ +theorem exists_min_mem_image_mk_support {R : Type*} [Zero R] (x : R⟦G⟧) + (hx : x.support ⊆ Set.Iic 0) {T : Set (ArchimedeanClass G)} + (hT : T ⊆ ArchimedeanClass.mk '' x.support) (hne : T.Nonempty) : + ∃ c ∈ T, ∀ d ∈ T, c ≤ d := + exists_min_mem_image_mk_of_isWF x.isWF_support hx hT hne + +/-- The classes met by a nonpositive Hahn support have well-founded strict order. -/ +theorem wellFounded_supportArchimedeanClasses {R : Type*} [Zero R] (x : R⟦G⟧) + (hx : x.support ⊆ Set.Iic 0) : + WellFounded ((· < ·) : + {c : ArchimedeanClass G // c ∈ ArchimedeanClass.mk '' x.support} → + {c : ArchimedeanClass G // c ∈ ArchimedeanClass.mk '' x.support} → Prop) := by + rw [WellFounded.wellFounded_iff_has_min] + intro U hU + let V : Set (ArchimedeanClass G) := Subtype.val '' U + have hVne : V.Nonempty := by + obtain ⟨c, hc⟩ := hU + exact ⟨c, c, hc, rfl⟩ + have hVsub : V ⊆ ArchimedeanClass.mk '' x.support := by + rintro _ ⟨c, -, rfl⟩ + exact c.2 + obtain ⟨c, hcV, hcmin⟩ := exists_min_mem_image_mk_support x hx hVsub hVne + obtain ⟨c', hc'U, hc'c⟩ := hcV + refine ⟨c', hc'U, ?_⟩ + intro d hdU hdc + exact (not_lt_of_ge (hcmin d ⟨d, hdU, rfl⟩)) (hc'c ▸ hdc) + +/-- The Archimedean classes met by a nonpositive Hahn series are partially well ordered. -/ +theorem Nonpositive.isPWO_supportArchimedeanClasses + {R : Type*} [Ring R] (x : Nonpositive G R) : + (ArchimedeanClass.mk '' (x : R⟦G⟧).support).IsPWO := by + apply (x : R⟦G⟧).isPWO_support.image_of_monotoneOn + intro a ha b hb hab + exact ArchimedeanClass.mk_le_mk_of_abs (by + rw [abs_of_nonpos (Nonpositive.support_subset x hb), + abs_of_nonpos (Nonpositive.support_subset x ha)] + exact neg_le_neg hab) + +/-- The Archimedean classes of the nonzero support are partially well ordered. -/ +theorem Nonpositive.isPWO_nonzeroSupportArchimedeanClasses + {R : Type*} [Ring R] (x : Nonpositive G R) : + x.nonzeroSupportArchimedeanClasses.IsPWO := by + apply x.isPWO_supportArchimedeanClasses.mono + exact Set.image_mono Set.sdiff_subset + +/-- If the nonzero support classes of one series lie strictly below a support class of another, +their order type is strictly smaller. -/ +@[blueprint "lem:support-class-order-type-strict-decrease" + (phase := "Refinement over Archimedean classes") + (title := "Strict decrease of support-class order type") + (statement := /-- + Let $x,y\in K((G^{\le0}))$. If $c$ is a nonzero Archimedean class met by + $\operatorname{supp}(x)$ and every nonzero class met by + $\operatorname{supp}(y)$ is a class met by $\operatorname{supp}(x)$ and is + strictly below $c$, then the order type of the nonzero support classes of + $y$ is strictly + smaller than that of $x$. + -/) + (proof := /-- + The classes met by either nonpositive support are partially well ordered. + Monotonicity of order type embeds the classes of $y$ into the initial + segment of the classes of $x$ below $c$, and a proper initial segment of a + well-order has strictly smaller order type. + -/)] +theorem Nonpositive.orderType_nonzeroSupportArchimedeanClasses_lt + {R : Type*} [Ring R] (x y : Nonpositive G R) + {c : ArchimedeanClass G} (hc : c ∈ x.nonzeroSupportArchimedeanClasses) + (hsub : y.nonzeroSupportArchimedeanClasses ⊆ + x.nonzeroSupportArchimedeanClasses ∩ Set.Iio c) : + y.isPWO_nonzeroSupportArchimedeanClasses.orderType < + x.isPWO_nonzeroSupportArchimedeanClasses.orderType := by + let hxbelow := x.isPWO_nonzeroSupportArchimedeanClasses.mono + (s := x.nonzeroSupportArchimedeanClasses ∩ Set.Iio c) Set.inter_subset_left + exact (y.isPWO_nonzeroSupportArchimedeanClasses.orderType_mono hxbelow hsub).trans_lt + (x.isPWO_nonzeroSupportArchimedeanClasses.orderType_inter_Iio_lt hc) + +/-- For a finite family of nonpositive Hahn series, the classes met by their supports are either +finite or split into an initial block of nonzero limit order type and a finite final block. -/ +theorem Nonpositive.finite_or_exists_limit_initial_finite_final_supportArchimedeanClasses + {R : Type*} [Ring R] {ι : Type*} [Finite ι] (x : ι → Nonpositive G R) : + let s := ⋃ i, ArchimedeanClass.mk '' (x i : R⟦G⟧).support + s.Finite ∨ + ∃ (s₀ s₁ : Set (ArchimedeanClass G)) (hs₀ : s₀.IsPWO) (_ : s₁.IsPWO), + s₀ ⊆ s ∧ + s₁ ⊆ s ∧ + (∀ a ∈ s₀, ∀ b ∈ s₁, a < b) ∧ + Order.IsSuccLimit hs₀.orderType ∧ + s₁.Finite ∧ + s = s₀ ∪ s₁ := by + dsimp only + apply Set.IsPWO.finite_or_exists_limit_initial_finite_final + exact Set.IsPWO.iUnion_of_finite _ fun i ↦ + Nonpositive.isPWO_supportArchimedeanClasses (x i) + +end + +end HahnSeries diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/SupportSupremum.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/SupportSupremum.lean new file mode 100644 index 0000000000..dd500181d0 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/SupportSupremum.lean @@ -0,0 +1,226 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Nonpositive +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Translation +public import Mathlib.Algebra.Order.Archimedean.Real.Basic + +/-! +# Supremum of the support of a nonpositive real Hahn series + +For a Hahn series supported in `ℝ⁽≤0⁾`, `HahnSeries.Nonpositive.supportSup` is the +supremum from LM24, Definition 3.1.3. Its codomain is `WithBot ℝ`: the zero series has value +`⊥`, while a nonzero series has the ordinary real supremum of its nonempty, bounded support. +The least-upper-bound characterization certifies this semantic identification directly. + +The addition and multiplication inequalities are LM24, Proposition 3.1.4. Normalization translates +a series by the negative of its real support supremum. A nonzero normalized series is again +nonpositive and has support supremum zero; this is the normalization used in the proof of LM24, +Proposition 3.3.7. + +This operation is deliberately not extended to arbitrary real Hahn series. An unbounded support +has no value in `WithBot ℝ`, and LM24, Remark 3.3.9 uses precisely this obstruction to show that +arbitrary real Hahn series need not have normal forms. + +The construction uses conditional completeness of the reals. Its public characterization and +monomial formula avoid exposing the underlying supremum calculation. +-/ + +universe v + +public noncomputable section + +namespace HahnSeries.Nonpositive + +variable {R : Type v} [Ring R] + +/-- The supremum of a nonpositive real Hahn-series support, with value `⊥` at zero. -/ +def supportSup (x : Nonpositive ℝ R) : WithBot ℝ := + sSup ((fun a : ℝ ↦ (a : WithBot ℝ)) '' (x : R⟦ℝ⟧).support) + +/-- Negation preserves the support supremum. -/ +@[simp] +theorem supportSup_neg (x : Nonpositive ℝ R) : supportSup (-x) = supportSup x := by + simp only [supportSup, Subring.coe_neg, HahnSeries.support_neg] + +/-- A nonpositive real Hahn-series support is bounded above by zero. -/ +theorem bddAbove_support (x : Nonpositive ℝ R) : + BddAbove (x : R⟦ℝ⟧).support := + ⟨0, support_subset x⟩ + +@[simp] +theorem supportSup_zero : supportSup (0 : Nonpositive ℝ R) = ⊥ := by + rw [supportSup] + simp + +/-- On a nonzero series, `supportSup` is the ordinary real supremum of the support. -/ +theorem supportSup_of_ne {x : Nonpositive ℝ R} (hx : x ≠ 0) : + supportSup x = (sSup (x : R⟦ℝ⟧).support : ℝ) := by + rw [supportSup] + have hx' : (x : R⟦ℝ⟧) ≠ 0 := by simpa using hx + exact (WithBot.coe_sSup' (support_nonempty_iff.mpr hx') (bddAbove_support x)).symm + +/-- The support supremum is `⊥` exactly at the zero series. -/ +@[simp] +theorem supportSup_eq_bot {x : Nonpositive ℝ R} : supportSup x = ⊥ ↔ x = 0 := by + constructor + · intro h + by_contra hx + rw [supportSup_of_ne hx] at h + exact WithBot.coe_ne_bot h + · rintro rfl + exact supportSup_zero + +/-- Characterization of a finite support-supremum value by the least-upper-bound property. -/ +theorem supportSup_eq_coe_iff {x : Nonpositive ℝ R} {a : ℝ} : + supportSup x = (a : WithBot ℝ) ↔ + x ≠ 0 ∧ IsLUB (x : R⟦ℝ⟧).support a := by + constructor + · intro h + have hx : x ≠ 0 := by + intro hzero + subst x + simp at h + have hx' : (x : R⟦ℝ⟧) ≠ 0 := by simpa using hx + rw [supportSup_of_ne hx, WithBot.coe_eq_coe] at h + exact ⟨hx, h ▸ isLUB_csSup (support_nonempty_iff.mpr hx') (bddAbove_support x)⟩ + · rintro ⟨hx, ha⟩ + have hx' : (x : R⟦ℝ⟧) ≠ 0 := by simpa using hx + rw [supportSup_of_ne hx, WithBot.coe_eq_coe] + exact ha.csSup_eq (support_nonempty_iff.mpr hx') + +/-- The support supremum of a nonpositive series is at most zero. -/ +theorem supportSup_le_zero (x : Nonpositive ℝ R) : supportSup x ≤ 0 := by + by_cases hx : x = 0 + · subst x + simp + · rw [supportSup_of_ne hx] + norm_cast + have hx' : (x : R⟦ℝ⟧) ≠ 0 := by simpa using hx + exact csSup_le (support_nonempty_iff.mpr hx') (support_subset x) + +/-- The support supremum of a nonzero monomial is its exponent. -/ +theorem supportSup_single {x : ℝ} {r : R} (hr : r ≠ 0) (hx : x ≤ 0) : + supportSup (single x r hx) = x := by + have hne : single x r hx ≠ 0 := by + intro h + have h' : HahnSeries.single x r = (0 : R⟦ℝ⟧) := by + simpa only [coe_single, Subring.coe_zero] using congrArg Subtype.val h + exact HahnSeries.single_ne_zero hr h' + rw [supportSup_of_ne hne] + norm_cast + rw [coe_single, HahnSeries.support_single_of_ne hr, csSup_singleton] + +/-- Support supremum satisfies the ultrametric addition inequality. This is LM24, Proposition +3.1.4(1). -/ +theorem supportSup_add_le (x y : Nonpositive ℝ R) : + supportSup (x + y) ≤ max (supportSup x) (supportSup y) := by + by_cases hsum : x + y = 0 + · rw [hsum, supportSup_zero] + exact bot_le + by_cases hx : x = 0 + · subst x + simp + by_cases hy : y = 0 + · subst y + simp + rw [supportSup_of_ne hsum, supportSup_of_ne hx, supportSup_of_ne hy] + norm_cast + have hsum' : ((x + y : Nonpositive ℝ R) : R⟦ℝ⟧) ≠ 0 := + fun h ↦ hsum (Subtype.ext h) + apply csSup_le (support_nonempty_iff.mpr hsum') + intro g hg + rcases support_add_subset (x : R⟦ℝ⟧) y hg with hg | hg + · exact (le_csSup (bddAbove_support x) hg).trans (le_max_left _ _) + · exact (le_csSup (bddAbove_support y) hg).trans (le_max_right _ _) + +/-- Support supremum is submultiplicative. This is LM24, Proposition 3.1.4(2). -/ +theorem supportSup_mul_le (x y : Nonpositive ℝ R) : + supportSup (x * y) ≤ supportSup x + supportSup y := by + by_cases hxy : x * y = 0 + · rw [hxy, supportSup_zero] + exact bot_le + have hx : x ≠ 0 := fun h ↦ hxy (h ▸ zero_mul y) + have hy : y ≠ 0 := fun h ↦ hxy (h ▸ mul_zero x) + rw [supportSup_of_ne hxy, supportSup_of_ne hx, supportSup_of_ne hy] + norm_cast + have hxy' : ((x * y : Nonpositive ℝ R) : R⟦ℝ⟧) ≠ 0 := + fun h ↦ hxy (Subtype.ext h) + apply csSup_le (support_nonempty_iff.mpr hxy') + intro g hg + obtain ⟨i, hi, j, hj, rfl⟩ := support_mul_subset hg + exact add_le_add (le_csSup (bddAbove_support x) hi) + (le_csSup (bddAbove_support y) hj) + +end HahnSeries.Nonpositive + +namespace HahnSeries + +variable {R : Type v} [Ring R] + +/-- Translating a nonzero bounded real Hahn-series support translates its real supremum. -/ +theorem csSup_support_translate {x : R⟦ℝ⟧} (hx : x ≠ 0) + (hbounded : BddAbove x.support) (a : ℝ) : + sSup (translate a x).support = a + sSup x.support := by + rw [support_translate] + exact ((OrderIso.addLeft a).map_csSup' (support_nonempty_iff.mpr hx) hbounded).symm + +namespace Nonpositive + +/-- Translate a nonpositive series by the negative of the real supremum of its support. For a +nonzero series, the result has support supremum zero. -/ +def normalize (x : Nonpositive ℝ R) : Nonpositive ℝ R := + ⟨translate (-sSup (x : R⟦ℝ⟧).support) x, by + rw [mem_nonpositiveSubring, support_translate] + rintro _ ⟨g, hg, rfl⟩ + have hgSup : g ≤ sSup (x : R⟦ℝ⟧).support := + le_csSup (bddAbove_support x) hg + simpa [sub_eq_add_neg, add_comm] using sub_nonpos.mpr hgSup⟩ + +@[simp] +theorem coe_normalize (x : Nonpositive ℝ R) : + (normalize x : R⟦ℝ⟧) = translate (-sSup (x : R⟦ℝ⟧).support) x := + (rfl) + +@[simp] +theorem normalize_zero : normalize (0 : Nonpositive ℝ R) = 0 := by + apply Subtype.ext + simp + +/-- Normalization preserves nonzeroness. -/ +theorem normalize_ne_zero {x : Nonpositive ℝ R} (hx : x ≠ 0) : normalize x ≠ 0 := by + intro hzero + have hval := congrArg Subtype.val hzero + change translate (-sSup (x : R⟦ℝ⟧).support) (x : R⟦ℝ⟧) = (0 : R⟦ℝ⟧) at hval + have hxval : (x : R⟦ℝ⟧) = 0 := + (translate _).injective (hval.trans (map_zero _).symm) + exact hx (Subtype.ext hxval) + +/-- Translating a normalized series back by its original support supremum recovers the series. -/ +theorem translate_csSup_normalize (x : Nonpositive ℝ R) : + translate (sSup (x : R⟦ℝ⟧).support) (normalize x : R⟦ℝ⟧) = x := by + rw [coe_normalize, translate_add_apply] + simp + +/-- Normalization preserves ordinary support order type. -/ +theorem supportOrderType_normalize (x : Nonpositive ℝ R) : + (normalize x : R⟦ℝ⟧).supportOrderType = (x : R⟦ℝ⟧).supportOrderType := by + rw [coe_normalize, supportOrderType_translate] + +/-- A nonzero normalized series has support supremum zero. -/ +theorem supportSup_normalize {x : Nonpositive ℝ R} (hx : x ≠ 0) : + supportSup (normalize x) = 0 := by + rw [supportSup_of_ne (normalize_ne_zero hx)] + norm_cast + rw [coe_normalize, csSup_support_translate] + · simp + · simpa using hx + · exact bddAbove_support x + +end Nonpositive + +end HahnSeries diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Tests.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Tests.lean new file mode 100644 index 0000000000..9ef19c7d77 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Tests.lean @@ -0,0 +1,26 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Tests.ArchimedeanSplitting +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Tests.CardinalTruncation +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Tests.FiniteSupportGCD +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Tests.FiniteSupportResidue +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Tests.FiniteSupportScalarExtension +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Tests.Fixtures +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Tests.Iterate +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Tests.Multiplicativity +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Tests.NegativePresentation +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Tests.NonpositiveDomainEquiv +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Tests.NormalForm +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Tests.OrderTypeDegree +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Tests.PrincipalAddition +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Tests.Truncation +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Tests.TruncationIntegerPartPrimal +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Tests.WeakNormalForm + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Tests/ArchimedeanSplitting.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Tests/ArchimedeanSplitting.lean new file mode 100644 index 0000000000..4fad872c31 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Tests/ArchimedeanSplitting.lean @@ -0,0 +1,40 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.ArchimedeanSplitting + +/-! +# API checks for the Hahn-series Archimedean splitting + +The check is polymorphic in independent stratum and ball coordinates and verifies that a monomial +on their sum becomes a nested monomial coefficient at exactly those two coordinates. In +particular, it certifies the dominant-then-infinitesimal orientation without unfolding either +equivalence. +-/ + +public noncomputable section + +namespace Tests + +open FiniteArchimedeanClass + +variable {K M : Type*} [DivisionRing K] [LinearOrder K] [IsOrderedRing K] [Archimedean K] +variable [AddCommGroup M] [LinearOrder M] [IsOrderedAddMonoid M] +variable [Module K M] [IsOrderedModule K M] + +open HahnEmbedding in +theorem archimedeanSeriesSplitting_monomial_coeff + (u : ArchimedeanStrata K M) (c : FiniteArchimedeanClass M) + (s : u.stratum c) (b : ball K c) : + ((HahnSeries.archimedeanSplitRingEquiv u c + (HahnSeries.single + (ArchimedeanStrata.stratumLexBallEquivClosedBall u c (toLex (s, b))) (13 : ℤ))).coeff + s).coeff b = 13 := by + rw [HahnSeries.archimedeanSplitRingEquiv_coeff] + simp + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Tests/CardinalTruncation.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Tests/CardinalTruncation.lean new file mode 100644 index 0000000000..ef8ca67f0e --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Tests/CardinalTruncation.lean @@ -0,0 +1,54 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.CardinalTruncation + +/-! +# API checks for cardinal-bounded Hahn truncation integer parts + +This separately compiled client exercises the support-cofinality and zero-exponent-group +fraction-field branches. These checks certify the public interfaces; the cofinality proof itself +provides the nondegenerate semantic content by constructing a monomial denominator for an +arbitrary bounded series. +-/ + +universe u v + +public noncomputable section + +open Cardinal + +namespace Tests + +open HahnSeries + +theorem cardSuppLTTruncation_fraction_of_cofinality + {G : Type u} {R : Type v} {κ : Cardinal.{u}} + [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] [Field R] + [Fact (ℵ₀ < κ)] (Z : Subring R) (hcof : κ ≤ Order.cof G) : + Subring.fracSubring + (cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) = ⊤ := + fracSubring_cardSuppLTTruncationIntegerPart_eq_top_of_le_cof Z hcof + +theorem cardSuppLTTruncation_fraction_of_zero_exponent_group + {G : Type u} {R : Type v} {κ : Cardinal.{u}} + [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] [Subsingleton G] [Field R] + [Fact (ℵ₀ < κ)] (Z : Subring R) (hfrac : Subring.fracSubring Z = ⊤) : + Subring.fracSubring + (cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) = ⊤ := + fracSubring_cardSuppLTTruncationIntegerPart_eq_top_of_subsingleton Z hfrac + +theorem zero_mem_cardSuppLTTruncationIntegerPart + {G : Type u} {R : Type v} {κ : Cardinal.{u}} + [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] [Field R] + [Fact (ℵ₀ < κ)] (Z : Subring R) : + (0 : CardSuppLTField (G := G) (R := R) (κ := κ)) ∈ + cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z := by + rw [mem_cardSuppLTTruncationIntegerPart] + simp + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Tests/FiniteSupportGCD.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Tests/FiniteSupportGCD.lean new file mode 100644 index 0000000000..00c14f8496 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Tests/FiniteSupportGCD.lean @@ -0,0 +1,110 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.FiniteSupport + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.FiniteSupportGCDProof +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.FiniteSupportUnit + +/-! +# API checks for LM24, Fact 2.5.2 + +The monomial `t⁻¹` is a unit in the finite-support ring on the whole exponent group `ℤ`, with +inverse `t`. The same underlying Hahn series is not a unit in the nonpositive finite-support +ring, because its inverse has positive exponent. This distinguishes LM24's unit statement from +the nearby incorrect statement for the full group ring. + +The gcd fixture uses the pair `(0, t⁻¹)`, with a witness associated to `t⁻¹`. Its exact +characterization is `e ∣ 0 ∧ e ∣ t⁻¹ ↔ e ∣ d`. This checks the zero boundary and the +greatest-common-divisor orientation in the second part of Fact 2.5.2. +-/ + +open scoped HahnSeries + +public noncomputable section + +namespace Tests + +/-- The ring of rational finite-support Hahn series with nonpositive integer exponents. -/ +abbrev IntegerNonpositiveFiniteSupportRing := + HahnSeries.Nonpositive.finiteSupportSubring (G := ℤ) (K := ℚ) + +/-- The ring of rational finite-support Hahn series with arbitrary integer exponents. -/ +abbrev IntegerFiniteSupportRing := + (HahnSeries.finiteSupportSubring : Subring ℚ⟦ℤ⟧) + +/-- The nonpositive exponent `-1`. -/ +def negativeExponent : HahnSeries.Nonpositive.exponentMonoid ℤ := + ⟨-1, show (-1 : ℤ) ≤ 0 by norm_num⟩ + +/-- The monomial `t⁻¹` in the nonpositive finite-support ring. -/ +def nonpositiveNegativeMonomial : IntegerNonpositiveFiniteSupportRing := + HahnSeries.Nonpositive.finiteSupportMonomial (K := ℚ) negativeExponent + +/-- The monomial `t⁻¹` is not a unit in the nonpositive finite-support ring. -/ +theorem nonpositiveNegativeMonomial_not_isUnit : + ¬ IsUnit nonpositiveNegativeMonomial := by + rw [HahnSeries.Nonpositive.isUnit_finiteSupport_iff_exists_scalar] + rintro ⟨k, -, h⟩ + have hcoeff := congrArg + (fun p : IntegerNonpositiveFiniteSupportRing ↦ + (((p : HahnSeries.Nonpositive ℤ ℚ) : ℚ⟦ℤ⟧).coeff (-1))) h + simp [nonpositiveNegativeMonomial, negativeExponent] at hcoeff + +/-- The monomial `t⁻¹` in the finite-support ring on the whole exponent group. -/ +def fullNegativeMonomial : IntegerFiniteSupportRing := + ⟨HahnSeries.single (-1) 1, by + rw [HahnSeries.mem_finiteSupportSubring_iff] + exact Set.Finite.subset (Set.finite_singleton (-1)) + HahnSeries.support_single_subset⟩ + +/-- The monomial `t` in the finite-support ring on the whole exponent group. -/ +def fullPositiveMonomial : IntegerFiniteSupportRing := + ⟨HahnSeries.single 1 1, by + rw [HahnSeries.mem_finiteSupportSubring_iff] + exact Set.Finite.subset (Set.finite_singleton 1) + HahnSeries.support_single_subset⟩ + +theorem fullNegativeMonomial_mul_fullPositiveMonomial : + fullNegativeMonomial * fullPositiveMonomial = 1 := by + apply Subtype.ext + simp [fullNegativeMonomial, fullPositiveMonomial, HahnSeries.single_mul_single] + +theorem fullPositiveMonomial_mul_fullNegativeMonomial : + fullPositiveMonomial * fullNegativeMonomial = 1 := by + apply Subtype.ext + simp [fullNegativeMonomial, fullPositiveMonomial, HahnSeries.single_mul_single] + +/-- In the full exponent-group finite-support ring, `t⁻¹` is a unit with inverse `t`. -/ +theorem fullNegativeMonomial_isUnit : IsUnit fullNegativeMonomial := by + exact ⟨{ + val := fullNegativeMonomial + inv := fullPositiveMonomial + val_inv := fullNegativeMonomial_mul_fullPositiveMonomial + inv_val := fullPositiveMonomial_mul_fullNegativeMonomial + }, rfl⟩ + +/-- The full-ring and nonpositive-ring fixtures have the same underlying Hahn series. -/ +theorem fullNegativeMonomial_eq_nonpositiveNegativeMonomial : + (fullNegativeMonomial : ℚ⟦ℤ⟧) = + ((nonpositiveNegativeMonomial : HahnSeries.Nonpositive ℤ ℚ) : ℚ⟦ℤ⟧) := by + simp [fullNegativeMonomial, nonpositiveNegativeMonomial, negativeExponent] + +/-- The gcd supplied for `(0, t⁻¹)` is associated to `t⁻¹` and satisfies the exact defining +orientation from LM24, Fact 2.5.2. -/ +theorem finiteSupportGCD_zero_left : + ∃ d : IntegerNonpositiveFiniteSupportRing, + (d ∣ nonpositiveNegativeMonomial ∧ nonpositiveNegativeMonomial ∣ d) ∧ + ∀ e : IntegerNonpositiveFiniteSupportRing, + e ∣ 0 ∧ e ∣ nonpositiveNegativeMonomial ↔ e ∣ d := by + obtain ⟨d, hd⟩ := HahnSeries.Nonpositive.finiteSupport_pairwise_gcd_exists + (0 : IntegerNonpositiveFiniteSupportRing) nonpositiveNegativeMonomial + refine ⟨d, ⟨?_, ?_⟩, hd⟩ + · exact ((hd d).mpr dvd_rfl).2 + · exact (hd nonpositiveNegativeMonomial).mp ⟨dvd_zero _, dvd_rfl⟩ + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Tests/FiniteSupportResidue.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Tests/FiniteSupportResidue.lean new file mode 100644 index 0000000000..0106a2f8e3 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Tests/FiniteSupportResidue.lean @@ -0,0 +1,129 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Tests.Fixtures.ApproachZero +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.FiniteSupportResidue + +/-! +# API checks for the degree-zero residue ring + +A two-term nonpositive series belongs to the finite-support subring and has a nonzero coefficient +at exponent `-1`, so this subring cannot be replaced by the constants. The approach-to-zero +series has support order type `ω` and is excluded, so the finite-support subring cannot be replaced +by the whole nonpositive Hahn ring. For any valuation realizing degree, the residue equivalence +sends the two-term series to a nonzero class. +-/ + +public noncomputable section + +open scoped DirectSum HahnSeries + +namespace Tests + +/-- A nonconstant two-term nonpositive Hahn series. -/ +def finiteSupportTwoTerm : HahnSeries.Nonpositive ℝ ℚ := + HahnSeries.Nonpositive.C 1 + + HahnSeries.Nonpositive.single (-1) 1 (by norm_num) + +/-- The two-term fixture has a nonzero coefficient at exponent `-1`. -/ +theorem finiteSupportTwoTerm_coeff_neg_one : + (finiteSupportTwoTerm : ℚ⟦ℝ⟧).coeff (-1) = 1 := by + simp [finiteSupportTwoTerm] + +/-- The two-term fixture has constant coefficient one. -/ +theorem finiteSupportTwoTerm_coeff_zero : + (finiteSupportTwoTerm : ℚ⟦ℝ⟧).coeff 0 = 1 := by + simp [finiteSupportTwoTerm] + +/-- The two-term fixture belongs to the finite-support subring. -/ +theorem finiteSupportTwoTerm_mem : + finiteSupportTwoTerm ∈ + (HahnSeries.Nonpositive.finiteSupportSubring : + Subring (HahnSeries.Nonpositive ℝ ℚ)) := by + rw [HahnSeries.Nonpositive.mem_finiteSupportSubring_iff] + apply Set.Finite.subset + ((Set.finite_singleton 0).union (Set.finite_singleton (-1))) + intro x hx + rcases HahnSeries.support_add_subset _ _ hx with hx | hx + · left + rw [HahnSeries.Nonpositive.coe_C] at hx + exact HahnSeries.support_single_subset hx + · right + rw [HahnSeries.Nonpositive.coe_single] at hx + exact HahnSeries.support_single_subset hx + +/-- The finite-support subring contains more than the constant series. -/ +theorem finiteSupportTwoTerm_not_constant : + ∀ q : ℚ, finiteSupportTwoTerm ≠ HahnSeries.Nonpositive.C q := by + intro q h + have hcoeff := congrArg + (fun b : HahnSeries.Nonpositive ℝ ℚ ↦ (b : ℚ⟦ℝ⟧).coeff (-1)) h + have hconstant : + ((HahnSeries.Nonpositive.C q : HahnSeries.Nonpositive ℝ ℚ) : + ℚ⟦ℝ⟧).coeff (-1) = 0 := by + rw [HahnSeries.Nonpositive.coe_C, HahnSeries.C_apply] + simp + rw [finiteSupportTwoTerm_coeff_neg_one, hconstant] at hcoeff + exact one_ne_zero hcoeff + +/-- An infinite nonpositive support is not in the finite-support subring. -/ +theorem approachZero_not_mem_finiteSupportSubring : + approachZeroNonpositive ∉ + (HahnSeries.Nonpositive.finiteSupportSubring : + Subring (HahnSeries.Nonpositive ℝ ℚ)) := by + rw [HahnSeries.Nonpositive.mem_finiteSupportSubring_iff] + intro hfinite + have hlt := HahnSeries.support_finite_iff_supportOrderType_lt_omega.mp hfinite + rw [coe_approachZeroNonpositive, approachZero_supportOrderType] at hlt + exact (lt_irrefl Ordinal.omega0) hlt + +section Residue + +variable (w : MaxAddDegree (HahnSeries.Nonpositive ℝ ℚ) NatOrdinal) + (hvalue : ∀ b, w b = (b : ℚ⟦ℝ⟧).degree) + +/-- The two-term fixture as an element of the finite-support subring. -/ +def finiteSupportTwoTermInSubring : + (HahnSeries.Nonpositive.finiteSupportSubring : + Subring (HahnSeries.Nonpositive ℝ ℚ)) := + ⟨finiteSupportTwoTerm, finiteSupportTwoTerm_mem⟩ + +/-- The residue equivalence does not kill the nonconstant two-term fixture. -/ +theorem finiteSupportTwoTerm_residue_ne_zero : + HahnSeries.Nonpositive.finiteSupportResidueEquiv w hvalue + finiteSupportTwoTermInSubring ≠ 0 := by + intro himage + have hzero : finiteSupportTwoTermInSubring = 0 := by + apply (HahnSeries.Nonpositive.finiteSupportResidueEquiv w hvalue).injective + rw [himage, map_zero] + have hcoeff := congrArg + (fun b : HahnSeries.Nonpositive ℝ ℚ ↦ (b : ℚ⟦ℝ⟧).coeff (-1)) + (congrArg Subtype.val hzero) + simp [finiteSupportTwoTermInSubring, finiteSupportTwoTerm_coeff_neg_one] at hcoeff + +/-- The transported `rv` class agrees with the residue isomorphism on the two-term fixture. -/ +theorem finiteSupportTwoTerm_rv_residue_compatibility [w.IsMultiplicative] : + (w.rvEquivHomogeneous (w.rv finiteSupportTwoTerm) : w.AssociatedGraded) = + w.residueRingHom + (HahnSeries.Nonpositive.finiteSupportResidueEquiv w hvalue + finiteSupportTwoTermInSubring) := + HahnSeries.Nonpositive.coe_rvEquivHomogeneous_rv_eq_residueRingHom_finiteSupportResidueEquiv + w hvalue finiteSupportTwoTermInSubring + +/-- The RV/residue compatibility includes the bottom-valued zero class. -/ +theorem finiteSupportZero_rv_residue_compatibility [w.IsMultiplicative] : + (w.rvEquivHomogeneous (w.rv (0 : HahnSeries.Nonpositive ℝ ℚ)) : + w.AssociatedGraded) = + w.residueRingHom + (HahnSeries.Nonpositive.finiteSupportResidueEquiv w hvalue + (0 : HahnSeries.Nonpositive.finiteSupportSubring)) := + HahnSeries.Nonpositive.coe_rvEquivHomogeneous_rv_eq_residueRingHom_finiteSupportResidueEquiv + w hvalue 0 + +end Residue + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Tests/FiniteSupportScalarExtension.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Tests/FiniteSupportScalarExtension.lean new file mode 100644 index 0000000000..9f67b5d220 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Tests/FiniteSupportScalarExtension.lean @@ -0,0 +1,199 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.FiniteSupportScalarExtension + +/-! +# API checks for finite-support coefficient extension + +The integer fixture has nonzero coefficients at exponents `0` and `-1`. Its scalar extension to +the rationals retains both coefficients, so it rejects maps that preserve only constants, delete +the nonconstant term, or move its exponent. The rational fixture with coefficient `1 / 2` at +exponent `-1` is not in the image of integer scalar extension; this separates the exact +coefficientwise range from the full rational finite-support ring and from a support-only test. + +The diagonal map `ℚ → ℚ × ℚ` supplies a separate scalar-recovery test. Multiplying the +extended nonzero fixture by the constant `(1, 0)` leaves the image, because that coefficient is +not diagonal. This exercises the step in Remark 6.3.5 which recovers a redistributed scalar from +one nonzero coefficient. An identity-map fixture then exercises the generic divisibility-reflection +reduction with an explicit scalar-redistribution witness. +-/ + +open scoped HahnSeries + +namespace Tests.HahnSeries.FiniteSupportScalarExtension + +public noncomputable section + +/-- The nonpositive exponent `-1` used by the coefficient-extension fixtures. -/ +def negativeOne : HahnSeries.Nonpositive.exponentMonoid ℤ := + ⟨-1, show (-1 : ℤ) ≤ 0 by norm_num⟩ + +/-- A finite-support integer series with coefficients `3` at `0` and `2` at `-1`. -/ +def integerFixture : + HahnSeries.Nonpositive.FiniteSupportRing (G := ℤ) (K := ℤ) := + HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℤ) 3 + + HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℤ) 2 * + HahnSeries.Nonpositive.finiteSupportMonomial (K := ℤ) negativeOne + +/-- The coefficientwise extension of `integerFixture` from `ℤ` to `ℚ`. -/ +def rationalFixture : + HahnSeries.Nonpositive.FiniteSupportRing (G := ℤ) (K := ℚ) := + HahnSeries.Nonpositive.finiteSupportScalarExtension + (G := ℤ) (K := ℤ) (L := ℚ) integerFixture + +/-- Scalar extension maps both coefficients and preserves the nonconstant exponent. -/ +theorem rationalFixture_eq : + rationalFixture = + HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℤ) (3 : ℚ) + + HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℤ) (2 : ℚ) * + HahnSeries.Nonpositive.finiteSupportMonomial (K := ℚ) negativeOne := by + rw [rationalFixture, integerFixture, map_add, map_mul, + HahnSeries.Nonpositive.finiteSupportScalarExtension_scalar, + HahnSeries.Nonpositive.finiteSupportScalarExtension_scalar, + HahnSeries.Nonpositive.finiteSupportScalarExtension_monomial] + norm_num + +/-- The nonconstant coefficient survives scalar extension and is mapped to `2 : ℚ`. -/ +theorem rationalFixture_negativeOne_coeff : + HahnSeries.Nonpositive.finiteSupportCoefficients rationalFixture negativeOne = 2 := by + rw [rationalFixture_eq, + ← HahnSeries.Nonpositive.smul_finiteSupport_eq_scalar_mul, + map_add, map_smul] + simp [HahnSeries.Nonpositive.finiteSupportCoefficients_apply, + HahnSeries.Nonpositive.coe_finiteSupportScalarHom, negativeOne] + +/-- The constant coefficient survives scalar extension and is mapped to `3 : ℚ`. -/ +theorem rationalFixture_zero_coeff : + HahnSeries.Nonpositive.finiteSupportCoefficients rationalFixture + (0 : HahnSeries.Nonpositive.exponentMonoid ℤ) = 3 := by + rw [rationalFixture_eq, + ← HahnSeries.Nonpositive.smul_finiteSupport_eq_scalar_mul, + map_add, map_smul] + simp [HahnSeries.Nonpositive.finiteSupportCoefficients_apply, + HahnSeries.Nonpositive.coe_finiteSupportScalarHom, negativeOne, + Subtype.ext_iff] + +/-- The scalar-extended integer fixture belongs to the image by construction. -/ +theorem rationalFixture_mem_range : + rationalFixture ∈ Set.range + (HahnSeries.Nonpositive.finiteSupportScalarExtension + (G := ℤ) (K := ℤ) (L := ℚ)) := + ⟨integerFixture, rfl⟩ + +/-- A rational finite-support series whose nonconstant coefficient is not an integer. -/ +def rationalOutside : + HahnSeries.Nonpositive.FiniteSupportRing (G := ℤ) (K := ℚ) := + HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℤ) 3 + + HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℤ) (1 / 2 : ℚ) * + HahnSeries.Nonpositive.finiteSupportMonomial (K := ℚ) negativeOne + +/-- The coefficient of `rationalOutside` at exponent `-1` is `1 / 2`. -/ +theorem rationalOutside_negativeOne_coeff : + HahnSeries.Nonpositive.finiteSupportCoefficients rationalOutside negativeOne = 1 / 2 := by + rw [rationalOutside, + ← HahnSeries.Nonpositive.smul_finiteSupport_eq_scalar_mul, + map_add, map_smul] + simp [HahnSeries.Nonpositive.finiteSupportCoefficients_apply, + HahnSeries.Nonpositive.coe_finiteSupportScalarHom, negativeOne] + +/-- A nonintegral coefficient prevents membership in the image of integer scalar extension. -/ +theorem rationalOutside_not_mem_range : + rationalOutside ∉ Set.range + (HahnSeries.Nonpositive.finiteSupportScalarExtension + (G := ℤ) (K := ℤ) (L := ℚ)) := by + rw [HahnSeries.Nonpositive.mem_range_finiteSupportScalarExtension_iff] + push Not + refine ⟨negativeOne, ?_⟩ + rw [rationalOutside_negativeOne_coeff] + rintro ⟨z, hz⟩ + change (z : ℚ) = 1 / 2 at hz + have hz' : (2 : ℚ) * (z : ℚ) = 1 := by + rw [hz] + norm_num + have hzInt : 2 * z = 1 := by + exact_mod_cast hz' + omega + +/-- Scalar extension from integer to rational finite-support series is injective. -/ +theorem integer_scalarExtension_injective : + Function.Injective + (HahnSeries.Nonpositive.finiteSupportScalarExtension + (G := ℤ) (K := ℤ) (L := ℚ)) := + HahnSeries.Nonpositive.finiteSupportScalarExtension_injective + (Int.cast_injective : Function.Injective (algebraMap ℤ ℚ)) + +/-- The diagonal embedding of the rationals into the product ring. -/ +def rationalDiagonal : ℚ →+* ℚ × ℚ := + (RingHom.id ℚ).prod (RingHom.id ℚ) + +/-- The scalar `(1, 0)` does not belong to the image of the diagonal embedding. -/ +theorem one_zero_not_mem_rationalDiagonal_range : + (1, 0) ∉ Set.range rationalDiagonal := by + rintro ⟨q, hq⟩ + have hfirst := congrArg Prod.fst hq + have hsecond := congrArg Prod.snd hq + change q = 1 at hfirst + change q = 0 at hsecond + exact zero_ne_one (hsecond.symm.trans hfirst) + +/-- The rational fixture is nonzero, witnessed by its coefficient at exponent `-1`. -/ +theorem rationalFixture_ne_zero : rationalFixture ≠ 0 := by + intro hzero + have hcoeff := congrArg + (fun p : HahnSeries.Nonpositive.FiniteSupportRing (G := ℤ) (K := ℚ) ↦ + HahnSeries.Nonpositive.finiteSupportCoefficients p negativeOne) hzero + rw [rationalFixture_negativeOne_coeff] at hcoeff + simp at hcoeff + +/-- Multiplication by the non-diagonal scalar `(1, 0)` takes the extended nonzero fixture out of +the diagonal coefficient image. -/ +theorem diagonalFixture_mul_one_zero_not_mem_range : + HahnSeries.Nonpositive.finiteSupportMap rationalDiagonal rationalFixture * + HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℤ) (1, 0) ∉ + Set.range (HahnSeries.Nonpositive.finiteSupportMap (G := ℤ) rationalDiagonal) := by + intro hmem + have hscalar := + HahnSeries.Nonpositive.coefficient_mem_range_of_map_mul_scalar_mem_range + (Field.toIsField ℚ) rationalDiagonal rationalFixture_ne_zero hmem + exact one_zero_not_mem_rationalDiagonal_range hscalar + +/-- Scalar redistribution is immediate for the identity coefficient map: choose the scalar one. -/ +theorem identity_exists_scalarRedistribution : + ∀ {p₁ p₂ : HahnSeries.Nonpositive.FiniteSupportRing (G := ℤ) (K := ℚ)}, + p₁ ≠ 0 → p₂ ≠ 0 → + p₁ * p₂ ∈ Set.range + (HahnSeries.Nonpositive.finiteSupportMap (G := ℤ) (RingHom.id ℚ)) → + ∃ B : ℚ, + B ≠ 0 ∧ + p₁ * HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℤ) B ∈ + Set.range (HahnSeries.Nonpositive.finiteSupportMap + (G := ℤ) (RingHom.id ℚ)) ∧ + p₂ * HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℤ) B⁻¹ ∈ + Set.range (HahnSeries.Nonpositive.finiteSupportMap + (G := ℤ) (RingHom.id ℚ)) := by + intro p₁ p₂ _ _ _ + refine ⟨1, one_ne_zero, ⟨p₁, ?_⟩, ⟨p₂, ?_⟩⟩ <;> + simp [HahnSeries.Nonpositive.finiteSupportMap_id] + +/-- The generic reduction recovers a nonconstant divisibility relation from its image under the +identity coefficient map. -/ +theorem identity_reflects_nonconstant_divisibility : + rationalFixture ∣ rationalFixture * rationalOutside := by + have hlarge : + HahnSeries.Nonpositive.finiteSupportMap (RingHom.id ℚ) rationalFixture ∣ + HahnSeries.Nonpositive.finiteSupportMap (RingHom.id ℚ) + (rationalFixture * rationalOutside) := by + rw [HahnSeries.Nonpositive.finiteSupportMap_id] + exact dvd_mul_right _ _ + exact (HahnSeries.Nonpositive.finiteSupportMap_dvd_iff_of_scalarRedistribution + (RingHom.id ℚ) Function.injective_id identity_exists_scalarRedistribution + rationalFixture (rationalFixture * rationalOutside)).mp hlarge + +end + +end Tests.HahnSeries.FiniteSupportScalarExtension diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Tests/Fixtures.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Tests/Fixtures.lean new file mode 100644 index 0000000000..d6bc09ae05 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Tests/Fixtures.lean @@ -0,0 +1,11 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Tests.Fixtures.ApproachZero + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Tests/Fixtures/ApproachZero.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Tests/Fixtures/ApproachZero.lean new file mode 100644 index 0000000000..00dfef92c8 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Tests/Fixtures/ApproachZero.lean @@ -0,0 +1,168 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.NormalForm + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Domain + +/-! +# A principal Hahn series approaching exponent zero + +This module provides the shared nondegenerate fixture + +``` +∑ n : ℕ, t ^ (-1 / (n + 1)). +``` + +Its support has ordinary order type `ω`, is cofinal in zero, and does not contain zero. Thus its +support supremum is an unattained least upper bound, and the series is principal in the sense of +LM24. API-client modules use these proved properties to test normal forms, truncation bounds, +the negative-monomial ideal, and multiplicativity without duplicating the series. + +This is shared example infrastructure for the checks, not part of the mathematical API. +-/ + +public noncomputable section + +namespace Tests + +open scoped HahnSeries NatOrdinal + +/-- The coefficient-one Hahn series on `ℕ`. -/ +def natOnes : ℚ⟦ℕ⟧ where + coeff _ := 1 + isPWO_support' := by + simpa [Function.support] using Set.IsPWO.of_linearOrder (Set.univ : Set ℕ) + +/-- Every coefficient of `natOnes` is one. -/ +@[simp] +theorem natOnes_coeff (n : ℕ) : natOnes.coeff n = 1 := + (rfl) + +/-- The support of `natOnes` is all of `ℕ`. -/ +@[simp] +theorem natOnes_support : natOnes.support = Set.univ := by + ext n + simp [HahnSeries.mem_support] + +private theorem approachZero_strictMono : + StrictMono (fun n : ℕ ↦ -(1 / (n + 1 : ℝ))) := + strictMono_nat_of_lt_succ fun n ↦ by + apply neg_lt_neg + apply one_div_lt_one_div_of_lt + · positivity + · norm_num + +/-- The order embedding `n ↦ -1/(n+1)`. -/ +def approachZeroEmbedding : ℕ ↪o ℝ := + OrderEmbedding.ofStrictMono _ approachZero_strictMono + +/-- Evaluation of the exponent embedding used by `approachZero`. -/ +@[simp] +theorem approachZeroEmbedding_apply (n : ℕ) : + approachZeroEmbedding n = -(1 / (n + 1 : ℝ)) := + (rfl) + +/-- The coefficient-one series on the support `{-1/(n+1) | n ∈ ℕ}`. -/ +def approachZero : ℚ⟦ℝ⟧ := + HahnSeries.embDomain approachZeroEmbedding natOnes + +/-- The coefficient at every embedded exponent is one. -/ +theorem approachZero_coeff_embedding (n : ℕ) : + approachZero.coeff (approachZeroEmbedding n) = 1 := by + rw [approachZero, HahnSeries.embDomain_coeff, natOnes_coeff] + +/-- The support of `approachZero` is exactly the range of its exponent embedding. -/ +theorem approachZero_support : + approachZero.support = Set.range approachZeroEmbedding := by + rw [approachZero, HahnSeries.support_embDomain, natOnes_support, + Set.image_univ] + +/-- `approachZero` regarded as a nonpositive Hahn series. -/ +def approachZeroNonpositive : HahnSeries.Nonpositive ℝ ℚ := + ⟨approachZero, by + rw [HahnSeries.mem_nonpositiveSubring, approachZero_support] + rintro _ ⟨n, rfl⟩ + exact neg_nonpos.mpr (by + change 0 ≤ 1 / (n + 1 : ℝ) + positivity)⟩ + +/-- Coercing `approachZeroNonpositive` recovers the underlying real Hahn series. -/ +@[simp] +theorem coe_approachZeroNonpositive : + (approachZeroNonpositive : ℚ⟦ℝ⟧) = approachZero := + (rfl) + +/-- The nonpositive `approachZero` series is nonzero. -/ +theorem approachZero_ne_zero : approachZeroNonpositive ≠ 0 := by + intro hzero + have hval := congrArg Subtype.val hzero + change approachZero = (0 : ℚ⟦ℝ⟧) at hval + have hmem : approachZeroEmbedding 0 ∈ approachZero.support := by + rw [approachZero_support] + exact Set.mem_range_self 0 + exact (HahnSeries.support_nonempty_iff.mp ⟨_, hmem⟩) hval + +private theorem approachZero_isLUB : IsLUB approachZero.support 0 := by + rw [approachZero_support] + constructor + · rintro _ ⟨n, rfl⟩ + exact neg_nonpos.mpr (by + change 0 ≤ 1 / (n + 1 : ℝ) + positivity) + · intro a ha + by_contra hnot + have haNeg : a < 0 := lt_of_not_ge hnot + obtain ⟨n, hn⟩ := exists_nat_one_div_lt (neg_pos.mpr haNeg) + have hmem : approachZeroEmbedding n ∈ Set.range approachZeroEmbedding := ⟨n, rfl⟩ + have hle := ha hmem + change -(1 / (n + 1 : ℝ)) ≤ a at hle + linarith + +/-- The support supremum of `approachZero` is zero, although zero is not in its support. -/ +theorem approachZero_supportSup : + HahnSeries.Nonpositive.supportSup approachZeroNonpositive = 0 := by + apply HahnSeries.Nonpositive.supportSup_eq_coe_iff.mpr + exact ⟨approachZero_ne_zero, approachZero_isLUB⟩ + +/-- The supremum zero of `approachZero` is not attained by its support. -/ +theorem zero_not_mem_approachZero_support : 0 ∉ approachZero.support := by + rw [approachZero_support] + rintro ⟨n, hn⟩ + have hneg : approachZeroEmbedding n < 0 := by + change -(1 / (n + 1 : ℝ)) < 0 + exact neg_lt_zero.mpr (by positivity) + exact hneg.ne hn + +/-- The support of `approachZero` has ordinary order type `ω`. -/ +theorem approachZero_supportOrderType : + approachZero.supportOrderType = Ordinal.omega0 := by + rw [HahnSeries.supportOrderType_eq_setOrderType] + have e : approachZero.support ≃o ℕ := + (Set.orderIsoOfEq approachZero.support (Set.range approachZeroEmbedding) + approachZero_support).trans approachZeroEmbedding.orderIso.symm + exact approachZero.isPWO_support.orderType_eq_typeLT_of_orderIso e |>.trans + Ordinal.type_nat_lt + +/-- The Hahn-series degree of `approachZero` is one. -/ +theorem approachZero_degree_eq_one : + (approachZeroNonpositive : ℚ⟦ℝ⟧).degree = + (1 : WithBot NatOrdinal) := by + rw [HahnSeries.degree_eq_cantorDegree, coe_approachZeroNonpositive, + approachZero_supportOrderType, Ordinal.cantorDegree_omega] + +/-- `approachZero` is a nonconstant principal series of support order type `ω`. -/ +theorem approachZero_isPrincipal : + HahnSeries.Nonpositive.IsPrincipal approachZeroNonpositive := by + rw [HahnSeries.Nonpositive.isPrincipal_iff] + constructor + · rw [HahnSeries.isWeaklyPrincipal_iff, coe_approachZeroNonpositive, + approachZero_supportOrderType] + simpa using Ordinal.isAdditivelyPrincipal_omega0_opow 1 + · exact approachZero_supportSup + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Tests/Iterate.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Tests/Iterate.lean new file mode 100644 index 0000000000..7347fa5346 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Tests/Iterate.lean @@ -0,0 +1,43 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Iterate +public import Mathlib.Algebra.Order.Group.Int + +/-! +# API checks for iterated Hahn series + +This file checks the public ring equivalence on nested monomials. Both exponent coordinates are +nonzero and unequal. Their product appears at the coordinatewise sum in outer-then-inner order and +not at the swapped coordinate, separating the intended flattening from the nearest orientation +error. +-/ + +public noncomputable section + +namespace Tests + +open HahnSeries + +/-- A nested monomial with outer exponent `2` and inner exponent `3`. -/ +def firstIteratedMonomial : ℚ⟦ℤ⟧⟦ℤ⟧ := single 2 (single 3 5) + +/-- A nested monomial with outer exponent `7` and inner exponent `11`. -/ +def secondIteratedMonomial : ℚ⟦ℤ⟧⟦ℤ⟧ := single 7 (single 11 13) + +theorem iterateRingEquiv_product_coeff : + (iterateRingEquiv (firstIteratedMonomial * secondIteratedMonomial)).coeff + (toLex ((9 : ℤ), (14 : ℤ))) = 65 := by + simp [firstIteratedMonomial, secondIteratedMonomial, single_mul_single] + norm_num + +theorem iterateRingEquiv_product_coeff_swapped : + (iterateRingEquiv (firstIteratedMonomial * secondIteratedMonomial)).coeff + (toLex ((14 : ℤ), (9 : ℤ))) = 0 := by + simp [firstIteratedMonomial, secondIteratedMonomial, single_mul_single] + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Tests/Multiplicativity.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Tests/Multiplicativity.lean new file mode 100644 index 0000000000..c6c3f8ce6e --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Tests/Multiplicativity.lean @@ -0,0 +1,165 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Multiplicativity + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Degree.Statements.Degree + +/-! +# API checks for LM24 degree multiplicativity + +The zero-factor certificate exposes the missing nonzero hypothesis in the printed first case of +LM24, Lemma 3.4.2: the empty support is strictly above every cutoff, but the claimed strict degree +inequality becomes `⊥ < ⊥`. + +The nonzero monomial certificate exercises the repaired strict-support case at a genuinely +separated cutoff. A separate endpoint theorem shows that replacing `Set.Ioi` by `Set.Ici` would +incorrectly admit the monomial at its own exponent when its degree is zero. + +The final two certificates exercise both the parameterized reduction in LM24, Proposition 3.4.3 +and the characteristic-zero theorem on the same non-weakly-principal series. +-/ + +public noncomputable section + +namespace Tests + +open scoped HahnSeries + +/-- The coefficient-one monomial at exponent `-1`, regarded as nonpositive. -/ +def negativeOneMonomial : HahnSeries.Nonpositive ℝ ℚ := + HahnSeries.Nonpositive.single (-1) 1 (by norm_num) + +@[simp] +theorem negativeOneMonomial_coe : + (negativeOneMonomial : ℚ⟦ℝ⟧) = HahnSeries.single (-1) 1 := + by + simpa only [negativeOneMonomial] using + HahnSeries.Nonpositive.coe_single (-1 : ℝ) (1 : ℚ) (by norm_num) + +theorem negativeOneMonomial_ne_zero : negativeOneMonomial ≠ 0 := by + intro hzero + have hcoeff := congrArg + (fun x : HahnSeries.Nonpositive ℝ ℚ ↦ (x : ℚ⟦ℝ⟧).coeff (-1)) hzero + norm_num [negativeOneMonomial] at hcoeff + +/-- The monomial support lies strictly above the cutoff `-2`. -/ +theorem negativeOneMonomial_support_subset_Ioi_neg_two : + (negativeOneMonomial : ℚ⟦ℝ⟧).support ⊆ Set.Ioi (-2) := by + intro i hi + rw [negativeOneMonomial_coe] at hi + have hi' : i = -1 := HahnSeries.eq_of_mem_support_single hi + rw [hi'] + norm_num + +/-- Repaired LM24, Lemma 3.4.2(1) applies to a nonzero separated monomial. -/ +theorem strictSupport_truncation_degree_lt : + (HahnSeries.truncLE (-2) + (((1 : HahnSeries.Nonpositive ℝ ℚ) * negativeOneMonomial : + HahnSeries.Nonpositive ℝ ℚ) : ℚ⟦ℝ⟧)).degree < + ((1 : HahnSeries.Nonpositive ℝ ℚ) : ℚ⟦ℝ⟧).degree + + (negativeOneMonomial : ℚ⟦ℝ⟧).degree := by + exact HahnSeries.Nonpositive.degree_truncLE_mul_lt + HahnSeries.Nonpositive.isPrincipal_one negativeOneMonomial_ne_zero + (Or.inl negativeOneMonomial_support_subset_Ioi_neg_two) + +/-- At its own exponent, the monomial support is weakly but not strictly above the cutoff. -/ +theorem negativeOneMonomial_endpoint_separator : + (negativeOneMonomial : ℚ⟦ℝ⟧).support ⊆ Set.Ici (-1) ∧ + ¬(negativeOneMonomial : ℚ⟦ℝ⟧).support ⊆ Set.Ioi (-1) := by + constructor + · intro i hi + rw [negativeOneMonomial_coe] at hi + rw [HahnSeries.eq_of_mem_support_single hi] + exact (le_rfl : (-1 : ℝ) ≤ -1) + · intro h + have hmem : + (-1 : ℝ) ∈ (negativeOneMonomial : ℚ⟦ℝ⟧).support := by + rw [negativeOneMonomial_coe, HahnSeries.support_single_of_ne one_ne_zero] + simp + exact (lt_irrefl (-1 : ℝ)) (h hmem) + +/-- Counterexample to the first case of the printed LM24, Lemma 3.4.2 when `c = 0`. -/ +theorem printed_degree_truncLE_mul_lt_case_one_zero_counterexample (x : ℝ) : + ((0 : HahnSeries.Nonpositive ℝ ℚ) : ℚ⟦ℝ⟧).support ⊆ Set.Ioi x ∧ + ¬(HahnSeries.truncLE x + (((1 : HahnSeries.Nonpositive ℝ ℚ) * 0 : + HahnSeries.Nonpositive ℝ ℚ) : ℚ⟦ℝ⟧)).degree < + ((1 : HahnSeries.Nonpositive ℝ ℚ) : ℚ⟦ℝ⟧).degree + + ((0 : HahnSeries.Nonpositive ℝ ℚ) : ℚ⟦ℝ⟧).degree := by + constructor + · simp + · simp + +/-- A two-term nonpositive series whose support order type is two. -/ +def twoTermNonprincipal : HahnSeries.Nonpositive ℝ ℚ := + negativeOneMonomial + 1 + +private theorem twoTermNonprincipal_coe : + (twoTermNonprincipal : ℚ⟦ℝ⟧) = + HahnSeries.single (-1) 1 + HahnSeries.single 0 1 := by + ext i + simp [twoTermNonprincipal, negativeOneMonomial] + +theorem twoTermNonprincipal_supportOrderType : + (twoTermNonprincipal : ℚ⟦ℝ⟧).supportOrderType = 2 := by + have hbelow : + HahnSeries.SupportBelow + (HahnSeries.single (-1 : ℝ) (1 : ℚ)) + (HahnSeries.single 0 (1 : ℚ)) := by + rw [HahnSeries.supportBelow_iff] + intro i hi j hj + rw [HahnSeries.eq_of_mem_support_single hi, + HahnSeries.eq_of_mem_support_single hj] + norm_num + rw [twoTermNonprincipal_coe] + have htype := (HahnSeries.supportOrderType_eq_add_iff + (HahnSeries.single (-1 : ℝ) (1 : ℚ) + HahnSeries.single 0 1) + 1 1).mpr + ⟨HahnSeries.single (-1) 1, HahnSeries.single 0 1, hbelow, + HahnSeries.supportOrderType_single one_ne_zero, + HahnSeries.supportOrderType_single one_ne_zero, + rfl⟩ + calc + (HahnSeries.single (-1 : ℝ) (1 : ℚ) + + HahnSeries.single 0 1).supportOrderType = + (1 : Ordinal) + 1 := htype + _ = 2 := by norm_num + +/-- The two-term series is not weakly principal; support order type two is not a power of `ω`. -/ +theorem twoTermNonprincipal_not_isWeaklyPrincipal : + ¬HahnSeries.IsWeaklyPrincipal (twoTermNonprincipal : ℚ⟦ℝ⟧) := by + intro hprincipal + have hp := + (Ordinal.isAdditivelyPrincipal_iff_ne_zero_and_isPrincipal_add.mp + (HahnSeries.isWeaklyPrincipal_iff.mp hprincipal)).2 + rw [twoTermNonprincipal_supportOrderType] at hp + have hone : (1 : Ordinal) < 2 := by norm_num + have hfalse := hp hone hone + norm_num at hfalse + +/-- The parameterized LM24, Proposition 3.4.3 applies beyond weakly principal factors. -/ +theorem twoTermNonprincipal_square_degree_of_orderTypeMultiplicative + (h : + HahnSeries.Nonpositive.OrderTypeMultiplicativeOnWeaklyPrincipal ℚ) : + ((twoTermNonprincipal * twoTermNonprincipal : + HahnSeries.Nonpositive ℝ ℚ) : ℚ⟦ℝ⟧).degree = + (twoTermNonprincipal : ℚ⟦ℝ⟧).degree + + (twoTermNonprincipal : ℚ⟦ℝ⟧).degree := + HahnSeries.Nonpositive.degree_mul_of_orderTypeMultiplicativeOnWeaklyPrincipal + h twoTermNonprincipal twoTermNonprincipal + +/-- LM24, Theorem D applies beyond the weakly-principal input class used in its Berarducci +prerequisite. -/ +theorem twoTermNonprincipal_square_degree : + ((twoTermNonprincipal * twoTermNonprincipal : + HahnSeries.Nonpositive ℝ ℚ) : ℚ⟦ℝ⟧).degree = + (twoTermNonprincipal : ℚ⟦ℝ⟧).degree + + (twoTermNonprincipal : ℚ⟦ℝ⟧).degree := + HahnSeries.Nonpositive.degree_mul _ _ + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Tests/NegativePresentation.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Tests/NegativePresentation.lean new file mode 100644 index 0000000000..89dfee48f3 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Tests/NegativePresentation.lean @@ -0,0 +1,84 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Negative +public import Mathlib.Algebra.Order.Ring.Rat +import Mathlib.Tactic.NormNum + +/-! +# API checks for the strictly negative presentation + +This file checks the public presentation of a truncation integer part as the pointwise sum of +integral constants and strictly negative Hahn series. The examples distinguish strict-negative +support from nonpositive support, exercise multiplication in the nonunital negative ring, and +verify existence and uniqueness for a nonconstant element of `TIP(ℤ, ℚ, ℚ)`. +-/ + +public noncomputable section + +namespace Tests + +open scoped Pointwise + +open HahnSeries + +/-- The monomial `3t⁻¹`, regarded as a strictly negative rational Hahn series. -/ +def negativeMonomial : Negative ℚ ℚ := + Negative.single (-1) 3 (by norm_num) + +theorem negativeMonomial_coeff_neg_one : + (negativeMonomial : HahnSeries ℚ ℚ).coeff (-1) = 3 := by + simp [negativeMonomial] + +theorem negativeMonomial_constantCoeff : + Nonpositive.constantCoeff (Γ := ℚ) (R := ℚ) negativeMonomial = 0 := + Negative.constantCoeff_eq_zero negativeMonomial + +theorem one_not_mem_negativeIdeal : + (1 : Nonpositive ℚ ℚ) ∉ negativeIdeal ℚ ℚ := by + intro h + have hzero := Negative.constantCoeff_eq_zero + (⟨1, h⟩ : Negative ℚ ℚ) + simp at hzero + +theorem negativeMonomial_mul_self_coeff_neg_two : + (((negativeMonomial * negativeMonomial : Negative ℚ ℚ) : Nonpositive ℚ ℚ) : + HahnSeries ℚ ℚ).coeff (-2) = 9 := by + norm_num [negativeMonomial] + +/-- The series `2 + 3t⁻¹` in the nonpositive rational Hahn ring. -/ +def presentedIntegerPartSeries : Nonpositive ℚ ℚ := + Nonpositive.C (Γ := ℚ) (R := ℚ) 2 + (negativeMonomial : Nonpositive ℚ ℚ) + +theorem presentedIntegerPartSeries_mem : + presentedIntegerPartSeries ∈ truncationIntegerPart ℚ (⊥ : Subring ℚ) := by + apply (mem_truncationIntegerPart_iff_exists_add_negative + (Γ := ℚ) (R := ℚ)).mpr + exact ⟨2, negativeMonomial, rfl⟩ + +theorem presentedIntegerPartSeries_negativePart : + Nonpositive.negativePart ℚ ℚ presentedIntegerPartSeries = negativeMonomial := by + simp [presentedIntegerPartSeries] + +theorem presentedIntegerPartSeries_decomposition_unique + (z : (⊥ : Subring ℚ)) (n : Negative ℚ ℚ) + (h : presentedIntegerPartSeries = + Nonpositive.C (Γ := ℚ) (R := ℚ) z + (n : Nonpositive ℚ ℚ)) : + z = 2 ∧ n = negativeMonomial := by + apply (constant_add_negative_eq_iff (Γ := ℚ) (R := ℚ)).mp + have htwo : ((2 : (⊥ : Subring ℚ)) : ℚ) = 2 := + Subring.coe_natCast (⊥ : Subring ℚ) 2 + simpa only [presentedIntegerPartSeries, htwo] using h.symm + +theorem rational_truncationIntegerPart_carrier : + (truncationIntegerPart ℚ (⊥ : Subring ℚ) : Set (Nonpositive ℚ ℚ)) = + (constantSubring ℚ ℚ (⊥ : Subring ℚ) : Set (Nonpositive ℚ ℚ)) + + (negativeIdeal ℚ ℚ : Set (Nonpositive ℚ ℚ)) := + coe_truncationIntegerPart_eq_constantSubring_add_negativeIdeal ℚ ℚ + (⊥ : Subring ℚ) + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Tests/NonpositiveDomainEquiv.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Tests/NonpositiveDomainEquiv.lean new file mode 100644 index 0000000000..c13c99a24e --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Tests/NonpositiveDomainEquiv.lean @@ -0,0 +1,59 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.NonpositiveDomainEquiv + +/-! +# API checks for nonpositive Hahn-series exponent equivalences + +The negative monomial below is nonconstant and has genuinely negative support. The checks show +that exponent reindexing preserves its selected coefficient and that the inverse recovers the +series. A polymorphic theorem separately exercises the cross-universe support-order-type API. +-/ + +public noncomputable section + +open scoped HahnSeries + +namespace Tests + +open HahnSeries.Nonpositive + +/-- The identity ordered additive equivalence of the integer exponent group. -/ +def integerExponentEquiv : ℤ ≃+o ℤ := + OrderAddMonoidIso.refl ℤ + +/-- The rational monomial `7t⁻²` used to check reindexing by an exponent equivalence. -/ +def negativeIntegerMonomial : HahnSeries.Nonpositive ℤ ℚ := + single (-2) 7 (by omega) + +theorem negativeIntegerMonomial_reindex_coeff : + ((embDomainRingEquiv integerExponentEquiv negativeIntegerMonomial : + HahnSeries.Nonpositive ℤ ℚ) : HahnSeries ℤ ℚ).coeff + (integerExponentEquiv (-2)) = 7 := by + rw [coe_embDomainRingEquiv, HahnSeries.embDomainRingEquiv_coeff] + simp [negativeIntegerMonomial] + +theorem negativeIntegerMonomial_reindex_roundtrip : + (embDomainRingEquiv integerExponentEquiv).symm + (embDomainRingEquiv integerExponentEquiv negativeIntegerMonomial) = + negativeIntegerMonomial := + (embDomainRingEquiv integerExponentEquiv).symm_apply_apply negativeIntegerMonomial + +universe u v w + +theorem reindex_lift_supportOrderType + {G : Type u} {H : Type v} {K : Type w} + [LinearOrder G] [AddCommGroup G] [IsOrderedAddMonoid G] + [LinearOrder H] [AddCommGroup H] [IsOrderedAddMonoid H] [CommRing K] + (e : G ≃+o H) (x : HahnSeries.Nonpositive G K) : + Ordinal.lift.{u, v} + (HahnSeries.supportOrderType (embDomainRingEquiv e x : K⟦H⟧)) = + Ordinal.lift.{v, u} (HahnSeries.supportOrderType (x : K⟦G⟧)) := + lift_supportOrderType_embDomainRingEquiv e x + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Tests/NormalForm.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Tests/NormalForm.lean new file mode 100644 index 0000000000..282781dae4 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Tests/NormalForm.lean @@ -0,0 +1,180 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Tests.Fixtures.ApproachZero +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Domain +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Multiplicativity + +/-! +# API checks for LM24 principal series and normal forms + +The series `approachZero` has coefficient one at every exponent `-1/(n+1)`. Its support has order +type `ω`, has supremum zero, and does not contain zero. It therefore certifies that support +supremum is a genuine least upper bound rather than a maximum and gives a nonconstant principal +series. + +Adding the constant term gives the exact example from LM24, Remark 3.3.10. Its normal form has an +infinite principal coefficient at exponent zero followed by the constant principal coefficient at +the same exponent. This separates the source definition from the incorrect variant requiring +strictly increasing exponents. + +The series supported on `ℕ ⊆ ℝ` is unbounded above. The final certificate proves that it has +no finite normal form, exercising the obstruction in LM24, Remark 3.3.9 instead of merely checking +the existence theorem on its nonpositive domain. + +The same `approachZero` fixture exercises the weak-support, positive-degree branch of the repaired +LM24, Lemma 3.4.2 at its minimum exponent. +-/ + +public noncomputable section + +namespace Tests + +open scoped HahnSeries + +/-- The empty list is the normal form of the zero series. -/ +theorem zero_normalForm : + HahnSeries.IsNormalForm (0 : ℚ⟦ℝ⟧) [] := by + rw [HahnSeries.isNormalForm_iff] + simp [List.sortedLE_iff_pairwise, List.sortedGE_iff_pairwise] + +/-- Every normal form of the zero series is empty. -/ +theorem zero_normalForm_unique (terms : List (HahnSeries.NormalForm.Term ℚ)) + (hterms : HahnSeries.IsNormalForm (0 : ℚ⟦ℝ⟧) terms) : + terms = [] := + hterms.unique zero_normalForm + +private theorem approachZero_support_subset_Ici_neg_one : + (approachZeroNonpositive : ℚ⟦ℝ⟧).support ⊆ Set.Ici (-1) := by + rw [coe_approachZeroNonpositive, approachZero_support] + rintro _ ⟨n, rfl⟩ + rw [approachZeroEmbedding_apply] + change -1 ≤ -(1 / (n + 1 : ℝ)) + apply neg_le_neg + simpa using one_div_le_one_div_of_le (a := (1 : ℝ)) + (b := n + 1) (by norm_num) (by norm_num) + +private theorem approachZero_degree : + (approachZeroNonpositive : ℚ⟦ℝ⟧).degree = + (1 : WithBot NatOrdinal) := by + rw [HahnSeries.degree_eq_cantorDegree, coe_approachZeroNonpositive, + approachZero_supportOrderType, Ordinal.cantorDegree_omega] + +/-- The positive-degree branch of repaired LM24, Lemma 3.4.2 applies at the attained minimum +exponent of the infinite principal series. -/ +theorem approachZero_positiveDegree_truncation_degree_lt : + (HahnSeries.truncLE (-1) + (((1 : HahnSeries.Nonpositive ℝ ℚ) * approachZeroNonpositive : + HahnSeries.Nonpositive ℝ ℚ) : ℚ⟦ℝ⟧)).degree < + ((1 : HahnSeries.Nonpositive ℝ ℚ) : ℚ⟦ℝ⟧).degree + + (approachZeroNonpositive : ℚ⟦ℝ⟧).degree := by + apply HahnSeries.Nonpositive.degree_truncLE_mul_lt + · exact HahnSeries.Nonpositive.isPrincipal_one + · exact approachZero_ne_zero + · right + refine ⟨approachZero_support_subset_Ici_neg_one, ?_⟩ + rw [approachZero_degree] + norm_num + +/-- The constant series one in the nonpositive Hahn ring. -/ +def constantOneNonpositive : HahnSeries.Nonpositive ℝ ℚ := + HahnSeries.Nonpositive.C 1 + +private theorem constantOne_supportOrderType : + (constantOneNonpositive : ℚ⟦ℝ⟧).supportOrderType = 1 := by + simpa [constantOneNonpositive, HahnSeries.Nonpositive.coe_C, + HahnSeries.C_apply] using + HahnSeries.supportOrderType_single (a := (0 : ℝ)) (r := (1 : ℚ)) one_ne_zero + +/-- The constant series one is principal. -/ +theorem constantOne_isPrincipal : + HahnSeries.Nonpositive.IsPrincipal constantOneNonpositive := by + exact HahnSeries.Nonpositive.isPrincipal_C one_ne_zero + +/-- The infinite principal term at exponent zero. -/ +def approachZeroTerm : HahnSeries.NormalForm.Term ℚ := + ⟨approachZeroNonpositive, 0⟩ + +/-- The constant principal term at exponent zero. -/ +def constantOneTerm : HahnSeries.NormalForm.Term ℚ := + ⟨constantOneNonpositive, 0⟩ + +/-- LM24's `ω + 1` example has a two-term normal form in which exponent zero occurs twice. -/ +theorem repeatedZeroExponentNormalForm : + HahnSeries.IsNormalForm + (approachZero + 1) [approachZeroTerm, constantOneTerm] := by + rw [HahnSeries.isNormalForm_iff_isChain] + refine ⟨?_, ?_, ?_, ?_, ?_⟩ + · ext x + simp [approachZeroTerm, constantOneTerm, + coe_approachZeroNonpositive, constantOneNonpositive] + · simp [approachZeroTerm, constantOneTerm, List.sortedLE_iff_pairwise] + · intro t ht + simp only [List.mem_cons, List.not_mem_nil, or_false] at ht + rcases ht with rfl | rfl + · exact approachZero_isPrincipal + · exact constantOne_isPrincipal + · simp only [approachZeroTerm, constantOneTerm, List.map_cons, List.map_nil, + constantOne_supportOrderType, coe_approachZeroNonpositive, + approachZero_supportOrderType] + rw [List.sortedGE_iff_pairwise] + simp [Ordinal.one_lt_omega0.le] + · apply List.isChain_pair.mpr + rw [HahnSeries.supportBelow_iff] + intro i hi j hj + have hj0 : j = 0 := by + simpa [constantOneTerm, constantOneNonpositive, + HahnSeries.NormalForm.Term.series_eq_translate] using hj + subst j + rw [approachZeroTerm, HahnSeries.NormalForm.Term.series_eq_translate, + HahnSeries.translate_zero_apply] at hi + rw [coe_approachZeroNonpositive, approachZero_support] at hi + obtain ⟨n, rfl⟩ := hi + rw [approachZeroEmbedding_apply] + change -(1 / (n + 1 : ℝ)) < 0 + exact neg_lt_zero.mpr (by positivity) + +/-- The order embedding of the natural numbers into the reals. -/ +def natCastEmbedding : ℕ ↪o ℝ := + OrderEmbedding.ofStrictMono _ Nat.strictMono_cast + +/-- The coefficient-one series on the unbounded support `ℕ ⊆ ℝ`. -/ +def unboundedSeries : ℚ⟦ℝ⟧ := + HahnSeries.embDomain natCastEmbedding natOnes + +private theorem unboundedSeries_support : + unboundedSeries.support = Set.range natCastEmbedding := by + rw [unboundedSeries, HahnSeries.support_embDomain] + simp + +private theorem unboundedSeries_supportOrderType : + unboundedSeries.supportOrderType = Ordinal.omega0 := by + rw [HahnSeries.supportOrderType_eq_setOrderType] + have e : unboundedSeries.support ≃o ℕ := + (Set.orderIsoOfEq unboundedSeries.support (Set.range natCastEmbedding) + unboundedSeries_support).trans natCastEmbedding.orderIso.symm + exact unboundedSeries.isPWO_support.orderType_eq_typeLT_of_orderIso e |>.trans + Ordinal.type_nat_lt + +/-- The unbounded coefficient-one series is weakly principal of support order type `ω`. -/ +theorem unboundedSeries_isWeaklyPrincipal : + HahnSeries.IsWeaklyPrincipal unboundedSeries := by + rw [HahnSeries.isWeaklyPrincipal_iff, unboundedSeries_supportOrderType] + simpa using Ordinal.isAdditivelyPrincipal_omega0_opow 1 + +/-- The unbounded weakly principal series in LM24, Remark 3.3.9 has no finite normal form. -/ +theorem unboundedSeries_has_no_normalForm : + ∀ terms : List (HahnSeries.NormalForm.Term ℚ), + ¬HahnSeries.IsNormalForm unboundedSeries terms := by + intro terms hnormal + obtain ⟨a, ha⟩ := hnormal.bddAbove_support + rw [unboundedSeries_support] at ha + obtain ⟨n, hn⟩ := exists_nat_gt a + have hle := ha ⟨n, rfl⟩ + exact (not_le_of_gt hn) hle + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Tests/OrderTypeDegree.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Tests/OrderTypeDegree.lean new file mode 100644 index 0000000000..571120c37e --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Tests/OrderTypeDegree.lean @@ -0,0 +1,358 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrderType +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.HahnSeries.Degree +public import Mathlib.Data.Prod.Lex +public import Mathlib.Data.Sum.Order + +import Mathlib.Data.Finsupp.Basic +import Mathlib.Data.Finsupp.Single + +/-! +# API checks for support order type and degree + +This client imports the public order-type and degree interface from a separate module. Its +coefficient-one series have supports of ordinary ordinal types `1 + ω = ω`, `ω + ω`, and +`(ω + 1) * ω = ω²`. The asymmetric sum and product distinguish ordinary ordinal arithmetic from +Hessenberg arithmetic at the level of order type. The degree certificates separately distinguish +LM24's leading-Cantor-exponent degree from the support order type itself and from the incorrect rule +that two consecutive infinite blocks have degree two. + +The `ω + ω` fixture tests the ordinal calculation independently of any displayed real-exponent +series. The finite fixture has two support points, while the zero fixture is checked separately, +so degree zero cannot accidentally include the zero series. +-/ + +universe u + +public noncomputable section + +namespace Tests + +open Ordinal +open scoped HahnSeries + +/-- A Hessenberg sum of terms of degrees two and one has degree two, not three. -/ +theorem naturalSumDegree_separator : + NatOrdinal.cantorDegree (ω^ (2 : NatOrdinal) + ω^ (1 : NatOrdinal)) = 2 := by + rw [NatOrdinal.cantorDegree_add, NatOrdinal.cantorDegree_wpow, + NatOrdinal.cantorDegree_wpow] + simp + +/-- The absorbing bottom value records that a Hessenberg product with zero is zero. -/ +theorem naturalProductDegree_zero : + NatOrdinal.cantorDegree ((0 : NatOrdinal) * ω^ (2 : NatOrdinal)) = ⊥ := by + simp + +private theorem naturalProductDegree_asymmetric : + NatOrdinal.cantorDegree + (ω^ (1 : NatOrdinal) * ω^ NatOrdinal.of Ordinal.omega0) = + (NatOrdinal.of (Ordinal.omega0 + 1) : WithBot NatOrdinal) := by + rw [NatOrdinal.cantorDegree_mul, NatOrdinal.cantorDegree_wpow, + NatOrdinal.cantorDegree_wpow, ← WithBot.coe_add, WithBot.coe_eq_coe, + add_comm, ← NatOrdinal.of_add_one] + +private theorem ordinaryProductDegree_asymmetric : + Ordinal.cantorDegree + (Ordinal.omega0 * Ordinal.omega0 ^ Ordinal.omega0) = + (NatOrdinal.of Ordinal.omega0 : WithBot NatOrdinal) := by + have hproduct : Ordinal.omega0 * Ordinal.omega0 ^ Ordinal.omega0 = + Ordinal.omega0 ^ Ordinal.omega0 := by + calc + Ordinal.omega0 * Ordinal.omega0 ^ Ordinal.omega0 = + Ordinal.omega0 ^ (1 : Ordinal) * + Ordinal.omega0 ^ Ordinal.omega0 := by + rw [Ordinal.opow_one] + _ = Ordinal.omega0 ^ ((1 : Ordinal) + Ordinal.omega0) := by + exact (Ordinal.opow_add Ordinal.omega0 1 Ordinal.omega0).symm + _ = Ordinal.omega0 ^ Ordinal.omega0 := by rw [Ordinal.one_add_omega0] + rw [hproduct, + Ordinal.cantorDegree_of_ne_zero + (Ordinal.opow_ne_zero Ordinal.omega0 Ordinal.omega0_ne_zero), + Ordinal.log_opow Ordinal.one_lt_omega0] + +/-- Hessenberg and ordinary multiplication can have different leading Cantor exponents. -/ +theorem naturalProductDegree_ne_ordinaryProductDegree : + NatOrdinal.cantorDegree + (ω^ (1 : NatOrdinal) * ω^ NatOrdinal.of Ordinal.omega0) ≠ + Ordinal.cantorDegree + (Ordinal.omega0 * Ordinal.omega0 ^ Ordinal.omega0) := by + rw [naturalProductDegree_asymmetric, ordinaryProductDegree_asymmetric] + intro h + have h' : NatOrdinal.of (Ordinal.omega0 + 1) = + NatOrdinal.of Ordinal.omega0 := WithBot.coe_eq_coe.mp h + exact (lt_add_one Ordinal.omega0).ne' (NatOrdinal.of.injective h') + +private def cancelingSeries : ℤ⟦ℤ⟧ := + HahnSeries.single 0 1 + +private theorem cancelingSeries_ne_zero : cancelingSeries ≠ 0 := by + simp [cancelingSeries] + +private theorem cancelingSeries_support_finite : cancelingSeries.support.Finite := + (Set.finite_singleton 0).subset HahnSeries.support_single_subset + +private theorem cancelingSeries_degree : cancelingSeries.degree = 0 := + HahnSeries.degree_eq_zero.mpr + ⟨cancelingSeries_ne_zero, cancelingSeries_support_finite⟩ + +private theorem neg_cancelingSeries_degree : (-cancelingSeries).degree = 0 := by + apply HahnSeries.degree_eq_zero.mpr + constructor + · simpa using cancelingSeries_ne_zero + · exact cancelingSeries_support_finite.subset (HahnSeries.support_neg_subset _) + +/-- LM24's additive degree inequality applies in a cancellation case and can be strict. -/ +theorem degree_add_cancellation_boundary : + ∃ x : ℤ⟦ℤ⟧, + (x + -x).degree ≤ max x.degree (-x).degree ∧ + (x + -x).degree < max x.degree (-x).degree := by + refine ⟨cancelingSeries, HahnSeries.degree_add_le _ _, ?_⟩ + rw [add_neg_cancel, HahnSeries.degree_zero, cancelingSeries_degree, + neg_cancelingSeries_degree] + simp + +private def twoTermCoeffs : ℤ →₀ ℕ := + Finsupp.single 0 1 + Finsupp.single 1 1 + +/-- The Hahn series with coefficient one at exponents `0` and `1`. -/ +def twoTermOrderTypeSeries : ℕ⟦ℤ⟧ := + HahnSeries.ofFinsupp twoTermCoeffs + +/-- `twoTermOrderTypeSeries` has support `{0, 1}`. -/ +@[simp] +theorem twoTermOrderTypeSeries_support : + twoTermOrderTypeSeries.support = {0, 1} := by + classical + ext z + by_cases hz0 : z = 0 + · simp [twoTermOrderTypeSeries, twoTermCoeffs, hz0] + by_cases hz1 : z = 1 + · simp [twoTermOrderTypeSeries, twoTermCoeffs, hz1] + · simp [twoTermOrderTypeSeries, twoTermCoeffs, hz0, hz1] + +theorem twoTermOrderTypeSeries_ne_zero : twoTermOrderTypeSeries ≠ 0 := by + apply HahnSeries.support_nonempty_iff.mp + rw [twoTermOrderTypeSeries_support] + simp + +theorem twoTermOrderTypeSeries_support_finite : + twoTermOrderTypeSeries.support.Finite := by + rw [twoTermOrderTypeSeries_support] + simp + +/-- A nonzero series with two support points has degree zero. -/ +theorem twoTermOrderTypeSeries_degree : + twoTermOrderTypeSeries.degree = (0 : WithBot NatOrdinal) := + HahnSeries.degree_eq_zero.mpr + ⟨twoTermOrderTypeSeries_ne_zero, twoTermOrderTypeSeries_support_finite⟩ + +/-- Interface smoke test: the multiplicative degree bound applies to two nonzero series whose +supports each have exactly two points. -/ +theorem twoTermOrderTypeSeries_square_degree_le : + twoTermOrderTypeSeries ≠ 0 ∧ + (twoTermOrderTypeSeries * twoTermOrderTypeSeries).degree ≤ + twoTermOrderTypeSeries.degree + twoTermOrderTypeSeries.degree := + ⟨twoTermOrderTypeSeries_ne_zero, HahnSeries.degree_mul_le _ _⟩ + +/-- The zero series has degree `⊥`, rather than degree zero. -/ +theorem zeroOrderTypeSeries_degree : + (0 : ℕ⟦ℤ⟧).degree = ⊥ := + HahnSeries.degree_zero + +private instance : WellFoundedLT (Unit ⊕ₗ ℕ) := + (Sum.Lex.toLexRelIsoLT (α := Unit) (β := ℕ)).symm.toRelEmbedding.wellFounded' + +/-- The coefficient-one Hahn series on the ordered sum of `Unit` and `ℕ`. -/ +def oneAddOmegaOrderTypeSeries : ℕ⟦Unit ⊕ₗ ℕ⟧ where + coeff _ := 1 + isPWO_support' := by + simpa [Function.support] using + Set.IsPWO.of_linearOrder (Set.univ : Set (Unit ⊕ₗ ℕ)) + +@[simp] +theorem oneAddOmegaOrderTypeSeries_support : + oneAddOmegaOrderTypeSeries.support = Set.univ := by + ext n + simp [oneAddOmegaOrderTypeSeries] + +theorem oneAddOmegaOrderTypeSeries_supportOrderType : + oneAddOmegaOrderTypeSeries.supportOrderType = Ordinal.omega0 := by + calc + oneAddOmegaOrderTypeSeries.supportOrderType = typeLT (Unit ⊕ₗ ℕ) := by + let e : oneAddOmegaOrderTypeSeries.support ≃o Unit ⊕ₗ ℕ := + (Set.orderIsoOfEq oneAddOmegaOrderTypeSeries.support Set.univ + oneAddOmegaOrderTypeSeries_support).trans + (OrderIso.Set.univ (α := Unit ⊕ₗ ℕ)) + exact HahnSeries.supportOrderType_eq_typeLT e + _ = Ordinal.type (Sum.Lex (· < · : Unit → Unit → Prop) + (· < · : ℕ → ℕ → Prop)) := + (Sum.Lex.toLexRelIsoLT (α := Unit) (β := ℕ)).ordinalType_congr.symm + _ = Ordinal.omega0 := by + rw [Ordinal.type_sum_lex, Ordinal.type_nat_lt] + simp + +theorem oneAddOmegaOrderTypeSeries_degree : + oneAddOmegaOrderTypeSeries.degree = (1 : WithBot NatOrdinal) := by + rw [HahnSeries.degree_eq_cantorDegree, oneAddOmegaOrderTypeSeries_supportOrderType, + Ordinal.cantorDegree_omega] + +/-- Ordinary `1 + ω` differs from the Hessenberg sum of `1` and `ω`. -/ +theorem naturalOneAddOmega_ne_supportOrderType : + NatOrdinal.of (1 : Ordinal) + NatOrdinal.of Ordinal.omega0 ≠ + NatOrdinal.of oneAddOmegaOrderTypeSeries.supportOrderType := by + rw [oneAddOmegaOrderTypeSeries_supportOrderType] + intro h + rw [add_comm] at h + have hone : NatOrdinal.of (1 : Ordinal) = 1 := rfl + rw [hone, ← NatOrdinal.of_add_one] at h + exact (lt_add_one Ordinal.omega0).ne' (NatOrdinal.of.injective h) + +private instance : WellFoundedLT (ℕ ⊕ₗ ℕ) := + (Sum.Lex.toLexRelIsoLT (α := ℕ) (β := ℕ)).symm.toRelEmbedding.wellFounded' + +/-- The coefficient-one Hahn series on the ordered sum of two copies of `ℕ`. -/ +def omegaAddOmegaOrderTypeSeries : ℕ⟦ℕ ⊕ₗ ℕ⟧ where + coeff _ := 1 + isPWO_support' := by + simpa [Function.support] using + Set.IsPWO.of_linearOrder (Set.univ : Set (ℕ ⊕ₗ ℕ)) + +@[simp] +theorem omegaAddOmegaOrderTypeSeries_support : + omegaAddOmegaOrderTypeSeries.support = Set.univ := by + ext n + simp [omegaAddOmegaOrderTypeSeries] + +theorem omegaAddOmegaOrderTypeSeries_supportOrderType : + omegaAddOmegaOrderTypeSeries.supportOrderType = + Ordinal.omega0 + Ordinal.omega0 := by + calc + omegaAddOmegaOrderTypeSeries.supportOrderType = typeLT (ℕ ⊕ₗ ℕ) := by + let e : omegaAddOmegaOrderTypeSeries.support ≃o ℕ ⊕ₗ ℕ := + (Set.orderIsoOfEq omegaAddOmegaOrderTypeSeries.support Set.univ + omegaAddOmegaOrderTypeSeries_support).trans + (OrderIso.Set.univ (α := ℕ ⊕ₗ ℕ)) + exact HahnSeries.supportOrderType_eq_typeLT e + _ = Ordinal.type (Sum.Lex (· < ·) (· < ·)) := + (Sum.Lex.toLexRelIsoLT (α := ℕ) (β := ℕ)).ordinalType_congr.symm + _ = Ordinal.omega0 + Ordinal.omega0 := by + rw [Ordinal.type_sum_lex, Ordinal.type_nat_lt] + +/-- A support of ordinary ordinal type `ω + ω` has degree one. -/ +theorem omegaAddOmegaOrderTypeSeries_degree : + omegaAddOmegaOrderTypeSeries.degree = (1 : WithBot NatOrdinal) := by + rw [HahnSeries.degree_eq_cantorDegree, omegaAddOmegaOrderTypeSeries_supportOrderType, + Ordinal.cantorDegree_omega_add_omega] + +private instance : WellFoundedLT (ℕ ⊕ₗ Unit) := + (Sum.Lex.toLexRelIsoLT (α := ℕ) (β := Unit)).symm.toRelEmbedding.wellFounded' + +/-- A coefficient-one Hahn series whose support has ordinary type `(ω + 1) * ω`. -/ +def omegaSuccTimesOmegaOrderTypeSeries : ℕ⟦ℕ ×ₗ (ℕ ⊕ₗ Unit)⟧ where + coeff _ := 1 + isPWO_support' := by + simpa [Function.support] using + Set.IsPWO.of_linearOrder (Set.univ : Set (ℕ ×ₗ (ℕ ⊕ₗ Unit))) + +@[simp] +theorem omegaSuccTimesOmegaOrderTypeSeries_support : + omegaSuccTimesOmegaOrderTypeSeries.support = Set.univ := by + ext n + simp [omegaSuccTimesOmegaOrderTypeSeries] + +theorem omegaSuccTimesOmegaOrderTypeSeries_supportOrderType : + omegaSuccTimesOmegaOrderTypeSeries.supportOrderType = + Ordinal.omega0 ^ (2 : Ordinal) := by + calc + omegaSuccTimesOmegaOrderTypeSeries.supportOrderType = + typeLT (ℕ ×ₗ (ℕ ⊕ₗ Unit)) := by + let e : omegaSuccTimesOmegaOrderTypeSeries.support ≃o ℕ ×ₗ (ℕ ⊕ₗ Unit) := + (Set.orderIsoOfEq omegaSuccTimesOmegaOrderTypeSeries.support Set.univ + omegaSuccTimesOmegaOrderTypeSeries_support).trans + (OrderIso.Set.univ (α := ℕ ×ₗ (ℕ ⊕ₗ Unit))) + exact HahnSeries.supportOrderType_eq_typeLT e + _ = (typeLT (ℕ ⊕ₗ Unit)) * (typeLT ℕ) := by + -- The strict order on the lexicographic product synonym is definitionally `Prod.Lex`. + change Ordinal.type + (Prod.Lex (· < · : ℕ → ℕ → Prop) + (· < · : (ℕ ⊕ₗ Unit) → (ℕ ⊕ₗ Unit) → Prop)) = _ + exact Ordinal.type_prod_lex (· < ·) (· < ·) + _ = (Ordinal.omega0 + 1) * Ordinal.omega0 := by + rw [Ordinal.type_nat_lt] + congr 1 + calc + typeLT (ℕ ⊕ₗ Unit) = + Ordinal.type (Sum.Lex (· < · : ℕ → ℕ → Prop) + (· < · : Unit → Unit → Prop)) := + (Sum.Lex.toLexRelIsoLT (α := ℕ) (β := Unit)).ordinalType_congr.symm + _ = Ordinal.omega0 + 1 := by + rw [Ordinal.type_sum_lex, Ordinal.type_nat_lt] + simp + _ = Ordinal.omega0 * Ordinal.omega0 := + Ordinal.add_mul_of_isSuccLimit Ordinal.one_add_omega0 + Ordinal.isSuccLimit_omega0 + _ = Ordinal.omega0 ^ (2 : Ordinal) := by + have hsucc : (1 : Ordinal) + 1 = 2 := one_add_one_eq_two + rw [← hsucc, Ordinal.opow_add_one, Ordinal.opow_one] + +/-- A support of ordinary ordinal type `ω²` has degree two. -/ +theorem omegaSuccTimesOmegaOrderTypeSeries_degree : + omegaSuccTimesOmegaOrderTypeSeries.degree = (2 : WithBot NatOrdinal) := by + rw [HahnSeries.degree_eq_cantorDegree, + omegaSuccTimesOmegaOrderTypeSeries_supportOrderType, + Ordinal.cantorDegree_omega_sq] + +/-- Ordinary `(ω + 1) * ω` differs from the corresponding Hessenberg product. -/ +theorem naturalOmegaSuccTimesOmega_ne_supportOrderType : + NatOrdinal.of (Ordinal.omega0 + 1) * NatOrdinal.of Ordinal.omega0 ≠ + NatOrdinal.of omegaSuccTimesOmegaOrderTypeSeries.supportOrderType := by + rw [omegaSuccTimesOmegaOrderTypeSeries_supportOrderType] + have hfactor : + NatOrdinal.of Ordinal.omega0 < NatOrdinal.of (Ordinal.omega0 + 1) := + NatOrdinal.of.lt_iff_lt.mpr (lt_add_one Ordinal.omega0) + have homega : (0 : NatOrdinal) < NatOrdinal.of Ordinal.omega0 := + NatOrdinal.of.lt_iff_lt.mpr Ordinal.omega0_pos + have hproduct : + NatOrdinal.of Ordinal.omega0 * NatOrdinal.of Ordinal.omega0 < + NatOrdinal.of (Ordinal.omega0 + 1) * NatOrdinal.of Ordinal.omega0 := + mul_lt_mul_of_pos_right hfactor homega + have hord : Ordinal.omega0 * Ordinal.omega0 = + Ordinal.omega0 ^ (2 : Ordinal) := by + have hsucc : (1 : Ordinal) + 1 = 2 := one_add_one_eq_two + rw [← hsucc, Ordinal.opow_add_one, Ordinal.opow_one] + have hordinary : NatOrdinal.of (Ordinal.omega0 ^ (2 : Ordinal)) ≤ + NatOrdinal.of Ordinal.omega0 * NatOrdinal.of Ordinal.omega0 := by + rw [← hord] + simpa using NatOrdinal.omul_le_mul + (NatOrdinal.of Ordinal.omega0) (NatOrdinal.of Ordinal.omega0) + exact (hordinary.trans_lt hproduct).ne' + +/-- A surreal Hahn monomial, used only to check the small-support degree interface. -/ +def surrealHahnMonomial : SurrealHahnSeries.{u} := + SurrealHahnSeries.single 0 1 + +theorem surrealHahnMonomial_ne_zero : + (surrealHahnMonomial : SurrealHahnSeries.{u}) ≠ 0 := by + intro h + have hcoeff := congrArg + (fun x : SurrealHahnSeries.{u} ↦ x.coeff (0 : Surreal.{u})) h + simp [surrealHahnMonomial] at hcoeff + +theorem surrealHahnMonomial_support_finite : + (surrealHahnMonomial : SurrealHahnSeries.{u}).support.Finite := + (Set.finite_singleton 0).subset SurrealHahnSeries.support_single_subset + +/-- Interface smoke test: a nonzero surreal Hahn monomial has degree zero. -/ +theorem surrealHahnMonomial_supportDegree : + (surrealHahnMonomial : SurrealHahnSeries.{u}).supportDegree = + (0 : WithBot NatOrdinal) := + SurrealHahnSeries.supportDegree_eq_zero.mpr + ⟨surrealHahnMonomial_ne_zero, surrealHahnMonomial_support_finite⟩ + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Tests/PrincipalAddition.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Tests/PrincipalAddition.lean new file mode 100644 index 0000000000..925adb4252 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Tests/PrincipalAddition.lean @@ -0,0 +1,122 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Tests.Fixtures.ApproachZero + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.PrincipalAddition + +/-! +# API checks for addition of principal series + +The approach-zero series and the constant one give a compiled counterexample to LM24, +Proposition 3.6.2 as printed: both summands are principal and the degree of the sum equals the +degree of the first summand, but the nonzero terminal constant makes the sum nonprincipal. + +Adding the approach-zero series to itself exercises the corrected equal-degree theorem on a +nonconstant, infinite-support example. This is the author-confirmed repair used by later LM24 +arguments; the broader author-suggested repair for two simultaneously zero or nonzero degrees is +not assumed here. +-/ + +public noncomputable section + +namespace Tests + +open HahnSeries +open scoped NatOrdinal + +private theorem one_nonpositive_degree_eq_zero : + ((1 : HahnSeries.Nonpositive ℝ ℚ) : ℚ⟦ℝ⟧).degree = + (0 : WithBot NatOrdinal) := by + rw [← map_one (HahnSeries.Nonpositive.C : + ℚ →+* HahnSeries.Nonpositive ℝ ℚ), HahnSeries.Nonpositive.coe_C] + change (HahnSeries.C (Γ := ℝ) (1 : ℚ)).degree = + (0 : WithBot NatOrdinal) + rw [HahnSeries.C_apply, HahnSeries.degree_eq_cantorDegree, + HahnSeries.supportOrderType_single one_ne_zero, + Ordinal.cantorDegree_one] + +private theorem approachZero_add_one_degree_eq_one : + (((approachZeroNonpositive + 1 : HahnSeries.Nonpositive ℝ ℚ) : ℚ⟦ℝ⟧)).degree = + (1 : WithBot NatOrdinal) := by + have h := HahnSeries.degree_add_eq_left_of_lt + (x := (approachZeroNonpositive : ℚ⟦ℝ⟧)) + (y := ((1 : HahnSeries.Nonpositive ℝ ℚ) : ℚ⟦ℝ⟧)) + (by rw [approachZero_degree_eq_one, one_nonpositive_degree_eq_zero]; norm_num) + simpa using h.trans approachZero_degree_eq_one + +private theorem approachZero_constantCoeff_eq_zero : + HahnSeries.Nonpositive.constantCoeff approachZeroNonpositive = 0 := by + rw [HahnSeries.Nonpositive.constantCoeff_apply, coe_approachZeroNonpositive] + apply not_ne_iff.mp + simpa [HahnSeries.mem_support] using zero_not_mem_approachZero_support + +/-- The printed formulation of LM24, Proposition 3.6.2 is false. -/ +theorem printed_proposition_3_6_2_counterexample : + ∃ b c : HahnSeries.Nonpositive ℝ ℚ, + HahnSeries.Nonpositive.IsPrincipal b ∧ + HahnSeries.Nonpositive.IsPrincipal c ∧ + (((b + c : HahnSeries.Nonpositive ℝ ℚ) : ℚ⟦ℝ⟧)).degree = + (b : ℚ⟦ℝ⟧).degree ∧ + ¬HahnSeries.Nonpositive.IsPrincipal (b + c) := by + refine ⟨approachZeroNonpositive, 1, approachZero_isPrincipal, + HahnSeries.Nonpositive.isPrincipal_one, ?_, ?_⟩ + · rw [approachZero_add_one_degree_eq_one, approachZero_degree_eq_one] + · intro hprincipal + have hconstant := hprincipal.constantCoeff_eq_zero_of_degree_pos + approachZero_add_one_degree_eq_one (by norm_num) + rw [map_add, approachZero_constantCoeff_eq_zero, map_one, zero_add] at hconstant + exact one_ne_zero hconstant + +private theorem approachZero_add_self_degree_eq_one : + (((approachZeroNonpositive + approachZeroNonpositive : + HahnSeries.Nonpositive ℝ ℚ) : ℚ⟦ℝ⟧)).degree = + (1 : WithBot NatOrdinal) := by + have hsupport : + (((approachZeroNonpositive + approachZeroNonpositive : + HahnSeries.Nonpositive ℝ ℚ) : ℚ⟦ℝ⟧)).support = + (approachZeroNonpositive : ℚ⟦ℝ⟧).support := by + ext x + simp only [HahnSeries.mem_support, Subring.coe_add, HahnSeries.coeff_add] + rw [coe_approachZeroNonpositive] + constructor + · intro hsum hzero + exact hsum (by simp [hzero]) + · intro hcoeff hsum + apply hcoeff + linarith + have htype : + (((approachZeroNonpositive + approachZeroNonpositive : + HahnSeries.Nonpositive ℝ ℚ) : ℚ⟦ℝ⟧)).supportOrderType = + (approachZeroNonpositive : ℚ⟦ℝ⟧).supportOrderType := + HahnSeries.supportOrderType_eq_setOrderType _ |>.trans + (((approachZeroNonpositive + approachZeroNonpositive : + HahnSeries.Nonpositive ℝ ℚ) : ℚ⟦ℝ⟧).isPWO_support.orderType_congr + (approachZeroNonpositive : ℚ⟦ℝ⟧).isPWO_support hsupport) |>.trans + (HahnSeries.supportOrderType_eq_setOrderType _).symm + calc + (((approachZeroNonpositive + approachZeroNonpositive : + HahnSeries.Nonpositive ℝ ℚ) : ℚ⟦ℝ⟧)).degree = + Ordinal.cantorDegree + (((approachZeroNonpositive + approachZeroNonpositive : + HahnSeries.Nonpositive ℝ ℚ) : ℚ⟦ℝ⟧)).supportOrderType := + HahnSeries.degree_eq_cantorDegree _ + _ = Ordinal.cantorDegree + (approachZeroNonpositive : ℚ⟦ℝ⟧).supportOrderType := congrArg _ htype + _ = (approachZeroNonpositive : ℚ⟦ℝ⟧).degree := + (HahnSeries.degree_eq_cantorDegree _).symm + _ = (1 : WithBot NatOrdinal) := approachZero_degree_eq_one + +/-- The corrected equal-degree theorem applies to two genuine infinite principal series. -/ +theorem approachZero_add_self_isPrincipal : + HahnSeries.Nonpositive.IsPrincipal + (approachZeroNonpositive + approachZeroNonpositive) := by + apply approachZero_isPrincipal.add_of_degree_eq approachZero_isPrincipal + · rfl + · rw [approachZero_add_self_degree_eq_one, approachZero_degree_eq_one] + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Tests/Truncation.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Tests/Truncation.lean new file mode 100644 index 0000000000..0821b8bd8c --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Tests/Truncation.lean @@ -0,0 +1,269 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrderType + +import Mathlib.Data.Finsupp.Basic +import Mathlib.Data.Finsupp.Single +import Mathlib.Data.Sum.Order + +/-! +# API checks for Hahn-series truncations + +This client uses only the public Hahn-series interface. Its series has nonzero coefficients exactly +at `-1`, `0`, and `1`, and is truncated at `0`. The four exact support calculations distinguish the +intended intervals `< 0`, `≤ 0`, `≥ 0`, and `> 0`; in particular, they reject the nearby wrong +definitions obtained by interchanging strict and weak endpoints. The extreme cuts at `-1` and `1` +exercise the empty-summand cases. + +The order-type and uniqueness checks exercise LM24, Fact 2.2.3(1), Proposition 3.2.1, and +Definition 3.2.2 through their public consequences. The root `LM24` module does not import this +client module. +-/ + +public noncomputable section + +namespace Tests + +open scoped HahnSeries + +private def threeTermCoeffs : ℤ →₀ ℚ := + Finsupp.single (-1) 1 + Finsupp.single 0 2 + Finsupp.single 1 3 + +/-- A Hahn series with nonzero coefficients precisely at `-1`, `0`, and `1`. -/ +def threeTermTruncationSeries : ℚ⟦ℤ⟧ := + HahnSeries.ofFinsupp threeTermCoeffs + +@[simp] +theorem threeTermTruncationSeries_support : + threeTermTruncationSeries.support = {-1, 0, 1} := by + classical + ext z + by_cases hneg : z = -1 + · simp [threeTermTruncationSeries, threeTermCoeffs, hneg] + by_cases hzero : z = 0 + · simp [threeTermTruncationSeries, threeTermCoeffs, hzero] + by_cases hone : z = 1 + · simp [threeTermTruncationSeries, threeTermCoeffs, hone] + · simp [threeTermTruncationSeries, threeTermCoeffs, hneg, hzero, hone] + +/-- Strict lower truncation at zero keeps exactly the exponent `-1`. -/ +theorem threeTermTruncationSeries_support_truncLT : + (HahnSeries.truncLT 0 threeTermTruncationSeries).support = {-1} := by + rw [HahnSeries.support_truncLT, threeTermTruncationSeries_support] + ext z + simp only [Set.mem_ofPred_eq, Set.mem_insert_iff, Set.mem_singleton_iff] + omega + +/-- Weak lower truncation at zero keeps exactly the exponents `-1` and `0`. -/ +theorem threeTermTruncationSeries_support_truncLE : + (HahnSeries.truncLE 0 threeTermTruncationSeries).support = {-1, 0} := by + rw [HahnSeries.support_truncLE, threeTermTruncationSeries_support] + ext z + simp only [Set.mem_ofPred_eq, Set.mem_insert_iff, Set.mem_singleton_iff] + omega + +/-- Weak upper truncation at zero keeps exactly the exponents `0` and `1`. -/ +theorem threeTermTruncationSeries_support_truncGE : + (HahnSeries.truncGE 0 threeTermTruncationSeries).support = {0, 1} := by + rw [HahnSeries.support_truncGE, threeTermTruncationSeries_support] + ext z + simp only [Set.mem_ofPred_eq, Set.mem_insert_iff, Set.mem_singleton_iff] + omega + +/-- Strict upper truncation at zero keeps exactly the exponent `1`. -/ +theorem threeTermTruncationSeries_support_truncGT : + (HahnSeries.truncGT 0 threeTermTruncationSeries).support = {1} := by + rw [HahnSeries.support_truncGT, threeTermTruncationSeries_support] + ext z + simp only [Set.mem_ofPred_eq, Set.mem_insert_iff, Set.mem_singleton_iff] + omega + +/-- At the cut exponent, the weak truncations keep the coefficient and the strict truncations +discard it. -/ +theorem threeTermTruncationSeries_endpoint_coefficients : + (HahnSeries.truncLT 0 threeTermTruncationSeries).coeff 0 = 0 ∧ + (HahnSeries.truncLE 0 threeTermTruncationSeries).coeff 0 = 2 ∧ + (HahnSeries.truncGE 0 threeTermTruncationSeries).coeff 0 = 2 ∧ + (HahnSeries.truncGT 0 threeTermTruncationSeries).coeff 0 = 0 := by + norm_num [threeTermTruncationSeries, threeTermCoeffs] + +/-- Both complementary pairs of truncations reconstruct the original nonconstant series. -/ +theorem threeTermTruncationSeries_splits : + HahnSeries.truncLT 0 threeTermTruncationSeries + + HahnSeries.truncGE 0 threeTermTruncationSeries = threeTermTruncationSeries ∧ + HahnSeries.truncLE 0 threeTermTruncationSeries + + HahnSeries.truncGT 0 threeTermTruncationSeries = threeTermTruncationSeries := + ⟨HahnSeries.truncLT_add_truncGE 0 threeTermTruncationSeries, + HahnSeries.truncLE_add_truncGT 0 threeTermTruncationSeries⟩ + +/-- The weak lower truncation at zero is proper because it discards the term at exponent `1`. -/ +theorem threeTermTruncationSeries_truncLE_ne : + HahnSeries.truncLE 0 threeTermTruncationSeries ≠ threeTermTruncationSeries := by + intro h + have hcoeff := congrArg (fun x : ℚ⟦ℤ⟧ => x.coeff 1) h + simp [threeTermTruncationSeries, threeTermCoeffs] at hcoeff + +/-- The proper weak lower truncation has strictly smaller support order type. -/ +theorem threeTermTruncationSeries_truncLE_orderType_lt : + (HahnSeries.truncLE 0 threeTermTruncationSeries).supportOrderType < + threeTermTruncationSeries.supportOrderType := + HahnSeries.supportOrderType_truncLE_lt 0 threeTermTruncationSeries_truncLE_ne + +/-- Both support-order-type decompositions use ordinary ordinal addition in lower-to-upper order. -/ +theorem threeTermTruncationSeries_orderType_splits : + threeTermTruncationSeries.supportOrderType = + (HahnSeries.truncLT 0 threeTermTruncationSeries).supportOrderType + + (HahnSeries.truncGE 0 threeTermTruncationSeries).supportOrderType ∧ + threeTermTruncationSeries.supportOrderType = + (HahnSeries.truncLE 0 threeTermTruncationSeries).supportOrderType + + (HahnSeries.truncGT 0 threeTermTruncationSeries).supportOrderType := + ⟨HahnSeries.supportOrderType_eq_truncLT_add_truncGE 0 threeTermTruncationSeries, + HahnSeries.supportOrderType_eq_truncLE_add_truncGT 0 threeTermTruncationSeries⟩ + +/-- Truncation at the least and greatest support exponents exercises both empty-summand cases. -/ +theorem threeTermTruncationSeries_boundary_truncations : + HahnSeries.truncLT (-1) threeTermTruncationSeries = 0 ∧ + HahnSeries.truncGE (-1) threeTermTruncationSeries = threeTermTruncationSeries ∧ + HahnSeries.truncLE 1 threeTermTruncationSeries = threeTermTruncationSeries ∧ + HahnSeries.truncGT 1 threeTermTruncationSeries = 0 := by + have hlt : HahnSeries.truncLT (-1) threeTermTruncationSeries = 0 := by + rw [← HahnSeries.support_eq_empty_iff, HahnSeries.support_truncLT, + threeTermTruncationSeries_support] + ext z + simp only [Set.mem_ofPred_eq, Set.mem_empty_iff_false, iff_false, Set.mem_insert_iff, + Set.mem_singleton_iff] + omega + have hgt : HahnSeries.truncGT 1 threeTermTruncationSeries = 0 := by + rw [← HahnSeries.support_eq_empty_iff, HahnSeries.support_truncGT, + threeTermTruncationSeries_support] + ext z + simp only [Set.mem_ofPred_eq, Set.mem_empty_iff_false, iff_false, Set.mem_insert_iff, + Set.mem_singleton_iff] + omega + refine ⟨hlt, ?_, ?_, hgt⟩ + · simpa [hlt] using + HahnSeries.truncLT_add_truncGE (-1) threeTermTruncationSeries + · simpa [hgt] using + HahnSeries.truncLE_add_truncGT 1 threeTermTruncationSeries + +/-- Any separated decomposition with the same lower order type as the cut at zero is that cut. -/ +theorem threeTermTruncationSeries_decomposition_unique (x y : ℚ⟦ℤ⟧) + (hxy : ∀ i ∈ x.support, ∀ j ∈ y.support, i < j) + (htype : x.supportOrderType = + (HahnSeries.truncLE 0 threeTermTruncationSeries).supportOrderType) + (hsum : x + y = threeTermTruncationSeries) : + x = HahnSeries.truncLE 0 threeTermTruncationSeries ∧ + y = HahnSeries.truncGT 0 threeTermTruncationSeries := by + have htrunc : ∀ i ∈ (HahnSeries.truncLE 0 threeTermTruncationSeries).support, + ∀ j ∈ (HahnSeries.truncGT 0 threeTermTruncationSeries).support, i < j := by + intro i hi j hj + rw [HahnSeries.support_truncLE] at hi + rw [HahnSeries.support_truncGT] at hj + exact hi.2.trans_lt hj.2 + apply HahnSeries.add_decomposition_unique (HahnSeries.supportBelow_iff.mpr hxy) + (HahnSeries.supportBelow_iff.mpr htrunc) htype + exact hsum.trans (HahnSeries.truncLE_add_truncGT 0 threeTermTruncationSeries).symm + +private instance : WellFoundedLT (Unit ⊕ₗ ℕ) := + (Sum.Lex.toLexRelIsoLT (α := Unit) (β := ℕ)).symm.toRelEmbedding.wellFounded' + +/-- The coefficient-one series on an ordered singleton followed by `ℕ`. -/ +def oneAddOmegaSplitSeries : ℚ⟦Unit ⊕ₗ ℕ⟧ where + coeff _ := 1 + isPWO_support' := by + simpa [Function.support] using + Set.IsPWO.of_linearOrder (Set.univ : Set (Unit ⊕ₗ ℕ)) + +/-- The singleton first part of `oneAddOmegaSplitSeries`. -/ +def oneAddOmegaLower : ℚ⟦Unit ⊕ₗ ℕ⟧ := + HahnSeries.filter (fun x ↦ (ofLex x).isLeft) oneAddOmegaSplitSeries + +/-- The `ℕ`-indexed second part of `oneAddOmegaSplitSeries`. -/ +def oneAddOmegaUpper : ℚ⟦Unit ⊕ₗ ℕ⟧ := + HahnSeries.filter (fun x ↦ (ofLex x).isRight) oneAddOmegaSplitSeries + +private theorem oneAddOmegaLower_support : oneAddOmegaLower.support = Set.range Sum.inlₗ := by + rw [oneAddOmegaLower, HahnSeries.support_filter] + ext x + induction x using Lex.rec with + | h x => + rcases x with x | x + · constructor + · intro _ + exact ⟨x, rfl⟩ + · intro _ + simp [oneAddOmegaSplitSeries] + · constructor + · intro h + simp at h + · rintro ⟨y, h⟩ + have hlt : Sum.inlₗ y < Sum.inrₗ x := Sum.Lex.inl_lt_inr y x + exact (hlt.ne h).elim + +private theorem oneAddOmegaUpper_support : oneAddOmegaUpper.support = Set.range Sum.inrₗ := by + rw [oneAddOmegaUpper, HahnSeries.support_filter] + ext x + induction x using Lex.rec with + | h x => + rcases x with x | x + · constructor + · intro h + simp at h + · rintro ⟨y, h⟩ + have hlt : Sum.inlₗ x < Sum.inrₗ y := Sum.Lex.inl_lt_inr x y + exact (hlt.ne h.symm).elim + · constructor + · intro _ + exact ⟨x, rfl⟩ + · intro _ + simp [oneAddOmegaSplitSeries] + +private theorem oneAddOmegaLower_supportOrderType : oneAddOmegaLower.supportOrderType = 1 := by + rw [HahnSeries.supportOrderType_eq_setOrderType] + have e : oneAddOmegaLower.support ≃o Unit := + (Set.orderIsoOfEq oneAddOmegaLower.support (Set.range Sum.inlₗ) + oneAddOmegaLower_support).trans + (OrderEmbedding.ofStrictMono Sum.inlₗ Sum.Lex.inl_strictMono).orderIso.symm + exact oneAddOmegaLower.isPWO_support.orderType_eq_typeLT_of_orderIso e |>.trans + Ordinal.type_unit + +private theorem oneAddOmegaUpper_supportOrderType : + oneAddOmegaUpper.supportOrderType = Ordinal.omega0 := by + rw [HahnSeries.supportOrderType_eq_setOrderType] + have e : oneAddOmegaUpper.support ≃o ℕ := + (Set.orderIsoOfEq oneAddOmegaUpper.support (Set.range Sum.inrₗ) + oneAddOmegaUpper_support).trans + (OrderEmbedding.ofStrictMono Sum.inrₗ Sum.Lex.inr_strictMono).orderIso.symm + exact oneAddOmegaUpper.isPWO_support.orderType_eq_typeLT_of_orderIso e |>.trans + Ordinal.type_nat_lt + +/-- The source decomposition uses ordinary `1 + ω = ω`, not the Hessenberg sum `ω + 1`. -/ +theorem oneAddOmega_decomposition_uses_ordinary_addition : + (oneAddOmegaLower + oneAddOmegaUpper).supportOrderType = Ordinal.omega0 ∧ + NatOrdinal.of oneAddOmegaLower.supportOrderType + + NatOrdinal.of oneAddOmegaUpper.supportOrderType ≠ + NatOrdinal.of (oneAddOmegaLower + oneAddOmegaUpper).supportOrderType := by + have hsep : ∀ i ∈ oneAddOmegaLower.support, ∀ j ∈ oneAddOmegaUpper.support, i < j := by + rw [oneAddOmegaLower_support, oneAddOmegaUpper_support] + rintro _ ⟨i, rfl⟩ _ ⟨j, rfl⟩ + exact Sum.Lex.inl_lt_inr i j + have hord := (HahnSeries.supportOrderType_eq_add_iff + (oneAddOmegaLower + oneAddOmegaUpper) 1 Ordinal.omega0).mpr + ⟨oneAddOmegaLower, oneAddOmegaUpper, HahnSeries.supportBelow_iff.mpr hsep, + oneAddOmegaLower_supportOrderType, oneAddOmegaUpper_supportOrderType, rfl⟩ + constructor + · simpa using hord + · rw [oneAddOmegaLower_supportOrderType, oneAddOmegaUpper_supportOrderType, hord, + Ordinal.one_add_omega0] + intro h + rw [add_comm] at h + have hone : NatOrdinal.of (1 : Ordinal) = 1 := rfl + rw [hone, ← NatOrdinal.of_add_one] at h + exact (lt_add_one Ordinal.omega0).ne' (NatOrdinal.of.injective h) + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Tests/TruncationIntegerPartPrimal.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Tests/TruncationIntegerPartPrimal.lean new file mode 100644 index 0000000000..962e82019d --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Tests/TruncationIntegerPartPrimal.lean @@ -0,0 +1,58 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.TruncationIntegerPartPrimal + +/-! +# API checks for truncation-integer-part primality + +This separately compiled client checks the Hahn-series specialization of LM24, Lemma 9.2.1. +-/ + +public noncomputable section + +namespace Tests + +open HahnSeries + +theorem truncationIntegerPart_primality_cases + {G L : Type*} + [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] [Field L] + (Z : Subring L) (b : truncationIntegerPart G Z) : + IsPrimal b ↔ + (Nonpositive.constantCoeffAlgHom (b : Nonpositive G L) ≠ 0 ∧ + IsPrimal (⟨Nonpositive.constantCoeffAlgHom (b : Nonpositive G L), by + rw [Nonpositive.constantCoeffAlgHom_apply] + exact (mem_truncationIntegerPart (R := L) (Γ := G)).mp b.2⟩ : Z) ∧ + IsPrimal (b : Nonpositive G L)) ∨ + (Nonpositive.constantCoeffAlgHom (b : Nonpositive G L) = 0 ∧ + IsPrimal (⟨(b : Nonpositive G L), Subring.le_fracSubring (by + change Nonpositive.constantCoeffAlgHom (b : Nonpositive G L) ∈ Z + rw [Nonpositive.constantCoeffAlgHom_apply] + exact (mem_truncationIntegerPart (R := L) (Γ := G)).mp b.2)⟩ : + Subring.residueSubring Nonpositive.constantCoeffAlgHom + (Subring.fracSubring Z))) := + Nonpositive.isPrimal_truncationIntegerPart_iff Z b + +theorem truncationIntegerPart_primality_at_one + {G L : Type*} + [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] [Field L] + (Z : Subring L) (b : truncationIntegerPart G Z) + (hb : Nonpositive.constantCoeffAlgHom (b : Nonpositive G L) = 1) : + IsPrimal b ↔ IsPrimal (b : Nonpositive G L) := + Nonpositive.isPrimal_truncationIntegerPart_iff_of_constantCoeff_eq_one Z b hb + +theorem truncationIntegerPart_primality_at_zero + {G L : Type*} + [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] [Field L] + (Z : Subring L) (hfrac : Subring.fracSubring Z = ⊤) + (b : truncationIntegerPart G Z) + (hb : Nonpositive.constantCoeffAlgHom (b : Nonpositive G L) = 0) : + IsPrimal b ↔ IsPrimal (b : Nonpositive G L) := + Nonpositive.isPrimal_truncationIntegerPart_iff_of_constantCoeff_eq_zero Z hfrac b hb + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Tests/WeakNormalForm.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Tests/WeakNormalForm.lean new file mode 100644 index 0000000000..e9c367dc91 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Tests/WeakNormalForm.lean @@ -0,0 +1,231 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.WeakNormalForm +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.CantorTermCount + +import Mathlib.Data.Sum.Order + +/-! +# API checks for LM24 weak normal forms + +The ordinal certificates separate LM24's positive additive-principal convention from Mathlib's +convention, which includes zero, and refute the false indecomposability clause printed in LM24, +Definition 3.3.1, using `1 + ω = ω`. + +The main Hahn-series fixture has coefficient one at every point of the lexicographic sum +`ℕ ⊕ₗ ℕ`. Its lower and upper components both have support order type `ω`, yet form two +strictly support-separated blocks. Hence its weak normal form has equal consecutive block order +types. This distinguishes LM24, Definition 3.3.2 from the nearby incorrect definition requiring +strict decrease, and it verifies that the uncompressed Cantor-term list retains repeated terms. +The exact terminal truncation also exercises LM24, Corollary 3.3.5 on a nonconstant, +infinite-support series. +-/ + +public noncomputable section + +namespace Tests + +open scoped HahnSeries + +/-- Zero distinguishes LM24's positive additive-principal convention from Mathlib's convention. -/ +theorem zero_separates_LM24_from_mathlib_principal : + ¬Ordinal.IsAdditivelyPrincipal 0 ∧ Ordinal.IsPrincipal (· + ·) 0 := by + constructor + · intro h + exact h.ne_zero rfl + · exact Ordinal.isPrincipal_zero + +/-- The additive-principal ordinal `ω` refutes the false printed indecomposability clause because +`1 + ω = ω` although neither summand is zero. -/ +theorem omega_refutes_printed_indecomposability : + Ordinal.IsAdditivelyPrincipal Ordinal.omega0 ∧ + ¬(∀ b c : Ordinal, Ordinal.omega0 = b + c → b = 0 ∨ c = 0) := by + constructor + · simpa using Ordinal.isAdditivelyPrincipal_omega0_opow 1 + · intro h + rcases h 1 Ordinal.omega0 (by simp) with h | h + · norm_num at h + · exact Ordinal.omega0_ne_zero h + +/-- The empty block list is the weak normal form of the zero series. -/ +theorem zero_weakNormalForm : + HahnSeries.IsWeakNormalForm (0 : ℚ⟦ℤ⟧) [] := by + rw [HahnSeries.isWeakNormalForm_iff] + simp [List.sortedGE_iff_pairwise] + +private instance : WellFoundedLT (ℕ ⊕ₗ ℕ) := + (Sum.Lex.toLexRelIsoLT (α := ℕ) (β := ℕ)).symm.toRelEmbedding.wellFounded' + +/-- The coefficient-one Hahn series on the lexicographic sum of two copies of `ℕ`. -/ +def twoOmegaSeries : ℚ⟦ℕ ⊕ₗ ℕ⟧ where + coeff _ := 1 + isPWO_support' := by + simpa [Function.support] using Set.IsPWO.of_linearOrder (Set.univ : Set (ℕ ⊕ₗ ℕ)) + +/-- The first `ℕ`-indexed component of `twoOmegaSeries`. -/ +def twoOmegaLower : ℚ⟦ℕ ⊕ₗ ℕ⟧ := + HahnSeries.filter (fun x ↦ (ofLex x).isLeft) twoOmegaSeries + +/-- The second `ℕ`-indexed component of `twoOmegaSeries`. -/ +def twoOmegaUpper : ℚ⟦ℕ ⊕ₗ ℕ⟧ := + HahnSeries.filter (fun x ↦ (ofLex x).isRight) twoOmegaSeries + +private theorem twoOmegaLower_support : twoOmegaLower.support = Set.range Sum.inlₗ := by + rw [twoOmegaLower, HahnSeries.support_filter] + ext x + induction x using Lex.rec with + | h x => + rcases x with x | x + · constructor + · intro _ + exact ⟨x, rfl⟩ + · intro _ + simp [twoOmegaSeries] + · constructor + · intro h + simp at h + · rintro ⟨y, h⟩ + exact ((Sum.Lex.inl_lt_inr y x).ne h).elim + +private theorem twoOmegaUpper_support : twoOmegaUpper.support = Set.range Sum.inrₗ := by + rw [twoOmegaUpper, HahnSeries.support_filter] + ext x + induction x using Lex.rec with + | h x => + rcases x with x | x + · constructor + · intro h + simp at h + · rintro ⟨y, h⟩ + exact ((Sum.Lex.inl_lt_inr x y).ne h.symm).elim + · constructor + · intro _ + exact ⟨x, rfl⟩ + · intro _ + simp [twoOmegaSeries] + +private theorem twoOmegaLower_supportOrderType : + twoOmegaLower.supportOrderType = Ordinal.omega0 := by + rw [HahnSeries.supportOrderType_eq_setOrderType] + have e : twoOmegaLower.support ≃o ℕ := + (Set.orderIsoOfEq twoOmegaLower.support (Set.range Sum.inlₗ) + twoOmegaLower_support).trans + (OrderEmbedding.ofStrictMono Sum.inlₗ Sum.Lex.inl_strictMono).orderIso.symm + exact twoOmegaLower.isPWO_support.orderType_eq_typeLT_of_orderIso e |>.trans + Ordinal.type_nat_lt + +private theorem twoOmegaUpper_supportOrderType : + twoOmegaUpper.supportOrderType = Ordinal.omega0 := by + rw [HahnSeries.supportOrderType_eq_setOrderType] + have e : twoOmegaUpper.support ≃o ℕ := + (Set.orderIsoOfEq twoOmegaUpper.support (Set.range Sum.inrₗ) + twoOmegaUpper_support).trans + (OrderEmbedding.ofStrictMono Sum.inrₗ Sum.Lex.inr_strictMono).orderIso.symm + exact twoOmegaUpper.isPWO_support.orderType_eq_typeLT_of_orderIso e |>.trans + Ordinal.type_nat_lt + +private theorem twoOmega_supportBelow : + HahnSeries.SupportBelow twoOmegaLower twoOmegaUpper := by + rw [HahnSeries.supportBelow_iff, twoOmegaLower_support, twoOmegaUpper_support] + rintro _ ⟨i, rfl⟩ _ ⟨j, rfl⟩ + exact Sum.Lex.inl_lt_inr i j + +private theorem twoOmegaLower_add_upper : + twoOmegaLower + twoOmegaUpper = twoOmegaSeries := by + ext x + induction x using Lex.rec with + | h x => + cases x <;> simp [twoOmegaLower, twoOmegaUpper, twoOmegaSeries] + +private theorem twoOmegaLower_isWeaklyPrincipal : + HahnSeries.IsWeaklyPrincipal twoOmegaLower := by + rw [HahnSeries.isWeaklyPrincipal_iff, twoOmegaLower_supportOrderType] + simpa using Ordinal.isAdditivelyPrincipal_omega0_opow 1 + +private theorem twoOmegaUpper_isWeaklyPrincipal : + HahnSeries.IsWeaklyPrincipal twoOmegaUpper := by + rw [HahnSeries.isWeaklyPrincipal_iff, twoOmegaUpper_supportOrderType] + simpa using Ordinal.isAdditivelyPrincipal_omega0_opow 1 + +/-- The two equal-order-type components form an LM24 weak normal form. -/ +theorem twoOmega_weakNormalForm : + HahnSeries.IsWeakNormalForm twoOmegaSeries [twoOmegaLower, twoOmegaUpper] := by + rw [HahnSeries.isWeakNormalForm_iff_isChain] + refine ⟨?_, ?_, ?_, ?_⟩ + · simpa using twoOmegaLower_add_upper + · intro b hb + simp only [List.mem_cons, List.not_mem_nil, or_false] at hb + rcases hb with rfl | rfl + · exact twoOmegaLower_isWeaklyPrincipal + · exact twoOmegaUpper_isWeaklyPrincipal + · simp [twoOmegaLower_supportOrderType, twoOmegaUpper_supportOrderType, + List.sortedGE_iff_pairwise] + · exact List.isChain_pair.mpr twoOmega_supportBelow + +/-- The support order type of the two-block fixture is the ordinary ordinal sum `ω + ω`. -/ +theorem twoOmegaSeries_supportOrderType : + twoOmegaSeries.supportOrderType = Ordinal.omega0 + Ordinal.omega0 := by + apply (HahnSeries.supportOrderType_eq_add_iff _ _ _).mpr + exact ⟨twoOmegaLower, twoOmegaUpper, twoOmega_supportBelow, + twoOmegaLower_supportOrderType, twoOmegaUpper_supportOrderType, + twoOmegaLower_add_upper.symm⟩ + +/-- Equal consecutive block order types are permitted by LM24's nonincreasing condition. -/ +theorem twoOmega_weakNormalForm_has_equal_block_orderTypes : + HahnSeries.IsWeakNormalForm twoOmegaSeries [twoOmegaLower, twoOmegaUpper] ∧ + twoOmegaLower.supportOrderType = twoOmegaUpper.supportOrderType := by + exact ⟨twoOmega_weakNormalForm, + twoOmegaLower_supportOrderType.trans twoOmegaUpper_supportOrderType.symm⟩ + +/-- The uncompressed Cantor-term list retains the two repeated `ω` terms. -/ +theorem twoOmega_repeated_additivePrincipalTerms : + twoOmegaSeries.supportOrderType.additivePrincipalTerms = + [Ordinal.omega0, Ordinal.omega0] := by + have h := twoOmega_weakNormalForm.supportOrderTypes_eq_additivePrincipalTerms + simpa only [List.map_cons, List.map_nil, twoOmegaLower_supportOrderType, + twoOmegaUpper_supportOrderType] using h.symm + +/-- Counting the uncompressed Cantor terms retains both repeated copies of `ω`. -/ +theorem twoOmega_cantorTermCount : + NatOrdinal.cantorTermCount + (NatOrdinal.of twoOmegaSeries.supportOrderType) = 2 := by + rw [NatOrdinal.cantorTermCount_of, twoOmega_repeated_additivePrincipalTerms] + rfl + +/-- The public uniqueness theorem identifies any weak normal form of the fixture. -/ +theorem twoOmega_weakNormalForm_unique (blocks : List ℚ⟦ℕ ⊕ₗ ℕ⟧) + (hblocks : HahnSeries.IsWeakNormalForm twoOmegaSeries blocks) : + blocks = [twoOmegaLower, twoOmegaUpper] := + hblocks.unique twoOmega_weakNormalForm + +/-- At the first exponent of the upper block, weak upper truncation returns exactly that block. -/ +theorem twoOmega_terminal_truncation : + HahnSeries.truncGE (Sum.inrₗ 0) twoOmegaSeries = twoOmegaUpper := by + ext x + induction x using Lex.rec with + | h x => + rcases x with x | x + · rw [HahnSeries.coeff_truncGE_of_lt (Sum.Lex.inl_lt_inr x 0)] + rw [twoOmegaUpper, HahnSeries.coeff_filter] + rfl + · have hle : (Sum.inrₗ 0 : ℕ ⊕ₗ ℕ) ≤ Sum.inrₗ x := + Sum.Lex.inr_le_inr_iff.mpr (Nat.zero_le x) + rw [HahnSeries.coeff_truncGE_of_le hle] + rw [twoOmegaUpper, HahnSeries.coeff_filter] + rfl + +/-- The explicit terminal truncation is nonzero and weakly principal, as in LM24, Corollary +3.3.5. -/ +theorem twoOmega_terminal_truncation_certificate : + HahnSeries.truncGE (Sum.inrₗ 0) twoOmegaSeries ≠ 0 ∧ + HahnSeries.IsWeaklyPrincipal + (HahnSeries.truncGE (Sum.inrₗ 0) twoOmegaSeries) := by + rw [twoOmega_terminal_truncation] + exact ⟨twoOmegaUpper_isWeaklyPrincipal.ne_zero, twoOmegaUpper_isWeaklyPrincipal⟩ + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Translation.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Translation.lean new file mode 100644 index 0000000000..1c6d7bf09c --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Translation.lean @@ -0,0 +1,192 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrderType +public import Mathlib.Algebra.Order.Group.OrderIso + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Domain + +/-! +# Translation of Hahn-series exponents + +An order isomorphism between exponent types induces an additive equivalence between the +corresponding Hahn-series types. Translation by `a` is the specialization to the order +isomorphism `g ↦ a + g`. Its support is the translate of the original support, and it preserves +support order type. + +For a semiring of coefficients, translation agrees with multiplication on either side by the +coefficient-one monomial at `a`. Thus `HahnSeries.translate a x` is the operation denoted by +`t^a x` or `x t^a` in LM24. + +The construction uses `HahnSeries.embDomain`; the exact support formula comes from the +domain-embedding interface. +-/ + +universe u v w + +public noncomputable section + +namespace HahnSeries + +section Reindex + +variable {R : Type w} {G : Type u} {H : Type v} +variable [PartialOrder G] [PartialOrder H] [AddMonoid R] + +/-- Reindex Hahn-series exponents along an order isomorphism. -/ +def embDomainAddEquiv (e : G ≃o H) : R⟦G⟧ ≃+ R⟦H⟧ where + toFun := embDomain e.toOrderEmbedding + invFun := embDomain e.symm.toOrderEmbedding + left_inv x := by + ext g + have outer := embDomain_coeff (f := e.symm.toOrderEmbedding) + (x := embDomain e.toOrderEmbedding x) (a := e g) + have inner := embDomain_coeff (f := e.toOrderEmbedding) (x := x) (a := g) + simpa using outer.trans inner + right_inv x := by + ext h + have outer := embDomain_coeff (f := e.toOrderEmbedding) + (x := embDomain e.symm.toOrderEmbedding x) (a := e.symm h) + have inner := embDomain_coeff (f := e.symm.toOrderEmbedding) (x := x) (a := h) + simpa using outer.trans inner + map_add' := embDomain_add e.toOrderEmbedding + +@[simp] +theorem coeff_embDomainAddEquiv (e : G ≃o H) (x : R⟦G⟧) (g : G) : + (embDomainAddEquiv e x).coeff (e g) = x.coeff g := + embDomain_coeff + +end Reindex + +section OrderType + +variable {R : Type v} {G H : Type u} +variable [LinearOrder G] [LinearOrder H] [AddMonoid R] + +/-- Reindexing along an order isomorphism preserves ordinary support order type. -/ +@[simp] +theorem supportOrderType_embDomainAddEquiv (e : G ≃o H) (x : R⟦G⟧) : + (embDomainAddEquiv e x).supportOrderType = x.supportOrderType := by + rw [supportOrderType_eq_setOrderType, supportOrderType_eq_setOrderType] + let : WellFoundedLT x.support := x.isWF_support + let supportEquiv : (embDomainAddEquiv e x).support ≃o x.support := + (Set.orderIsoOfEq _ (e '' x.support) (support_embDomain e.toOrderEmbedding x)).trans + (StrictMonoOn.orderIso e x.support (e.strictMono.strictMonoOn x.support)).symm + exact (embDomainAddEquiv e x).isPWO_support.orderType_eq_typeLT_of_orderIso supportEquiv |>.trans + (x.isPWO_support.orderType_eq_typeLT_of_orderIso (OrderIso.refl x.support)).symm + +end OrderType + +section Translation + +variable {R : Type v} {G : Type u} +variable [PartialOrder G] [AddCommGroup G] [IsOrderedAddMonoid G] [AddMonoid R] + +/-- Translate every exponent in a Hahn series by `a`. -/ +def translate (a : G) : R⟦G⟧ ≃+ R⟦G⟧ := + embDomainAddEquiv (OrderIso.addLeft a) + +theorem coeff_translate_add (a g : G) (x : R⟦G⟧) : + (translate a x).coeff (a + g) = x.coeff g := + coeff_embDomainAddEquiv _ _ _ + +/-- Translation evaluates at `g` by reading the original coefficient at `g - a`. -/ +@[simp] +theorem coeff_translate (a g : G) (x : R⟦G⟧) : + (translate a x).coeff g = x.coeff (g - a) := by + simpa [sub_eq_add_neg, add_assoc, add_comm, add_left_comm] using + coeff_translate_add a (g - a) x + +/-- The support of a translated Hahn series is the corresponding translate of its support. -/ +theorem support_translate (a : G) (x : R⟦G⟧) : + (translate a x).support = (a + ·) '' x.support := + support_embDomain _ _ + +@[simp] +theorem translate_zero_apply (x : R⟦G⟧) : translate 0 x = x := by + ext g + simp + +@[simp] +theorem translate_add_apply (a b : G) (x : R⟦G⟧) : + translate a (translate b x) = translate (a + b) x := by + ext g + simp [sub_sub] + +theorem translate_neg_apply (a : G) (x : R⟦G⟧) : + translate (-a) (translate a x) = x := by + rw [translate_add_apply, neg_add_cancel, translate_zero_apply] + +end Translation + +section TranslationOrderType + +variable {R : Type v} {G : Type u} +variable [LinearOrder G] [AddCommGroup G] [IsOrderedAddMonoid G] [AddMonoid R] + +/-- Translation preserves ordinary support order type. -/ +@[simp] +theorem supportOrderType_translate (a : G) (x : R⟦G⟧) : + (translate a x).supportOrderType = x.supportOrderType := + supportOrderType_embDomainAddEquiv (R := R) _ _ + +/-- Translation preserves LM24 degree. -/ +@[simp] +theorem degree_translate (a : G) (x : R⟦G⟧) : + (translate a x).degree = x.degree := by + rw [degree_eq_cantorDegree, supportOrderType_translate, ← degree_eq_cantorDegree] + +/-- Weak lower truncation commutes with translation after shifting the cutoff. -/ +theorem truncLE_translate (a c : G) (x : R⟦G⟧) : + truncLE c (translate a x) = translate a (truncLE (c - a) x) := by + ext g + simp only [HahnSeries.coeff_truncLE, coeff_translate] + by_cases hgc : g ≤ c + · have hsub : g - a ≤ c - a := sub_le_sub_right hgc a + simp [hgc, hsub] + · have hsub : ¬g - a ≤ c - a := fun h ↦ hgc ((sub_le_sub_iff_right a).mp h) + simp [hgc, hsub] + +end TranslationOrderType + +section Monomial + +variable {R : Type v} {G : Type u} +variable [PartialOrder G] [AddCommGroup G] [IsOrderedAddMonoid G] [Semiring R] + +/-- Left multiplication by the coefficient-one monomial at `a` translates exponents by `a`. -/ +theorem single_one_mul_eq_translate (a : G) (x : R⟦G⟧) : + single a 1 * x = translate a x := by + ext g + rw [coeff_single_mul, coeff_translate, one_mul] + +/-- Right multiplication by the coefficient-one monomial at `a` translates exponents by `a`. -/ +theorem mul_single_one_eq_translate (x : R⟦G⟧) (a : G) : + x * single a 1 = translate a x := by + ext g + rw [coeff_mul_single, coeff_translate, mul_one] + +/-- The product of two translated Hahn series is the translate of their product by the sum of +the two shifts. -/ +theorem translate_mul_translate (a b : G) (x y : R⟦G⟧) : + translate a x * translate b y = translate (a + b) (x * y) := by + calc + translate a x * translate b y = + (single a 1 * x) * (single b 1 * y) := by + rw [single_one_mul_eq_translate, single_one_mul_eq_translate] + _ = single a 1 * (x * single b 1) * y := by simp only [mul_assoc] + _ = single a 1 * translate b x * y := by + rw [mul_single_one_eq_translate x b] + _ = single a 1 * (single b 1 * x) * y := by + rw [single_one_mul_eq_translate b x] + _ = (single a 1 * single b 1) * (x * y) := by simp only [mul_assoc] + _ = single (a + b) 1 * (x * y) := by rw [single_mul_single, one_mul] + _ = translate (a + b) (x * y) := single_one_mul_eq_translate _ _ + +end Monomial + +end HahnSeries diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Truncation.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Truncation.lean new file mode 100644 index 0000000000..a6496d3de6 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/Truncation.lean @@ -0,0 +1,196 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import Mathlib.RingTheory.HahnSeries.Addition + +/-! +# Coefficient restrictions and truncations of Hahn series + +This module restricts a Hahn series to an arbitrary decidable predicate on its exponents. The four +interval restrictions specialize this operation to LM24, Definition 3.2.2. Mathlib already +provides the strict lower truncation `HahnSeries.truncLT`; the definitions here add the weak lower, +weak upper, and strict upper truncations with the same argument order and `ZeroHom` interface. +Every resulting support is a subset of the original support, so these operations preserve any +fixed upper bound on support cardinality used in LM24. + +The inequalities use the ambient order on the exponents. Thus `truncLE c x` retains the coefficient +of `x` at `i` exactly when `i ≤ c`; no reversal of the support order occurs. + +Mathlib supplies `HahnSeries.truncLT`, which is reused directly. `Finsupp.filter` cannot apply to an +arbitrary well-ordered, possibly infinite support, and CombinatorialGames' surreal truncation uses +its reverse-support representation. The operations here therefore work directly with Hahn-series +coefficients and support proofs. +-/ + +universe u v + +public noncomputable section + +namespace HahnSeries + +variable {R : Type v} {G : Type u} + +section Zero + +variable [PartialOrder G] [Zero R] + +/-- Keep exactly the coefficients whose indices satisfy `p`. -/ +def filter (p : G → Prop) [DecidablePred p] : ZeroHom R⟦G⟧ R⟦G⟧ where + toFun x := + { coeff i := if p i then x.coeff i else 0 + isPWO_support' := x.isPWO_support.mono (by simp) } + map_zero' := by ext; simp + +@[simp] +protected theorem coeff_filter (p : G → Prop) [DecidablePred p] (x : R⟦G⟧) (i : G) : + (filter p x).coeff i = if p i then x.coeff i else 0 := + (rfl) + +/-- The support of a coefficient restriction is the corresponding subset of the original support. -/ +theorem support_filter (p : G → Prop) [DecidablePred p] (x : R⟦G⟧) : + (filter p x).support = {i ∈ x.support | p i} := by + ext i + simp [and_comm] + +theorem support_filter_subset (p : G → Prop) [DecidablePred p] (x : R⟦G⟧) : + (filter p x).support ⊆ x.support := by + rw [support_filter] + exact Set.sep_subset _ _ + +/-- Keeps exactly the coefficients at indices `i` satisfying `i ≤ c`. -/ +def truncLE [DecidableLE G] (c : G) : ZeroHom R⟦G⟧ R⟦G⟧ := + filter (· ≤ c) + +/-- Keeps exactly the coefficients at indices `i` satisfying `c ≤ i`. -/ +def truncGE [DecidableLE G] (c : G) : ZeroHom R⟦G⟧ R⟦G⟧ := + filter (c ≤ ·) + +/-- Keeps exactly the coefficients at indices `i` satisfying `c < i`. -/ +def truncGT [DecidableLT G] (c : G) : ZeroHom R⟦G⟧ R⟦G⟧ := + filter (c < ·) + +@[simp] +protected theorem coeff_truncLE [DecidableLE G] (c : G) (x : R⟦G⟧) (i : G) : + (truncLE c x).coeff i = if i ≤ c then x.coeff i else 0 := + (rfl) + +@[simp] +protected theorem coeff_truncGE [DecidableLE G] (c : G) (x : R⟦G⟧) (i : G) : + (truncGE c x).coeff i = if c ≤ i then x.coeff i else 0 := + (rfl) + +@[simp] +protected theorem coeff_truncGT [DecidableLT G] (c : G) (x : R⟦G⟧) (i : G) : + (truncGT c x).coeff i = if c < i then x.coeff i else 0 := + (rfl) + +theorem coeff_truncLE_of_le [DecidableLE G] {c i : G} (h : i ≤ c) (x : R⟦G⟧) : + (truncLE c x).coeff i = x.coeff i := by + simp [h] + +theorem coeff_truncLE_of_lt [DecidableLE G] {c i : G} (h : c < i) (x : R⟦G⟧) : + (truncLE c x).coeff i = 0 := by + simp [not_le_of_gt h] + +theorem coeff_truncGE_of_le [DecidableLE G] {c i : G} (h : c ≤ i) (x : R⟦G⟧) : + (truncGE c x).coeff i = x.coeff i := by + simp [h] + +theorem coeff_truncGE_of_lt [DecidableLE G] {c i : G} (h : i < c) (x : R⟦G⟧) : + (truncGE c x).coeff i = 0 := by + simp [not_le_of_gt h] + +theorem coeff_truncGT_of_lt [DecidableLT G] {c i : G} (h : c < i) (x : R⟦G⟧) : + (truncGT c x).coeff i = x.coeff i := by + simp [h] + +theorem coeff_truncGT_of_le [DecidableLT G] {c i : G} (h : i ≤ c) (x : R⟦G⟧) : + (truncGT c x).coeff i = 0 := by + simp [not_lt_of_ge h] + +theorem support_truncLE [DecidableLE G] (c : G) (x : R⟦G⟧) : + (truncLE c x).support = {i ∈ x.support | i ≤ c} := + support_filter _ _ + +theorem support_truncGE [DecidableLE G] (c : G) (x : R⟦G⟧) : + (truncGE c x).support = {i ∈ x.support | c ≤ i} := + support_filter _ _ + +theorem support_truncGT [DecidableLT G] (c : G) (x : R⟦G⟧) : + (truncGT c x).support = {i ∈ x.support | c < i} := + support_filter _ _ + +theorem support_truncLE_subset [DecidableLE G] (c : G) (x : R⟦G⟧) : + (truncLE c x).support ⊆ x.support := + support_filter_subset _ _ + +theorem support_truncGE_subset [DecidableLE G] (c : G) (x : R⟦G⟧) : + (truncGE c x).support ⊆ x.support := + support_filter_subset _ _ + +theorem support_truncGT_subset [DecidableLT G] (c : G) (x : R⟦G⟧) : + (truncGT c x).support ⊆ x.support := + support_filter_subset _ _ + +/-- A weak lower truncation is the original series when the support lies below its cutoff. -/ +theorem truncLE_eq_self_of_support_subset_Iic [DecidableLE G] + {c : G} {x : R⟦G⟧} (h : x.support ⊆ Set.Iic c) : + truncLE c x = x := by + ext i + by_cases hi : i ∈ x.support + · exact coeff_truncLE_of_le (h hi) x + · have hcoeff : x.coeff i = 0 := not_ne_iff.mp hi + simp [hcoeff] + +end Zero + +section AddMonoid + +variable [PartialOrder G] [AddMonoid R] + +theorem filter_add (p : G → Prop) [DecidablePred p] (x y : R⟦G⟧) : + filter p (x + y) = filter p x + filter p y := by + ext i + by_cases hi : p i <;> simp [hi] + +theorem truncLE_add [DecidableLE G] (c : G) (x y : R⟦G⟧) : + truncLE c (x + y) = truncLE c x + truncLE c y := + filter_add _ _ _ + +theorem truncGE_add [DecidableLE G] (c : G) (x y : R⟦G⟧) : + truncGE c (x + y) = truncGE c x + truncGE c y := + filter_add _ _ _ + +theorem truncGT_add [DecidableLT G] (c : G) (x y : R⟦G⟧) : + truncGT c (x + y) = truncGT c x + truncGT c y := + filter_add _ _ _ + +end AddMonoid + +section LinearOrder + +variable [LinearOrder G] [AddMonoid R] + +/-- A Hahn series is the sum of its strict lower and weak upper truncations. -/ +theorem truncLT_add_truncGE (c : G) (x : R⟦G⟧) : + truncLT c x + truncGE c x = x := by + ext i + by_cases hi : i < c + · simp [hi, not_le_of_gt hi] + · simp [hi, le_of_not_gt hi] + +/-- A Hahn series is the sum of its weak lower and strict upper truncations. -/ +theorem truncLE_add_truncGT (c : G) (x : R⟦G⟧) : + truncLE c x + truncGT c x = x := by + ext i + by_cases hi : i ≤ c + · simp [hi, not_lt_of_ge hi] + · simp [hi, lt_of_not_ge hi] + +end LinearOrder + +end HahnSeries diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/TruncationIntegerPartPrimal.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/TruncationIntegerPartPrimal.lean new file mode 100644 index 0000000000..0c7c5cd2ec --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/TruncationIntegerPartPrimal.lean @@ -0,0 +1,169 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Divisibility.PrimalPreimage +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Negative + +/-! +# Primality in a Hahn-series truncation integer part + +This module specializes the generic residue-preimage form of LM24, Lemma 9.2.1 to +`Z + L((H^{<0}))`, represented intrinsically as the nonpositive Hahn series whose coefficient at +zero belongs to `Z`. The coefficient-at-zero map is an algebra retraction of constant series. +-/ + +universe u v + +public noncomputable section + +namespace HahnSeries.Nonpositive + +variable {G : Type u} {L : Type v} +variable [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] [Field L] + +/-- Nonpositive Hahn series form an algebra over their coefficient field by constant series. -/ +instance : Algebra L (Nonpositive G L) where + algebraMap := C + smul r x := C r * x + commutes' _ _ := mul_comm _ _ + smul_def' _ _ := rfl + +/-- The coefficient-field algebra map is the constant-series embedding. -/ +@[simp] +theorem algebraMap_apply (r : L) : + algebraMap L (Nonpositive G L) r = C r := (rfl) + +/-- Scalar multiplication commutes with the coercion to Hahn series. -/ +@[simp, norm_cast] +theorem coe_smul (r : L) (x : Nonpositive G L) : + ((r • x : Nonpositive G L) : L⟦G⟧) = r • (x : L⟦G⟧) := by + rw [Algebra.smul_def, algebraMap_apply, Subring.coe_mul, coe_C, + HahnSeries.C_mul_eq_smul] + +/-- Coefficient at exponent zero as an algebra retraction of the constant-series embedding. -/ +def constantCoeffAlgHom : Nonpositive G L →ₐ[L] L where + __ := constantCoeff + commutes' r := by + change constantCoeff (C r : Nonpositive G L) = r + simp + +@[simp] +theorem constantCoeffAlgHom_apply (x : Nonpositive G L) : + constantCoeffAlgHom x = (x : L⟦G⟧).coeff 0 := + constantCoeff_apply x + +/-- The truncation integer part is definitionally the residue preimage under coefficient at +zero. -/ +theorem truncationIntegerPart_eq_residueSubring (Z : Subring L) : + truncationIntegerPart G Z = + Subring.residueSubring (constantCoeffAlgHom (G := G) (L := L)) Z := + by + ext x + rw [mem_truncationIntegerPart, Subring.mem_residueSubring, + constantCoeffAlgHom_apply] + +/-- The canonical identity-on-elements equivalence with the residue-preimage presentation. -/ +def truncationIntegerPartEquivResidueSubring (Z : Subring L) : + truncationIntegerPart G Z ≃+* + Subring.residueSubring (constantCoeffAlgHom (G := G) (L := L)) Z where + toFun x := ⟨x, by rw [← truncationIntegerPart_eq_residueSubring Z]; exact x.2⟩ + invFun x := ⟨x, by rw [truncationIntegerPart_eq_residueSubring Z]; exact x.2⟩ + left_inv _ := rfl + right_inv _ := rfl + map_mul' _ _ := rfl + map_add' _ _ := rfl + +/-- LM24, Lemma 9.2.1 specialized to `Z + L((G^{<0}))`. -/ +theorem isPrimal_truncationIntegerPart_iff (Z : Subring L) + (b : truncationIntegerPart G Z) : + IsPrimal b ↔ + (constantCoeffAlgHom (b : Nonpositive G L) ≠ 0 ∧ + IsPrimal (⟨constantCoeffAlgHom (b : Nonpositive G L), by + rw [constantCoeffAlgHom_apply] + exact (mem_truncationIntegerPart (R := L) (Γ := G)).mp b.2⟩ : Z) ∧ + IsPrimal (b : Nonpositive G L)) ∨ + (constantCoeffAlgHom (b : Nonpositive G L) = 0 ∧ + IsPrimal (⟨(b : Nonpositive G L), Subring.le_fracSubring (by + change constantCoeffAlgHom (b : Nonpositive G L) ∈ Z + rw [constantCoeffAlgHom_apply] + exact (mem_truncationIntegerPart (R := L) (Γ := G)).mp b.2)⟩ : + Subring.residueSubring constantCoeffAlgHom (Subring.fracSubring Z))) := + by + let e := truncationIntegerPartEquivResidueSubring (G := G) (L := L) Z + rw [← RingEquiv.isPrimal_iff e b] + exact Subring.isPrimal_residueSubring_iff (e b).2 + +/-- At constant coefficient one, primality in the truncation integer part is exactly primality +in the ambient nonpositive Hahn ring. This is the nonzero-residue case used in LM24, +Proposition 9.2.2. -/ +theorem isPrimal_truncationIntegerPart_iff_of_constantCoeff_eq_one + (Z : Subring L) (b : truncationIntegerPart G Z) + (hb : constantCoeffAlgHom (b : Nonpositive G L) = 1) : + IsPrimal b ↔ IsPrimal (b : Nonpositive G L) := by + constructor + · intro h + rcases (isPrimal_truncationIntegerPart_iff Z b).mp h with hnonzero | hzero + · exact hnonzero.2.2 + · exact (one_ne_zero (hb.symm.trans hzero.1)).elim + · intro h + apply (isPrimal_truncationIntegerPart_iff Z b).mpr + left + refine ⟨?_, ?_, h⟩ + · rw [hb] + exact one_ne_zero + · have hone : (⟨constantCoeffAlgHom (b : Nonpositive G L), by + rw [constantCoeffAlgHom_apply] + exact (mem_truncationIntegerPart (R := L) (Γ := G)).mp b.2⟩ : Z) = 1 := by + apply Subtype.ext + exact hb + rw [hone] + intro c d _ + exact ⟨1, 1, one_dvd _, one_dvd _, (mul_one 1).symm⟩ + +/-- At constant coefficient zero, if the fraction field generated by the coefficient subring is +the whole coefficient field, primality in the truncation integer part is exactly ambient +primality. This is the zero-residue case used in LM24, Proposition 9.2.2. -/ +theorem isPrimal_truncationIntegerPart_iff_of_constantCoeff_eq_zero + (Z : Subring L) (hfrac : Subring.fracSubring Z = ⊤) + (b : truncationIntegerPart G Z) + (hb : constantCoeffAlgHom (b : Nonpositive G L) = 0) : + IsPrimal b ↔ IsPrimal (b : Nonpositive G L) := by + let e : Subring.residueSubring + (constantCoeffAlgHom (G := G) (L := L)) (Subring.fracSubring Z) ≃+* + Nonpositive G L := { + toFun x := x + invFun x := ⟨x, by rw [Subring.mem_residueSubring, hfrac]; exact Subring.mem_top _⟩ + left_inv _ := rfl + right_inv _ := rfl + map_mul' _ _ := rfl + map_add' _ _ := rfl } + constructor + · intro h + rcases (isPrimal_truncationIntegerPart_iff Z b).mp h with hnonzero | hzero + · exact (hnonzero.1 hb).elim + · let b' : Subring.residueSubring + (constantCoeffAlgHom (G := G) (L := L)) (Subring.fracSubring Z) := + ⟨b, Subring.le_fracSubring (by + change constantCoeffAlgHom (b : Nonpositive G L) ∈ Z + rw [constantCoeffAlgHom_apply] + exact (mem_truncationIntegerPart (R := L) (Γ := G)).mp b.2)⟩ + have hb' : IsPrimal b' := by exact hzero.2 + exact (RingEquiv.isPrimal_iff e b').mpr hb' + · intro h + apply (isPrimal_truncationIntegerPart_iff Z b).mpr + right + refine ⟨hb, ?_⟩ + let b' : Subring.residueSubring + (constantCoeffAlgHom (G := G) (L := L)) (Subring.fracSubring Z) := + ⟨b, Subring.le_fracSubring (by + change constantCoeffAlgHom (b : Nonpositive G L) ∈ Z + rw [constantCoeffAlgHom_apply] + exact (mem_truncationIntegerPart (R := L) (Γ := G)).mp b.2)⟩ + have hb' := (RingEquiv.isPrimal_iff e b').mp h + exact hb' + +end HahnSeries.Nonpositive diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/WeakNormalForm.lean b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/WeakNormalForm.lean new file mode 100644 index 0000000000..764722b127 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/HahnSeries/WeakNormalForm.lean @@ -0,0 +1,232 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrderType +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.AdditivelyPrincipal + +/-! +# Weak normal forms of Hahn series + +This module formalizes LM24, Definitions 3.3.1 and 3.3.2, Proposition 3.3.4, and Corollary +3.3.5. A weakly principal Hahn series has positive additive-principal support order type. A weak +normal form is a finite lower-to-upper decomposition into weakly principal blocks whose support +order types are nonincreasing. The definition uses pairwise support separation; the +`isWeakNormalForm_iff_isChain` theorem proves that this is exactly the adjacent chain printed in +LM24 because every weakly principal block is nonzero. + +The order-type condition is deliberately nonstrict. Repeated equal powers of `ω` represent finite +coefficients in Cantor normal form and must produce distinct consecutive blocks. The zero series +has the empty weak normal form. + +The existence and uniqueness theorem is generalized from field coefficients and LM24's fixed +support-cardinality bound to additive-monoid coefficients and unrestricted Hahn series. Every +constructed block has support contained in the original support, so the construction restricts to +the source's bounded-support regime. +-/ + +universe u v + +public noncomputable section + +namespace HahnSeries + +variable {R : Type v} {G : Type u} [LinearOrder G] [AddMonoid R] + +/-- A weakly principal Hahn series has positive additive-principal support order type. -/ +def IsWeaklyPrincipal (x : R⟦G⟧) : Prop := + x.supportOrderType.IsAdditivelyPrincipal + +/-- Characterization of weakly principal Hahn series by their support order type. -/ +theorem isWeaklyPrincipal_iff {x : R⟦G⟧} : + IsWeaklyPrincipal x ↔ x.supportOrderType.IsAdditivelyPrincipal := + (Iff.rfl) + +/-- A weakly principal Hahn series is nonzero. -/ +theorem IsWeaklyPrincipal.ne_zero {x : R⟦G⟧} (hx : IsWeaklyPrincipal x) : x ≠ 0 := by + intro hzero + subst x + exact (Ordinal.IsAdditivelyPrincipal.ne_zero (isWeaklyPrincipal_iff.mp hx)) + supportOrderType_zero + +/-- The four clauses defining an LM24 weak normal form. -/ +def IsWeakNormalForm (x : R⟦G⟧) (blocks : List R⟦G⟧) : Prop := + blocks.sum = x ∧ + (∀ b ∈ blocks, IsWeaklyPrincipal b) ∧ + (blocks.map supportOrderType).SortedGE ∧ + blocks.Pairwise SupportBelow + +/-- Characterization of an LM24 weak normal form by its sum, blocks, order types, and supports. -/ +theorem isWeakNormalForm_iff {x : R⟦G⟧} {blocks : List R⟦G⟧} : + IsWeakNormalForm x blocks ↔ + blocks.sum = x ∧ + (∀ b ∈ blocks, IsWeaklyPrincipal b) ∧ + (blocks.map supportOrderType).SortedGE ∧ + blocks.Pairwise SupportBelow := + (Iff.rfl) + +/-- Source-form characterization using the adjacent support chain printed in LM24, Definition +3.3.2. Nonzeroness of weakly principal blocks makes this equivalent to pairwise separation. -/ +theorem isWeakNormalForm_iff_isChain {x : R⟦G⟧} {blocks : List R⟦G⟧} : + IsWeakNormalForm x blocks ↔ + blocks.sum = x ∧ + (∀ b ∈ blocks, IsWeaklyPrincipal b) ∧ + (blocks.map supportOrderType).SortedGE ∧ + blocks.IsChain SupportBelow := by + rw [isWeakNormalForm_iff] + constructor + · rintro ⟨hsum, hprincipal, hsorted, hpair⟩ + exact ⟨hsum, hprincipal, hsorted, hpair.isChain⟩ + · rintro ⟨hsum, hprincipal, hsorted, hchain⟩ + refine ⟨hsum, hprincipal, hsorted, ?_⟩ + apply pairwise_supportBelow_of_isChain + · exact fun b hb ↦ (hprincipal b hb).ne_zero + · exact hchain + +private theorem exists_orderType_blocks (x : R⟦G⟧) (types : List Ordinal) + (htype : x.supportOrderType = types.sum) : + ∃ blocks : List R⟦G⟧, + blocks.sum = x ∧ + blocks.map supportOrderType = types ∧ + blocks.Pairwise SupportBelow := by + induction types generalizing x with + | nil => + have hx : x = 0 := supportOrderType_eq_zero.mp (by simpa using htype) + subst x + exact ⟨[], by simp⟩ + | cons a types ih => + have hsplit : x.supportOrderType = a + types.sum := by + simpa only [List.sum_cons] using htype + obtain ⟨y, z, hyz, hya, hztypes, hx⟩ := + (supportOrderType_eq_add_iff x a types.sum).mp hsplit + obtain ⟨blocks, hsum, htypes, hpair⟩ := ih z hztypes + refine ⟨y :: blocks, ?_, ?_, ?_⟩ + · rw [List.sum_cons, hsum] + exact hx.symm + · simp only [List.map_cons, hya, htypes] + · rw [List.pairwise_cons] + refine ⟨?_, hpair⟩ + intro b hb + rw [supportBelow_iff] + intro i hi j hj + have hbsub : b.support ⊆ z.support := by + have hsubset := support_subset_list_sum_of_mem hpair hb + rwa [hsum] at hsubset + exact hyz.lt hi (hbsub hj) + +/-- Every Hahn series has a weak normal form. This is the existence part of LM24, Proposition +3.3.4. -/ +theorem exists_isWeakNormalForm (x : R⟦G⟧) : + ∃ blocks : List R⟦G⟧, IsWeakNormalForm x blocks := by + obtain ⟨blocks, hsum, htypes, hpair⟩ := exists_orderType_blocks x + x.supportOrderType.additivePrincipalTerms + (Ordinal.additivePrincipalTerms_sum x.supportOrderType).symm + refine ⟨blocks, isWeakNormalForm_iff.mpr ⟨hsum, ?_, ?_, hpair⟩⟩ + · intro b hb + rw [isWeaklyPrincipal_iff] + apply Ordinal.isAdditivelyPrincipal_of_mem_additivePrincipalTerms + rw [← htypes] + exact List.mem_map.mpr ⟨b, hb, rfl⟩ + · rw [htypes] + exact Ordinal.additivePrincipalTerms_sortedGE _ + +/-- The support order types of a weak normal form are the uncompressed Cantor terms of the whole +support order type. -/ +theorem IsWeakNormalForm.supportOrderTypes_eq_additivePrincipalTerms + {x : R⟦G⟧} {blocks : List R⟦G⟧} (h : IsWeakNormalForm x blocks) : + blocks.map supportOrderType = x.supportOrderType.additivePrincipalTerms := by + obtain ⟨hsum, hprincipal, hsorted, hpair⟩ := isWeakNormalForm_iff.mp h + apply Ordinal.additivePrincipalTerms_unique + · calc + (blocks.map supportOrderType).sum = blocks.sum.supportOrderType := + (supportOrderType_list_sum hpair).symm + _ = x.supportOrderType := congrArg supportOrderType hsum + · intro a ha + obtain ⟨b, hb, rfl⟩ := List.mem_map.mp ha + exact isWeaklyPrincipal_iff.mp (hprincipal b hb) + · exact hsorted + +private theorem eq_of_pairwise_sum_and_orderTypes {xs ys : List R⟦G⟧} + (hxpair : xs.Pairwise SupportBelow) (hypair : ys.Pairwise SupportBelow) + (hsum : xs.sum = ys.sum) (htypes : xs.map supportOrderType = ys.map supportOrderType) : + xs = ys := by + induction xs generalizing ys with + | nil => simpa using htypes + | cons x xs ih => + cases ys with + | nil => simp at htypes + | cons y ys => + rw [List.pairwise_cons] at hxpair hypair + simp only [List.map_cons, List.cons.injEq] at htypes + have hxbelow : SupportBelow x xs.sum := supportBelow_list_sum hxpair.1 + have hybelow : SupportBelow y ys.sum := supportBelow_list_sum hypair.1 + have hdecomp := add_decomposition_unique hxbelow hybelow htypes.1 (by + simpa only [List.sum_cons] using hsum) + rw [hdecomp.1] + congr 1 + exact ih hxpair.2 hypair.2 hdecomp.2 htypes.2 + +/-- Two weak normal forms of the same series are equal. This is the uniqueness part of LM24, +Proposition 3.3.4. -/ +theorem IsWeakNormalForm.unique {x : R⟦G⟧} {blocks other : List R⟦G⟧} + (hblocks : IsWeakNormalForm x blocks) (hother : IsWeakNormalForm x other) : + blocks = other := by + obtain ⟨hsum, _, _, hpair⟩ := isWeakNormalForm_iff.mp hblocks + obtain ⟨hotherSum, _, _, hotherPair⟩ := isWeakNormalForm_iff.mp hother + apply eq_of_pairwise_sum_and_orderTypes hpair hotherPair + · exact hsum.trans hotherSum.symm + · exact hblocks.supportOrderTypes_eq_additivePrincipalTerms.trans + hother.supportOrderTypes_eq_additivePrincipalTerms.symm + +/-- Every Hahn series has exactly one weak normal form. This is LM24, Proposition 3.3.4. -/ +theorem existsUnique_isWeakNormalForm (x : R⟦G⟧) : + ∃! blocks : List R⟦G⟧, IsWeakNormalForm x blocks := by + obtain ⟨blocks, hblocks⟩ := exists_isWeakNormalForm x + exact ⟨blocks, hblocks, fun other hother ↦ (hblocks.unique hother).symm⟩ + +/-- Every nonzero Hahn series has a nonzero weakly principal weak upper truncation. This is LM24, +Corollary 3.3.5, generalized from ordered-group exponents to a linearly ordered type with zero. -/ +theorem exists_nonzero_isWeaklyPrincipal_truncGE [Zero G] {x : R⟦G⟧} (hx : x ≠ 0) : + ∃ c : G, truncGE c x ≠ 0 ∧ IsWeaklyPrincipal (truncGE c x) := by + obtain ⟨blocks, hblocks⟩ := exists_isWeakNormalForm x + obtain ⟨hsum, hprincipal, _, hpair⟩ := isWeakNormalForm_iff.mp hblocks + have hblocksne : blocks ≠ [] := by + intro hzero + rw [hzero] at hsum + exact hx (by simpa using hsum.symm) + let last := blocks.getLast hblocksne + have hlastMem : last ∈ blocks := List.getLast_mem hblocksne + have hlastPrincipal : IsWeaklyPrincipal last := hprincipal last hlastMem + have hlastNe : last ≠ 0 := hlastPrincipal.ne_zero + have hlastOrderMem : last.order ∈ last.support := + (mem_support last last.order).mpr (coeff_order_eq_zero.not.mpr hlastNe) + have hprefixBelow : SupportBelow blocks.dropLast.sum last := by + apply list_sum_supportBelow + intro b hb + exact hpair.rel_dropLast_getLast hb + have hprefixTrunc : truncGE last.order blocks.dropLast.sum = 0 := by + rw [← support_eq_empty_iff, support_truncGE] + ext i + simp only [Set.mem_ofPred_eq, Set.mem_empty_iff_false, iff_false, not_and] + intro hi + exact fun hle ↦ (not_lt_of_ge hle) (hprefixBelow.lt hi hlastOrderMem) + have hlastTrunc : truncGE last.order last = last := by + ext i + by_cases hi : last.coeff i = 0 + · simp [hi] + · simp [order_le_of_coeff_ne_zero hi] + have hxsplit : blocks.dropLast.sum + last = x := by + calc + blocks.dropLast.sum + last = (blocks.dropLast ++ [last]).sum := by simp + _ = blocks.sum := congrArg List.sum (List.dropLast_append_getLast hblocksne) + _ = x := hsum + refine ⟨last.order, ?_, ?_⟩ + · rw [← hxsplit, truncGE_add, hprefixTrunc, hlastTrunc, zero_add] + exact hlastNe + · rw [← hxsplit, truncGE_add, hprefixTrunc, hlastTrunc, zero_add] + exact hlastPrincipal + +end HahnSeries diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/LinearAlgebra.lean b/LeanPool/ConwayRefinement/ConwayRefinement/LinearAlgebra.lean new file mode 100644 index 0000000000..d7b62e9d0b --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/LinearAlgebra.lean @@ -0,0 +1,14 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.LinearAlgebra.AlgebraicIndependentDet +public import LeanPool.ConwayRefinement.ConwayRefinement.LinearAlgebra.FiniteSpanRelation +public import LeanPool.ConwayRefinement.ConwayRefinement.LinearAlgebra.IndicatorFinsupp +public import LeanPool.ConwayRefinement.ConwayRefinement.LinearAlgebra.TensorProduct + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/LinearAlgebra/AlgebraicIndependentDet.lean b/LeanPool/ConwayRefinement/ConwayRefinement/LinearAlgebra/AlgebraicIndependentDet.lean new file mode 100644 index 0000000000..1605e1e2c5 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/LinearAlgebra/AlgebraicIndependentDet.lean @@ -0,0 +1,80 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import Mathlib.RingTheory.AlgebraicIndependent.Defs +public import Mathlib.LinearAlgebra.Matrix.Determinant.Basic + +import Mathlib.Algebra.MvPolynomial.Basic + +/-! +# Determinants of matrices of algebraically independent entries + +A square matrix whose entries are either `0` or members of an algebraically independent family, +with no member used twice and every diagonal entry a member, has nonzero determinant. The +determinant is the image of the determinant of the symbolic matrix, which is a nonzero +polynomial: specializing the diagonal variables to `1` and all others to `0` evaluates it to +`det 1 = 1`. + +The zero pattern is recorded by a function `v : n → n → Option V`; the entry at `(i, j)` is +`f w` when `v i j = some w` and `0` when `v i j = none`. +-/ + +universe u v w + +public section + +namespace Matrix + +variable {R : Type u} {A : Type v} [CommRing R] [Nontrivial R] [CommRing A] [Algebra R A] + +/-- A matrix of distinct algebraically independent entries and zeros, with a full diagonal of +entries, has nonzero determinant. -/ +theorem det_ne_zero_of_algebraicIndependent {V : Type w} {f : V → A} + (hf : AlgebraicIndependent R f) {n : Type*} [Fintype n] [DecidableEq n] + (v : n → n → Option V) (M : Matrix n n A) (hM : ∀ i j, M i j = (v i j).elim 0 f) + (hdiag : ∀ i, (v i i).isSome) + (hdistinct : ∀ i j i' j' w, v i j = some w → v i' j' = some w → i = i' ∧ j = j') : + M.det ≠ 0 := by + classical + intro hdet + let Msym : Matrix n n (MvPolynomial V R) := Matrix.of fun i j ↦ (v i j).elim 0 MvPolynomial.X + have hmap : (MvPolynomial.aeval f).mapMatrix Msym = M := by + ext i j + rw [AlgHom.mapMatrix_apply, Matrix.map_apply, hM i j] + simp only [Msym, Matrix.of_apply] + cases v i j <;> simp + have hdetSym : MvPolynomial.aeval f Msym.det = 0 := by + rw [AlgHom.map_det, hmap, hdet] + have hzero : Msym.det = 0 := hf.eq_zero_of_aeval_eq_zero _ hdetSym + let e : V → R := fun w ↦ if ∃ i, v i i = some w then 1 else 0 + have heval : (MvPolynomial.eval e).mapMatrix Msym = 1 := by + ext i j + rw [RingHom.mapMatrix_apply, Matrix.map_apply, Matrix.one_apply] + simp only [Msym, Matrix.of_apply] + by_cases hij : i = j + · subst hij + obtain ⟨w, hw⟩ := Option.isSome_iff_exists.mp (hdiag i) + rw [hw, ite_eq_left rfl] + simp only [Option.elim, MvPolynomial.eval_X, e] + rw [ite_eq_left ⟨i, hw⟩] + · rw [ite_eq_right hij] + cases hv : v i j with + | none => simp + | some w => + simp only [Option.elim, MvPolynomial.eval_X, e] + rw [ite_eq_right] + rintro ⟨i', hi'⟩ + obtain ⟨h1, h2⟩ := hdistinct i j i' i' w hv hi' + exact hij (h1.trans h2.symm) + have hone : MvPolynomial.eval e Msym.det = 1 := by + rw [RingHom.map_det, heval, Matrix.det_one] + rw [hzero, map_zero] at hone + exact zero_ne_one hone + +end Matrix + +end diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/LinearAlgebra/FiniteSpanRelation.lean b/LeanPool/ConwayRefinement/ConwayRefinement/LinearAlgebra/FiniteSpanRelation.lean new file mode 100644 index 0000000000..a2a4a29b62 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/LinearAlgebra/FiniteSpanRelation.lean @@ -0,0 +1,47 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import Mathlib.LinearAlgebra.Dimension.Constructions +public import Mathlib.LinearAlgebra.Dimension.Finite + +/-! +# A nontrivial relation among too many vectors of a finite span + +More vectors than generators are linearly dependent: if a family `w : Γ → V` of vectors lies in +the span of `M` generators and `Γ` has more than `M` elements, then some finite nontrivial +`K`-linear combination of the `w γ` vanishes. The vectors `w γ` need not be distinct. +-/ + +universe u v w + +public section + +namespace Module + +variable {K : Type u} {V : Type v} [Field K] [AddCommGroup V] [Module K V] + +/-- A family of more than `M` vectors in the span of `M` generators admits a nontrivial vanishing +linear combination. -/ +theorem exists_nontrivial_relation_of_mem_span_range {ι : Type w} [Fintype ι] (gens : ι → V) + {Γ : Type*} [Fintype Γ] (w : Γ → V) + (hw : ∀ γ, w γ ∈ Submodule.span K (Set.range gens)) (hcard : Fintype.card ι < Fintype.card Γ) : + ∃ (s : Finset Γ) (δ : Γ → K), ∑ γ ∈ s, δ γ • w γ = 0 ∧ ∃ γ ∈ s, δ γ ≠ 0 := by + by_contra hrel + rw [← not_linearIndependent_iff, not_not] at hrel + let w' : Γ → Submodule.span K (Set.range gens) := fun γ ↦ ⟨w γ, hw γ⟩ + have hw' : LinearIndependent K w' := by + refine LinearIndependent.of_comp (Submodule.span K (Set.range gens)).subtype ?_ + exact hrel + have : Module.Finite K (Submodule.span K (Set.range gens)) := + Module.Finite.span_of_finite K (Set.finite_range gens) + have hle := hw'.fintype_card_le_finrank + have hrank := finrank_range_le_card (R := K) gens + exact absurd (hle.trans hrank) (not_le.mpr hcard) + +end Module + +end diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/LinearAlgebra/IndicatorFinsupp.lean b/LeanPool/ConwayRefinement/ConwayRefinement/LinearAlgebra/IndicatorFinsupp.lean new file mode 100644 index 0000000000..958ca965b3 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/LinearAlgebra/IndicatorFinsupp.lean @@ -0,0 +1,97 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import Mathlib.LinearAlgebra.Finsupp.LinearCombination +public import Mathlib.LinearAlgebra.LinearIndependent.Defs + +/-! +# Indicators in the free module on a set + +For a set `L` in a module `M` over `R`, the indicator of `y ∈ M` is the basis vector of +`L →₀ R` at `y` when `y ∈ L`, and `0` otherwise. Its linear combination along the inclusion +`L → M` is `y` when `y ∈ L` and `0` otherwise. When `L` is linearly independent, a vanishing +combination of elements of `L` lifts to the free module, where it can be evaluated at a chosen +basis vector; this is how relations among elements of an independent set are resolved. +-/ + +universe u v + +public section + +namespace Set + +variable {R : Type u} {M : Type v} [Semiring R] + +open scoped Classical in +/-- The indicator of `y` in the free `R`-module on `L`: the basis vector at `y` when `y ∈ L`, +and `0` otherwise. -/ +noncomputable def indicatorFinsupp (L : Set M) (R : Type u) [Semiring R] (y : M) : L →₀ R := + if h : y ∈ L then Finsupp.single ⟨y, h⟩ 1 else 0 + +open scoped Classical in +theorem indicatorFinsupp_apply_of_mem (L : Set M) {y : M} (h : y ∈ L) (z : L) : + L.indicatorFinsupp R y z = if (z : M) = y then 1 else 0 := by + rw [indicatorFinsupp, dite_eq_left h, Finsupp.single_apply] + by_cases hz : (z : M) = y + · rw [ite_eq_left hz, ite_eq_left (Subtype.ext hz).symm] + · rw [ite_eq_right hz, ite_eq_right fun h' ↦ hz (congrArg Subtype.val h').symm] + +theorem indicatorFinsupp_apply_of_notMem (L : Set M) {y : M} (h : y ∉ L) (z : L) : + L.indicatorFinsupp R y z = 0 := by + rw [indicatorFinsupp, dite_eq_right h, Finsupp.zero_apply] + +/-- The indicator of `y` evaluated at the basis vector of `y` itself is `1`. -/ +theorem indicatorFinsupp_apply_self (L : Set M) {y : M} (h : y ∈ L) : + L.indicatorFinsupp R y ⟨y, h⟩ = 1 := by + classical + rw [indicatorFinsupp_apply_of_mem L h, ite_eq_left rfl] + +/-- The indicator of `y` vanishes at a basis vector other than `y`. -/ +theorem indicatorFinsupp_apply_of_ne (L : Set M) (y : M) (z : L) (hz : (z : M) ≠ y) : + L.indicatorFinsupp R y z = 0 := by + classical + by_cases h : y ∈ L + · rw [indicatorFinsupp_apply_of_mem L h, ite_eq_right hz] + · exact indicatorFinsupp_apply_of_notMem L h z + +theorem indicatorFinsupp_apply_nonneg [PartialOrder R] [IsOrderedRing R] (L : Set M) (y : M) + (z : L) : 0 ≤ L.indicatorFinsupp R y z := by + classical + by_cases h : y ∈ L + · rw [indicatorFinsupp_apply_of_mem L h] + split_ifs + · exact zero_le_one + · exact le_rfl + · rw [indicatorFinsupp_apply_of_notMem L h] + +variable [AddCommMonoid M] [Module R M] + +variable (R) in +open scoped Classical in +theorem linearCombination_indicatorFinsupp (L : Set M) (y : M) : + Finsupp.linearCombination R (fun z : L ↦ (z : M)) (L.indicatorFinsupp R y) = + if y ∈ L then y else 0 := by + by_cases h : y ∈ L + · rw [indicatorFinsupp, dite_eq_left h, Finsupp.linearCombination_single, one_smul, ite_eq_left h] + · rw [indicatorFinsupp, dite_eq_right h, map_zero, ite_eq_right h] + +variable (R) in +/-- The linear combination of the indicator of a member of `L` is that member. -/ +theorem linearCombination_indicatorFinsupp_of_mem (L : Set M) {y : M} (h : y ∈ L) : + Finsupp.linearCombination R (fun z : L ↦ (z : M)) (L.indicatorFinsupp R y) = y := by + rw [linearCombination_indicatorFinsupp, ite_eq_left h] + +variable (R) in +/-- The linear combination of the indicator of `0` is `0`, whether or not `0 ∈ L`. -/ +theorem linearCombination_indicatorFinsupp_zero (L : Set M) : + Finsupp.linearCombination R (fun z : L ↦ (z : M)) (L.indicatorFinsupp R 0) = 0 := by + rw [linearCombination_indicatorFinsupp] + split_ifs <;> rfl + +end Set + +end diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/LinearAlgebra/TensorProduct.lean b/LeanPool/ConwayRefinement/ConwayRefinement/LinearAlgebra/TensorProduct.lean new file mode 100644 index 0000000000..44d02f9017 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/LinearAlgebra/TensorProduct.lean @@ -0,0 +1,12 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.LinearAlgebra.TensorProduct.Content +public import LeanPool.ConwayRefinement.ConwayRefinement.LinearAlgebra.TensorProduct.SubalgebraBasis + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/LinearAlgebra/TensorProduct/Content.lean b/LeanPool/ConwayRefinement/ConwayRefinement/LinearAlgebra/TensorProduct/Content.lean new file mode 100644 index 0000000000..2626069f0e --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/LinearAlgebra/TensorProduct/Content.lean @@ -0,0 +1,328 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import Mathlib.Algebra.GCDMonoid.Basic +public import Mathlib.Algebra.Algebra.Defs +public import Mathlib.LinearAlgebra.TensorProduct.Map + +import Mathlib.Algebra.GCDMonoid.Finset +import Mathlib.LinearAlgebra.Basis.VectorSpace +import Mathlib.LinearAlgebra.TensorProduct.Basis + +/-! +# Content of a tensor over a GCD algebra + +Let `K` be a field, let `D` be a commutative `K`-algebra, and let `V` be a `K`-vector space. +For `z : V ⊗[K] D`, a class `a : Associates D` is the content of `z` when, for every `q : D`, +`q` divides `a` exactly when `z` is obtained by multiplying the right tensor factor by `q`. + +This divisibility property is the public definition. Existence over a GCD monoid is proved by +choosing a basis of `V` internally and taking the greatest common divisor of the finitely many +nonzero coordinates. The resulting associate class is independent of both that basis and the +chosen `GCDMonoid` structure. +-/ + +open scoped TensorProduct + +universe u v w x + +namespace TensorProduct + +public noncomputable section + +variable {K : Type u} {D : Type v} {V : Type w} +variable [Field K] [CommRing D] [IsDomain D] [Algebra K D] +variable [AddCommGroup V] [Module K V] + +/-- Multiply the right tensor factor by `q`. -/ +def mulRightFactor (q : D) : V ⊗[K] D →ₗ[K] V ⊗[K] D := + LinearMap.lTensor (R := K) V (LinearMap.mulLeft K (A := D) q) + +omit [IsDomain D] in +/-- Multiplication on the right tensor factor sends `x ⊗ d` to `x ⊗ qd`. -/ +@[simp] +theorem mulRightFactor_tmul (q d : D) (x : V) : + mulRightFactor (K := K) (D := D) (V := V) q (x ⊗ₜ[K] d) = + x ⊗ₜ[K] (q * d) := by + simp [mulRightFactor] + +/-- `a` is the associate class of the greatest common divisor of the coefficients of `z`. + +The right-hand side is intrinsic: it does not mention a basis or chosen coordinates. -/ +def IsContent (z : V ⊗[K] D) (a : Associates D) : Prop := + ∀ q : D, Associates.mk q ≤ a ↔ + ∃ y : V ⊗[K] D, mulRightFactor (K := K) q y = z + +omit [IsDomain D] in +/-- The intrinsic divisibility characterization of tensor content. -/ +theorem isContent_iff (z : V ⊗[K] D) (a : Associates D) : + IsContent z a ↔ + ∀ q : D, Associates.mk q ≤ a ↔ + ∃ y : V ⊗[K] D, mulRightFactor (K := K) q y = z := + Iff.rfl + +omit [IsDomain D] in +/-- Applying a linear map to the left tensor factor commutes with multiplication on the right +tensor factor. -/ +theorem rTensor_mulRightFactor + {W : Type x} [AddCommGroup W] [Module K W] + (f : V →ₗ[K] W) (q : D) (z : V ⊗[K] D) : + f.rTensor D (mulRightFactor (K := K) q z) = + mulRightFactor (K := K) q (f.rTensor D z) := by + induction z using TensorProduct.inductionOn with + | tmul y d => simp + | add y z hy hz => simp [map_add, hy, hz] + +omit [IsDomain D] in +/-- An injective linear change of the left tensor factor preserves the intrinsic content +property. -/ +theorem isContent_rTensor_iff_of_injective + {W : Type x} [AddCommGroup W] [Module K W] + (f : V →ₗ[K] W) (hf : Function.Injective f) + (z : V ⊗[K] D) (a : Associates D) : + IsContent (f.rTensor D z) a ↔ IsContent z a := by + let hker : f.ker = ⊥ := LinearMap.ker_eq_bot.mpr hf + let g := f.leftInverse + have hgf : g.comp f = LinearMap.id := f.leftInverse_comp_of_inj hker + have hgfTensor (y : V ⊗[K] D) : g.rTensor D (f.rTensor D y) = y := by + rw [← LinearMap.rTensor_comp_apply, hgf, LinearMap.rTensor_id] + rfl + constructor + · intro h + rw [isContent_iff] at h ⊢ + intro q + constructor + · intro hqa + obtain ⟨y, hy⟩ := (h q).mp hqa + refine ⟨g.rTensor D y, ?_⟩ + calc + mulRightFactor (K := K) q (g.rTensor D y) = + g.rTensor D (mulRightFactor (K := K) q y) := + (rTensor_mulRightFactor g q y).symm + _ = g.rTensor D (f.rTensor D z) := congrArg (g.rTensor D) hy + _ = z := hgfTensor z + · rintro ⟨y, hy⟩ + apply (h q).mpr + refine ⟨f.rTensor D y, ?_⟩ + calc + mulRightFactor (K := K) q (f.rTensor D y) = + f.rTensor D (mulRightFactor (K := K) q y) := + (rTensor_mulRightFactor f q y).symm + _ = f.rTensor D z := congrArg (f.rTensor D) hy + · intro h + rw [isContent_iff] at h ⊢ + intro q + constructor + · intro hqa + obtain ⟨y, hy⟩ := (h q).mp hqa + refine ⟨f.rTensor D y, ?_⟩ + calc + mulRightFactor (K := K) q (f.rTensor D y) = + f.rTensor D (mulRightFactor (K := K) q y) := + (rTensor_mulRightFactor f q y).symm + _ = f.rTensor D z := congrArg (f.rTensor D) hy + · rintro ⟨y, hy⟩ + apply (h q).mpr + refine ⟨g.rTensor D y, ?_⟩ + calc + mulRightFactor (K := K) q (g.rTensor D y) = + g.rTensor D (mulRightFactor (K := K) q y) := + (rTensor_mulRightFactor g q y).symm + _ = g.rTensor D (f.rTensor D z) := congrArg (g.rTensor D) hy + _ = z := hgfTensor z + +/-- The intrinsic content property determines at most one associate class. -/ +theorem IsContent.eq {z : V ⊗[K] D} {a b : Associates D} + (ha : IsContent z a) (hb : IsContent z b) : a = b := by + induction a using Quotient.inductionOn with + | _ a => + induction b using Quotient.inductionOn with + | _ b => + apply le_antisymm + · exact (hb a).2 ((ha a).1 le_rfl) + · exact (ha b).2 ((hb b).1 le_rfl) + +@[implicit_reducible] +private noncomputable def normalizedAssociatesGCDMonoid + (gcdStructure : GCDMonoid D) : + NormalizedGCDMonoid (Associates D) := by + classical + letI : GCDMonoid D := gcdStructure + letI : GCDMonoid (Associates D) := inferInstance + exact normalizedGCDMonoidOfExistsGCD fun a b ↦ + ⟨gcd a b, fun d ↦ (dvd_gcd_iff d a b).symm⟩ + +private noncomputable def contentBasis : + Module.Basis (Module.Free.ChooseBasisIndex K V) K V := + Module.Free.chooseBasis K V + +private noncomputable def contentCoordinates : + V ⊗[K] D ≃ₗ[K] Module.Free.ChooseBasisIndex K V →₀ D := + TensorProduct.equivFinsuppOfBasisLeft + (contentBasis (K := K) (V := V)) + +omit [IsDomain D] in +private theorem contentCoordinates_mulRightFactor_apply + (q : D) (z : V ⊗[K] D) + (i : Module.Free.ChooseBasisIndex K V) : + contentCoordinates (K := K) (D := D) (V := V) + (mulRightFactor (K := K) q z) i = + q * contentCoordinates (K := K) (D := D) (V := V) z i := by + induction z using TensorProduct.inductionOn with + | tmul x d => + rw [mulRightFactor_tmul] + simp only [contentCoordinates, + TensorProduct.equivFinsuppOfBasisLeft_apply_tmul_apply] + rw [_root_.Algebra.smul_def, _root_.Algebra.smul_def] + ring + | add x y hx hy => simp [map_add, hx, hy, mul_add] + +omit [IsDomain D] in +private theorem exists_mulRightFactor_eq_iff + (q : D) (z : V ⊗[K] D) : + (∃ y : V ⊗[K] D, mulRightFactor (K := K) q y = z) ↔ + ∀ i, q ∣ contentCoordinates (K := K) (D := D) (V := V) z i := by + constructor + · rintro ⟨y, rfl⟩ i + exact ⟨contentCoordinates (K := K) (D := D) (V := V) y i, + contentCoordinates_mulRightFactor_apply (K := K) q y i⟩ + · intro h + let c := contentCoordinates (K := K) (D := D) (V := V) z + let c' : Module.Free.ChooseBasisIndex K V →₀ D := + Finsupp.onFinset c.support + (fun i ↦ if hi : i ∈ c.support then Classical.choose (h i) else 0) + (fun i hi ↦ by + by_contra hnot + simp [hnot] at hi) + refine ⟨(contentCoordinates (K := K) (D := D) (V := V)).symm c', ?_⟩ + apply (contentCoordinates (K := K) (D := D) (V := V)).injective + ext i + rw [contentCoordinates_mulRightFactor_apply, + LinearEquiv.apply_symm_apply] + by_cases hi : i ∈ c.support + · rw [show c' i = Classical.choose (h i) by simp [c', hi]] + exact (Classical.choose_spec (h i)).symm + · rw [show c' i = 0 by simp [c', hi], mul_zero] + exact Finsupp.notMem_support_iff.mp hi |>.symm + +omit [IsDomain D] in +/-- The zero tensor has zero content. -/ +theorem isContent_zero : IsContent (0 : V ⊗[K] D) 0 := by + intro q + constructor + · intro _ + exact ⟨0, (mulRightFactor (K := K) q).map_zero⟩ + · intro _ + change Associates.mk q ≤ Associates.mk 0 + exact Associates.mk_le_mk_of_dvd (dvd_zero q) + +omit [IsDomain D] in +/-- A pure tensor with nonzero left factor has the content of its right factor. -/ +theorem isContent_tmul_of_ne_zero (x : V) (hx : x ≠ 0) (d : D) : + IsContent (x ⊗ₜ[K] d) (Associates.mk d) := by + classical + intro q + rw [Associates.mk_le_mk_iff_dvd] + constructor + · rintro ⟨e, he⟩ + refine ⟨x ⊗ₜ[K] e, ?_⟩ + rw [mulRightFactor_tmul, he] + · intro hfactor + have hcoordinates := + (exists_mulRightFactor_eq_iff (K := K) q (x ⊗ₜ[K] d)).mp hfactor + have hrepr : (contentBasis (K := K) (V := V)).repr x ≠ 0 := by + intro hzero + apply hx + apply (contentBasis (K := K) (V := V)).repr.injective + simpa using hzero + obtain ⟨i, hi⟩ := Finsupp.support_nonempty_iff.mpr hrepr + have hqi := hcoordinates i + simp only [contentCoordinates, + TensorProduct.equivFinsuppOfBasisLeft_apply_tmul_apply] at hqi + have hunit : IsUnit + (algebraMap K D ((contentBasis (K := K) (V := V)).repr x i)) := + (isUnit_iff_ne_zero.mpr (Finsupp.mem_support_iff.mp hi)).map + (algebraMap K D) + rw [_root_.Algebra.smul_def] at hqi + exact hunit.dvd_mul_left.mp hqi + +omit [IsDomain D] in +/-- A nonzero pure tensor `x ⊗ 1` has unit content. -/ +theorem isContent_tmul_one_of_ne_zero (x : V) (hx : x ≠ 0) : + IsContent (x ⊗ₜ[K] (1 : D)) 1 := by + simpa using isContent_tmul_of_ne_zero (D := D) x hx (1 : D) + +private noncomputable def contentAux + (gcdStructure : GCDMonoid D) (z : V ⊗[K] D) : Associates D := by + letI : GCDMonoid D := gcdStructure + letI : NormalizedGCDMonoid (Associates D) := + normalizedAssociatesGCDMonoid gcdStructure + let c := contentCoordinates (K := K) (D := D) (V := V) z + exact c.support.gcd fun i ↦ Associates.mk (c i) + +private theorem contentAux_isContent + (gcdStructure : GCDMonoid D) (z : V ⊗[K] D) : + IsContent z (contentAux gcdStructure z) := by + let : GCDMonoid D := gcdStructure + let : NormalizedGCDMonoid (Associates D) := + normalizedAssociatesGCDMonoid gcdStructure + intro q + change Associates.mk q ∣ contentAux gcdStructure z ↔ _ + rw [contentAux, Finset.dvd_gcd_iff, + exists_mulRightFactor_eq_iff] + constructor + · intro h i + by_cases hi : i ∈ + (contentCoordinates (K := K) (D := D) (V := V) z).support + · exact Associates.mk_le_mk_iff_dvd.mp (h i hi) + · rw [Finsupp.notMem_support_iff.mp hi] + exact dvd_zero q + · intro h i hi + exact Associates.mk_le_mk_of_dvd (h i) + +/-- Over a GCD monoid, every tensor has a unique intrinsic content class. -/ +theorem existsUnique_isContent + (gcdStructure : GCDMonoid D) (z : V ⊗[K] D) : + ∃! a : Associates D, IsContent z a := + ⟨contentAux gcdStructure z, contentAux_isContent gcdStructure z, + fun _a ha ↦ ha.eq (contentAux_isContent gcdStructure z)⟩ + +/-- Pairwise existence of greatest common divisors suffices for every tensor to have a unique +intrinsic content class. -/ +theorem existsUnique_isContent_of_exists_gcd + (h : ∀ a b : D, ∃ c : D, ∀ d : D, + d ∣ a ∧ d ∣ b ↔ d ∣ c) + (z : V ⊗[K] D) : + ∃! a : Associates D, IsContent z a := by + classical + exact existsUnique_isContent (gcdMonoidOfExistsGCD h) z + +/-- The intrinsic content class of a tensor, for an explicit `GCDMonoid` structure on `D`. -/ +def content (gcdStructure : GCDMonoid D) (z : V ⊗[K] D) : Associates D := + Classical.choose (existsUnique_isContent gcdStructure z) + +/-- The content class satisfies its intrinsic divisibility characterization. -/ +theorem content_isContent (gcdStructure : GCDMonoid D) (z : V ⊗[K] D) : + IsContent z (content gcdStructure z) := + Classical.choose_spec (existsUnique_isContent gcdStructure z) |>.1 + +/-- Any class satisfying the content property is the chosen content class. -/ +theorem content_eq_of_isContent (gcdStructure : GCDMonoid D) + {z : V ⊗[K] D} {a : Associates D} (ha : IsContent z a) : + content gcdStructure z = a := + (content_isContent gcdStructure z).eq ha + +/-- The content class does not depend on the chosen `GCDMonoid` structure. -/ +theorem content_independent (gcdStructure₁ gcdStructure₂ : GCDMonoid D) + (z : V ⊗[K] D) : + content gcdStructure₁ z = content gcdStructure₂ z := + (content_isContent gcdStructure₁ z).eq + (content_isContent gcdStructure₂ z) + +end + +end TensorProduct diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/LinearAlgebra/TensorProduct/SubalgebraBasis.lean b/LeanPool/ConwayRefinement/ConwayRefinement/LinearAlgebra/TensorProduct/SubalgebraBasis.lean new file mode 100644 index 0000000000..31153978d3 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/LinearAlgebra/TensorProduct/SubalgebraBasis.lean @@ -0,0 +1,111 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import Mathlib.RingTheory.TensorProduct.Maps +public import Mathlib.LinearAlgebra.DirectSum.Finsupp +public import Mathlib.LinearAlgebra.Basis.Basic + +/-! +# Base change of a basis over a subalgebra + +Let `G` be a commutative `K`-algebra, `S ⊆ G` a `K`-subalgebra, and `B` an `S`-basis of `G`. +For any commutative `K`-algebra `L`, the elements `B i ⊗ 1` are a basis of `G ⊗[K] L` over the +image of `S ⊗[K] L`: every element is uniquely a finite sum `∑ j(xᵢ) (B i ⊗ 1)` with +`xᵢ ∈ S ⊗[K] L`, where `j : S ⊗[K] L → G ⊗[K] L` is induced by the inclusion. +-/ + +universe u v w x + +open scoped TensorProduct + +public noncomputable section + +namespace Subalgebra + +variable {K : Type u} {G : Type v} {L : Type w} {ι : Type x} +variable [CommRing K] [CommRing G] [Algebra K G] [CommRing L] [Algebra K L] +variable (S : Subalgebra K G) (B : Module.Basis ι S G) + +/-- The inclusion `S ⊗[K] L → G ⊗[K] L`. -/ +def tensorInclusion : S ⊗[K] L →ₐ[K] G ⊗[K] L := + Algebra.TensorProduct.map S.val (AlgHom.id K L) + +theorem tensorInclusion_tmul (s : S) (l : L) : + S.tensorInclusion (s ⊗ₜ[K] l) = (s : G) ⊗ₜ[K] l := + Algebra.TensorProduct.map_tmul _ _ _ _ + +theorem tensorInclusion_zero : S.tensorInclusion (0 : S ⊗[K] L) = 0 := + map_zero _ + +theorem tensorInclusion_add (x y : S ⊗[K] L) : + S.tensorInclusion (x + y) = S.tensorInclusion x + S.tensorInclusion y := + map_add _ x y + +theorem tensorInclusion_mul (x y : S ⊗[K] L) : + S.tensorInclusion (x * y) = S.tensorInclusion x * S.tensorInclusion y := + map_mul _ x y + +variable [DecidableEq ι] + +/-- The coordinate equivalence `G ⊗[K] L ≃ ι →₀ (S ⊗[K] L)` induced by the basis. -/ +def tensorBasisRepr : G ⊗[K] L ≃ₗ[K] ι →₀ (S ⊗[K] L) := + (LinearEquiv.rTensor L (B.repr.restrictScalars K)) ≪≫ₗ + TensorProduct.finsuppLeft K K S L ι + +theorem tensorBasisRepr_tmul (g : G) (l : L) : + S.tensorBasisRepr B (g ⊗ₜ[K] l) = + (B.repr g).sum fun i s ↦ Finsupp.single i (s ⊗ₜ[K] l) := by + rw [tensorBasisRepr, LinearEquiv.trans_apply, LinearEquiv.rTensor_tmul, + TensorProduct.finsuppLeft_apply_tmul] + rfl + +/-- The key formula: the coordinates of `j(x) · (B i ⊗ 1)` are `single i x`. -/ +theorem tensorBasisRepr_tensorInclusion_mul (x : S ⊗[K] L) (i : ι) : + S.tensorBasisRepr B (S.tensorInclusion x * (B i ⊗ₜ[K] 1)) = Finsupp.single i x := by + induction x using TensorProduct.inductionOn with + | tmul s l => + rw [tensorInclusion_tmul, Algebra.TensorProduct.tmul_mul_tmul, mul_one, tensorBasisRepr_tmul] + have hsmul : (s : G) * B i = s • B i := rfl + rw [hsmul, map_smul, Module.Basis.repr_self, Finsupp.smul_single, smul_eq_mul, mul_one, + Finsupp.sum_single_index] + rw [TensorProduct.zero_tmul, Finsupp.single_zero] + | add x y hx hy => + rw [map_add, add_mul, map_add, hx, hy, Finsupp.single_add] + +theorem tensorBasisRepr_sum (s : Finset ι) (x : ι → S ⊗[K] L) : + S.tensorBasisRepr B (∑ i ∈ s, S.tensorInclusion (x i) * (B i ⊗ₜ[K] 1)) = + ∑ i ∈ s, Finsupp.single i (x i) := by + rw [map_sum] + exact Finset.sum_congr rfl fun i _ ↦ S.tensorBasisRepr_tensorInclusion_mul B (x i) i + +omit [DecidableEq ι] in +/-- Linear independence of `B i ⊗ 1` over `S ⊗[K] L`. -/ +theorem eq_zero_of_sum_tensorInclusion_mul_eq_zero (s : Finset ι) (x : ι → S ⊗[K] L) + (h : ∑ i ∈ s, S.tensorInclusion (x i) * (B i ⊗ₜ[K] 1) = 0) : ∀ i ∈ s, x i = 0 := by + classical + intro i hi + have h1 := congrArg (S.tensorBasisRepr B) h + rw [S.tensorBasisRepr_sum B, map_zero] at h1 + have h2 := congrArg (fun f : ι →₀ (S ⊗[K] L) ↦ f i) h1 + simp only [Finsupp.finsetSum_apply, Finsupp.coe_zero, Pi.zero_apply] at h2 + rw [Finset.sum_eq_single i (fun j _ hj ↦ Finsupp.single_eq_of_ne hj.symm) + (fun hni ↦ absurd hi hni), Finsupp.single_eq_same] at h2 + exact h2 + +omit [DecidableEq ι] in +/-- Spanning: every element of `G ⊗[K] L` is a combination of the `B i ⊗ 1` over +`S ⊗[K] L`. -/ +theorem exists_eq_sum_tensorInclusion_mul (g : G ⊗[K] L) : + ∃ (s : Finset ι) (x : ι → S ⊗[K] L), + g = ∑ i ∈ s, S.tensorInclusion (x i) * (B i ⊗ₜ[K] 1) := by + classical + refine ⟨(S.tensorBasisRepr B g).support, fun i ↦ S.tensorBasisRepr B g i, ?_⟩ + apply (S.tensorBasisRepr B).injective + rw [S.tensorBasisRepr_sum B] + exact (Finsupp.sum_single (S.tensorBasisRepr B g)).symm + +end Subalgebra diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Order.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Order.lean new file mode 100644 index 0000000000..86c454f071 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Order.lean @@ -0,0 +1,13 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Order.Archimedean +public import LeanPool.ConwayRefinement.ConwayRefinement.Order.DifferenceAvoidance +public import LeanPool.ConwayRefinement.ConwayRefinement.Order.Filter + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Order/Archimedean.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Order/Archimedean.lean new file mode 100644 index 0000000000..4e33117607 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Order/Archimedean.lean @@ -0,0 +1,54 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import Mathlib.Algebra.Order.Archimedean.Basic +public import Mathlib.Data.Set.Countable +public import Mathlib.Order.WellFoundedSet + +import Mathlib.Basic.Real.Embedding +import Mathlib.Topology.Order.Basic +import Mathlib.Topology.Instances.Real.Lemmas + +/-! +# Countability in Archimedean ordered groups + +Every partially well-ordered subset of an Archimedean linearly ordered additive group is +countable. The proof embeds the group into `ℝ` and assigns to each point the gap before its +successor in the subset; second countability of `ℝ` makes the resulting disjoint family of +intervals countable. +-/ + +universe u + +public section + +variable {G : Type u} +variable [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] [Archimedean G] + +open TopologicalSpace + +namespace Set.IsPWO + +/-- A partially well-ordered subset of an Archimedean ordered additive group is countable. -/ +theorem countable_of_archimedean {s : Set G} (hs : s.IsPWO) : s.Countable := by + obtain ⟨f, hf⟩ := Archimedean.exists_orderAddMonoidHom_real_injective G + have hfstrict : StrictMono f := f.monotone'.strictMono_of_injective hf + have hcount := countable_image_lt_image_Ioi_within (t := s) f + apply hcount.mono + intro x hx + refine ⟨hx, ?_⟩ + by_cases hupper : ({y ∈ s | x < y} : Set G).Nonempty + · obtain ⟨y, hy⟩ := (hs.mono fun z hz => hz.1).exists_minimal hupper + refine ⟨f y, ?_, ?_⟩ + · exact hfstrict hy.1.2 + · intro z hz hxz + exact f.monotone' ((le_total y z).elim id fun hzy => hy.2 ⟨hz, hxz⟩ hzy) + · refine ⟨f x + 1, by linarith, ?_⟩ + intro y hy hxy + exact (hupper ⟨y, hy, hxy⟩).elim + +end Set.IsPWO diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Order/DifferenceAvoidance.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Order/DifferenceAvoidance.lean new file mode 100644 index 0000000000..7b4f742da9 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Order/DifferenceAvoidance.lean @@ -0,0 +1,66 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import Mathlib.Data.Set.Finite.Basic +public import Mathlib.Data.Finset.Lattice.Fold +public import Mathlib.Algebra.Group.Basic + +import Mathlib.Data.Finset.Image +import Mathlib.Data.Finset.Union + +/-! +# Choosing points with differences outside a finite set + +Given finitely many infinite subsets `E i` of a commutative additive group and a finite set `D`, +one can pick one point from each `E i` so that no difference of two chosen points lies in `D`. +The points are chosen one at a time; at each step only finitely many values are excluded. +-/ + +universe u v + +public section + +/-- From finitely many infinite sets one can choose one point each with all pairwise differences +outside a given finite set. -/ +theorem exists_forall_mem_forall_sub_notMem {α : Type u} [AddCommGroup α] {ι : Type v} + (s : Finset ι) (E : ι → Set α) (hE : ∀ i, (E i).Infinite) (D : Finset α) : + ∃ x : ι → α, (∀ i ∈ s, x i ∈ E i) ∧ ∀ i ∈ s, ∀ j ∈ s, i ≠ j → x i - x j ∉ D := by + classical + induction s using Finset.induction_on with + | empty => + refine ⟨fun i ↦ (hE i).nonempty.choose, fun i hi ↦ absurd hi (Finset.notMem_empty i), + fun i hi ↦ absurd hi (Finset.notMem_empty i)⟩ + | insert a s ha ih => + obtain ⟨x, hxE, hxD⟩ := ih + -- The values excluded for the new point: `x j + d` and `x j - d` for `j ∈ s`, `d ∈ D`. + let F : Finset α := s.biUnion fun j ↦ D.image (fun d ↦ x j + d) ∪ D.image (fun d ↦ x j - d) + obtain ⟨y, hyE, hyF⟩ := (hE a).exists_notMem_finset F + refine ⟨Function.update x a y, fun i hi ↦ ?_, fun i hi j hj hij ↦ ?_⟩ + · rcases Finset.mem_insert.mp hi with hia | hi + · rw [hia, Function.update_self]; exact hyE + · rw [Function.update_of_ne (fun h ↦ ha (by rw [← h]; exact hi))]; exact hxE i hi + · rcases Finset.mem_insert.mp hi with hia | hi + · rcases Finset.mem_insert.mp hj with hja | hj + · exact absurd (hia.trans hja.symm) hij + · rw [hia, Function.update_self, + Function.update_of_ne (fun h ↦ ha (by rw [← h]; exact hj))] + intro hd + apply hyF + refine Finset.mem_biUnion.mpr ⟨j, hj, Finset.mem_union_left _ ?_⟩ + exact Finset.mem_image.mpr ⟨y - x j, hd, add_sub_cancel (x j) y⟩ + · rcases Finset.mem_insert.mp hj with hja | hj + · rw [hja, Function.update_self, + Function.update_of_ne (fun h ↦ ha (by rw [← h]; exact hi))] + intro hd + apply hyF + refine Finset.mem_biUnion.mpr ⟨i, hi, Finset.mem_union_right _ ?_⟩ + exact Finset.mem_image.mpr ⟨x i - y, hd, sub_sub_cancel (x i) y⟩ + · rw [Function.update_of_ne (fun h ↦ ha (by rw [← h]; exact hi)), + Function.update_of_ne (fun h ↦ ha (by rw [← h]; exact hj))] + exact hxD i hi j hj hij + +end diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Order/Filter.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Order/Filter.lean new file mode 100644 index 0000000000..f0048b058b --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Order/Filter.lean @@ -0,0 +1,13 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Order.Filter.FunAtZeroMinus +public import LeanPool.ConwayRefinement.ConwayRefinement.Order.Filter.Germ +public import LeanPool.ConwayRefinement.ConwayRefinement.Order.Filter.Tests + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Order/Filter/FunAtZeroMinus.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Order/Filter/FunAtZeroMinus.lean new file mode 100644 index 0000000000..5724abe19e --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Order/Filter/FunAtZeroMinus.lean @@ -0,0 +1,381 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Order.Filter.Germ.LinearMap +public import Mathlib.Algebra.Module.Submodule.Range +public import Mathlib.Topology.MetricSpace.Pseudo.Defs +public import Mathlib.LinearAlgebra.TensorProduct.Map + +import LeanPool.ConwayRefinement.ConwayRefinement.Topology.Order.LeftNeighborhood +import Mathlib.LinearAlgebra.TensorProduct.RightExactness +import Mathlib.LinearAlgebra.Basis.VectorSpace +import Mathlib.RingTheory.Flat.Basic +import Mathlib.Topology.MetricSpace.Pseudo.Lemmas +import Mathlib.Tactic.Linarith + +/-! +# Functions at `0⁻` with values in a vector space + +`Fun_{0⁻}(V)` is the space of `V`-valued functions at `0⁻`: functions defined on some interval +`(η, 0)`, identified when they agree for all `γ < 0` sufficiently close to `0`. In Lean it is +Mathlib's `Filter.Germ` at `𝓝[<] 0`. The paper's section on functions at `0⁻` says of the word +this construction avoids: "In the language of analysis these classes are the germs at `0⁻` of +`V`-valued functions; we avoid the word, which in this subject denotes a class of series modulo +`J` [Berarducci, Def. 5.1]." + +For a subspace `U ⊆ V` the map `Fun_{0⁻}(U) → Fun_{0⁻}(V)` is injective, and its image consists +of the functions taking values in `U` near `0`. Such a function lifts uniquely to `Fun_{0⁻}(U)`, +where a linear map defined on `U` can be applied pointwise; this gives the maps +`Fun_{0⁻}(U) → Fun_{0⁻}(U/U')` used by the compatibility lemmas. + +Pointwise pure tensors give the paper's map `θ`: a linear map `u : U → Fun_{0⁻}(V)` extends to +`U ⊗[K] E → Fun_{0⁻}(V ⊗[K] E)` as the canonical map +`θ : Fun_{0⁻}(V) ⊗[K] E → Fun_{0⁻}(V ⊗[K] E)` after `u ⊗ 1`. Over a field both factors are +injective when `u` is, so the extension preserves injectivity. +-/ + +open Filter Topology +open scoped TensorProduct + +universe u v w + +public noncomputable section + +/-- `Fun_{0⁻}(V)`, the `V`-valued functions at `0⁻`: functions on an interval `(η, 0)`, identified +when they agree for all `γ < 0` sufficiently close to `0` (Mathlib's `Filter.Germ` at `𝓝[<] 0`). -/ +abbrev FunAtZeroMinus (V : Type v) := Filter.Germ (𝓝[<] (0 : ℝ)) V + +/-- Two functions represent the same element of `Fun_{0⁻}(V)` exactly when they agree on some +interval `(-ε, 0)`. -/ +theorem funAtZeroMinus_coe_eq_iff_exists {V : Type v} (f g : ℝ → V) : + (f : FunAtZeroMinus V) = (g : FunAtZeroMinus V) ↔ + ∃ ε > 0, ∀ γ : ℝ, -ε < γ → γ < 0 → f γ = g γ := by + rw [Filter.Germ.coe_eq] + change (∀ᶠ γ in 𝓝[<] (0 : ℝ), f γ = g γ) ↔ _ + rw [eventually_nhdsLT_iff_exists] + constructor + · rintro ⟨l, hl, h⟩ + refine ⟨-l, by linarith, fun γ hγ hγ0 ↦ ?_⟩ + exact h γ (by linarith) hγ0 + · rintro ⟨ε, hε, h⟩ + refine ⟨-ε, by linarith, fun γ hγ hγ0 ↦ ?_⟩ + exact h γ (by linarith) hγ0 + +section Submodule + +variable {K : Type u} {V : Type v} [Semiring K] [AddCommMonoid V] [Module K V] + +/-- The injective linear map `Fun_{0⁻}(W) → Fun_{0⁻}(V)` induced by the inclusion of a submodule +`W ⊆ V`. -/ +def funAtZeroMinusSubmoduleMap (W : Submodule K V) : + FunAtZeroMinus W →ₗ[K] FunAtZeroMinus V := + Filter.Germ.mapLinear W.subtype + +/-- The inclusion of a submodule `W ⊆ V` induces an injective map `Fun_{0⁻}(W) → Fun_{0⁻}(V)`. -/ +theorem funAtZeroMinusSubmoduleMap_injective (W : Submodule K V) : + Function.Injective (funAtZeroMinusSubmoduleMap W) := + Filter.Germ.mapLinear_injective W.subtype W.injective_subtype + +/-- Evaluation of `Fun_{0⁻}(W) → Fun_{0⁻}(V)` on the class of a function `f : ℝ → W`. -/ +@[simp] +theorem funAtZeroMinusSubmoduleMap_coe (W : Submodule K V) (f : ℝ → W) : + funAtZeroMinusSubmoduleMap W (f : FunAtZeroMinus W) = + ((fun γ ↦ (f γ : V)) : FunAtZeroMinus V) := by + rw [funAtZeroMinusSubmoduleMap, Filter.Germ.mapLinear_coe] + rfl + +/-- `Fun_{0⁻}(W) ⊆ Fun_{0⁻}(V)`: the functions taking values in `W` near `0`, as the image of +`Fun_{0⁻}(W) → Fun_{0⁻}(V)`. -/ +def funAtZeroMinusSubmodule (W : Submodule K V) : Submodule K (FunAtZeroMinus V) := + LinearMap.range (funAtZeroMinusSubmoduleMap W) + +theorem funAtZeroMinusSubmodule_eq_range (W : Submodule K V) : + funAtZeroMinusSubmodule W = LinearMap.range (funAtZeroMinusSubmoduleMap W) := (rfl) + +/-- A function at `0⁻` lies in `Fun_{0⁻}(W) ⊆ Fun_{0⁻}(V)` exactly when it takes values in `W` +for all `γ < 0` sufficiently close to `0`. -/ +theorem mem_funAtZeroMinusSubmodule_iff (W : Submodule K V) (f : FunAtZeroMinus V) : + f ∈ funAtZeroMinusSubmodule W ↔ Filter.Germ.LiftPred (· ∈ W) f := by + classical + constructor + · rintro ⟨g, rfl⟩ + induction g using Filter.Germ.inductionOn with + | _ g => + rw [funAtZeroMinusSubmoduleMap, Filter.Germ.mapLinear_coe, + Filter.Germ.liftPred_coe] + exact Filter.Eventually.of_forall fun x ↦ (g x).property + · intro hf + induction f using Filter.Germ.inductionOn with + | _ f => + rw [Filter.Germ.liftPred_coe] at hf + let g : ℝ → W := fun x ↦ if hx : f x ∈ W then ⟨f x, hx⟩ else 0 + refine ⟨(g : FunAtZeroMinus W), ?_⟩ + rw [funAtZeroMinusSubmoduleMap, Filter.Germ.mapLinear_coe, + Filter.Germ.coe_eq] + exact hf.mono fun x hx ↦ by simp [g, hx] + +/-- The class of a function `f : ℝ → V` lies in `Fun_{0⁻}(W) ⊆ Fun_{0⁻}(V)` exactly when +`f γ ∈ W` for all `γ < 0` sufficiently close to `0`. -/ +theorem coe_mem_funAtZeroMinusSubmodule_iff (W : Submodule K V) (f : ℝ → V) : + (f : FunAtZeroMinus V) ∈ funAtZeroMinusSubmodule W ↔ + ∀ᶠ x in 𝓝[<] (0 : ℝ), f x ∈ W := by + rw [mem_funAtZeroMinusSubmodule_iff, Filter.Germ.liftPred_coe] + +/-- The class of a function `f : ℝ → V` lies in `Fun_{0⁻}(W) ⊆ Fun_{0⁻}(V)` exactly when `f` is +`W`-valued throughout some interval `(-ε, 0)`. -/ +theorem coe_mem_funAtZeroMinusSubmodule_iff_exists (W : Submodule K V) (f : ℝ → V) : + (f : FunAtZeroMinus V) ∈ funAtZeroMinusSubmodule W ↔ + ∃ ε > 0, ∀ γ : ℝ, -ε < γ → γ < 0 → f γ ∈ W := by + rw [coe_mem_funAtZeroMinusSubmodule_iff, eventually_nhdsLT_iff_exists] + constructor + · rintro ⟨l, hl, h⟩ + refine ⟨-l, by linarith, fun γ hγ hγ0 ↦ ?_⟩ + exact h γ (by linarith) hγ0 + · rintro ⟨ε, hε, h⟩ + refine ⟨-ε, by linarith, fun γ hγ hγ0 ↦ ?_⟩ + exact h γ (by linarith) hγ0 + +/-- An element of `Fun_{0⁻}(W) ⊆ Fun_{0⁻}(V)` has a representative valued in `W` everywhere. -/ +theorem exists_coe_eq_of_mem_funAtZeroMinusSubmodule (W : Submodule K V) {g : FunAtZeroMinus V} + (hg : g ∈ funAtZeroMinusSubmodule W) : + ∃ f : ℝ → V, (∀ γ, f γ ∈ W) ∧ g = (f : FunAtZeroMinus V) := by + classical + induction g using Filter.Germ.inductionOn with + | _ f => + rw [coe_mem_funAtZeroMinusSubmodule_iff] at hg + refine ⟨fun γ ↦ if f γ ∈ W then f γ else 0, fun γ ↦ ?_, ?_⟩ + · by_cases h : f γ ∈ W + · simp [h] + · simp [h] + · rw [Filter.Germ.coe_eq] + exact hg.mono fun γ hγ ↦ by simp [hγ] + +/-- The pointwise image of a function at `0⁻` under a linear map `f` takes values in the range +of `f`. -/ +theorem mapLinear_mem_funAtZeroMinusSubmodule_range {U : Type*} [AddCommMonoid U] [Module K U] + (f : U →ₗ[K] V) (g : FunAtZeroMinus U) : + Filter.Germ.mapLinear f g ∈ funAtZeroMinusSubmodule (LinearMap.range f) := by + induction g using Filter.Germ.inductionOn with + | _ h => + rw [Filter.Germ.mapLinear_coe, coe_mem_funAtZeroMinusSubmodule_iff] + exact Filter.Eventually.of_forall fun γ ↦ LinearMap.mem_range_self f (h γ) + +/-- A function at `0⁻` lying in both `Fun_{0⁻}(W)` and `Fun_{0⁻}(W')` lies in +`Fun_{0⁻}(W ⊓ W')`. -/ +theorem mem_funAtZeroMinusSubmodule_inf (W W' : Submodule K V) {g : FunAtZeroMinus V} + (hg : g ∈ funAtZeroMinusSubmodule W) (hg' : g ∈ funAtZeroMinusSubmodule W') : + g ∈ funAtZeroMinusSubmodule (W ⊓ W') := by + rw [mem_funAtZeroMinusSubmodule_iff] at hg hg' ⊢ + induction g using Filter.Germ.inductionOn with + | _ f => + rw [Filter.Germ.liftPred_coe] at hg hg' ⊢ + exact (hg.and hg').mono fun γ hγ ↦ Submodule.mem_inf.mpr hγ + +end Submodule + +section TensorProduct + +variable {K : Type u} {U : Type*} {V : Type v} {E : Type w} +variable [CommSemiring K] +variable [AddCommMonoid U] [AddCommMonoid V] [AddCommMonoid E] +variable [Module K U] [Module K V] [Module K E] + +/-- The paper's composite `V ⊗ V' → V ⊗ Fun_{0⁻}(W) → Fun_{0⁻}(V ⊗ W)` of +lem:germ-linear-algebra (second map `θ`), with the tensor factor on the right: a linear map +`u : U → Fun_{0⁻}(V)` extends to `U ⊗[K] E → Fun_{0⁻}(V ⊗[K] E)`, sending `x ⊗ e` to the class +of the pointwise tensors `γ ↦ u(x)(γ) ⊗ e`. -/ +def funAtZeroMinusTensorId (u : U →ₗ[K] FunAtZeroMinus V) : + U ⊗[K] E →ₗ[K] FunAtZeroMinus (V ⊗[K] E) := + (Filter.Germ.tensorProduct (l := 𝓝[<] (0 : ℝ))).comp + (TensorProduct.map u LinearMap.id) + +/-- Evaluation of the tensor extension on a pure tensor. -/ +@[simp] +theorem funAtZeroMinusTensorId_tmul (u : U →ₗ[K] FunAtZeroMinus V) (x : U) (e : E) : + funAtZeroMinusTensorId (E := E) u (x ⊗ₜ[K] e) = + Filter.Germ.mapLinear ((TensorProduct.mk K V E).flip e) (u x) := by + rw [funAtZeroMinusTensorId, LinearMap.comp_apply, TensorProduct.map_tmul, + Filter.Germ.tensorProduct_tmul] + rfl + +/-- If a value of `u` is represented by `f`, then its tensor extension is represented by +the pointwise pure-tensor function. -/ +theorem funAtZeroMinusTensorId_tmul_of_eq_coe + (u : U →ₗ[K] FunAtZeroMinus V) (x : U) (e : E) (f : ℝ → V) + (h : u x = (f : FunAtZeroMinus V)) : + funAtZeroMinusTensorId (E := E) u (x ⊗ₜ[K] e) = + (fun γ ↦ f γ ⊗ₜ[K] e : FunAtZeroMinus (V ⊗[K] E)) := by + rw [funAtZeroMinusTensorId_tmul, h, Filter.Germ.mapLinear_coe] + rfl + +end TensorProduct + +section SubmoduleQuotient + +variable {K : Type u} {V : Type v} [Semiring K] [AddCommMonoid V] [Module K V] + +/-- `Fun_{0⁻}(W) ⊆ Fun_{0⁻}(W')` inside `Fun_{0⁻}(V)` when `W ⊆ W'`. -/ +theorem funAtZeroMinusSubmodule_mono {W W' : Submodule K V} (hWW : W ≤ W') {x : FunAtZeroMinus V} + (hx : x ∈ funAtZeroMinusSubmodule W) : x ∈ funAtZeroMinusSubmodule W' := by + rw [mem_funAtZeroMinusSubmodule_iff] at hx ⊢ + induction x using Filter.Germ.inductionOn with + | _ f => + rw [Filter.Germ.liftPred_coe] at hx ⊢ + exact hx.mono fun gamma hgamma ↦ hWW hgamma + +/-- The map `Fun_{0⁻}(W) → Fun_{0⁻}(V)` with codomain restricted to its image +`Fun_{0⁻}(W) ⊆ Fun_{0⁻}(V)`. -/ +def funAtZeroMinusSubmoduleOf (W : Submodule K V) : + FunAtZeroMinus W →ₗ[K] funAtZeroMinusSubmodule W := + (funAtZeroMinusSubmoduleMap W).codRestrict (funAtZeroMinusSubmodule W) fun g ↦ by + rw [mem_funAtZeroMinusSubmodule_iff] + induction g using Filter.Germ.inductionOn with + | _ f => + rw [funAtZeroMinusSubmoduleMap_coe, Filter.Germ.liftPred_coe] + exact Filter.Eventually.of_forall fun x ↦ (f x).property + +/-- `Fun_{0⁻}(W) ≃ Fun_{0⁻}(W) ⊆ Fun_{0⁻}(V)`: the functions at `0⁻` with values in `W` are +linearly equivalent to their image in `Fun_{0⁻}(V)`, the identification the paper makes. -/ +def funAtZeroMinusSubmoduleEquiv (W : Submodule K V) : + FunAtZeroMinus W ≃ₗ[K] funAtZeroMinusSubmodule W := + LinearEquiv.ofBijective (funAtZeroMinusSubmoduleOf W) (by + constructor + · intro g g' hgg + apply funAtZeroMinusSubmoduleMap_injective W + exact congrArg Subtype.val hgg + · rintro ⟨f, hf⟩ + classical + rw [mem_funAtZeroMinusSubmodule_iff] at hf + induction f using Filter.Germ.inductionOn with + | _ f => + rw [Filter.Germ.liftPred_coe] at hf + let g : ℝ → W := fun x ↦ if hx : f x ∈ W then ⟨f x, hx⟩ else 0 + refine ⟨(g : FunAtZeroMinus W), Subtype.ext ?_⟩ + change funAtZeroMinusSubmoduleMap W (g : FunAtZeroMinus W) = (f : FunAtZeroMinus V) + rw [funAtZeroMinusSubmoduleMap_coe, Filter.Germ.coe_eq] + exact hf.mono fun x hx ↦ by simp [g, hx]) + +/-- The equivalence `Fun_{0⁻}(W) ≃ Fun_{0⁻}(W) ⊆ Fun_{0⁻}(V)` is the map +`Fun_{0⁻}(W) → Fun_{0⁻}(V)` on underlying functions at `0⁻`. -/ +theorem coe_funAtZeroMinusSubmoduleEquiv_apply (W : Submodule K V) (g : FunAtZeroMinus W) : + ((funAtZeroMinusSubmoduleEquiv W g : funAtZeroMinusSubmodule W) : FunAtZeroMinus V) = + funAtZeroMinusSubmoduleMap W g := (rfl) + +/-- `Fun_{0⁻}(W) → Fun_{0⁻}(Q)` along a linear map `q : W → Q`, applied pointwise to a function +at `0⁻` taking values in `W` near `0`; for `q` a quotient map this is +`Fun_{0⁻}(W) → Fun_{0⁻}(W/W')`. -/ +def funAtZeroMinusQuotientMap (W : Submodule K V) {Q : Type w} [AddCommMonoid Q] [Module K Q] + (q : W →ₗ[K] Q) : funAtZeroMinusSubmodule W →ₗ[K] FunAtZeroMinus Q := + (Filter.Germ.mapLinear q).comp (funAtZeroMinusSubmoduleEquiv W).symm.toLinearMap + +/-- Evaluation of `Fun_{0⁻}(W) → Fun_{0⁻}(Q)` on the class of a `W`-valued function `f`: the +class of `γ ↦ q (f γ)`. -/ +theorem funAtZeroMinusQuotientMap_coe (W : Submodule K V) {Q : Type w} + [AddCommMonoid Q] [Module K Q] (q : W →ₗ[K] Q) (f : ℝ → W) + (hf : ((fun γ ↦ (f γ : V)) : FunAtZeroMinus V) ∈ funAtZeroMinusSubmodule W) : + funAtZeroMinusQuotientMap W q ⟨((fun γ ↦ (f γ : V)) : FunAtZeroMinus V), hf⟩ = + ((fun γ ↦ q (f γ)) : FunAtZeroMinus Q) := by + have hsymm : (funAtZeroMinusSubmoduleEquiv W).symm + ⟨((fun γ ↦ (f γ : V)) : FunAtZeroMinus V), hf⟩ = (f : FunAtZeroMinus W) := by + apply (funAtZeroMinusSubmoduleEquiv W).injective + rw [LinearEquiv.apply_symm_apply] + apply Subtype.ext + change ((fun γ ↦ (f γ : V)) : FunAtZeroMinus V) = + funAtZeroMinusSubmoduleMap W (f : FunAtZeroMinus W) + rw [funAtZeroMinusSubmoduleMap_coe] + rw [funAtZeroMinusQuotientMap, LinearMap.comp_apply, LinearEquiv.coe_toLinearMap, hsymm, + Filter.Germ.mapLinear_coe] + rfl + +/-- The image in `Fun_{0⁻}(Q)` vanishes exactly when the function takes values in the kernel +submodule `W'` for all `γ < 0` sufficiently close to `0`. -/ +theorem funAtZeroMinusQuotientMap_eq_zero_iff (W W' : Submodule K V) {Q : Type w} + [AddCommMonoid Q] [Module K Q] (q : W →ₗ[K] Q) + (hker : ∀ w : W, q w = 0 ↔ (w : V) ∈ W') + (g : funAtZeroMinusSubmodule W) : + funAtZeroMinusQuotientMap W q g = 0 ↔ (g : FunAtZeroMinus V) ∈ funAtZeroMinusSubmodule W' := by + obtain ⟨u, rfl⟩ := (funAtZeroMinusSubmoduleEquiv W).surjective g + induction u using Filter.Germ.inductionOn with + | _ f => + have hcoe : ((funAtZeroMinusSubmoduleEquiv W (f : FunAtZeroMinus W) : + funAtZeroMinusSubmodule W) : FunAtZeroMinus V) = + ((fun γ ↦ (f γ : V)) : FunAtZeroMinus V) := by + change funAtZeroMinusSubmoduleMap W (f : FunAtZeroMinus W) = + ((fun γ ↦ (f γ : V)) : FunAtZeroMinus V) + rw [funAtZeroMinusSubmoduleMap_coe] + rw [funAtZeroMinusQuotientMap, LinearMap.comp_apply, LinearEquiv.coe_toLinearMap, + LinearEquiv.symm_apply_apply, Filter.Germ.mapLinear_coe, hcoe, + coe_mem_funAtZeroMinusSubmodule_iff, + show (0 : FunAtZeroMinus Q) = ((fun _ : ℝ ↦ (0 : Q)) : FunAtZeroMinus Q) from rfl, + Filter.Germ.coe_eq] + exact ⟨fun h ↦ h.mono fun γ hγ ↦ (hker (f γ)).mp hγ, + fun h ↦ h.mono fun γ hγ ↦ (hker (f γ)).mpr hγ⟩ + +end SubmoduleQuotient + +section Injectivity + +/-- Tensor extension by the identity preserves injectivity for linear maps into functions at `0⁻` +over a field: the paper's canonical map `θ : Fun_{0⁻}(V) ⊗[K] E → Fun_{0⁻}(V ⊗[K] E)` is +injective, and so is `u ⊗ 1` by flatness. -/ +theorem funAtZeroMinusTensorId_injective_of_injective + {K : Type u} {U : Type*} {V : Type v} {E : Type w} + [Field K] + [AddCommGroup U] [AddCommGroup V] [AddCommGroup E] + [Module K U] [Module K V] [Module K E] + (u : U →ₗ[K] FunAtZeroMinus V) (hu : Function.Injective u) : + Function.Injective (funAtZeroMinusTensorId (E := E) u) := + Filter.Germ.tensorProduct_injective.comp + (Module.Flat.rTensor_preserves_injective_linearMap (M := E) u hu) + +/-- Naturality of the tensor extension in the second factor. -/ +theorem mapLinear_lTensor_funAtZeroMinusTensorId + {K : Type u} {U : Type*} {V : Type v} {E E' : Type*} + [CommSemiring K] + [AddCommMonoid U] [AddCommMonoid V] [AddCommMonoid E] [AddCommMonoid E'] + [Module K U] [Module K V] [Module K E] [Module K E'] + (u : U →ₗ[K] FunAtZeroMinus V) (f : E →ₗ[K] E') (T : U ⊗[K] E) : + Filter.Germ.mapLinear (f.lTensor V) (funAtZeroMinusTensorId u T) = + funAtZeroMinusTensorId u (f.lTensor U T) := by + induction T using TensorProduct.inductionOn with + | tmul x e => + rw [LinearMap.lTensor_tmul, funAtZeroMinusTensorId_tmul, funAtZeroMinusTensorId_tmul] + induction u x using Filter.Germ.inductionOn with + | _ g => + rw [Filter.Germ.mapLinear_coe, Filter.Germ.mapLinear_coe, Filter.Germ.mapLinear_coe] + rfl + | add x y hx hy => simp only [map_add, hx, hy] + +/-- Exactness for the tensor extension into `Fun_{0⁻}(V ⊗[K] E)`: if `u` is injective and +`(u ⊗ 1) T` is represented by values in the image of `1 ⊗ m`, then `T` itself lies in the image +of `1 ⊗ m`. -/ +theorem exists_eq_lTensor_of_funAtZeroMinusTensorId_eq + {K : Type u} {U : Type*} {V : Type v} {E A : Type*} + [Field K] + [AddCommGroup U] [AddCommGroup V] [AddCommGroup E] [AddCommGroup A] + [Module K U] [Module K V] [Module K E] [Module K A] + (u : U →ₗ[K] FunAtZeroMinus V) (hu : Function.Injective u) (m : A →ₗ[K] E) + (T : U ⊗[K] E) (g : FunAtZeroMinus (V ⊗[K] A)) + (h : funAtZeroMinusTensorId u T = Filter.Germ.mapLinear (m.lTensor V) g) : + ∃ T' : U ⊗[K] A, T = m.lTensor U T' := by + set π := (LinearMap.range m).mkQ + have hπ : (π.lTensor V).comp (m.lTensor V) = 0 := by + rw [← LinearMap.lTensor_comp, LinearMap.range_mkQ_comp, LinearMap.lTensor_zero] + have h1 := congrArg (Filter.Germ.mapLinear (π.lTensor V)) h + rw [mapLinear_lTensor_funAtZeroMinusTensorId] at h1 + have h2 : Filter.Germ.mapLinear (π.lTensor V) (Filter.Germ.mapLinear (m.lTensor V) g) = 0 := by + rw [Filter.Germ.mapLinear_comp, hπ] + exact Filter.Germ.mapLinear_zero_apply g + rw [h2] at h1 + have h3 : π.lTensor U T = 0 := + funAtZeroMinusTensorId_injective_of_injective u hu (by rw [h1, map_zero]) + exact ((lTensor_exact U (LinearMap.exact_map_mkQ_range m) + (Submodule.mkQ_surjective _)) T).mp h3 |>.imp fun T' hT' ↦ hT'.symm + +end Injectivity + +end diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Order/Filter/FunAtZeroMinus/Pointwise.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Order/Filter/FunAtZeroMinus/Pointwise.lean new file mode 100644 index 0000000000..8b8b6bdbf4 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Order/Filter/FunAtZeroMinus/Pointwise.lean @@ -0,0 +1,114 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Order.Filter.FunAtZeroMinus + +import LeanPool.ConwayRefinement.ConwayRefinement.Topology.Order.LeftNeighborhood +import Mathlib.Topology.Instances.Real.Lemmas + +/-! +# Pointwise identities in `Fun_{0⁻}(V)` + +An equation in `Fun_{0⁻}(V)` is an equation between representatives for all `γ < 0` sufficiently +close to `0`. This module collects the forms in which such equations arise: a function at `0⁻` +vanishing, or equal to a constant function, or equal to a constant times a function at `0⁻`, each +reduced to a statement about the representatives on some interval `(-ε, 0)`. A `K`-algebra `A` +acts on `Fun_{0⁻}(A)` through constant functions, and that action is scalar multiplication. +-/ + +open Filter Topology + +public section + +universe v + +namespace FunAtZeroMinus + +variable {V : Type v} + +/-- A function at `0⁻` is zero exactly when its representatives vanish near zero. -/ +theorem coe_eq_zero_iff [Zero V] (f : ℝ → V) : + ((f : ℝ → V) : FunAtZeroMinus V) = 0 ↔ ∀ᶠ γ in 𝓝[<] (0 : ℝ), f γ = 0 := + Filter.Germ.coe_eq + +/-- A function at `0⁻` is zero exactly when its representatives vanish on some `(-ε, 0)`. -/ +theorem coe_eq_zero_iff_exists [Zero V] (f : ℝ → V) : + ((f : ℝ → V) : FunAtZeroMinus V) = 0 ↔ ∃ η < (0 : ℝ), ∀ γ, η < γ → γ < 0 → f γ = 0 := by + rw [coe_eq_zero_iff, eventually_nhdsLT_iff_exists] + +/-- A function at `0⁻` equals a constant function exactly when its representatives take that +value near zero. -/ +theorem coe_eq_const_iff (f : ℝ → V) (x : V) : + ((f : ℝ → V) : FunAtZeroMinus V) = (x : FunAtZeroMinus V) ↔ ∀ᶠ γ in 𝓝[<] (0 : ℝ), f γ = x := + Filter.Germ.coe_eq + +/-- Two functions at `0⁻` are equal when their representatives agree near zero; the converse is +`Filter.Germ.coe_eq`. -/ +theorem coe_eq_coe_of_eventually {f g : ℝ → V} (h : ∀ᶠ γ in 𝓝[<] (0 : ℝ), f γ = g γ) : + ((f : ℝ → V) : FunAtZeroMinus V) = (g : ℝ → V) := + Filter.Germ.coe_eq.mpr h + +/-- Addition of constant functions. -/ +theorem const_add [Add V] (x y : V) : + ((x + y : V) : FunAtZeroMinus V) = (x : FunAtZeroMinus V) + (y : FunAtZeroMinus V) := rfl + +/-- The constant function `0`. -/ +theorem const_zero [Zero V] : ((0 : V) : FunAtZeroMinus V) = 0 := rfl + +section Ring + +variable {R : Type v} [Semiring R] + +/-- A constant function times a function at `0⁻` is the class of the pointwise products. -/ +theorem const_mul_coe (x : R) (f : ℝ → R) : + (x : FunAtZeroMinus R) * ((f : ℝ → R) : FunAtZeroMinus R) = + ((fun γ ↦ x * f γ : ℝ → R) : FunAtZeroMinus R) := + rfl + +/-- A function at `0⁻` times a constant function is the class of the pointwise products. -/ +theorem coe_mul_const (f : ℝ → R) (x : R) : + ((f : ℝ → R) : FunAtZeroMinus R) * (x : FunAtZeroMinus R) = + ((fun γ ↦ f γ * x : ℝ → R) : FunAtZeroMinus R) := + rfl + +/-- A constant function times a function at `0⁻` is zero exactly when the pointwise products +vanish near zero. -/ +theorem const_mul_coe_eq_zero_iff (x : R) (f : ℝ → R) : + (x : FunAtZeroMinus R) * ((f : ℝ → R) : FunAtZeroMinus R) = 0 ↔ + ∀ᶠ γ in 𝓝[<] (0 : ℝ), x * f γ = 0 := by + rw [const_mul_coe, coe_eq_zero_iff] + +end Ring + +section Algebra + +variable {K : Type*} {A : Type v} [CommSemiring K] [Semiring A] [Algebra K A] + +/-- The constant function of a scalar acts on `Fun_{0⁻}(A)`, `A` a `K`-algebra, by scalar +multiplication. -/ +theorem const_algebraMap_mul (k : K) (g : FunAtZeroMinus A) : + ((algebraMap K A k : A) : FunAtZeroMinus A) * g = k • g := by + induction g using Filter.Germ.inductionOn with + | _ f => + rw [← Filter.Germ.coe_smul, const_mul_coe] + exact congrArg _ (funext fun γ ↦ (Algebra.smul_def k (f γ)).symm) + +/-- An element of `Fun_{0⁻}(A)`, `A` a `K`-algebra, times the constant function of a scalar is +scalar multiplication. -/ +theorem mul_const_algebraMap (k : K) (g : FunAtZeroMinus A) : + g * ((algebraMap K A k : A) : FunAtZeroMinus A) = k • g := by + induction g using Filter.Germ.inductionOn with + | _ f => + rw [← Filter.Germ.coe_smul, coe_mul_const] + exact congrArg _ (funext fun γ ↦ (Algebra.commutes k (f γ)).symm.trans + (Algebra.smul_def k (f γ)).symm) + +end Algebra + +end FunAtZeroMinus + +end diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Order/Filter/Germ.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Order/Filter/Germ.lean new file mode 100644 index 0000000000..59a3f48237 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Order/Filter/Germ.lean @@ -0,0 +1,11 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Order.Filter.Germ.LinearMap + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Order/Filter/Germ/LinearMap.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Order/Filter/Germ/LinearMap.lean new file mode 100644 index 0000000000..7d34f5d7f3 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Order/Filter/Germ/LinearMap.lean @@ -0,0 +1,193 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import Mathlib.LinearAlgebra.TensorProduct.Basic +public import Mathlib.Order.Filter.Germ.Basic + +import Mathlib.LinearAlgebra.Basis.VectorSpace +import Mathlib.LinearAlgebra.TensorProduct.Basis + +/-! +# Linear maps on filter germs + +A linear map acts pointwise on germs of functions at a filter. Pointwise pure tensors also +induce a canonical linear map from a tensor product with a germ space to a germ space with +tensor-product values. Over a field that canonical map is injective: a kernel element expanded +along a basis of the second factor has germ coordinates that are killed by the dual coordinate +functionals, applied pointwise. +-/ + +open Filter +open scoped TensorProduct + +universe u v w + +namespace Filter.Germ + +public section + +variable {R : Type u} {M : Type v} {N : Type w} +variable [Semiring R] [AddCommMonoid M] [AddCommMonoid N] +variable [Module R M] [Module R N] +variable {α : Type*} {l : Filter α} + +instance instIsScalarTower {S : Type*} [SMul S R] [SMul S M] [IsScalarTower S R M] : + IsScalarTower S R (Germ l M) where + smul_assoc s r x := by + induction x using inductionOn with + | _ x => + rw [← coe_smul, ← coe_smul, ← coe_smul] + exact EventuallyEq.germ_eq <| Eventually.of_forall fun a ↦ smul_assoc s r (x a) + +instance instSMulCommClass {S : Type*} [SMul S M] [SMulCommClass S R M] : + SMulCommClass S R (Germ l M) where + smul_comm s r x := by + induction x using inductionOn with + | _ x => + rw [← coe_smul, ← coe_smul, ← coe_smul, ← coe_smul] + exact EventuallyEq.germ_eq <| Eventually.of_forall fun a ↦ smul_comm s r (x a) + +/-- The pointwise action of a linear map on germs at a filter. -/ +def mapLinear (f : M →ₗ[R] N) : Germ l M →ₗ[R] Germ l N where + toFun := map f + map_add' x y := by + induction x using inductionOn with + | _ x => + induction y using inductionOn with + | _ y => + rw [← coe_add, map_coe, map_coe, map_coe] + exact EventuallyEq.germ_eq <| Eventually.of_forall fun a ↦ f.map_add (x a) (y a) + map_smul' c x := by + induction x using inductionOn with + | _ x => + rw [← coe_smul, map_coe, map_coe] + exact EventuallyEq.germ_eq <| Eventually.of_forall fun a ↦ f.map_smul c (x a) + +/-- Pointwise evaluation of `mapLinear` on a representative. -/ +@[simp] +theorem mapLinear_coe (f : M →ₗ[R] N) (g : α → M) : + mapLinear f (g : Germ l M) = (f ∘ g : α → N) := + (rfl) + +/-- `mapLinear` is functorial. -/ +theorem mapLinear_comp {P : Type*} [AddCommMonoid P] [Module R P] (f : M →ₗ[R] N) + (g : N →ₗ[R] P) (x : Germ l M) : + mapLinear g (mapLinear f x) = mapLinear (g.comp f) x := by + induction x using inductionOn with + | _ x => rfl + +/-- The zero map acts as zero on germs. -/ +theorem mapLinear_zero_apply (x : Germ l M) : mapLinear (0 : M →ₗ[R] N) x = 0 := by + induction x using inductionOn with + | _ x => + rw [mapLinear_coe] + exact EventuallyEq.germ_eq <| Eventually.of_forall fun a ↦ rfl + +/-- An injective linear map acts injectively on germs. -/ +theorem mapLinear_injective (f : M →ₗ[R] N) (hf : Function.Injective f) : + Function.Injective (mapLinear (l := l) f) := by + intro x y hxy + induction x using inductionOn with + | _ x => + induction y using inductionOn with + | _ y => + rw [mapLinear_coe, mapLinear_coe, coe_eq] at hxy + rw [coe_eq] + exact hxy.mono fun _ hx ↦ hf hx + +section TensorProduct + +variable {K : Type u} {V : Type v} {E : Type w} +variable [CommSemiring K] [AddCommMonoid V] [AddCommMonoid E] +variable [Module K V] [Module K E] + +/-- The bilinear pointwise pure-tensor map on germs. -/ +def tensorBilinear : + Germ l V →ₗ[K] E →ₗ[K] Germ l (V ⊗[K] E) := + LinearMap.mk₂ K + (fun g e ↦ mapLinear ((TensorProduct.mk K V E).flip e) g) + (fun g₁ g₂ e ↦ (mapLinear ((TensorProduct.mk K V E).flip e)).map_add g₁ g₂) + (fun c g e ↦ (mapLinear ((TensorProduct.mk K V E).flip e)).map_smul c g) + (by + intro g e₁ e₂ + induction g using inductionOn with + | _ g => + rw [mapLinear_coe, mapLinear_coe, mapLinear_coe, ← coe_add, coe_eq] + exact Eventually.of_forall fun x ↦ by simp) + (by + intro c g e + induction g using inductionOn with + | _ g => + rw [mapLinear_coe, mapLinear_coe, ← coe_smul, coe_eq] + exact Eventually.of_forall fun x ↦ by simp) + +/-- Pointwise tensoring of a germ with a fixed vector, extended linearly over a tensor product. -/ +def tensorProduct : + Germ l V ⊗[K] E →ₗ[K] Germ l (V ⊗[K] E) := + TensorProduct.lift tensorBilinear + +/-- On a pure tensor, `tensorProduct` is represented by pointwise pure tensors. -/ +@[simp] +theorem tensorProduct_tmul (g : Germ l V) (e : E) : + tensorProduct (l := l) (g ⊗ₜ[K] e) = + mapLinear ((TensorProduct.mk K V E).flip e) g := by + rw [tensorProduct, TensorProduct.lift.tmul] + rfl + +/-- Contraction of the right tensor factor against a functional. -/ +private def tensorRightContraction (lambda : E →ₗ[K] K) : V ⊗[K] E →ₗ[K] V := + (TensorProduct.rid K V).toLinearMap.comp (lambda.lTensor V) + +@[simp] +private theorem tensorRightContraction_tmul (lambda : E →ₗ[K] K) (v : V) (e : E) : + tensorRightContraction lambda (v ⊗ₜ[K] e) = lambda e • v := by + simp [tensorRightContraction] + +private theorem mapLinear_tensorRightContraction_tensorProduct (lambda : E →ₗ[K] K) + (T : Germ l V ⊗[K] E) : + mapLinear (tensorRightContraction lambda) (tensorProduct (l := l) T) = + tensorRightContraction lambda T := by + induction T using TensorProduct.inductionOn with + | tmul g e => + rw [tensorProduct_tmul, tensorRightContraction_tmul] + induction g using inductionOn with + | _ f => + rw [mapLinear_coe, mapLinear_coe] + rfl + | add x y hx hy => simp only [map_add, hx, hy] + +end TensorProduct + +section Injective + +variable {K : Type u} {V : Type v} {E : Type w} +variable [Field K] [AddCommGroup V] [AddCommGroup E] +variable [Module K V] [Module K E] + +/-- Over a field, the canonical map `Germ(V) ⊗[K] E → Germ(V ⊗[K] E)` is injective. -/ +theorem tensorProduct_injective : + Function.Injective (tensorProduct (l := l) (K := K) (V := V) (E := E)) := by + let C := Module.Free.chooseBasis K E + rw [← LinearMap.ker_eq_bot] + refine eq_bot_iff.mpr fun T hT ↦ ?_ + change T = 0 + change tensorProduct (l := l) T = 0 at hT + let c := TensorProduct.equivFinsuppOfBasisRight C T + have hc : c = 0 := by + apply Finsupp.ext + intro i + have hcontract := congrArg (mapLinear (tensorRightContraction (C.coord i))) hT + rw [mapLinear_tensorRightContraction_tensorProduct, map_zero] at hcontract + simpa [c, tensorRightContraction, TensorProduct.equivFinsuppOfBasisRight_apply] using hcontract + apply (TensorProduct.equivFinsuppOfBasisRight C).injective + simp [c, hc] + +end Injective + +end + +end Filter.Germ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Order/Filter/Tests.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Order/Filter/Tests.lean new file mode 100644 index 0000000000..5e34987697 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Order/Filter/Tests.lean @@ -0,0 +1,11 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Order.Filter.Tests.FunAtZeroMinus + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Order/Filter/Tests/FunAtZeroMinus.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Order/Filter/Tests/FunAtZeroMinus.lean new file mode 100644 index 0000000000..53a6c9baef --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Order/Filter/Tests/FunAtZeroMinus.lean @@ -0,0 +1,108 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Order.Filter.FunAtZeroMinus + +import Mathlib.Topology.MetricSpace.Pseudo.Lemmas +import Mathlib.Tactic.Linarith +import Mathlib.Tactic.NormNum + +/-! +# API checks for functions at `0⁻` + +A function that vanishes near zero represents `0` in `Fun_{0⁻}(ℚ)` even when it is globally +nonzero. A second fixture is eventually valued in a proper coordinate subspace but leaves it +away from zero. These distinguish eventual equality and membership from their global versions. +A nonzero constant function remains nonzero, and the tensor check evaluates the pointwise +representative formula on a nonconstant real-valued function at `0⁻`. +-/ + +open Filter Topology +open scoped TensorProduct + +namespace Tests + +public noncomputable section + +/-- A rational-valued function that vanishes throughout `(-1, 0)` but not globally. -/ +def tailZero (γ : ℝ) : ℚ := + if γ < -1 then 1 else 0 + +/-- The test function is globally nonzero. -/ +theorem tailZero_neg_two : tailZero (-2) = 1 := by + norm_num [tailZero] + +/-- Agreement near `0`, rather than global equality, makes the test function `0` in +`Fun_{0⁻}(ℚ)`. -/ +theorem tailZero_funAtZeroMinus_eq_zero : + (tailZero : FunAtZeroMinus ℚ) = 0 := by + change (tailZero : FunAtZeroMinus ℚ) = ((fun _ : ℝ ↦ (0 : ℚ)) : FunAtZeroMinus ℚ) + rw [funAtZeroMinus_coe_eq_iff_exists] + refine ⟨1, by norm_num, fun γ hγ _ ↦ ?_⟩ + rw [tailZero, ite_eq_right] + linarith + +/-- Constant functions remain distinct in `Fun_{0⁻}(ℚ)`. -/ +theorem funAtZeroMinus_one_ne_zero : + (1 : FunAtZeroMinus ℚ) ≠ 0 := by + change ((1 : ℚ) : FunAtZeroMinus ℚ) ≠ ((0 : ℚ) : FunAtZeroMinus ℚ) + intro h + exact one_ne_zero (Filter.Germ.const_inj.mp h) + +/-- The first coordinate axis in `ℚ × ℚ`. -/ +def firstAxis : Submodule ℚ (ℚ × ℚ) where + carrier := {x | x.2 = 0} + zero_mem' := rfl + add_mem' {x y} hx hy := by + change x.2 = 0 at hx + change y.2 = 0 at hy + change x.2 + y.2 = 0 + rw [hx, hy, add_zero] + smul_mem' c x hx := by + change x.2 = 0 at hx + change c * x.2 = 0 + rw [hx, mul_zero] + +/-- Membership in the first coordinate axis is vanishing of the second coordinate. -/ +@[simp] +theorem mem_firstAxis_iff (x : ℚ × ℚ) : + x ∈ firstAxis ↔ x.2 = 0 := by + change x.2 = 0 ↔ x.2 = 0 + rfl + +/-- A function that enters the first coordinate axis on `(-1, 0)`. -/ +def eventuallyFirstAxis (γ : ℝ) : ℚ × ℚ := + if γ < -1 then (0, 1) else (1, 0) + +/-- The subspace-valued test function does not lie in the first axis globally. -/ +theorem eventuallyFirstAxis_neg_two_not_mem : + eventuallyFirstAxis (-2) ∉ firstAxis := by + simp [eventuallyFirstAxis] + +/-- Taking values in the subspace near `0` suffices for membership of the function at `0⁻` in +`Fun_{0⁻}(W) ⊆ Fun_{0⁻}(V)`. -/ +theorem eventuallyFirstAxis_funAtZeroMinus_mem : + (eventuallyFirstAxis : FunAtZeroMinus (ℚ × ℚ)) ∈ funAtZeroMinusSubmodule firstAxis := by + rw [coe_mem_funAtZeroMinusSubmodule_iff_exists] + refine ⟨1, by norm_num, fun γ hγ _ ↦ ?_⟩ + rw [eventuallyFirstAxis, ite_eq_right] + · simp + · linarith + +/-- Tensor extension is represented by pointwise pure tensors on a nonconstant function at +`0⁻`. -/ +theorem funAtZeroMinusTensorId_identity_tmul : + funAtZeroMinusTensorId (E := ℝ) + (LinearMap.id : FunAtZeroMinus ℝ →ₗ[ℝ] FunAtZeroMinus ℝ) + (((fun γ : ℝ ↦ γ) : FunAtZeroMinus ℝ) ⊗ₜ[ℝ] (2 : ℝ)) = + ((fun γ : ℝ ↦ γ ⊗ₜ[ℝ] (2 : ℝ)) : FunAtZeroMinus (ℝ ⊗[ℝ] ℝ)) := by + apply funAtZeroMinusTensorId_tmul_of_eq_coe + rfl + +end + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/RingTheory.lean b/LeanPool/ConwayRefinement/ConwayRefinement/RingTheory.lean new file mode 100644 index 0000000000..eb3d95630f --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/RingTheory.lean @@ -0,0 +1,12 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.RingTheory.LaurentTower +public import LeanPool.ConwayRefinement.ConwayRefinement.RingTheory.LocalizationUFM + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/RingTheory/LaurentTower.lean b/LeanPool/ConwayRefinement/ConwayRefinement/RingTheory/LaurentTower.lean new file mode 100644 index 0000000000..4482b0e941 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/RingTheory/LaurentTower.lean @@ -0,0 +1,81 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import Mathlib.Algebra.Polynomial.Laurent + +import LeanPool.ConwayRefinement.ConwayRefinement.RingTheory.LocalizationUFM +import Mathlib.RingTheory.Polynomial.UniqueFactorization + +/-! +# Unique factorisation in the group ring of a free abelian group of finite rank + +The group ring of `ℤ ^ k` over a field is reached from the field by `k` Laurent extensions. Each +one is a polynomial extension, which preserves unique factorisation, followed by a localization at +the powers of the variable, which preserves it as well. +-/ + +universe u v + +public noncomputable section + +namespace LaurentPolynomial + +/-- A Laurent polynomial ring over a unique factorisation domain is a unique factorisation +domain. -/ +theorem uniqueFactorizationMonoid {A : Type u} [CommRing A] [IsDomain A] + [UniqueFactorizationMonoid A] : UniqueFactorizationMonoid (LaurentPolynomial A) := by + have hle : Submonoid.powers (Polynomial.X : Polynomial A) ≤ nonZeroDivisors (Polynomial A) := by + rintro _ ⟨n, rfl⟩ + exact mem_nonZeroDivisors_of_ne_zero (pow_ne_zero n Polynomial.X_ne_zero) + exact IsLocalization.uniqueFactorizationMonoid + (B := LaurentPolynomial A) (Submonoid.powers (Polynomial.X : Polynomial A)) hle + +end LaurentPolynomial + +namespace AddMonoidAlgebra + +/-- Splitting off the first coordinate of a tuple of integers. -/ +def finSuccAddEquiv (n : ℕ) : ((Fin (n + 1)) → ℤ) ≃+ (ℤ × (Fin n → ℤ)) where + toFun f := (f 0, fun i ↦ f i.succ) + invFun p := Fin.cons p.1 p.2 + left_inv f := by + funext i + refine Fin.cases ?_ ?_ i + · simp + · intro j + simp + right_inv p := by + ext + · simp + · simp + map_add' f g := by + ext + · simp + · simp + +/-- The group ring of `ℤ ^ k` over a field is a unique factorisation domain. -/ +theorem uniqueFactorizationMonoid_finInt (K : Type v) [Field K] : + ∀ k : ℕ, UniqueFactorizationMonoid (AddMonoidAlgebra K (Fin k → ℤ)) + | 0 => by + refine MulEquiv.uniqueFactorizationMonoid + (AddMonoidAlgebra.uniqueAlgEquiv (R := K) (A := K) + (M := (Fin 0 → ℤ))).symm.toRingEquiv.toMulEquiv ?_ + infer_instance + | (k + 1) => by + have ih := uniqueFactorizationMonoid_finInt K k + have hlaurent : UniqueFactorizationMonoid + (LaurentPolynomial (AddMonoidAlgebra K (Fin k → ℤ))) := + LaurentPolynomial.uniqueFactorizationMonoid + have f : AddMonoidAlgebra K (Fin (k + 1) → ℤ) ≃+* + LaurentPolynomial (AddMonoidAlgebra K (Fin k → ℤ)) := + RingEquiv.trans + (AddMonoidAlgebra.domCongr (R := K) (A := K) (e := finSuccAddEquiv k)).toRingEquiv + (AddMonoidAlgebra.curryAlgEquiv (R := K) (A := K) (M := ℤ) + (N := (Fin k → ℤ))).toRingEquiv + exact MulEquiv.uniqueFactorizationMonoid f.symm.toMulEquiv hlaurent + +end AddMonoidAlgebra diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/RingTheory/LocalizationUFM.lean b/LeanPool/ConwayRefinement/ConwayRefinement/RingTheory/LocalizationUFM.lean new file mode 100644 index 0000000000..fa8ac216a9 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/RingTheory/LocalizationUFM.lean @@ -0,0 +1,123 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import Mathlib.RingTheory.Localization.Defs +public import Mathlib.RingTheory.UniqueFactorizationDomain.Defs + +import Mathlib.RingTheory.UniqueFactorizationDomain.Basic + +/-! +# Localizations of unique factorisation domains + +A localization of a unique factorisation domain at a submonoid of nonzerodivisors is again one. +A prime of the base either becomes a unit or stays prime, so a factorisation of a numerator +becomes one after the primes that turned into units are dropped. + +Mathlib has the corresponding statements for polynomial rings and for principal ideal rings, but +none for localizations. The Laurent polynomial ring is a localization of the polynomial ring, so +this is what carries unique factorisation along the tower of Laurent extensions reaching the group +ring of a finitely generated free abelian group. +-/ + +universe u v + +public noncomputable section + +namespace IsLocalization + +variable {A : Type u} [CommRing A] [IsDomain A] +variable {B : Type v} [CommRing B] [IsDomain B] [Algebra A B] +variable (S : Submonoid A) [IsLocalization S B] + +omit [IsDomain A] [IsDomain B] in +/-- Divisibility after localization comes from divisibility up to a denominator. -/ +theorem exists_dvd_mul_of_dvd_algebraMap {p a : A} + (h : algebraMap A B p ∣ algebraMap A B a) : ∃ s ∈ S, p ∣ a * s := by + obtain ⟨c, hc⟩ := h + obtain ⟨⟨c₁, v⟩, hv⟩ := IsLocalization.surj (M := S) c + have hmap : algebraMap A B (a * v) = algebraMap A B (p * c₁) := by + rw [map_mul, map_mul, hc, mul_assoc, hv] + obtain ⟨w, hw⟩ := IsLocalization.exists_of_eq (M := S) hmap + refine ⟨(v : A) * (w : A), mul_mem v.2 w.2, ⟨c₁ * (w : A), ?_⟩⟩ + calc a * ((v : A) * (w : A)) = (w : A) * (a * (v : A)) := by ring + _ = (w : A) * (p * c₁) := hw + _ = p * (c₁ * (w : A)) := by ring + +omit [IsDomain A] [IsDomain B] in +/-- A prime of the base ring stays prime after localization unless it becomes a unit. -/ +theorem prime_algebraMap_of_prime (hS : S ≤ nonZeroDivisors A) {p : A} (hp : Prime p) + (hnu : ¬ IsUnit (algebraMap A B p)) : Prime (algebraMap A B p) := by + refine ⟨fun h ↦ hp.ne_zero (IsLocalization.injective B hS (by simpa using h)), hnu, ?_⟩ + intro y z hyz + obtain ⟨⟨y₁, t⟩, ht⟩ := IsLocalization.surj (M := S) y + obtain ⟨⟨z₁, u⟩, hu⟩ := IsLocalization.surj (M := S) z + have hdvd : algebraMap A B p ∣ algebraMap A B (y₁ * z₁) := by + have hrw : algebraMap A B (y₁ * z₁) + = (y * z) * (algebraMap A B (t : A) * algebraMap A B (u : A)) := by + rw [map_mul, ← ht, ← hu] + ring + rw [hrw] + exact hyz.mul_right _ + obtain ⟨s, hs, hps⟩ := exists_dvd_mul_of_dvd_algebraMap S hdvd + have hpns : ¬ p ∣ s := fun hd ↦ + hnu (isUnit_of_dvd_unit (map_dvd (algebraMap A B) hd) + (IsLocalization.map_units B ⟨s, hs⟩)) + rcases hp.dvd_mul.mp hps with hprod | hcon + · rcases hp.dvd_mul.mp hprod with hy | hz + · refine Or.inl ((IsUnit.dvd_mul_right (IsLocalization.map_units B t)).mp ?_) + rw [ht] + exact map_dvd _ hy + · refine Or.inr ((IsUnit.dvd_mul_right (IsLocalization.map_units B u)).mp ?_) + rw [hu] + exact map_dvd _ hz + · exact absurd hcon hpns + +omit [IsDomain A] [IsDomain B] in +/-- Mapping a list of primes into the localization and dropping those that become units leaves a +prime factorisation of the image. -/ +private theorem exists_prime_factors_algebraMap + (hS : S ≤ nonZeroDivisors A) (f : Multiset A) (hf : ∀ p ∈ f, Prime p) : + ∃ g : Multiset B, (∀ q ∈ g, Prime q) ∧ Associated g.prod (algebraMap A B f.prod) := by + induction f using Multiset.induction with + | empty => exact ⟨0, by simp, by simp⟩ + | cons p f ih => + obtain ⟨g, hgp, hga⟩ := ih fun q hq ↦ hf q (Multiset.mem_cons_of_mem hq) + have hp : Prime p := hf p (Multiset.mem_cons_self p f) + by_cases hu : IsUnit (algebraMap A B p) + · refine ⟨g, hgp, hga.trans ⟨hu.unit, ?_⟩⟩ + rw [Multiset.prod_cons, map_mul, IsUnit.unit_spec] + ring + · refine ⟨algebraMap A B p ::ₘ g, ?_, ?_⟩ + · intro q hq + rcases Multiset.mem_cons.mp hq with rfl | hq + · exact prime_algebraMap_of_prime S hS hp hu + · exact hgp q hq + · rw [Multiset.prod_cons, Multiset.prod_cons, map_mul] + exact hga.mul_left _ + +omit [IsDomain A] in +/-- A localization of a unique factorisation domain at a submonoid of nonzerodivisors is again a +unique factorisation domain. -/ +theorem uniqueFactorizationMonoid [UniqueFactorizationMonoid A] + (hS : S ≤ nonZeroDivisors A) : UniqueFactorizationMonoid B := by + refine UniqueFactorizationMonoid.of_exists_prime_factors (α := B) fun b hb ↦ ?_ + obtain ⟨⟨x, s⟩, hs⟩ := IsLocalization.surj (M := S) b + have hunit : IsUnit (algebraMap A B (s : A)) := IsLocalization.map_units B s + have hx0 : x ≠ 0 := by + intro h + rw [h, map_zero] at hs + rcases mul_eq_zero.mp hs with h' | h' + · exact hb h' + · exact hunit.ne_zero h' + obtain ⟨f, hfp, hfa⟩ := UniqueFactorizationMonoid.exists_prime_factors x hx0 + obtain ⟨g, hgp, hga⟩ := exists_prime_factors_algebraMap (B := B) S hS f hfp + refine ⟨g, hgp, hga.trans ?_⟩ + refine (hfa.map (algebraMap A B)).trans (Associated.symm ⟨hunit.unit, ?_⟩) + rw [IsUnit.unit_spec] + exact hs + +end IsLocalization diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory.lean b/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory.lean new file mode 100644 index 0000000000..df6d5dfddc --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory.lean @@ -0,0 +1,13 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.FinitePWOUnion +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.ZFC + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/FinitePWOUnion.lean b/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/FinitePWOUnion.lean new file mode 100644 index 0000000000..dc2f706e1c --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/FinitePWOUnion.lean @@ -0,0 +1,41 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import Mathlib.Order.WellFoundedSet + +/-! +# Finite unions of partially well-ordered sets + +A union indexed by a finite type is partially well ordered when every member is. This is the +finite-family form of closure of partially well-ordered subsets of a linear order under union. +-/ + +universe u v + +namespace Set.IsPWO + +variable {α : Type u} {ι : Type v} [LinearOrder α] + +public section + +/-- A finite union of partially well-ordered sets is partially well ordered. -/ +theorem iUnion_of_finite [Finite ι] (S : ι → Set α) (hS : ∀ i, (S i).IsPWO) : + (⋃ i, S i).IsPWO := by + classical + cases nonempty_fintype ι + have hfin : ∀ t : Finset ι, (⋃ i ∈ t, S i).IsPWO := by + intro t + induction t using Finset.induction_on with + | empty => simp + | @insert i t hi ht => + rw [Finset.set_biUnion_insert] + exact (hS i).union ht + simpa using hfin Finset.univ + +end + +end Set.IsPWO diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal.lean b/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal.lean new file mode 100644 index 0000000000..c8eb955ae8 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal.lean @@ -0,0 +1,32 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.AdditivelyPrincipal +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.AlgebraicOrder +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.CantorBendixson +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.CantorTermCount +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.Degree +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.FinitePart +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.GeneralFactorization +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.IncreasingSequenceUnion +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.LeastTerm +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.LeastTermSup +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.MultiplicativelyPrincipal +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.NaturalOrder +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.NaturalPowerFactorization +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.NaturalPrincipal +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.OrderedUnion +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.PairBounds +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.Separation +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.SetOrderType +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.Split +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.SuccessorFactorization +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.Sumset +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.Tests + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/AdditivelyPrincipal.lean b/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/AdditivelyPrincipal.lean new file mode 100644 index 0000000000..fa8045570b --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/AdditivelyPrincipal.lean @@ -0,0 +1,426 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.CombinatorialGames.NatOrdinal.Pow +public import Mathlib.SetTheory.Ordinal.Principal +import Mathlib.Algebra.Order.BigOperators.Group.List + +/-! +# Positive additive principal ordinals + +LM24, Definition 3.3.1 calls an ordinal additively principal when it is of the form +`Ordinal.omega0 ^ e`. In particular, LM24 excludes zero. Mathlib's more general predicate +`Ordinal.IsPrincipal (· + ·)` includes zero, so `Ordinal.IsAdditivelyPrincipal` records the +source convention explicitly and the bridge theorem retains the necessary nonzero condition. + +The purported second equivalence printed in Definition 3.3.1 is false for ordinary ordinal +addition: `1 + ω = ω`. The correct closure condition is Mathlib's +`Ordinal.IsPrincipal (· + ·)`, together with nonzeroness. + +The list `Ordinal.additivePrincipalTerms o` is the uncompressed Cantor normal form of `o`: each +finite coefficient is represented by repeated powers of `ω`. Thus repeated equal terms are +retained, as required by LM24's weak normal forms. + +The Cantor terms also settle when ordinary and Hessenberg multiplication by a power of `ω` agree. +The Hessenberg product `ω ^ x ⊙ ω ^ w` equals the ordinary product `ω ^ x * ω ^ w` exactly +when `w` is at most every Cantor term of `x`; the weaker `ω ^ w ≤ ω ^ x` does not suffice, as +`x = ω + 1`, `w = ω` gives `ω ^ (ω * 2)` against `ω ^ (ω * 2 + 1)`. Berarducci, Lemma 8.2 uses +this conversion silently, and its hypothesis on principal values supplies the term condition. + +Mathlib supplies `Ordinal.IsPrincipal`, its exact power-of-`ω` characterization, ordinal logarithm, +and compressed Cantor normal form. The uncompressed list is defined by repeatedly removing the +largest power of `ω`, which preserves repeated terms. +-/ + +universe u + +open scoped NatOrdinal + +public noncomputable section + +namespace Ordinal + +/-- An LM24 additive principal ordinal: a positive ordinal of the form `ω ^ e`. -/ +def IsAdditivelyPrincipal (o : Ordinal) : Prop := + ∃ e : Ordinal, o = omega0 ^ e + +/-- Characterization of LM24 additive principal ordinals by powers of `ω`. -/ +theorem isAdditivelyPrincipal_iff {o : Ordinal} : + IsAdditivelyPrincipal o ↔ ∃ e : Ordinal, o = omega0 ^ e := + (Iff.rfl) + +/-- The difference between LM24's positive convention and Mathlib's additive-principal predicate. -/ +theorem isAdditivelyPrincipal_iff_ne_zero_and_isPrincipal_add {o : Ordinal} : + IsAdditivelyPrincipal o ↔ o ≠ 0 ∧ IsPrincipal (· + ·) o := by + constructor + · rintro ⟨e, rfl⟩ + exact ⟨opow_ne_zero _ omega0_ne_zero, isPrincipal_add_omega0_opow e⟩ + · rintro ⟨ho, hp⟩ + rw [isPrincipal_add_iff_zero_or_omega0_opow] at hp + rcases hp with hzero | ⟨e, he⟩ + · exact (ho hzero).elim + · exact ⟨e, he.symm⟩ + +/-- Every power of `ω` is additive principal in the LM24 convention. -/ +theorem isAdditivelyPrincipal_omega0_opow (e : Ordinal) : + IsAdditivelyPrincipal (omega0 ^ e) := + ⟨e, rfl⟩ + +/-- An LM24 additive principal ordinal is nonzero. -/ +theorem IsAdditivelyPrincipal.ne_zero {o : Ordinal} (ho : IsAdditivelyPrincipal o) : o ≠ 0 := + (isAdditivelyPrincipal_iff_ne_zero_and_isPrincipal_add.mp ho).1 + +/-- Every proper initial segment of `ρ * (α + 1)` leaves a remainder of at least `ρ` when `ρ` is +additive principal. This is the principal-part computation used in Berarducci, Lemma 6.8. -/ +theorem IsAdditivelyPrincipal.le_of_add_eq_mul_succ {o a b c : Ordinal} + (ho : IsAdditivelyPrincipal o) (hb : b < o * (a + 1)) (h : b + c = o * (a + 1)) : + o ≤ c := by + by_contra hlt + rw [not_le] at hlt + have hprincipal := + (isAdditivelyPrincipal_iff_ne_zero_and_isPrincipal_add.mp ho).2 + rcases le_or_gt (o * a) b with hge | hlt2 + · set d := b - o * a with hd + have hbd : o * a + d = b := Ordinal.add_sub_cancel_of_le hge + rw [mul_add_one] at hb + have hdlt : d < o := by + rw [← hbd] at hb + exact lt_of_add_lt_add_left hb + have hsum : o * a + (d + c) < o * a + o := + (add_lt_add_iff_left _).mpr (hprincipal hdlt hlt) + rw [← add_assoc, hbd, h, mul_add_one] at hsum + exact lt_irrefl _ hsum + · have h1 : b + c ≤ o * a + c := by gcongr + have h2 : o * a + c < o * a + o := (add_lt_add_iff_left _).mpr hlt + rw [h, mul_add_one] at h1 + exact lt_irrefl _ (h1.trans_lt h2) + +/-- A positive additive-principal ordinal strictly above one is at least `ω`. -/ +theorem IsAdditivelyPrincipal.omega0_le_of_one_lt {o : Ordinal} + (ho : IsAdditivelyPrincipal o) (hone : 1 < o) : omega0 ≤ o := by + obtain ⟨e, rfl⟩ := isAdditivelyPrincipal_iff.mp ho + rw [one_lt_opow] at hone + simpa [opow_one] using + opow_le_opow_right omega0_pos (Order.one_le_iff_ne_zero.mpr hone.2) + +/-- An additive-principal ordinal strictly greater than one is a nonzero limit ordinal. -/ +theorem IsAdditivelyPrincipal.isSuccLimit_of_one_lt {o : Ordinal} + (ho : IsAdditivelyPrincipal o) (hone : 1 < o) : Order.IsSuccLimit o := by + obtain ⟨e, rfl⟩ := isAdditivelyPrincipal_iff.mp ho + rw [one_lt_opow] at hone + exact isSuccLimit_opow_left isSuccLimit_omega0 hone.2 + +/-- The finite list of additive principal terms in the uncompressed Cantor normal form of `o`. -/ +noncomputable def additivePrincipalTerms (o : Ordinal) : List Ordinal := + if o = 0 then [] + else omega0 ^ log omega0 o :: additivePrincipalTerms (o - omega0 ^ log omega0 o) +termination_by o +decreasing_by exact sub_omega0_opow_log_lt (by assumption) + +@[simp] +theorem additivePrincipalTerms_zero : additivePrincipalTerms 0 = [] := by + rw [additivePrincipalTerms] + simp + +theorem additivePrincipalTerms_of_ne_zero {o : Ordinal} (ho : o ≠ 0) : + additivePrincipalTerms o = + omega0 ^ log omega0 o :: additivePrincipalTerms (o - omega0 ^ log omega0 o) := by + rw [additivePrincipalTerms] + simp only [ite_eq_right ho] + +/-- A finite ordinary sum of ordinals below a positive additive-principal ordinal remains below +that ordinal. -/ +theorem IsAdditivelyPrincipal.list_sum_lt {o : Ordinal} (ho : IsAdditivelyPrincipal o) + {l : List Ordinal} (hl : ∀ a ∈ l, a < o) : l.sum < o := by + have hp := (isAdditivelyPrincipal_iff_ne_zero_and_isPrincipal_add.mp ho).2 + induction l with + | nil => simpa using (ho.ne_zero.bot_lt) + | cons a l ih => + rw [List.sum_cons] + apply hp (hl a (by simp)) + exact ih fun b hb ↦ hl b (by simp [hb]) + +/-- The ordinary ordinal sum of the uncompressed Cantor terms is the original ordinal. -/ +theorem additivePrincipalTerms_sum (o : Ordinal) : o.additivePrincipalTerms.sum = o := by + induction o using additivePrincipalTerms.induct with + | case1 => simp + | case2 o ho ih => + rw [additivePrincipalTerms_of_ne_zero ho, List.sum_cons, ih] + exact Ordinal.add_sub_cancel_of_le (opow_log_le_self omega0 ho) + +/-- Every term in the uncompressed Cantor normal form is LM24 additive principal. -/ +theorem isAdditivelyPrincipal_of_mem_additivePrincipalTerms {o a : Ordinal} + (ha : a ∈ o.additivePrincipalTerms) : IsAdditivelyPrincipal a := by + induction o using additivePrincipalTerms.induct with + | case1 => simp at ha + | case2 o ho ih => + rw [additivePrincipalTerms_of_ne_zero ho] at ha + simp only [List.mem_cons] at ha + rcases ha with rfl | ha + · exact isAdditivelyPrincipal_omega0_opow _ + · exact ih ha + +/-- The uncompressed Cantor terms occur in nonincreasing order. -/ +theorem additivePrincipalTerms_sortedGE (o : Ordinal) : + o.additivePrincipalTerms.SortedGE := by + induction o using additivePrincipalTerms.induct with + | case1 => simp [List.sortedGE_iff_pairwise] + | case2 o ho ih => + rw [additivePrincipalTerms_of_ne_zero ho] + rw [List.sortedGE_iff_pairwise] at ih ⊢ + rw [List.pairwise_cons] + refine ⟨?_, ih⟩ + intro a ha + obtain ⟨e, rfl⟩ := isAdditivelyPrincipal_of_mem_additivePrincipalTerms ha + apply opow_le_opow_right omega0_pos + apply le_log_of_opow_le one_lt_omega0 + calc + omega0 ^ e ≤ (o - omega0 ^ log omega0 o).additivePrincipalTerms.sum := + List.le_sum_of_mem ha + _ = o - omega0 ^ log omega0 o := additivePrincipalTerms_sum _ + _ ≤ o := sub_le_self _ _ + +/-- A sorted ordinary sum of positive powers of `ω` agrees with the corresponding Hessenberg +sum in `NatOrdinal`. -/ +theorem natOrdinal_of_sum_eq_sum_map_of_sorted {l : List Ordinal} + (hprincipal : ∀ a ∈ l, IsAdditivelyPrincipal a) + (hsorted : l.SortedGE) : + NatOrdinal.of l.sum = (l.map NatOrdinal.of).sum := by + induction l with + | nil => simp + | cons a l ih => + have haPrincipal := hprincipal a (by simp) + obtain ⟨e, rfl⟩ := isAdditivelyPrincipal_iff.mp haPrincipal + have hpairwise := List.sortedGE_iff_pairwise.mp hsorted + have htailSorted : l.SortedGE := + List.sortedGE_iff_pairwise.mpr (List.pairwise_cons.mp hpairwise).2 + have htailPrincipal : ∀ b ∈ l, IsAdditivelyPrincipal b := + fun b hb ↦ hprincipal b (by simp [hb]) + have htailBound : l.sum < omega0 ^ (e + 1) := by + apply (isAdditivelyPrincipal_omega0_opow _).list_sum_lt + intro b hb + have hble : b ≤ omega0 ^ e := (List.pairwise_cons.mp hpairwise).1 b hb + exact hble.trans_lt <| + (opow_lt_opow_iff_right one_lt_omega0).mpr (Order.lt_succ e) + rw [List.sum_cons, List.map_cons, List.sum_cons, + ← ih htailPrincipal htailSorted, NatOrdinal.of_omega0_opow] + symm + apply NatOrdinal.wpow_add_of_lt + rw [NatOrdinal.wpow_def, NatOrdinal.val_add_one, NatOrdinal.val_of] + exact NatOrdinal.of.lt_iff_lt.mpr htailBound + +/-- The uncompressed Cantor terms are the unique nonincreasing finite list of positive additive +principal ordinals whose ordinary ordinal sum is `o`. -/ +theorem additivePrincipalTerms_unique {o : Ordinal} {l : List Ordinal} + (hsum : l.sum = o) (hprincipal : ∀ a ∈ l, IsAdditivelyPrincipal a) + (hsorted : l.SortedGE) : l = o.additivePrincipalTerms := by + have canonicalSum := additivePrincipalTerms_sum o + have canonicalPrincipal : ∀ a ∈ o.additivePrincipalTerms, IsAdditivelyPrincipal a := + fun _ ha ↦ isAdditivelyPrincipal_of_mem_additivePrincipalTerms ha + have canonicalSorted := additivePrincipalTerms_sortedGE o + suffices hunique : ∀ {l m : List Ordinal}, l.sum = m.sum → + (∀ a ∈ l, IsAdditivelyPrincipal a) → l.SortedGE → + (∀ a ∈ m, IsAdditivelyPrincipal a) → m.SortedGE → l = m by + exact hunique (hsum.trans canonicalSum.symm) hprincipal hsorted canonicalPrincipal + canonicalSorted + intro l + induction l with + | nil => + intro m hsum _ _ hmPrincipal _ + cases m with + | nil => rfl + | cons b bs => + have hbpos : 0 < b := (hmPrincipal b (by simp)).ne_zero.bot_lt + have hble : b ≤ (b :: bs).sum := List.le_sum_of_mem (by simp) + rw [← hsum] at hble + have : b ≤ 0 := by simpa only [List.sum_nil] using hble + exact (not_lt_of_ge this hbpos).elim + | cons a as ih => + intro m hsum hlPrincipal hlSorted hmPrincipal hmSorted + cases m with + | nil => + have hapos : 0 < a := (hlPrincipal a (by simp)).ne_zero.bot_lt + have hale : a ≤ (a :: as).sum := List.le_sum_of_mem (by simp) + rw [hsum] at hale + have : a ≤ 0 := by simpa only [List.sum_nil] using hale + exact (not_lt_of_ge this hapos).elim + | cons b bs => + have hlPairwise : (a :: as).Pairwise (· ≥ ·) := + List.sortedGE_iff_pairwise.mp hlSorted + have hmPairwise : (b :: bs).Pairwise (· ≥ ·) := + List.sortedGE_iff_pairwise.mp hmSorted + have hal : ∀ x ∈ as, x ≤ a := (List.pairwise_cons.mp hlPairwise).1 + have hbl : ∀ x ∈ bs, x ≤ b := (List.pairwise_cons.mp hmPairwise).1 + have hab : a = b := by + apply le_antisymm + · apply le_of_not_gt + intro hba + have hlt : (b :: bs).sum < a := + (hlPrincipal a (by simp)).list_sum_lt (by + intro x hx + simp only [List.mem_cons] at hx + rcases hx with rfl | hx + · exact hba + · exact (hbl x hx).trans_lt hba) + have hale : a ≤ (a :: as).sum := List.le_sum_of_mem (by simp) + exact (not_lt_of_ge (hale.trans_eq hsum)) hlt + · apply le_of_not_gt + intro hab + have hlt : (a :: as).sum < b := + (hmPrincipal b (by simp)).list_sum_lt (by + intro x hx + simp only [List.mem_cons] at hx + rcases hx with rfl | hx + · exact hab + · exact (hal x hx).trans_lt hab) + have hble : b ≤ (b :: bs).sum := List.le_sum_of_mem (by simp) + exact (not_lt_of_ge (hble.trans_eq hsum.symm)) hlt + subst b + congr 1 + apply ih + · have htail : a + as.sum = a + bs.sum := by + simpa only [List.sum_cons] using hsum + exact add_left_cancel htail + · exact fun x hx ↦ hlPrincipal x (by simp [hx]) + · exact List.sortedGE_iff_pairwise.mpr (List.pairwise_cons.mp hlPairwise).2 + · exact fun x hx ↦ hmPrincipal x (by simp [hx]) + · exact List.sortedGE_iff_pairwise.mpr (List.pairwise_cons.mp hmPairwise).2 + +/-- If every uncompressed Cantor term of `u` is at least the additive-principal ordinal `w`, then +appending `w` does not reorder the terms, so the ordinary and Hessenberg sums agree. -/ +theorem natOrdinal_of_add_eq_add_of_forall_le {u w : Ordinal} + (hw : IsAdditivelyPrincipal w) + (hle : ∀ a ∈ u.additivePrincipalTerms, w ≤ a) : + NatOrdinal.of (u + w) = NatOrdinal.of u + NatOrdinal.of w := by + set l := u.additivePrincipalTerms with hldef + have hlprincipal : ∀ a ∈ l, IsAdditivelyPrincipal a := fun a ha ↦ + isAdditivelyPrincipal_of_mem_additivePrincipalTerms ha + have hlsorted : l.SortedGE := additivePrincipalTerms_sortedGE u + have hallprincipal : ∀ a ∈ l ++ [w], IsAdditivelyPrincipal a := by + intro a ha + rcases List.mem_append.mp ha with ha | ha + · exact hlprincipal a ha + · rw [List.mem_singleton] at ha + exact ha ▸ hw + have hsorted : (l ++ [w]).SortedGE := by + rw [List.sortedGE_iff_pairwise, List.pairwise_append] + refine ⟨List.sortedGE_iff_pairwise.mp hlsorted, by simp, ?_⟩ + intro a ha b hb + rw [List.mem_singleton] at hb + exact hb ▸ hle a ha + have hsum : (l ++ [w]).sum = u + w := by + rw [List.sum_append, List.sum_singleton, hldef, additivePrincipalTerms_sum] + have h1 := natOrdinal_of_sum_eq_sum_map_of_sorted hallprincipal hsorted + have h2 := natOrdinal_of_sum_eq_sum_map_of_sorted hlprincipal hlsorted + rw [hsum] at h1 + rw [h1, List.map_append, List.sum_append, ← h2, hldef, additivePrincipalTerms_sum] + simp + + +/-- The uncompressed Cantor terms of a Hessenberg sum of additive-principal ordinals are exactly +the summands. -/ +theorem mem_of_mem_additivePrincipalTerms_natSum {L : List Ordinal} + (hL : ∀ a ∈ L, IsAdditivelyPrincipal a) {a : Ordinal} + (ha : a ∈ (((L.map NatOrdinal.of).sum).val).additivePrincipalTerms) : a ∈ L := by + classical + set L' := L.mergeSort (fun x y ↦ decide (y ≤ x)) with hL'def + have hperm : L'.Perm L := List.mergeSort_perm L _ + have hsorted : L'.SortedGE := List.sortedGE_mergeSort + have hL'principal : ∀ x ∈ L', IsAdditivelyPrincipal x := + fun x hx ↦ hL x (hperm.mem_iff.mp hx) + have hmapsum : (L'.map NatOrdinal.of).sum = (L.map NatOrdinal.of).sum := + (hperm.map NatOrdinal.of).sum_eq + have hsum : NatOrdinal.of L'.sum = (L.map NatOrdinal.of).sum := by + rw [natOrdinal_of_sum_eq_sum_map_of_sorted hL'principal hsorted, hmapsum] + have hval : L'.sum = ((L.map NatOrdinal.of).sum).val := by + rw [← hsum, NatOrdinal.val_of] + have huniq := additivePrincipalTerms_unique (o := L'.sum) rfl hL'principal hsorted + rw [hval] at huniq + exact hperm.mem_iff.mp (huniq ▸ ha) + + +/-- Hessenberg and ordinary multiplication by `ω ^ w` agree on a power of `ω` whose exponent is a +Hessenberg sum of additive-principal ordinals all at least `w`. The hypothesis cannot be weakened +to `ω ^ w ≤ ω ^ x`: for `x = ω + 1` and `w = ω` the two products are `ω ^ (ω * 2)` and +`ω ^ (ω * 2 + 1)`. -/ +theorem natOrdinal_of_mul_wpow_eq_mul {w : Ordinal} {M : List Ordinal} + (hw : IsAdditivelyPrincipal w) + (hM : ∀ u ∈ M, IsAdditivelyPrincipal u ∧ w ≤ u) : + NatOrdinal.of (omega0 ^ ((M.map NatOrdinal.of).sum).val * omega0 ^ w) = + NatOrdinal.of (omega0 ^ ((M.map NatOrdinal.of).sum).val) * + NatOrdinal.of (omega0 ^ w) := by + set x := ((M.map NatOrdinal.of).sum).val with hxdef + have hterms : ∀ a ∈ x.additivePrincipalTerms, w ≤ a := by + intro a ha + exact (hM a (mem_of_mem_additivePrincipalTerms_natSum (fun u hu ↦ (hM u hu).1) ha)).2 + rw [← opow_add, NatOrdinal.of_omega0_opow, NatOrdinal.of_omega0_opow, + NatOrdinal.of_omega0_opow, natOrdinal_of_add_eq_add_of_forall_le hw hterms, + NatOrdinal.wpow_add] + +theorem IsAdditivelyPrincipal.opow_log_self {o : Ordinal} (ho : IsAdditivelyPrincipal o) : + omega0 ^ log omega0 o = o := by + obtain ⟨e, rfl⟩ := isAdditivelyPrincipal_iff.mp ho + rw [log_opow one_lt_omega0] + +theorem natOrdinal_of_eq_wpow_log {o : Ordinal} (ho : IsAdditivelyPrincipal o) : + NatOrdinal.of o = ω^ (NatOrdinal.of (log omega0 o)) := by + conv_lhs => rw [← ho.opow_log_self] + rw [NatOrdinal.of_omega0_opow] + +theorem natOrdinal_of_log_eq_sum_terms (o : Ordinal) : + NatOrdinal.of (log omega0 o) = + (((log omega0 o).additivePrincipalTerms).map NatOrdinal.of).sum := by + conv_lhs => rw [← additivePrincipalTerms_sum (log omega0 o)] + exact natOrdinal_of_sum_eq_sum_map_of_sorted + (fun _ ha ↦ isAdditivelyPrincipal_of_mem_additivePrincipalTerms ha) + (additivePrincipalTerms_sortedGE _) + +/-- The uncompressed Cantor terms of the logarithm of a Hessenberg product come from the two +factors. -/ +theorem mem_additivePrincipalTerms_log_natMul {o₁ o₂ : Ordinal} + (h₁ : IsAdditivelyPrincipal o₁) (h₂ : IsAdditivelyPrincipal o₂) {t : Ordinal} + (ht : t ∈ + (log omega0 ((NatOrdinal.of o₁ * NatOrdinal.of o₂).val)).additivePrincipalTerms) : + t ∈ (log omega0 o₁).additivePrincipalTerms ∨ + t ∈ (log omega0 o₂).additivePrincipalTerms := by + have hprod : NatOrdinal.of o₁ * NatOrdinal.of o₂ = + ω^ (NatOrdinal.of (log omega0 o₁) + NatOrdinal.of (log omega0 o₂)) := by + rw [NatOrdinal.wpow_add, ← natOrdinal_of_eq_wpow_log h₁, ← natOrdinal_of_eq_wpow_log h₂] + have hlog : log omega0 ((NatOrdinal.of o₁ * NatOrdinal.of o₂).val) = + (NatOrdinal.of (log omega0 o₁) + NatOrdinal.of (log omega0 o₂)).val := by + rw [hprod, NatOrdinal.val_wpow, log_opow one_lt_omega0] + set M := (log omega0 o₁).additivePrincipalTerms ++ (log omega0 o₂).additivePrincipalTerms + with hMdef + have hM : ∀ u ∈ M, IsAdditivelyPrincipal u := by + intro u hu + rcases List.mem_append.mp hu with hu | hu <;> + exact isAdditivelyPrincipal_of_mem_additivePrincipalTerms hu + have hsum : (M.map NatOrdinal.of).sum = + NatOrdinal.of (log omega0 o₁) + NatOrdinal.of (log omega0 o₂) := by + rw [hMdef, List.map_append, List.sum_append, ← natOrdinal_of_log_eq_sum_terms, + ← natOrdinal_of_log_eq_sum_terms] + rw [hlog, ← hsum] at ht + exact List.mem_append.mp (mem_of_mem_additivePrincipalTerms_natSum hM ht) + + +theorem additivePrincipalTerms_of_isAdditivelyPrincipal {o : Ordinal} + (ho : IsAdditivelyPrincipal o) : o.additivePrincipalTerms = [o] := by + rw [additivePrincipalTerms_of_ne_zero ho.ne_zero, ho.opow_log_self, Ordinal.sub_self, + additivePrincipalTerms_zero] + +/-- Ordinary and Hessenberg multiplication by `ω ^ w` agree on an additive-principal ordinal each +of whose canonical multiplicative factors is at least `ω ^ w`. -/ +theorem natOrdinal_of_mul_wpow_eq_mul_of_log_terms {w o : Ordinal} + (hw : IsAdditivelyPrincipal w) (ho : IsAdditivelyPrincipal o) + (hterms : ∀ t ∈ (log omega0 o).additivePrincipalTerms, w ≤ t) : + NatOrdinal.of (o * omega0 ^ w) = NatOrdinal.of o * NatOrdinal.of (omega0 ^ w) := by + have h1 : o * omega0 ^ w = omega0 ^ (log omega0 o + w) := by + rw [opow_add, ho.opow_log_self] + rw [h1, NatOrdinal.of_omega0_opow, natOrdinal_of_add_eq_add_of_forall_le hw hterms, + NatOrdinal.wpow_add, ← natOrdinal_of_eq_wpow_log ho, ← NatOrdinal.of_omega0_opow] + +end Ordinal diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/AlgebraicOrder.lean b/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/AlgebraicOrder.lean new file mode 100644 index 0000000000..4c2fcf7bd8 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/AlgebraicOrder.lean @@ -0,0 +1,345 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.Separation + +/-! +# The algebraic order for Hessenberg addition + +The algebraic order of a commutative monoid is `a ≼ b` when `a + c = b` for some `c`. Here the +operation is Hessenberg addition `⊕`, which is cancellative and strictly increasing in each +argument. Thus there is at most one `c` with `a ⊕ c = b`; when it exists, `b ⊖ a` denotes this +Hessenberg difference. Under the isomorphism +`(On, ⊕, ⊙) ≅ (ℕ[X_0, X_1, …], +, ·)` of [LM24, §2.2], `a ≼ b` exactly when each term in the +Cantor normal form of `a` occurs in that of `b` at least as often. This is not ordinal subtraction: +`ω ⊖ 1` is undefined although `1 + ω = ω`. + +The relation is reflexive and transitive, preserved by `⊕` on both sides and cancellable, and it +holds part by part for the parts `b_{≥β}`, `b_{<β}` of `Split.lean`. The last section relates it +to the separation condition (n) of `Separation.lean`: if `c ≠ 0` has last term `ω^ε` in its Cantor +normal form, `b ⊕ c = h` and `h_{≥ε} ≤ τ`, then `b ⊕ θ < τ` for every `θ < c`. +-/ + +universe u w + +open Ordinal + +public noncomputable section + +namespace NatOrdinal + +/-- `a` precedes `b` in the algebraic order for Hessenberg addition: there is `c` with +`a ⊕ c = b`. Equivalently, every Cantor term of `a` occurs in `b` at least as often. -/ +def AlgebraicLE (a b : NatOrdinal.{u}) : Prop := ∃ c, a + c = b + +theorem algebraicLE_iff {a b : NatOrdinal.{u}} : AlgebraicLE a b ↔ ∃ c, a + c = b := (Iff.rfl) + +theorem AlgebraicLE.le {a b : NatOrdinal.{u}} (h : AlgebraicLE a b) : a ≤ b := by + obtain ⟨c, rfl⟩ := h + exact le_add_of_nonneg_right zero_le + +theorem algebraicLE_refl (a : NatOrdinal.{u}) : AlgebraicLE a a := ⟨0, add_zero a⟩ + +theorem algebraicLE_zero (a : NatOrdinal.{u}) : AlgebraicLE 0 a := ⟨a, zero_add a⟩ + +theorem AlgebraicLE.trans {a b c : NatOrdinal.{u}} (hab : AlgebraicLE a b) + (hbc : AlgebraicLE b c) : + AlgebraicLE a c := by + obtain ⟨d, rfl⟩ := hab + obtain ⟨e, rfl⟩ := hbc + exact ⟨d + e, (add_assoc _ _ _).symm⟩ + +theorem algebraicLE_add_right (a b : NatOrdinal.{u}) : AlgebraicLE a (a + b) := ⟨b, rfl⟩ + +theorem algebraicLE_add_left (a b : NatOrdinal.{u}) : AlgebraicLE b (a + b) := ⟨a, add_comm b a⟩ + +theorem AlgebraicLE.add {a b a' b' : NatOrdinal.{u}} (h : AlgebraicLE a b) + (h' : AlgebraicLE a' b') : + AlgebraicLE (a + a') (b + b') := by + obtain ⟨c, rfl⟩ := h + obtain ⟨c', rfl⟩ := h' + exact ⟨c + c', (add_add_add_comm _ _ _ _).symm⟩ + +theorem AlgebraicLE.add_right_cancel {a b c : NatOrdinal.{u}} (h : AlgebraicLE (a + c) (b + c)) : + AlgebraicLE a b := by + obtain ⟨d, hd⟩ := h + exact ⟨d, by rw [add_right_comm] at hd; exact _root_.add_right_cancel hd⟩ + +/-- The algebraic order for Hessenberg addition is preserved by taking parts at or above `β`. -/ +theorem AlgebraicLE.partGE {a b : NatOrdinal.{u}} (h : AlgebraicLE a b) (β : NatOrdinal.{u}) : + AlgebraicLE (partGE β a) (partGE β b) := by + obtain ⟨c, rfl⟩ := h + rw [partGE_add] + exact algebraicLE_add_right _ _ + +/-- The algebraic order for Hessenberg addition is preserved by taking parts below `β`. -/ +theorem AlgebraicLE.partLT {a b : NatOrdinal.{u}} (h : AlgebraicLE a b) (β : NatOrdinal.{u}) : + AlgebraicLE (partLT β a) (partLT β b) := by + obtain ⟨c, rfl⟩ := h + rw [partLT_add] + exact algebraicLE_add_right _ _ + +/-- Algebraic-order comparisons above and below `β` combine into one comparison. -/ +theorem algebraicLE_of_partGE_of_partLT {a b β : NatOrdinal.{u}} + (hGE : AlgebraicLE (partGE β a) (partGE β b)) + (hLT : AlgebraicLE (partLT β a) (partLT β b)) : AlgebraicLE a b := by + have := hGE.add hLT + rwa [partGE_add_partLT, partGE_add_partLT] at this + +/-- The part `a_{≥β}` precedes `a` in the algebraic order for Hessenberg addition. -/ +theorem algebraicLE_partGE (β a : NatOrdinal.{u}) : AlgebraicLE (partGE β a) a := + ⟨partLT β a, partGE_add_partLT β a⟩ + +/-- The part `a_{<β}` precedes `a` in the algebraic order for Hessenberg addition. -/ +theorem algebraicLE_partLT (β a : NatOrdinal.{u}) : AlgebraicLE (partLT β a) a := + ⟨partGE β a, by rw [add_comm]; exact partGE_add_partLT β a⟩ + +/-! ### Ordinals below `c` and the last term of `c` -/ + +/-- If every term of the Cantor normal form of `c` is at least `ω^ε` and `θ < c`, then +`θ_{≥ε} ⊕ ω^ε ≤ c`. -/ +theorem partGE_add_wpow_le_of_lt {c ε θ : NatOrdinal.{u}} + (hc : ∀ t ∈ c.val.additivePrincipalTerms, (ω^ ε).val ≤ t) (hθ : θ < c) : + partGE ε θ + ω^ ε ≤ c := by + have hcGE : partGE ε c = c := partGE_eq_self_of_forall_le hc + have hlt : partGE ε θ < partGE ε c := by + rw [hcGE] + refine lt_of_le_of_ne ((partGE_mono hθ.le).trans hcGE.le) fun heq ↦ ?_ + exact absurd ((partGE_le ε θ).trans' heq.ge) (not_le.mpr hθ) + have h := add_le_of_dvd_of_lt (exists_val_partGE_eq_mul ε θ) + (exists_val_partGE_eq_mul ε c) (NatOrdinal.val.lt_iff_lt.mpr hlt) + rw [hcGE] at h + rw [partGE_add_wpow, ← NatOrdinal.of_val c, NatOrdinal.of.le_iff_le] + exact h + +/-- If `c ≠ 0` has last term `ω^ε` in its Cantor normal form and the sum of the terms in the +Cantor normal form of `b ⊕ c` at exponents at least `ε` is at most `τ`, then +`b ⊕ θ < τ` for every `θ < c`. -/ +@[blueprint "lem:separation" + (phase := "Algebraic and ordinal preliminaries") + (title := "Separation below the last Cantor term") + (statement := /-- + Let $\sigma\neq0$, let $\omega^\beta$ be its last Cantor term, and write + $\rho\oplus\sigma=h$. If the sum of the terms in the Cantor normal form + of $h$ at exponents at least $\beta$ is at most $\tau$, then + $\rho\oplus\theta<\tau$ for every $\theta<\sigma$. + -/) + (proof := /-- + Split each Cantor normal form at exponent $\beta$. For $\theta<\sigma$, + the terms of $\theta$ at exponents at least $\beta$, followed by one + further $\omega^\beta$, are bounded by $\sigma$. Hence + $\rho\oplus\theta$ is strictly below the assumed bound for the terms of + $\rho\oplus\sigma$ at those exponents, and therefore below $\tau$. + -/)] +theorem add_lt_of_lt_of_partGE_le {b c h τ ε : NatOrdinal.{u}} (hc0 : c ≠ 0) + (hε : leastTerm c = ω^ ε) (hbc : b + c = h) (hτ : partGE ε h ≤ τ) {θ : NatOrdinal.{u}} + (hθ : θ < c) : b + θ < τ := by + have hcterms : ∀ t ∈ c.val.additivePrincipalTerms, (ω^ ε).val ≤ t := + fun _ ht ↦ wpow_le_of_mem_additivePrincipalTerms_of_leastTerm_eq hc0 hε ht + have hθc := partGE_add_wpow_le_of_lt hcterms hθ + -- the part of `b ⊕ θ` at or above `ε`, plus `ω^ε`, is at most `h_{≥ε}` + have hhigh : partGE ε (b + θ) + ω^ ε ≤ partGE ε h := by + rw [partGE_add, add_assoc, ← hbc, partGE_add, + partGE_eq_self_of_forall_le hcterms] + exact add_le_add_right hθc _ + -- hence `b ⊕ θ < (b ⊕ θ)_{≥ε} + ω^ε ≤ h_{≥ε} ≤ τ` + calc b + θ = partGE ε (b + θ) + partLT ε (b + θ) := (partGE_add_partLT _ _).symm + _ < partGE ε (b + θ) + ω^ ε := add_lt_add_right (partLT_lt ε _) _ + _ ≤ partGE ε h := hhigh + _ ≤ τ := hτ + +/-- For `ε ≤ β`, the part at or above `ε` of the part at or above `β` is the part at or above `β` +itself. -/ +theorem partGE_partGE_of_ge {β ε : NatOrdinal} (h : ε ≤ β) (a : NatOrdinal) : + partGE ε (partGE β a) = partGE β a := + partGE_eq_self_of_forall_le fun _ hs ↦ + (NatOrdinal.val.le_iff_le.mpr (wpow_le_wpow.mpr h)).trans + (wpow_le_of_mem_additivePrincipalTerms_partGE hs) + +/-- The last term of the Cantor normal form of a natural ordinal is at most the ordinal. -/ +theorem leastTerm_le {a : NatOrdinal} (ha : a ≠ 0) : leastTerm a ≤ a := + of_le_of_mem_additivePrincipalTerms (val_leastTerm_mem ha) + +/-- The last term of the Cantor normal form of the part at or above `β` is at least `ω^β`. -/ +theorem wpow_le_leastTerm_partGE {β a : NatOrdinal} (ha : partGE β a ≠ 0) : + ω^ β ≤ leastTerm (partGE β a) := + NatOrdinal.val.le_iff_le.mp + (wpow_le_of_mem_additivePrincipalTerms_partGE (val_leastTerm_mem ha)) + +/-- When the part below `β` is nonzero, the last term of the Cantor normal form is the last term +of that part. -/ +theorem leastTerm_eq_leastTerm_partLT {β a : NatOrdinal} (h : partLT β a ≠ 0) : + leastTerm a = leastTerm (partLT β a) := by + conv_lhs => rw [← partGE_add_partLT β a] + rcases eq_or_ne (partGE β a) 0 with h0 | h0 + · rw [h0, zero_add] + · rw [leastTerm_add h0 h, min_eq_right] + exact ((leastTerm_le h).trans (partLT_lt β a).le).trans (wpow_le_leastTerm_partGE h0) + +/-- For `β ≤ ε`, the part at or above `ε` of the part at or above `β` is the part at or above +`ε`. -/ +theorem partGE_partGE_of_le {β ε : NatOrdinal} (h : β ≤ ε) (a : NatOrdinal) : + partGE ε (partGE β a) = partGE ε a := by + conv_rhs => rw [← partGE_add_partLT β a] + rw [partGE_add, + partGE_eq_zero_of_lt ((partLT_lt β a).trans_le (wpow_le_wpow.mpr h)), add_zero] + +theorem partGE_le_partGE_of_le {β ε : NatOrdinal} (h : β ≤ ε) (a : NatOrdinal) : + partGE ε a ≤ partGE β a := by + rw [← partGE_partGE_of_le h a] + exact partGE_le _ _ + +/-! ### Windows for the separation condition + +The bound `h_{≥ε} ≤ h_{≥β} ⊕ λ'` that `add_lt_of_lt_of_partGE_le` consumes splits into two cases +according to where the exponent `ε` of the last Cantor term sits relative to the cutoff `β`. Above +the cutoff the bound is monotonicity alone; below it the parts of `h` on either side of the cutoff +have to be compared with `λ'`, which the hypothesis relating them supplies. +-/ + +/-- **The window above the cutoff.** If the last Cantor term of a nonzero `c` has exponent at +least the cutoff -- which happens exactly when `c` has no part below the cutoff -- then the part of +any `h` at or above that exponent is bounded by its part at or above the cutoff. -/ +theorem partGE_le_partGE_add_of_partLT_eq_zero {β ε c : NatOrdinal.{u}} (hc0 : c ≠ 0) + (hcLT : partLT β c = 0) (hε : leastTerm c = ω^ ε) (h lam : NatOrdinal.{u}) : + partGE ε h ≤ partGE β h + lam := by + have hcGE : partGE β c = c := by + have := partGE_add_partLT β c + rwa [hcLT, add_zero] at this + have hβε : β ≤ ε := by + have h1 := wpow_le_leastTerm_partGE (β := β) (a := c) (by rw [hcGE]; exact hc0) + rw [hcGE, hε, wpow_le_wpow] at h1 + exact h1 + exact (partGE_le_partGE_of_le hβε h).trans (le_add_of_nonneg_right zero_le) + +/-- **The window below the cutoff.** If the exponent is at most the cutoff and the part of `λ'` at +or above it agrees with that of the part of `h` below the cutoff, then the part of `h` at or above +the exponent is again bounded by its part at or above the cutoff, together with `λ'`. + +Splitting `h` at the cutoff, the piece above it is unmoved by the coarser cut and the piece below +it is what `λ'` accounts for. -/ +theorem partGE_le_partGE_add_of_le_of_partGE_eq {β ε h lam : NatOrdinal.{u}} (hεβ : ε ≤ β) + (hlamε : partGE ε lam = partGE ε (partLT β h)) : + partGE ε h ≤ partGE β h + lam := + calc partGE ε h + = partGE ε (partGE β h) + partGE ε (partLT β h) := by + conv_lhs => rw [← partGE_add_partLT β h] + rw [partGE_add] + _ = partGE β h + partGE ε lam := by rw [partGE_partGE_of_ge hεβ, hlamε] + _ ≤ partGE β h + lam := add_le_add_right (partGE_le _ _) _ + +/-- The exponent of the last Cantor term of a nonzero part below the cutoff is at most the cutoff: +that part is itself below `ω^β`. -/ +theorem le_of_leastTerm_partLT_eq_wpow {β ε c : NatOrdinal.{u}} + (hne : partLT β c ≠ 0) (hε : leastTerm (partLT β c) = ω^ ε) : ε ≤ β := by + have h1 := leastTerm_le hne + rw [hε] at h1 + exact (wpow_lt_wpow.mp (h1.trans_lt (partLT_lt _ _))).le + +/-- **The cofactor-degree function from separation data.** Given finitely many generator degrees +with a common separation condition against a floor, there is a cofactor-degree function assigning +to each stage of the correction the degree its cofactors must have, agreeing with the prescribed +degree at the top stage. This is exactly the data the well-founded correction consumes: the +grading identity at every stage above the floor, and the separation inequality at the top. + +The separation lemma supplies, for each stage above the floor, a cofactor degree below the +prescribed one whose shift by the generator degree is that stage. -/ +theorem exists_cofactorDegree_of_separation {κ' : Type w} + (σQ ρQ : κ' → NatOrdinal.{u}) (τ μ : NatOrdinal.{u}) + (hσ : ∀ j, σQ j ≠ 0) + (hgrade : ∀ j, ρQ j + σQ j = μ) + (hsep : ∀ j, ∀ θ, θ < σQ j → ρQ j + θ < τ) : + ∃ P : κ' → NatOrdinal.{u} → NatOrdinal.{u}, + (∀ j β, τ < β → β ≤ μ → P j β + σQ j = β) ∧ + (∀ j θ, θ < σQ j → P j μ + θ < τ) := by + classical + have hchoice : ∀ j : κ', ∀ β : NatOrdinal.{u}, ∃ r : NatOrdinal.{u}, + (τ < β → β ≤ μ → r ≤ ρQ j ∧ r + σQ j = β) ∧ (β = μ → r = ρQ j) := by + intro j β + by_cases hβ : τ < β ∧ β ≤ μ + · obtain ⟨r, hrle, hreq⟩ := + exists_le_add_eq_of_forall_add_lt (hσ j) (hsep j) hβ.1 + (by rw [hgrade j]; exact hβ.2) + refine ⟨r, fun _ _ ↦ ⟨hrle, hreq⟩, fun hβμ ↦ ?_⟩ + -- At the top stage the shift determines the cofactor degree by cancellation. + have : r + σQ j = ρQ j + σQ j := by rw [hreq, hβμ, hgrade j] + exact add_right_cancel this + · refine ⟨ρQ j, fun h1 h2 ↦ absurd ⟨h1, h2⟩ hβ, fun hβμ ↦ rfl⟩ + choose P hP using hchoice + refine ⟨P, fun j β h1 h2 ↦ ((hP j β).1 h1 h2).2, fun j θ hθ ↦ ?_⟩ + rw [(hP j μ).2 rfl] + exact hsep j θ hθ + +/-- **Separation from a window.** A window bound at the exponent of the last Cantor term of the +generator degree gives the separation inequality directly. -/ +theorem separation_of_forall_partGE_le {b c h τ : NatOrdinal.{u}} (hc0 : c ≠ 0) + (hbc : b + c = h) (hwin : ∀ ε, leastTerm c = ω^ ε → partGE ε h ≤ τ) : + ∀ θ, θ < c → b + θ < τ := by + obtain ⟨ε, hε⟩ := exists_leastTerm_eq_wpow hc0 + exact fun θ hθ ↦ add_lt_of_lt_of_partGE_le hc0 hε hbc (hwin ε hε) hθ + +/-- **The cofactor-degree function from windows.** Combining the two steps: window bounds at the +generator degrees give the separation condition, which gives the cofactor-degree function the +correction consumes. -/ +theorem exists_cofactorDegree_of_forall_partGE_le {κ' : Type w} + (σQ ρQ : κ' → NatOrdinal.{u}) (τ μ : NatOrdinal.{u}) + (hσ : ∀ j, σQ j ≠ 0) + (hgrade : ∀ j, ρQ j + σQ j = μ) + (hwin : ∀ j, ∀ ε, leastTerm (σQ j) = ω^ ε → partGE ε μ ≤ τ) : + ∃ P : κ' → NatOrdinal.{u} → NatOrdinal.{u}, + (∀ j β, τ < β → β ≤ μ → P j β + σQ j = β) ∧ + (∀ j θ, θ < σQ j → P j μ + θ < τ) := + exists_cofactorDegree_of_separation σQ ρQ τ μ hσ hgrade + fun j ↦ separation_of_forall_partGE_le (hσ j) (hgrade j) (hwin j) + +/-! ### The windows at the two kinds of generator + +A generator degree `c` complementary to a variable weight `w`, in the sense `c ⊕ w = α`, meets its +window in one of two ways. If the variable carries all of `α`'s part below the cutoff, then `c` has +none, and the window above the cutoff applies. Otherwise the window below the cutoff applies, and +what it needs is that the bound `λ'` agrees with the part of `h` below the cutoff at or above the +exponent -- which follows from the corresponding agreement one level up. +-/ + +/-- A complementary degree has no part below the cutoff when its variable carries all of it. -/ +theorem partLT_eq_zero_of_partLT_eq {β α c w : NatOrdinal.{u}} (hc : c + w = α) + (hV2 : partLT β w = partLT β α) : partLT β c = 0 := by + have h1 : partLT β c + partLT β w = partLT β α := by rw [← partLT_add, hc] + rw [hV2] at h1 + exact add_right_cancel (h1.trans (zero_add _).symm) + +/-- **The window at a generator whose variable carries the whole part below the cutoff.** -/ +theorem partGE_le_of_partLT_eq {β α c w h lam : NatOrdinal.{u}} (hc0 : c ≠ 0) (hc : c + w = α) + (hV2 : partLT β w = partLT β α) {ε : NatOrdinal.{u}} (hε : leastTerm c = ω^ ε) : + partGE ε h ≤ partGE β h + lam := + partGE_le_partGE_add_of_partLT_eq_zero hc0 (partLT_eq_zero_of_partLT_eq hc hV2) hε h lam + +/-- The bound agrees with the part of `h` below the cutoff, at or above an exponent, as soon as it +does one level up: both are complements of the same part below the cutoff. -/ +theorem partGE_eq_partGE_partLT_of_partGE_eq {β α h w lam lam₀ ε : NatOrdinal.{u}} + (hh : h + w = α) (hlam : partLT β w + lam = lam₀) + (hlam₀ : partGE ε lam₀ = partGE ε (partLT β α)) : + partGE ε lam = partGE ε (partLT β h) := by + have e1 : partGE ε (partLT β w) + partGE ε lam = partGE ε lam₀ := by + rw [← partGE_add, hlam] + have e2 : partGE ε (partLT β h) + partGE ε (partLT β w) = partGE ε (partLT β α) := by + rw [← partGE_add, ← partLT_add, hh] + rw [hlam₀, ← e2, add_comm (partGE ε (partLT β h))] at e1 + exact add_left_cancel e1 + +/-- **The window at a generator whose variable leaves part of the cutoff level behind.** -/ +theorem partGE_le_of_partGE_eq {β α h w lam lam₀ c ε : NatOrdinal.{u}} + (hne : partLT β c ≠ 0) (hε : leastTerm (partLT β c) = ω^ ε) + (hh : h + w = α) (hlam : partLT β w + lam = lam₀) + (hlam₀ : partGE ε lam₀ = partGE ε (partLT β α)) : + partGE ε h ≤ partGE β h + lam := + partGE_le_partGE_add_of_le_of_partGE_eq (le_of_leastTerm_partLT_eq_wpow hne hε) + (partGE_eq_partGE_partLT_of_partGE_eq hh hlam hlam₀) + +end NatOrdinal diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/CantorBendixson.lean b/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/CantorBendixson.lean new file mode 100644 index 0000000000..ee627ba173 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/CantorBendixson.lean @@ -0,0 +1,259 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Topology.CantorBendixsonRank +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.PairBounds +public import Mathlib.SetTheory.Ordinal.Exponential +public import Mathlib.SetTheory.Ordinal.Topology + +import Mathlib.Topology.Maps.Basic +import Mathlib.Topology.Order.IsNormal + +/-! +# Cantor–Bendixson derivatives of ordinals + +A normal function on the ordinals is a closed topological embedding. Consequently the +`a`-th derivative of the ordinal space consists, apart from stage zero, of the positive +multiples of `ω ^ a`. +-/ + +open Cardinal Filter Order Set Topology + +universe u + +public noncomputable section + +namespace Order.IsNormal + +/-- A normal ordinal function is a closed map. -/ +theorem isClosedMap {f : Ordinal.{u} → Ordinal.{u}} (hf : IsNormal f) : IsClosedMap f := by + intro s hs + rw [Ordinal.isClosed_iff_iSup] + intro ι hι g hg + choose x hx hfx using hg + have hxsup : ⨆ i, x i ∈ s := by + rw [Ordinal.mem_iff_iSup_of_isClosed hs] + exact ⟨ι, hι, x, hx, rfl⟩ + refine ⟨⨆ i, x i, hxsup, ?_⟩ + have hbounded : BddAbove (range x) := Ordinal.bddAbove_of_small + rw [hf.map_iSup hbounded] + exact iSup_congr hfx + +/-- A normal ordinal function is a closed topological embedding. -/ +theorem isClosedEmbedding {f : Ordinal.{u} → Ordinal.{u}} (hf : IsNormal f) : + IsClosedEmbedding f := by + rw [IsClosedEmbedding.isClosedEmbedding_iff_continuous_injective_isClosedMap] + exact ⟨hf.continuous, hf.strictMono.injective, hf.isClosedMap⟩ + +end Order.IsNormal + +namespace NatOrdinal + +private theorem wpow_dvd_val_iff_le_lastExponent {a : NatOrdinal.{u}} (ha : a ≠ 0) + {β e : NatOrdinal.{u}} (he : leastTerm a = ω^ e) : + (ω^ β).val ∣ a.val ↔ β ≤ e := by + rw [wpow_dvd_val_iff_partLT_eq_zero] + constructor + · intro hzero + by_contra hnot + exact partLT_ne_zero_of_leastTerm_lt ha he (lt_of_not_ge hnot) hzero + · intro hβe + apply partLT_eq_zero_of_forall_le + intro t ht + calc + (ω^ β).val ≤ (ω^ e).val := + (Ordinal.opow_le_opow_iff_right Ordinal.one_lt_omega0).mpr + (NatOrdinal.val.le_iff_le.mpr hβe) + _ = (leastTerm a).val := congrArg NatOrdinal.val he.symm + _ ≤ t := val_leastTerm_le_of_mem ha ht + +end NatOrdinal + +namespace Ordinal + +private theorem derivedSet_univ_eq : + derivedSet (Set.univ : Set Ordinal.{u}) = {x | IsSuccLimit x} := by + ext x + rw [mem_derivedSet, AccPt] + simp only [principal_univ, inf_top_eq, Set.mem_ofPred_eq] + rw [← not_iff_not, not_neBot, ← isOpen_singleton_iff_punctured_nhds] + exact SuccOrder.isOpen_singleton_iff + +private theorem derivedSet_Ioi_zero_eq : + derivedSet (Ioi (0 : Ordinal.{u})) = {x | IsSuccLimit x} := by + have huniv : (Set.univ : Set Ordinal.{u}) = {0} ∪ Ioi 0 := by + ext x + simp + have hsingle : derivedSet ({0} : Set Ordinal.{u}) = ∅ := by + ext x + simp only [mem_derivedSet, mem_empty_iff_false, iff_false] + exact fun h ↦ (finite_singleton (0 : Ordinal.{u})).not_infinite + (Set.Infinite.of_accPt h) + rw [← derivedSet_univ_eq, huniv, derivedSet_union, hsingle, empty_union] + +/-- The positive ordinal multiples `ω ^ a * q`, with `q > 0`. -/ +def positivePrincipalMultiples (a : Ordinal.{u}) : Set Ordinal.{u} := + (fun x ↦ omega0 ^ a * x) '' Ioi 0 + +/-- Membership in the positive multiples of `ω ^ a`. -/ +theorem mem_positivePrincipalMultiples {a x : Ordinal.{u}} : + x ∈ positivePrincipalMultiples a ↔ ∃ q > 0, omega0 ^ a * q = x := Iff.rfl + +private theorem positivePrincipalMultiples_isClosed (a : Ordinal.{u}) : + IsClosed (positivePrincipalMultiples a) := by + apply (isNormal_mul_right (opow_pos a omega0_pos)).isClosedMap + have hset : Ioi (0 : Ordinal.{u}) = Ici 1 := by + ext x + change 0 < x ↔ (1 : Ordinal.{u}) ≤ x + exact one_le_iff_pos.symm + rw [hset] + exact isClosed_Ici + +private theorem derivedSet_positivePrincipalMultiples (a : Ordinal.{u}) : + derivedSet (positivePrincipalMultiples a) = positivePrincipalMultiples (a + 1) := by + let f : Ordinal.{u} → Ordinal.{u} := fun x ↦ omega0 ^ a * x + have hf : IsNormal f := isNormal_mul_right (opow_pos a omega0_pos) + have himage : derivedSet (f '' Ioi 0) = f '' derivedSet (Ioi 0) := by + apply Set.Subset.antisymm + · exact hf.isClosedMap.derivedSet_image_subset _ + · exact hf.continuous.image_derivedSet hf.strictMono.injective + rw [positivePrincipalMultiples, himage, derivedSet_Ioi_zero_eq, + positivePrincipalMultiples] + ext x + constructor + · rintro ⟨y, hy, rfl⟩ + change IsSuccLimit y at hy + obtain ⟨z, rfl⟩ := isSuccPrelimit_iff_omega0_dvd.mp hy.isSuccPrelimit + refine ⟨z, ?_, ?_⟩ + · change 0 < z + exact pos_iff_ne_zero.mpr fun hz ↦ hy.ne_bot (by simp [hz]) + · symm + change omega0 ^ a * (omega0 * z) = omega0 ^ (a + 1) * z + rw [Ordinal.opow_add_one, mul_assoc] + · rintro ⟨z, hz, rfl⟩ + refine ⟨omega0 * z, ?_, ?_⟩ + · change IsSuccLimit (omega0 * z) + refine ⟨?_, + isSuccPrelimit_iff_omega0_dvd.mpr (dvd_mul_right _ _)⟩ + rw [isMin_iff_eq_bot, Ordinal.bot_eq_zero] + exact mul_ne_zero omega0_ne_zero hz.ne' + · change omega0 ^ a * (omega0 * z) = omega0 ^ (a + 1) * z + rw [Ordinal.opow_add_one, mul_assoc] + +private theorem iInter_positivePrincipalMultiples {a : Ordinal.{u}} (ha : IsSuccLimit a) : + (⋂ i : Iio a, positivePrincipalMultiples i.1) = positivePrincipalMultiples a := by + ext x + constructor + · intro hx + have hxi (i : Iio a) : x ∈ positivePrincipalMultiples i.1 := mem_iInter.mp hx i + have hx0 : x ≠ 0 := by + let i : Iio a := ⟨0, ha.bot_lt⟩ + obtain ⟨y, hy, hxy⟩ := hxi i + rw [← hxy] + exact mul_ne_zero (opow_ne_zero _ omega0_ne_zero) hy.ne' + let n : NatOrdinal.{u} := NatOrdinal.of x + have hn0 : n ≠ 0 := by + intro hn + apply hx0 + have := congrArg NatOrdinal.val hn + simpa [n] using this + obtain ⟨e, he⟩ := NatOrdinal.exists_leastTerm_eq_wpow + (a := n) hn0 + have hie : ∀ i < a, NatOrdinal.of i ≤ e := by + intro i hi + obtain ⟨y, hy, hxy⟩ := hxi ⟨i, hi⟩ + apply (NatOrdinal.wpow_dvd_val_iff_le_lastExponent + (a := n) hn0 he).mp + change omega0 ^ i ∣ x + exact ⟨y, hxy.symm⟩ + have hae : a ≤ e.val := by + by_contra hnot + have hea : e.val < a := lt_of_not_ge hnot + have hsucc : e.val + 1 < a := ha.succ_lt hea + have := NatOrdinal.val.le_iff_le.mpr (hie (e.val + 1) hsucc) + simpa using (not_le_of_gt (Order.lt_succ e.val)) this + obtain ⟨q, hq⟩ := (NatOrdinal.wpow_dvd_val_iff_le_lastExponent + (a := n) (β := NatOrdinal.of a) hn0 he).mpr + (NatOrdinal.val.le_iff_le.mp hae) + refine ⟨q, ?_, ?_⟩ + · change 0 < q + apply pos_iff_ne_zero.mpr + intro hq0 + apply hx0 + calc + x = (ω^ (NatOrdinal.of a)).val * q := by simpa only [n, NatOrdinal.val_of] using hq + _ = 0 := by rw [hq0, mul_zero] + · change omega0 ^ a * q = x + simpa only [n, NatOrdinal.val_wpow, NatOrdinal.val_of] using hq.symm + · intro hx + apply mem_iInter.mpr + intro i + obtain ⟨y, hy, hxy⟩ := hx + refine ⟨(omega0 ^ (a - i.1)) * y, ?_, ?_⟩ + · exact mul_pos (opow_pos _ omega0_pos) hy + · change omega0 ^ i.1 * (omega0 ^ (a - i.1) * y) = x + rw [← mul_assoc, ← opow_add, Ordinal.add_sub_cancel_of_le i.2.le] + exact hxy + +private theorem positivePrincipalMultiples_zero : + positivePrincipalMultiples (0 : Ordinal.{u}) = Ioi 0 := by + ext x + simp [positivePrincipalMultiples] + +/-- The `a`-th derivative of the ordinal space is the set of positive multiples of `ω ^ a`, +except that stage zero is the whole space. -/ +theorem cantorBendixson_top_eq (a : Ordinal.{u}) : + ((⊤ : TopologicalSpace.Closeds Ordinal.{u}).cantorBendixson a : Set Ordinal.{u}) = + if a = 0 then Set.univ else positivePrincipalMultiples a := by + induction a using Ordinal.limitRecOn with + | zero => simp + | add_one a ih => + rw [TopologicalSpace.Closeds.cantorBendixson_add_one] + rw [TopologicalSpace.Closeds.coe_derived] + rw [ih] + by_cases ha : a = 0 + · subst a + simp only [zero_add, ite_true, ite_eq_right one_ne_zero] + rw [derivedSet_univ_eq, ← derivedSet_Ioi_zero_eq, + ← positivePrincipalMultiples_zero, + derivedSet_positivePrincipalMultiples] + simp + · simp only [ite_eq_right ha] + rw [derivedSet_positivePrincipalMultiples] + simp [ha] + | limit a ha ih => + rw [TopologicalSpace.Closeds.cantorBendixson_limit _ _ ha] + simp only [TopologicalSpace.Closeds.coe_iInf] + ext x + simp only [mem_iInter] + simp only [ite_eq_right (show a ≠ 0 from ha.ne_bot)] + constructor + · intro hx + apply (Set.ext_iff.mp (iInter_positivePrincipalMultiples ha) x).mp + apply mem_iInter.mpr + intro i + by_cases hi : i.1 = 0 + · rw [hi, positivePrincipalMultiples_zero] + have h1a : (1 : Ordinal.{u}) < a := by + simpa using ha.succ_lt ha.bot_lt + have hstage := hx ⟨(1 : Ordinal.{u}), h1a⟩ + rw [ih (1 : Ordinal.{u}) h1a, ite_eq_right one_ne_zero] at hstage + obtain ⟨y, hy, hxy⟩ := hstage + change 0 < x + exact pos_iff_ne_zero.mpr fun hx0 ↦ by + rw [hx0] at hxy + exact (mul_ne_zero (opow_ne_zero _ omega0_ne_zero) hy.ne') hxy + · simpa only [ih i.1 i.2, ite_eq_right hi] using hx i + · intro hx i + rw [ih i.1 i.2] + by_cases hi : i.1 = 0 + · simp [hi] + · rw [ite_eq_right hi] + have hall := (Set.ext_iff.mp (iInter_positivePrincipalMultiples ha) x).mpr hx + exact mem_iInter.mp hall i + +end Ordinal diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/CantorTermCount.lean b/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/CantorTermCount.lean new file mode 100644 index 0000000000..938fc7c60c --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/CantorTermCount.lean @@ -0,0 +1,148 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.AdditivelyPrincipal + +import Mathlib.Data.List.Sort + +/-! +# Number of terms in an uncompressed Cantor normal form + +LM24, Proposition 5.6.1 bounds the number of infinite-support irreducible factors by the number +of terms in the Cantor normal form of the degree. Finite coefficients are counted with +multiplicity: for example, `ω + ω` has two terms. + +`NatOrdinal.cantorTermCount` is therefore the length of +`Ordinal.additivePrincipalTerms`. Its characteristic arithmetic theorem says that this count is +additive under Hessenberg sum, exactly as required when a series factorisation splits its degree. +-/ + +open scoped NatOrdinal + +public noncomputable section + +namespace NatOrdinal + +/-- The number of terms in the uncompressed Cantor normal form of a natural ordinal. -/ +def cantorTermCount (a : NatOrdinal) : ℕ := + a.val.additivePrincipalTerms.length + +/-- Evaluation of the Cantor term count on an ordinary ordinal. -/ +@[simp] +theorem cantorTermCount_of (o : Ordinal) : + cantorTermCount (NatOrdinal.of o) = o.additivePrincipalTerms.length := by + rw [cantorTermCount, NatOrdinal.val_of] + +@[simp] +theorem cantorTermCount_zero : cantorTermCount 0 = 0 := by + simp [cantorTermCount] + +/-- A nonzero natural ordinal has at least one Cantor term. -/ +theorem cantorTermCount_pos {a : NatOrdinal} (ha : a ≠ 0) : + 0 < cantorTermCount a := by + rw [cantorTermCount, List.length_pos_iff_ne_nil] + intro hnil + have hsum := Ordinal.additivePrincipalTerms_sum a.val + rw [hnil] at hsum + apply ha + apply NatOrdinal.val.injective + simpa using hsum.symm + +/-- A natural ordinal has no Cantor terms exactly when it is zero. -/ +@[simp] +theorem cantorTermCount_eq_zero {a : NatOrdinal} : + cantorTermCount a = 0 ↔ a = 0 := by + constructor + · intro hcount + by_contra ha + exact (Nat.ne_of_gt (cantorTermCount_pos ha)) hcount + · rintro rfl + exact cantorTermCount_zero + +private def mergedTerms (a b : NatOrdinal) : List Ordinal := + (a.val.additivePrincipalTerms ++ b.val.additivePrincipalTerms).insertionSort (· ≥ ·) + +private theorem mergedTerms_sorted (a b : NatOrdinal) : + (mergedTerms a b).SortedGE := by + exact List.sortedGE_insertionSort + +private theorem mergedTerms_perm (a b : NatOrdinal) : + List.Perm (mergedTerms a b) + (a.val.additivePrincipalTerms ++ b.val.additivePrincipalTerms) := by + exact List.perm_insertionSort _ _ + +private theorem mergedTerms_principal (a b : NatOrdinal) : + ∀ o ∈ mergedTerms a b, Ordinal.IsAdditivelyPrincipal o := by + intro o ho + have ho' := (mergedTerms_perm a b).mem_iff.mp ho + rw [List.mem_append] at ho' + exact ho'.elim Ordinal.isAdditivelyPrincipal_of_mem_additivePrincipalTerms + Ordinal.isAdditivelyPrincipal_of_mem_additivePrincipalTerms + +private theorem mergedTerms_naturalSum (a b : NatOrdinal) : + ((mergedTerms a b).map NatOrdinal.of).sum = a + b := by + calc + ((mergedTerms a b).map NatOrdinal.of).sum = + ((a.val.additivePrincipalTerms ++ + b.val.additivePrincipalTerms).map NatOrdinal.of).sum := + ((mergedTerms_perm a b).map NatOrdinal.of).sum_eq + _ = (a.val.additivePrincipalTerms.map NatOrdinal.of).sum + + (b.val.additivePrincipalTerms.map NatOrdinal.of).sum := by + rw [List.map_append, List.sum_append] + _ = NatOrdinal.of a.val + NatOrdinal.of b.val := by + rw [← Ordinal.natOrdinal_of_sum_eq_sum_map_of_sorted + (fun _ h ↦ Ordinal.isAdditivelyPrincipal_of_mem_additivePrincipalTerms h) + (Ordinal.additivePrincipalTerms_sortedGE a.val), + ← Ordinal.natOrdinal_of_sum_eq_sum_map_of_sorted + (fun _ h ↦ Ordinal.isAdditivelyPrincipal_of_mem_additivePrincipalTerms h) + (Ordinal.additivePrincipalTerms_sortedGE b.val), + Ordinal.additivePrincipalTerms_sum, + Ordinal.additivePrincipalTerms_sum] + _ = a + b := by simp + +private theorem mergedTerms_eq_additivePrincipalTerms (a b : NatOrdinal) : + mergedTerms a b = (a + b).val.additivePrincipalTerms := by + apply Ordinal.additivePrincipalTerms_unique + · apply NatOrdinal.of.injective + calc + NatOrdinal.of (mergedTerms a b).sum = + ((mergedTerms a b).map NatOrdinal.of).sum := + Ordinal.natOrdinal_of_sum_eq_sum_map_of_sorted + (mergedTerms_principal a b) (mergedTerms_sorted a b) + _ = a + b := mergedTerms_naturalSum a b + _ = NatOrdinal.of (a + b).val := by simp + · exact mergedTerms_principal a b + · exact mergedTerms_sorted a b + +theorem additivePrincipalTerms_add_perm (a b : NatOrdinal) : + List.Perm (a + b).val.additivePrincipalTerms + (a.val.additivePrincipalTerms ++ b.val.additivePrincipalTerms) := by + rw [← mergedTerms_eq_additivePrincipalTerms] + exact mergedTerms_perm a b + +/-- The number of uncompressed Cantor terms is additive under Hessenberg sum. -/ +@[simp] +theorem cantorTermCount_add (a b : NatOrdinal) : + cantorTermCount (a + b) = cantorTermCount a + cantorTermCount b := by + rw [cantorTermCount, cantorTermCount, cantorTermCount, + ← mergedTerms_eq_additivePrincipalTerms] + calc + (mergedTerms a b).length = + (a.val.additivePrincipalTerms ++ + b.val.additivePrincipalTerms).length := + (mergedTerms_perm a b).length_eq + _ = a.val.additivePrincipalTerms.length + + b.val.additivePrincipalTerms.length := List.length_append + +-- Not a simp lemma: `simp` normalizes `r • a` to `↑r * a`. +theorem cantorTermCount_nsmul (r : ℕ) (a : NatOrdinal) : + cantorTermCount (r • a) = r * cantorTermCount a := by + induction r with + | zero => simp + | succ r ih => rw [succ_nsmul, cantorTermCount_add, ih, Nat.succ_mul] + +end NatOrdinal diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/Degree.lean b/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/Degree.lean new file mode 100644 index 0000000000..5b389d4f66 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/Degree.lean @@ -0,0 +1,335 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.CombinatorialGames.NatOrdinal.Pow +public import Mathlib.SetTheory.Ordinal.Exponential + +import Mathlib.Algebra.Order.SuccPred +import Mathlib.SetTheory.Ordinal.Principal + +/-! +# Leading Cantor exponent of an ordinal + +For a nonzero ordinal `o`, LM24 defines its degree to be the largest ordinal `a` such that +`Ordinal.omega0 ^ a ≤ o`; equivalently, it is the leading exponent in the Cantor normal form of +`o`. The value at zero is `⊥`, representing LM24's `-∞` convention. We call the resulting +function `Ordinal.cantorDegree` to distinguish this invariant from unrelated notions of degree. + +The codomain is `WithBot NatOrdinal`: the order comes from ordinals, while addition and +multiplication on non-bottom values are Hessenberg's natural operations. This is the convention of +LM24, Sections 1.5 and 2.2. + +The transported function `NatOrdinal.cantorDegree` lets the same invariant interact directly with +the dependency's Hessenberg addition and multiplication. Its arithmetic theorems formalize LM24, +Fact 2.2.2. +-/ + +universe u v + +public noncomputable section + +namespace Ordinal + +/-- The leading exponent in the Cantor normal form of a nonzero ordinal, and `⊥` at zero. -/ +def cantorDegree (o : Ordinal.{u}) : WithBot NatOrdinal.{u} := + if o = 0 then ⊥ else (NatOrdinal.of (log ω o) : WithBot NatOrdinal) + +@[simp] +theorem cantorDegree_zero : cantorDegree (0 : Ordinal.{u}) = ⊥ := by + simp [cantorDegree] + +/-- Away from zero, `cantorDegree` is the ordinal logarithm in base `ω`. -/ +theorem cantorDegree_of_ne_zero {o : Ordinal.{u}} (ho : o ≠ 0) : + cantorDegree o = NatOrdinal.of (log ω o) := by + simp [cantorDegree, ho] + +@[simp] +theorem cantorDegree_eq_bot {o : Ordinal.{u}} : cantorDegree o = ⊥ ↔ o = 0 := by + by_cases ho : o = 0 + · simp [ho] + · simp [cantorDegree, ho] + +/-- This is LM24's maximum characterization of the leading Cantor exponent. -/ +theorem coe_le_cantorDegree_iff {o a : Ordinal.{u}} (ho : o ≠ 0) : + (NatOrdinal.of a : WithBot NatOrdinal) ≤ cantorDegree o ↔ ω ^ a ≤ o := by + rw [cantorDegree_of_ne_zero ho, WithBot.coe_le_coe, NatOrdinal.of_le_iff] + exact (opow_le_iff_le_log one_lt_omega0 ho).symm + +theorem cantorDegree_mono : Monotone (cantorDegree : Ordinal.{u} → WithBot NatOrdinal) := by + intro a b hab + by_cases ha : a = 0 + · simp [ha] + have hb : b ≠ 0 := by + intro hb + subst b + exact ha (bot_unique hab) + rw [cantorDegree_of_ne_zero ha, cantorDegree_of_ne_zero hb, WithBot.coe_le_coe, + NatOrdinal.of_le_iff] + exact log_mono_right ω hab + +/-- An ordinal has degree zero exactly when it is nonzero and finite. -/ +@[simp] +theorem cantorDegree_eq_zero {o : Ordinal.{u}} : + cantorDegree o = (0 : WithBot NatOrdinal) ↔ o ≠ 0 ∧ o < ω := by + by_cases ho : o = 0 + · simp [ho] + rw [cantorDegree_of_ne_zero ho] + have hzero : (0 : WithBot NatOrdinal) = ((0 : NatOrdinal) : WithBot NatOrdinal) := rfl + rw [hzero, WithBot.coe_eq_coe, NatOrdinal.of_eq_zero] + constructor + · intro hlog + refine ⟨ho, ?_⟩ + have hlt : o < ω ^ Order.succ (0 : Ordinal) := by + simpa only [hlog] using lt_opow_succ_log_self one_lt_omega0 o + simpa using hlt + · exact fun h ↦ log_eq_zero h.2 + +@[simp] +theorem cantorDegree_one : cantorDegree (1 : Ordinal.{u}) = 0 := by + rw [cantorDegree_of_ne_zero one_ne_zero, log_one_right] + rfl + +@[simp] +theorem cantorDegree_omega : cantorDegree (ω : Ordinal.{u}) = 1 := by + have hlog : log ω ω = (1 : Ordinal) := by + simpa only [opow_one] using log_opow one_lt_omega0 (1 : Ordinal) + rw [cantorDegree_of_ne_zero omega0_ne_zero, hlog] + rfl + +/-- The ordinary ordinal sum `ω + ω` has degree one, not degree two. -/ +theorem cantorDegree_omega_add_omega : + cantorDegree ((ω : Ordinal.{u}) + ω) = 1 := by + have htwo : (2 : Ordinal.{u}) ≠ 0 := by + exact OfNat.ofNat_ne_zero 2 + have hlogTwo : log ω (2 : Ordinal.{u}) = 0 := + log_eq_zero (natCast_lt_omega0 2) + have hlog : log ω (ω + ω) = (1 : Ordinal) := by + simpa only [opow_one, Ordinal.mul_two, hlogTwo, add_zero] using + log_opow_mul one_lt_omega0 1 htwo + have hne : (ω : Ordinal.{u}) + ω ≠ 0 := fun h ↦ + omega0_ne_zero (eq_zero_of_add_right h) + rw [cantorDegree_of_ne_zero hne, hlog] + rfl + +/-- The ordinal `ω²` has degree two. -/ +theorem cantorDegree_omega_sq : + cantorDegree ((ω : Ordinal.{u}) ^ (2 : Ordinal)) = 2 := by + rw [cantorDegree_of_ne_zero (opow_ne_zero 2 omega0_ne_zero), + log_opow one_lt_omega0] + rfl + +/-! ### Finite powers of `ω` and `ω ^ ω` across universes -/ + +/-- Universe lifting commutes with finite powers of `ω`. -/ +theorem lift_omega0_opow_natCast (n : ℕ) : + lift.{u, v} ((ω : Ordinal.{v}) ^ (n : Ordinal)) = (ω : Ordinal.{max u v}) ^ (n : Ordinal) := by + rw [opow_natCast, opow_natCast] + induction n with + | zero => simp + | succ n ih => simp [pow_succ, lift_mul, ih] + +/-- Universe lifting fixes `ω ^ ω`. -/ +theorem lift_omega0_opow_omega0 : + lift.{u, v} ((ω : Ordinal.{v}) ^ (ω : Ordinal.{v})) = + (ω : Ordinal.{max u v}) ^ (ω : Ordinal.{max u v}) := by + apply le_antisymm + · apply le_of_forall_lt + intro c hc + obtain ⟨d, hd, rfl⟩ := lt_lift_iff.mp hc + obtain ⟨m, hm, hdm⟩ := (lt_opow_of_isSuccLimit omega0_ne_zero isSuccLimit_omega0).mp hd + obtain ⟨n, rfl⟩ := lt_omega0.mp hm + calc + lift.{u, v} d < lift.{u, v} ((ω : Ordinal.{v}) ^ (n : Ordinal)) := lift_lt.mpr hdm + _ = (ω : Ordinal.{max u v}) ^ (n : Ordinal) := lift_omega0_opow_natCast n + _ < ω ^ ω := (opow_lt_opow_iff_right one_lt_omega0).mpr (natCast_lt_omega0 n) + · apply le_of_forall_lt + intro c hc + obtain ⟨m, hm, hcm⟩ := (lt_opow_of_isSuccLimit omega0_ne_zero isSuccLimit_omega0).mp hc + obtain ⟨n, rfl⟩ := lt_omega0.mp hm + calc + c < (ω : Ordinal.{max u v}) ^ (n : Ordinal) := hcm + _ = lift.{u, v} ((ω : Ordinal.{v}) ^ (n : Ordinal)) := (lift_omega0_opow_natCast n).symm + _ ≤ lift.{u, v} ((ω : Ordinal.{v}) ^ (ω : Ordinal.{v})) := + lift_le.mpr ((opow_lt_opow_iff_right one_lt_omega0).mpr (natCast_lt_omega0 n)).le + +/-- Finite powers of `ω` lie below `ω ^ ω`. -/ +theorem omega0_opow_natCast_lt_omega0_opow_omega0 (n : ℕ) : + (ω : Ordinal.{u}) ^ (n : Ordinal) < ω ^ ω := + (opow_lt_opow_iff_right one_lt_omega0).mpr (natCast_lt_omega0 n) + +/-- One more than a finite power of `ω` still lies below `ω ^ ω`; this is the support order type +of a series with `ω ^ n` terms followed by one constant term. -/ +theorem omega0_opow_natCast_add_one_lt_omega0_opow_omega0 (n : ℕ) : + (ω : Ordinal.{u}) ^ (n : Ordinal) + 1 < ω ^ ω := + isPrincipal_add_omega0_opow ω (omega0_opow_natCast_lt_omega0_opow_omega0 n) + (one_lt_opow.mpr ⟨one_lt_omega0, omega0_ne_zero⟩) + +end Ordinal + +namespace NatOrdinal + +/-- The leading Cantor exponent of a natural ordinal, with value `⊥` at zero. -/ +def cantorDegree (a : NatOrdinal.{u}) : WithBot NatOrdinal.{u} := + Ordinal.cantorDegree a.val + +/-- `NatOrdinal.cantorDegree` is `Ordinal.cantorDegree` transported along `NatOrdinal.val`. -/ +theorem cantorDegree_eq_ordinalCantorDegree (a : NatOrdinal.{u}) : + cantorDegree a = Ordinal.cantorDegree a.val := + (rfl) + +/-- Transporting an ordinal into `NatOrdinal` does not change its leading Cantor exponent. -/ +@[simp] +theorem cantorDegree_of (a : Ordinal.{u}) : + cantorDegree (of a) = Ordinal.cantorDegree a := + (rfl) + +@[simp] +theorem cantorDegree_zero : cantorDegree (0 : NatOrdinal.{u}) = ⊥ := by + rw [cantorDegree_eq_ordinalCantorDegree, val_zero, Ordinal.cantorDegree_zero] + +@[simp] +theorem cantorDegree_eq_bot {a : NatOrdinal.{u}} : cantorDegree a = ⊥ ↔ a = 0 := by + rw [cantorDegree_eq_ordinalCantorDegree, Ordinal.cantorDegree_eq_bot] + exact val_eq_zero + +/-- Away from zero, `NatOrdinal.cantorDegree` is the ordinal logarithm in base `ω`. -/ +theorem cantorDegree_of_ne_zero {a : NatOrdinal.{u}} (ha : a ≠ 0) : + cantorDegree a = (of (Ordinal.log Ordinal.omega0 a.val) : WithBot NatOrdinal) := by + rw [cantorDegree_eq_ordinalCantorDegree, Ordinal.cantorDegree_of_ne_zero] + exact val_ne_zero.mpr ha + +/-- The leading Cantor exponent of `ω` raised to a natural ordinal is that ordinal. -/ +@[simp] +theorem cantorDegree_wpow (a : NatOrdinal.{u}) : + cantorDegree (ω^ a) = (a : WithBot NatOrdinal) := by + rw [cantorDegree_of_ne_zero (wpow_ne_zero a), WithBot.coe_eq_coe, + val_wpow, Ordinal.log_opow Ordinal.one_lt_omega0] + exact of_val a + +/-- An ordinal's leading Cantor exponent is at most `d` exactly when the ordinal lies below the +next power of `ω`. The statement includes the zero ordinal through the bottom convention. -/ +theorem cantorDegree_le_coe_iff (a d : NatOrdinal.{u}) : + cantorDegree a ≤ (d : WithBot NatOrdinal) ↔ a < ω^ (d + 1) := by + by_cases ha : a = 0 + · simp [ha, wpow_pos] + rw [cantorDegree_of_ne_zero ha, WithBot.coe_le_coe, of_le_iff, + ← val.lt_iff_lt] + simp only [val_wpow, val_add_one] + rw [Ordinal.lt_opow_iff_log_lt Ordinal.one_lt_omega0 + (val_ne_zero.mpr ha), ← Order.succ_eq_add_one, Order.lt_succ_iff] + +/-- An ordinal's leading Cantor exponent is strictly below `d` exactly when the ordinal lies +below `ω^d`. The statement includes the zero ordinal through the bottom convention. -/ +theorem cantorDegree_lt_coe_iff (a d : NatOrdinal.{u}) : + cantorDegree a < (d : WithBot NatOrdinal) ↔ a < ω^ d := by + by_cases ha : a = 0 + · simp [ha, wpow_pos] + rw [cantorDegree_of_ne_zero ha, WithBot.coe_lt_coe, of_lt_iff, + ← val.lt_iff_lt] + simp only [val_wpow] + exact (Ordinal.lt_opow_iff_log_lt Ordinal.one_lt_omega0 + (val_ne_zero.mpr ha)).symm + +/-- The degree of a Hessenberg sum is the maximum of the degrees. This is LM24, Fact 2.2.2(1), +with the equality noted parenthetically in the paper. -/ +theorem cantorDegree_add (a b : NatOrdinal.{u}) : + cantorDegree (a + b) = max (cantorDegree a) (cantorDegree b) := by + obtain rfl | ha := eq_or_ne a 0 + · simp + obtain rfl | hb := eq_or_ne b 0 + · simp + have hab : a + b ≠ 0 := by simp [ha, hb] + rw [cantorDegree_of_ne_zero hab, cantorDegree_of_ne_zero ha, + cantorDegree_of_ne_zero hb, ← WithBot.coe_max, WithBot.coe_eq_coe] + let da : NatOrdinal := of (Ordinal.log Ordinal.omega0 a.val) + let db : NatOrdinal := of (Ordinal.log Ordinal.omega0 b.val) + change of (Ordinal.log Ordinal.omega0 (a + b).val) = max da db + apply le_antisymm + · rw [← Order.lt_succ_iff, Order.succ_eq_add_one] + have ha_lt : a < ω^ (da + 1) := by + apply val.lt_iff_lt.mp + simp only [val_wpow, val_add_one, da, val_of] + exact Ordinal.lt_opow_succ_log_self Ordinal.one_lt_omega0 a.val + have hb_lt : b < ω^ (db + 1) := by + apply val.lt_iff_lt.mp + simp only [val_wpow, val_add_one, db, val_of] + exact Ordinal.lt_opow_succ_log_self Ordinal.one_lt_omega0 b.val + have ha_max : a < ω^ (max da db + 1) := + ha_lt.trans_le (wpow_le_wpow.mpr (add_le_add (le_max_left da db) le_rfl)) + have hb_max : b < ω^ (max da db + 1) := + hb_lt.trans_le (wpow_le_wpow.mpr (add_le_add (le_max_right da db) le_rfl)) + have hab_lt : a + b < ω^ (max da db + 1) := add_lt_wpow ha_max hb_max + apply val.lt_iff_lt.mp + apply (Ordinal.lt_opow_iff_log_lt' Ordinal.one_lt_omega0 (by simp)).mp + simpa only [val_wpow] using val.lt_iff_lt.mpr hab_lt + · apply max_le + · exact of.monotone + (Ordinal.log_mono_right Ordinal.omega0 (val.monotone le_add_right)) + · exact of.monotone + (Ordinal.log_mono_right Ordinal.omega0 (val.monotone le_add_left)) + +/-- The degree of a Hessenberg sum is at most the maximum of the degrees. This is the inequality +printed as LM24, Fact 2.2.2(1). -/ +theorem cantorDegree_add_le (a b : NatOrdinal.{u}) : + cantorDegree (a + b) ≤ max (cantorDegree a) (cantorDegree b) := + (cantorDegree_add a b).le + +/-- The degree of a Hessenberg product is the Hessenberg sum of the degrees. This is LM24, +Fact 2.2.2(2), including the paper's absorbing convention for `⊥`. -/ +theorem cantorDegree_mul (a b : NatOrdinal.{u}) : + cantorDegree (a * b) = cantorDegree a + cantorDegree b := by + obtain rfl | ha := eq_or_ne a 0 + · simp + obtain rfl | hb := eq_or_ne b 0 + · simp + have hab : a * b ≠ 0 := + (mul_pos (pos_iff_ne_zero.mpr ha) (pos_iff_ne_zero.mpr hb)).ne' + rw [cantorDegree_of_ne_zero hab, cantorDegree_of_ne_zero ha, + cantorDegree_of_ne_zero hb, ← WithBot.coe_add, WithBot.coe_eq_coe] + let da : NatOrdinal := of (Ordinal.log Ordinal.omega0 a.val) + let db : NatOrdinal := of (Ordinal.log Ordinal.omega0 b.val) + change of (Ordinal.log Ordinal.omega0 (a * b).val) = da + db + apply le_antisymm + · rw [← Order.lt_succ_iff, Order.succ_eq_add_one] + have ha_lt : a < ω^ (da + 1) := by + apply val.lt_iff_lt.mp + simp only [val_wpow, val_add_one, da, val_of] + exact Ordinal.lt_opow_succ_log_self Ordinal.one_lt_omega0 a.val + have hb_lt : b < ω^ (db + 1) := by + apply val.lt_iff_lt.mp + simp only [val_wpow, val_add_one, db, val_of] + exact Ordinal.lt_opow_succ_log_self Ordinal.one_lt_omega0 b.val + obtain ⟨n, han⟩ := lt_wpow_add_one_iff.mp ha_lt + obtain ⟨m, hbm⟩ := lt_wpow_add_one_iff.mp hb_lt + have hab_lt : a * b < ω^ (da + db + 1) := by + calc + a * b < (ω^ da * n) * (ω^ db * m) := + mul_lt_mul_of_pos han hbm (pos_iff_ne_zero.mpr ha) + ((pos_iff_ne_zero.mpr hb).trans hbm) + _ = ω^ (da + db) * ((n * m : ℕ) : NatOrdinal) := by + rw [mul_mul_mul_comm, ← Nat.cast_mul, ← wpow_add] + _ < ω^ (da + db + 1) := wpow_mul_natCast_lt (lt_add_one _) (n * m) + apply val.lt_iff_lt.mp + apply (Ordinal.lt_opow_iff_log_lt' Ordinal.one_lt_omega0 (by simp)).mp + simpa only [val_wpow] using val.lt_iff_lt.mpr hab_lt + · have hwa : ω^ da ≤ a := by + apply val.le_iff_le.mp + simp only [val_wpow, da, val_of] + exact Ordinal.opow_log_le_self Ordinal.omega0 (val_ne_zero.mpr ha) + have hwb : ω^ db ≤ b := by + apply val.le_iff_le.mp + simp only [val_wpow, db, val_of] + exact Ordinal.opow_log_le_self Ordinal.omega0 (val_ne_zero.mpr hb) + have hleading : ω^ (da + db) ≤ a * b := by + rw [wpow_add] + exact mul_le_mul hwa hwb bot_le bot_le + apply val_le_iff.mp + apply (Ordinal.opow_le_iff_le_log Ordinal.one_lt_omega0 + (val_ne_zero.mpr hab)).mp + simpa only [val_wpow] using val.monotone hleading + +end NatOrdinal diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/FinitePart.lean b/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/FinitePart.lean new file mode 100644 index 0000000000..3329a90850 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/FinitePart.lean @@ -0,0 +1,353 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.CombinatorialGames.NatOrdinal.Pow +public import Mathlib.SetTheory.Ordinal.CantorNormalForm + +/-! +# Finite Cantor coefficients of natural ordinals + +The constant Cantor coefficient of an ordinal is the coefficient of `ω ^ 0` in its Cantor +normal form. For a natural ordinal, this coefficient is a natural number. This module defines it +as the remainder after ordinal division by `ω` and proves that this agrees with Mathlib's Cantor +normal form. + +The complementary `limitPart` is divisible by `ω`. When `n` does not exceed the constant +coefficient, `removeNat a n` removes exactly `n` copies of the constant term; it is characterized +as the unique natural ordinal `b` satisfying `b + n = a`, where addition is Hessenberg addition. + +The final estimate bounds a Hessenberg product of two ordinals of finite Cantor degree. These +elementary facts support finite-degree arguments built on the LM24 degree and graded-ring +machinery. +-/ + +universe u + +public noncomputable section + +namespace Ordinal.CNF + +/-- The coefficient of `ω ^ 0` in the Cantor normal form of `a` is the remainder of `a` modulo +`ω`. -/ +theorem coeff_omega0_zero (a : Ordinal.{u}) : + coeff Ordinal.omega0 a 0 = a % Ordinal.omega0 := by + refine Ordinal.CNF.rec Ordinal.omega0 ?_ (fun o ho IH ↦ ?_) a + · simp + by_cases he : Ordinal.log Ordinal.omega0 o = 0 + · have ho_lt : o < Ordinal.omega0 := by + by_contra h + have hlog := Ordinal.log_pos Ordinal.one_lt_omega0 ho (le_of_not_gt h) + exact (ne_of_gt hlog) he + have hmem : (0, o) ∈ Ordinal.CNF Ordinal.omega0 o := by + rw [Ordinal.CNF.of_lt ho ho_lt] + simp + rw [coeff_of_mem_CNF hmem, Ordinal.mod_eq_of_lt ho_lt] + · have hx : o / Ordinal.omega0 ^ Ordinal.log Ordinal.omega0 o ≠ 0 := + (Ordinal.div_opow_log_pos Ordinal.omega0 ho).ne' + have hcoeff := coeff_opow_mul_add + (b := Ordinal.omega0) (e := Ordinal.log Ordinal.omega0 o) + (x := o / Ordinal.omega0 ^ Ordinal.log Ordinal.omega0 o) + (y := o % Ordinal.omega0 ^ Ordinal.log Ordinal.omega0 o) + Ordinal.one_lt_omega0 hx + (Ordinal.div_opow_log_lt o Ordinal.one_lt_omega0) + (Ordinal.mod_lt o <| Ordinal.opow_ne_zero + (Ordinal.log Ordinal.omega0 o) Ordinal.omega0_ne_zero) + have hdecomp := Ordinal.div_add_mod o + (Ordinal.omega0 ^ Ordinal.log Ordinal.omega0 o) + have hcoeff_zero : + coeff Ordinal.omega0 o 0 = + coeff Ordinal.omega0 + (o % Ordinal.omega0 ^ Ordinal.log Ordinal.omega0 o) 0 := by + calc + coeff Ordinal.omega0 o 0 = + coeff Ordinal.omega0 + (Ordinal.omega0 ^ Ordinal.log Ordinal.omega0 o * + (o / Ordinal.omega0 ^ Ordinal.log Ordinal.omega0 o) + + o % Ordinal.omega0 ^ Ordinal.log Ordinal.omega0 o) 0 := + congrArg (fun z ↦ coeff Ordinal.omega0 z 0) hdecomp.symm + _ = coeff Ordinal.omega0 + (o % Ordinal.omega0 ^ Ordinal.log Ordinal.omega0 o) 0 := by + rw [hcoeff] + simp [he] + rw [hcoeff_zero, IH] + apply Ordinal.mod_mod_of_dvd + simpa using Ordinal.opow_dvd_opow Ordinal.omega0 + (Order.one_le_iff_ne_zero.mpr he) + +end Ordinal.CNF + +namespace NatOrdinal + +/-- The coefficient of `ω ^ 0` in the Cantor normal form of a natural ordinal. -/ +def constantCoeff (a : NatOrdinal.{u}) : ℕ := + Classical.choose <| Ordinal.lt_omega0.mp <| + Ordinal.mod_lt a.val Ordinal.omega0_ne_zero + +/-- The constant Cantor coefficient, coerced to an ordinal, is the remainder modulo `ω`. -/ +@[simp] +theorem coe_constantCoeff (a : NatOrdinal.{u}) : + (a.constantCoeff : Ordinal) = a.val % Ordinal.omega0 := by + exact (Classical.choose_spec (Ordinal.lt_omega0.mp <| + Ordinal.mod_lt a.val Ordinal.omega0_ne_zero)).symm + +/-- `constantCoeff` agrees with Mathlib's coefficient at exponent zero in Cantor normal form. -/ +theorem coe_constantCoeff_eq_CNF_coeff (a : NatOrdinal.{u}) : + (a.constantCoeff : Ordinal) = Ordinal.CNF.coeff Ordinal.omega0 a.val 0 := by + rw [coe_constantCoeff, Ordinal.CNF.coeff_omega0_zero] + +@[simp] +theorem constantCoeff_zero : (0 : NatOrdinal.{u}).constantCoeff = 0 := by + apply Nat.cast_injective (R := Ordinal) + rw [coe_constantCoeff] + simp + +/-- The part of a natural ordinal whose constant Cantor coefficient is zero. -/ +def limitPart (a : NatOrdinal.{u}) : NatOrdinal.{u} := + NatOrdinal.of (Ordinal.omega0 * (a.val / Ordinal.omega0)) + +/-- A natural ordinal is the Hessenberg sum of its limit part and constant coefficient. -/ +theorem limitPart_add_constantCoeff (a : NatOrdinal.{u}) : + a.limitPart + a.constantCoeff = a := by + apply NatOrdinal.val.injective + rw [limitPart, val_add_natCast, val_of, coe_constantCoeff] + exact Ordinal.div_add_mod a.val Ordinal.omega0 + +/-- A natural ordinal is a successor prelimit exactly when its constant Cantor coefficient +vanishes. -/ +theorem isSuccPrelimit_iff_constantCoeff_eq_zero (a : NatOrdinal.{u}) : + Order.IsSuccPrelimit a ↔ a.constantCoeff = 0 := by + change Order.IsSuccPrelimit a.val ↔ _ + rw [Ordinal.isSuccPrelimit_iff_omega0_dvd, + Ordinal.dvd_iff_mod_eq_zero, ← coe_constantCoeff] + norm_cast + +/-- A positive power of `ω` has zero constant Cantor coefficient. -/ +theorem constantCoeff_wpow {a : NatOrdinal.{u}} (ha : a ≠ 0) : + (ω^ a).constantCoeff = 0 := by + rw [← isSuccPrelimit_iff_constantCoeff_eq_zero] + change Order.IsSuccPrelimit (ω^ a).val + rw [NatOrdinal.val_wpow, Ordinal.isSuccPrelimit_iff_omega0_dvd] + have hval : a.val ≠ 0 := by + intro hval + apply ha + apply NatOrdinal.val.injective + simpa using hval + simpa only [Ordinal.opow_one] using + Ordinal.opow_dvd_opow Ordinal.omega0 + (Order.one_le_iff_ne_zero.mpr hval) + +/-- The Hessenberg sum of two successor prelimits is a successor prelimit. -/ +theorem isSuccPrelimit_add {a b : NatOrdinal.{u}} + (ha : Order.IsSuccPrelimit a) (hb : Order.IsSuccPrelimit b) : + Order.IsSuccPrelimit (a + b) := by + rw [Order.isSuccPrelimit_iff_succ_lt] + intro c hc + rcases NatOrdinal.lt_add_iff.mp hc with + ⟨a', ha', hca⟩ | ⟨b', hb', hcb⟩ + · calc + Order.succ c ≤ Order.succ (a' + b) := Order.succ_mono hca + _ = (a' + b) + 1 := Order.succ_eq_add_one _ + _ = (a' + 1) + b := by ac_rfl + _ < a + b := by + simpa [add_comm] using add_lt_add_right (ha.add_one_lt ha') b + · calc + Order.succ c ≤ Order.succ (a + b') := Order.succ_mono hcb + _ = (a + b') + 1 := Order.succ_eq_add_one _ + _ = a + (b' + 1) := by ac_rfl + _ < a + b := by + simpa [add_comm] using add_lt_add_left (hb.add_one_lt hb') a + +/-- The limit part of a natural ordinal is a successor prelimit. -/ +theorem isSuccPrelimit_limitPart (a : NatOrdinal.{u}) : + Order.IsSuccPrelimit a.limitPart := by + rw [isSuccPrelimit_iff_constantCoeff_eq_zero] + apply Nat.cast_injective (R := Ordinal) + rw [coe_constantCoeff, limitPart, val_of, Ordinal.mul_mod] + simp + +/-- Adding a finite natural ordinal adds it to the constant Cantor coefficient. -/ +theorem constantCoeff_add_natCast (a : NatOrdinal.{u}) (n : ℕ) : + (a + n).constantCoeff = a.constantCoeff + n := by + apply Nat.cast_injective (R := Ordinal) + rw [coe_constantCoeff, val_add_natCast, Nat.cast_add, coe_constantCoeff] + nth_rw 1 [← Ordinal.div_add_mod a.val Ordinal.omega0] + rw [add_assoc, Ordinal.mul_add_mod_self, + Ordinal.mod_eq_of_lt + (Ordinal.isSuccLimit_omega0.add_natCast_lt + (Ordinal.mod_lt a.val Ordinal.omega0_ne_zero) n)] + +/-- The constant Cantor coefficient of a finite natural ordinal is that natural number. -/ +@[simp] +theorem constantCoeff_natCast (n : ℕ) : + (n : NatOrdinal.{u}).constantCoeff = n := by + simpa using constantCoeff_add_natCast (0 : NatOrdinal.{u}) n + +/-- Hessenberg addition adds constant Cantor coefficients. -/ +theorem constantCoeff_add (a b : NatOrdinal.{u}) : + (a + b).constantCoeff = a.constantCoeff + b.constantCoeff := by + have hbase : Order.IsSuccPrelimit (a.limitPart + b.limitPart) := + isSuccPrelimit_add (isSuccPrelimit_limitPart a) (isSuccPrelimit_limitPart b) + have hzero : (a.limitPart + b.limitPart).constantCoeff = 0 := + (isSuccPrelimit_iff_constantCoeff_eq_zero _).mp hbase + have hdecomp : + a + b = (a.limitPart + b.limitPart) + + (a.constantCoeff + b.constantCoeff : ℕ) := by + calc + a + b = (a.limitPart + a.constantCoeff) + + (b.limitPart + b.constantCoeff) := by + rw [limitPart_add_constantCoeff, limitPart_add_constantCoeff] + _ = (a.limitPart + b.limitPart) + + (a.constantCoeff + b.constantCoeff : ℕ) := by + rw [Nat.cast_add] + ac_rfl + rw [hdecomp, constantCoeff_add_natCast, hzero, zero_add] + +/-- Remove `n` copies of the constant Cantor term. This operation represents finite ordinal +predecessor only under the hypothesis `n ≤ a.constantCoeff`. -/ +def removeNat (a : NatOrdinal.{u}) (n : ℕ) : NatOrdinal.{u} := + a.limitPart + (a.constantCoeff - n : ℕ) + +/-- Removing `n` copies of the constant term subtracts `n` from the constant coefficient. -/ +theorem constantCoeff_removeNat (a : NatOrdinal.{u}) (n : ℕ) : + (a.removeNat n).constantCoeff = a.constantCoeff - n := by + rw [removeNat, constantCoeff_add_natCast, + (isSuccPrelimit_iff_constantCoeff_eq_zero _).mp + (isSuccPrelimit_limitPart a), zero_add] + +/-- If `n` does not exceed the constant coefficient, adding `n` after removing it recovers the +original natural ordinal. -/ +theorem removeNat_add_natCast {a : NatOrdinal.{u}} {n : ℕ} + (hn : n ≤ a.constantCoeff) : a.removeNat n + n = a := by + rw [removeNat] + calc + a.limitPart + ↑(a.constantCoeff - n) + ↑n = + a.limitPart + ↑((a.constantCoeff - n) + n) := by + rw [Nat.cast_add] + ac_rfl + _ = a.limitPart + a.constantCoeff := by rw [Nat.sub_add_cancel hn] + _ = a := limitPart_add_constantCoeff a + +/-- Removing zero copies of the constant term leaves a natural ordinal unchanged. -/ +@[simp] +theorem removeNat_zero (a : NatOrdinal.{u}) : a.removeNat 0 = a := by + simpa using removeNat_add_natCast (a := a) (n := 0) (Nat.zero_le a.constantCoeff) + +/-- Finite removal is the unique solution to addition by the removed natural ordinal. -/ +theorem eq_removeNat_iff_add_natCast_eq {a eta : NatOrdinal.{u}} {n : ℕ} + (hn : n ≤ a.constantCoeff) : eta = a.removeNat n ↔ eta + n = a := by + constructor + · rintro rfl + exact removeNat_add_natCast hn + · intro heta + apply add_right_cancel (b := (n : NatOrdinal)) + rw [heta, removeNat_add_natCast hn] + +/-- Removing a finite constant term from the left summand commutes with adding a right summand. -/ +theorem removeNat_add_right (a b : NatOrdinal.{u}) {n : ℕ} + (hn : n ≤ a.constantCoeff) : + (a + b).removeNat n = a.removeNat n + b := by + apply add_right_cancel (b := (n : NatOrdinal)) + rw [removeNat_add_natCast (hn.trans <| by + rw [constantCoeff_add] + exact Nat.le_add_right _ _)] + symm + calc + a.removeNat n + b + n = a.removeNat n + n + b := by ac_rfl + _ = a + b := by rw [removeNat_add_natCast hn] + +/-- Finite predecessor in the left summand commutes with adding a right summand. -/ +theorem removeOne_add_right (a b : NatOrdinal.{u}) (ha : 0 < a.constantCoeff) : + (a + b).removeNat 1 = a.removeNat 1 + b := + removeNat_add_right a b ha + +/-- If `a < ω ^ (p + 1)` and `b < ω ^ (q + 1)`, then their Hessenberg product is less than +`ω ^ (p + q + 1)`. -/ +theorem mul_lt_wpow_natCast_add_one {a b : NatOrdinal.{u}} {p q : ℕ} + (ha : a < ω^ ((p + 1 : ℕ) : NatOrdinal)) + (hb : b < ω^ ((q + 1 : ℕ) : NatOrdinal)) : + a * b < ω^ ((p + q + 1 : ℕ) : NatOrdinal) := by + have ha' : a < ω^ ((p : NatOrdinal) + 1) := by simpa using ha + have hb' : b < ω^ ((q : NatOrdinal) + 1) := by simpa using hb + obtain ⟨n, han⟩ := NatOrdinal.lt_wpow_add_one_iff.mp ha' + obtain ⟨m, hbm⟩ := NatOrdinal.lt_wpow_add_one_iff.mp hb' + by_cases haZero : a = 0 + · subst a + simp + by_cases hbZero : b = 0 + · subst b + simp + have hnZero : n ≠ 0 := by + intro hn + subst n + simp at han + have hboundPos : 0 < ω^ (p : NatOrdinal) * n := by + apply mul_pos (NatOrdinal.wpow_pos _) + exact_mod_cast Nat.pos_of_ne_zero hnZero + have hproduct : + a * b < (ω^ (p : NatOrdinal) * n) * (ω^ (q : NatOrdinal) * m) := by + calc + a * b < (ω^ (p : NatOrdinal) * n) * b := + mul_lt_mul_of_pos_right han (pos_iff_ne_zero.mpr hbZero) + _ < (ω^ (p : NatOrdinal) * n) * (ω^ (q : NatOrdinal) * m) := + mul_lt_mul_of_pos_left hbm hboundPos + have hrewrite : + (ω^ (p : NatOrdinal) * n) * (ω^ (q : NatOrdinal) * m) = + ω^ ((p + q : ℕ) : NatOrdinal) * (n * m) := by + rw [Nat.cast_add, NatOrdinal.wpow_add] + ac_rfl + rw [hrewrite] at hproduct + have hnext : + ω^ ((p + q : ℕ) : NatOrdinal) * (n * m : ℕ) < + ω^ ((p + q + 1 : ℕ) : NatOrdinal) := by + apply NatOrdinal.wpow_mul_natCast_lt + exact_mod_cast Nat.lt_succ_self (p + q) + exact hproduct.trans (by simpa only [Nat.cast_mul] using hnext) + +/-- The constant Cantor coefficient of an `r`-fold Hessenberg sum is `r` times the constant +Cantor coefficient. -/ +theorem constantCoeff_nsmul (r : ℕ) (alpha : NatOrdinal.{u}) : + (r • alpha).constantCoeff = r * alpha.constantCoeff := by + induction r with + | zero => simp + | succ r ih => + rw [succ_nsmul, constantCoeff_add, ih, Nat.succ_mul] + +/-- For a natural ordinal with positive constant Cantor coefficient, removing one constant term +from an `r`-fold Hessenberg sum removes it from a single summand. -/ +theorem removeNat_one_nsmul {alpha : NatOrdinal.{u}} + (halpha : 0 < alpha.constantCoeff) {r : ℕ} (hr : 1 ≤ r) : + alpha.removeNat 1 + (r - 1) • alpha = (r • alpha).removeNat 1 := by + obtain ⟨s, rfl⟩ : ∃ s, r = s + 1 := ⟨r - 1, by omega⟩ + have hcc : 1 ≤ ((s + 1) • alpha).constantCoeff := by + rw [constantCoeff_nsmul] + exact Nat.one_le_iff_ne_zero.mpr (Nat.mul_ne_zero (by omega) (by omega)) + rw [eq_removeNat_iff_add_natCast_eq hcc] + have hsimp : s + 1 - 1 = s := by omega + rw [hsimp] + calc + alpha.removeNat 1 + s • alpha + ((1 : ℕ) : NatOrdinal) + = (alpha.removeNat 1 + ((1 : ℕ) : NatOrdinal)) + s • alpha := by ac_rfl + _ = alpha + s • alpha := by rw [removeNat_add_natCast halpha] + _ = (s + 1) • alpha := by rw [succ_nsmul, add_comm] + +/-- Removing one constant term and then `j - 1` further ones removes `j` constant terms. -/ +theorem removeNat_one_removeNat_pred {delta : NatOrdinal.{u}} {j : ℕ} + (hjpos : 1 ≤ j) (hj : j ≤ delta.constantCoeff) : + (delta.removeNat 1).removeNat (j - 1) = delta.removeNat j := by + have hone : 1 ≤ delta.constantCoeff := hjpos.trans hj + have hpred : j - 1 ≤ (delta.removeNat 1).constantCoeff := by + rw [constantCoeff_removeNat] + omega + have hsplit : ((j : ℕ) : NatOrdinal) = + ((j - 1 : ℕ) : NatOrdinal) + ((1 : ℕ) : NatOrdinal) := by + rw [← Nat.cast_add] + congr 1 + omega + rw [eq_removeNat_iff_add_natCast_eq hj, hsplit, ← add_assoc, + removeNat_add_natCast hpred, removeNat_add_natCast hone] + +end NatOrdinal diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/GeneralFactorization.lean b/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/GeneralFactorization.lean new file mode 100644 index 0000000000..1fa5ff2fa0 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/GeneralFactorization.lean @@ -0,0 +1,85 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.MultiplicativelyPrincipal + +/-! +# Canonical multiplicative factors of a power of `ω`, at every exponent + +The canonical multiplicatively principal factors of `ω ^ α` are `ω` raised to the Cantor terms +of `α`, so the residual factor deletes the least such term. `SuccessorFactorization` is the +case of positive constant Cantor coefficient, where deleting the least term is deleting `1`. +-/ + +open Ordinal List + +universe u + +public noncomputable section + +namespace Ordinal + +private theorem dropLast_map_opow (l : List Ordinal.{u}) : + (l.map (fun a ↦ omega0 ^ a)).dropLast = l.dropLast.map (fun a ↦ omega0 ^ a) := by + induction l with + | nil => simp + | cons a t ih => + cases t with + | nil => simp + | cons b u => simp + +private theorem prod_map_opow (l : List Ordinal.{u}) : + (l.map (fun a ↦ omega0 ^ a)).prod = omega0 ^ l.sum := by + induction l with + | nil => simp + | cons a t ih => rw [List.map_cons, List.prod_cons, ih, List.sum_cons, opow_add] + +theorem multiplicativePrincipalFactors_omega0_opow (alpha : Ordinal.{u}) : + (omega0 ^ alpha).multiplicativePrincipalFactors = + alpha.additivePrincipalTerms.map (fun a ↦ omega0 ^ a) := by + symm + apply multiplicativePrincipalFactors_unique + · exact isAdditivelyPrincipal_omega0_opow alpha + · rw [prod_map_opow, additivePrincipalTerms_sum] + · intro f hf + rw [List.mem_map] at hf + obtain ⟨a, ha, rfl⟩ := hf + obtain ⟨e, rfl⟩ := + isAdditivelyPrincipal_iff.mp (isAdditivelyPrincipal_of_mem_additivePrincipalTerms ha) + exact isMultiplicativelyPrincipal_omega0_opow_opow e + · intro f hf + rw [List.mem_map] at hf + obtain ⟨a, ha, rfl⟩ := hf + obtain ⟨e, rfl⟩ := + isAdditivelyPrincipal_iff.mp (isAdditivelyPrincipal_of_mem_additivePrincipalTerms ha) + calc (1 : Ordinal) < omega0 := one_lt_omega0 + _ = omega0 ^ (1 : Ordinal) := (opow_one _).symm + _ ≤ omega0 ^ (omega0 ^ e) := + opow_le_opow_right omega0_pos (Order.one_le_iff_pos.mpr (opow_pos e omega0_pos)) + · have hs := additivePrincipalTerms_sortedGE alpha + rw [List.sortedGE_iff_pairwise] at hs ⊢ + exact hs.map _ fun _ _ hxy ↦ opow_le_opow_right omega0_pos hxy + +theorem residualFactor_omega0_opow (alpha : Ordinal.{u}) + (hadd : IsAdditivelyPrincipal (omega0 ^ alpha)) (hone : 1 < omega0 ^ alpha) : + AdditivePrincipalAboveOne.residualFactor ⟨omega0 ^ alpha, hadd, hone⟩ = + omega0 ^ alpha.additivePrincipalTerms.dropLast.sum := by + rw [AdditivePrincipalAboveOne.residualFactor_eq_dropLast_prod, + multiplicativePrincipalFactors_omega0_opow, dropLast_map_opow, prod_map_opow] + +theorem principalFactor_omega0_opow (alpha : Ordinal.{u}) + (hadd : IsAdditivelyPrincipal (omega0 ^ alpha)) (hone : 1 < omega0 ^ alpha) + (hne : alpha.additivePrincipalTerms ≠ []) : + AdditivePrincipalAboveOne.principalFactor ⟨omega0 ^ alpha, hadd, hone⟩ = + omega0 ^ alpha.additivePrincipalTerms.getLast hne := by + rw [AdditivePrincipalAboveOne.principalFactor_eq_getLast] + simp only [multiplicativePrincipalFactors_omega0_opow] + exact List.getLast_map _ + +end Ordinal + +end diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/IncreasingSequenceUnion.lean b/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/IncreasingSequenceUnion.lean new file mode 100644 index 0000000000..f717565798 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/IncreasingSequenceUnion.lean @@ -0,0 +1,298 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.SetOrderType +public import Mathlib.SetTheory.Ordinal.Arithmetic +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.NaturalPrincipal + +/-! +# The union of an increasing sequence of well-ordered sets + +A sequence `Y_0 < Y_1 < Y_2 < ⋯` of subsets of a linear order (Lean `B : ℕ → Set α`) is +*increasing* if every element of a later member lies strictly above every element of an earlier +one (the hypothesis `hord`). The union of an increasing sequence of partially well-ordered sets is +partially well ordered (`iUnion_of_ordered`): a strictly decreasing sequence in the union has +non-increasing indices of members, so from some point on it lies in a single member. Its order type +is bounded by any ordinal greater than every finite Hessenberg sum of copies of `ρ` when every +member has order type at most `ρ` (`orderType_iUnion_le_of_ordered`), and at most `ω^e` when every +member has order type below `ω^e` +(`orderType_iUnion_le_wpow_of_ordered`). + +[Ber00, Lem. 4.1] is the case of two sets; [Ber00, Lem. 4.7], formalised in +`ConwayRefinement.SetTheory.Ordinal.OrderedUnion`, bounds a union indexed by an ordinal +from below. +-/ + +universe u v + +open Order Ordinal +open scoped NatOrdinal + +public noncomputable section + +namespace Set.IsPWO + +variable {α : Type u} [LinearOrder α] {B : ℕ → Set α} + +/-- The union of a family of partially well-ordered sets, ordered by a partially well-ordered +linear index, is partially well ordered. -/ +theorem iUnion_of_ordered_index {ι : Type v} [LinearOrder ι] + (hι : (Set.univ : Set ι).IsPWO) (B : ι → Set α) (hB : ∀ i, (B i).IsPWO) + (hord : ∀ i j, i < j → ∀ x ∈ B i, ∀ y ∈ B j, x < y) : + (⋃ i, B i).IsPWO := by + classical + rw [Set.isPWO_iff_isWF, Set.isWF_iff_no_descending_seq] + intro f hf hmem + have hidx : ∀ n, ∃ i, f n ∈ B i := fun n ↦ Set.mem_iUnion.mp (hmem n) + choose idx hidx using hidx + have hanti : ∀ m n, m ≤ n → idx n ≤ idx m := by + intro m n hmn + by_contra hlt + rw [not_le] at hlt + rcases eq_or_lt_of_le hmn with rfl | hmn' + · exact hlt.false + · exact absurd (hord _ _ hlt (f m) (hidx m) (f n) (hidx n)) (hf hmn').not_gt + have hrange : (Set.range idx).IsWF := + Set.IsWF.mono hι.isWF (Set.subset_univ (Set.range idx)) + have hrange_ne : (Set.range idx).Nonempty := Set.range_nonempty idx + obtain ⟨N, hNval⟩ := hrange.min_mem hrange_ne + have hNval' : idx N = hrange.min hrange_ne := hNval + have hN : ∀ n, N ≤ n → idx n = idx N := by + intro n hn + exact le_antisymm (hanti N n hn) + (not_lt.mp fun h ↦ hrange.not_lt_min hrange_ne ⟨n, rfl⟩ (hNval' ▸ h)) + have htail : ∀ n, f (N + n) ∈ B (idx N) := fun n ↦ by + have := hidx (N + n) + rwa [hN (N + n) (Nat.le_add_right N n)] at this + have hstrict : StrictAnti fun n ↦ f (N + n) := fun m n hmn ↦ hf (by omega) + exact (Set.isWF_iff_no_descending_seq.mp (hB (idx N)).isWF) _ hstrict htail + +/-- The members of an increasing sequence of sets are pairwise disjoint. -/ +theorem ordered_disjoint (hord : ∀ j k, j < k → ∀ x ∈ B j, ∀ y ∈ B k, x < y) {j k : ℕ} + (hjk : j ≠ k) {x : α} (hj : x ∈ B j) (hk : x ∈ B k) : False := by + rcases hjk.lt_or_gt with h | h + · exact (hord j k h x hj x hk).false + · exact (hord k j h x hk x hj).false + +/-- An element of the union of an increasing sequence of sets lies in exactly one member. -/ +theorem exists_unique_index (hord : ∀ j k, j < k → ∀ x ∈ B j, ∀ y ∈ B k, x < y) {x : α} + (hx : x ∈ ⋃ k, B k) : ∃! k, x ∈ B k := by + obtain ⟨k, hk⟩ := Set.mem_iUnion.mp hx + exact ⟨k, hk, fun j hj ↦ by + by_contra hne + exact ordered_disjoint hord hne hj hk⟩ + +/-- The union of an ordered sequence of well-ordered subsets of a linear order is well ordered. -/ +@[blueprint "lem:increasing-union" + (phase := "Algebraic and ordinal preliminaries") + (title := "Well-ordering of a countable ordered union") + (statement := /-- + Let $(Y_n)$ be well-ordered subsets of a linear order, and suppose $x simp + | succ n ih => + have : (⋃ k ∈ Finset.range (n + 1), B k) = (⋃ k ∈ Finset.range n, B k) ∪ B n := by + ext x + simp only [Set.mem_iUnion, Finset.mem_range, Set.mem_union, exists_prop] + constructor + · rintro ⟨k, hk, hx⟩ + rcases Nat.lt_succ_iff_lt_or_eq.mp hk with hk | rfl + · exact Or.inl ⟨k, hk, hx⟩ + · exact Or.inr hx + · rintro (⟨k, hk, hx⟩ | hx) + · exact ⟨k, by omega, hx⟩ + · exact ⟨n, by omega, hx⟩ + rw [this] + exact ih.union (hB n) + +/-- The order type of the union of the first `n` members is at most the natural sum of `n` copies +of a common bound `ρ`. -/ +private theorem orderType_iUnion_lt_le (hB : ∀ k, (B k).IsPWO) (hρ : ∀ k, (hB k).orderType ≤ ρ) + (n : ℕ) : (isPWO_iUnion_lt hB n).orderType ≤ (n • NatOrdinal.of ρ).val := by + classical + induction n with + | zero => + have hempty : (⋃ k ∈ Finset.range 0, B k) = (∅ : Set α) := by simp + rw [Set.IsPWO.orderType_congr _ (Set.isPWO_empty) hempty, zero_nsmul] + simp [(Set.isPWO_empty (α := α)).orderType_eq_zero.mpr rfl] + | succ n ih => + have hsplit : (⋃ k ∈ Finset.range (n + 1), B k) = (⋃ k ∈ Finset.range n, B k) ∪ B n := by + ext x + simp only [Set.mem_iUnion, Finset.mem_range, Set.mem_union, exists_prop] + constructor + · rintro ⟨k, hk, hx⟩ + rcases Nat.lt_succ_iff_lt_or_eq.mp hk with hk | rfl + · exact Or.inl ⟨k, hk, hx⟩ + · exact Or.inr hx + · rintro (⟨k, hk, hx⟩ | hx) + · exact ⟨k, by omega, hx⟩ + · exact ⟨n, by omega, hx⟩ + rw [Set.IsPWO.orderType_congr _ ((isPWO_iUnion_lt hB n).union (hB n)) hsplit] + refine ((isPWO_iUnion_lt hB n).orderType_union_le_naturalAdd (hB n)).trans ?_ + rw [succ_nsmul] + exact NatOrdinal.val.le_iff_le.mpr + (add_le_add (NatOrdinal.of.le_iff_le.mpr ih) (NatOrdinal.of.le_iff_le.mpr (hρ n))) + +/-- **The order type of the union of an increasing sequence of sets** is at most any `o` exceeding +every natural sum of finitely many copies of a common bound `ρ` on the order types of the +members. -/ +@[blueprint "lem:increasing-union-order-type" + (phase := "Algebraic and ordinal preliminaries") + (title := "Order type of a countable ordered union") + (statement := /-- + Let $(Y_n)$ be well-ordered subsets of a linear order, and suppose $x + have hempty : (⋃ k ∈ Finset.range 0, B k) = (∅ : Set α) := by simp + rw [Set.IsPWO.orderType_congr _ (Set.isPWO_empty) hempty, + (Set.isPWO_empty (α := α)).orderType_eq_zero.mpr rfl] + exact Ordinal.opow_pos _ Ordinal.omega0_pos + | succ n ih => + have hsplit : (⋃ k ∈ Finset.range (n + 1), B k) = (⋃ k ∈ Finset.range n, B k) ∪ B n := by + ext x + simp only [Set.mem_iUnion, Finset.mem_range, Set.mem_union, exists_prop] + constructor + · rintro ⟨k, hk, hx⟩ + rcases Nat.lt_succ_iff_lt_or_eq.mp hk with hk | rfl + · exact Or.inl ⟨k, hk, hx⟩ + · exact Or.inr hx + · rintro (⟨k, hk, hx⟩ | hx) + · exact ⟨k, by omega, hx⟩ + · exact ⟨n, by omega, hx⟩ + rw [Set.IsPWO.orderType_congr _ ((isPWO_iUnion_lt hB n).union (hB n)) hsplit] + refine ((isPWO_iUnion_lt hB n).orderType_union_le_naturalAdd (hB n)).trans_lt ?_ + have h1 : NatOrdinal.of (isPWO_iUnion_lt hB n).orderType < ω^ e := by + rw [← NatOrdinal.of_val (ω^ e)] + exact NatOrdinal.of.lt_iff_lt.mpr ih + have h2 : NatOrdinal.of (hB n).orderType < ω^ e := by + rw [← NatOrdinal.of_val (ω^ e)] + exact NatOrdinal.of.lt_iff_lt.mpr (hρ n) + exact NatOrdinal.val.lt_iff_lt.mpr (NatOrdinal.add_lt_wpow h1 h2) + refine hU.orderType_le_of_forall_inter_Iic_lt fun x hx ↦ ?_ + obtain ⟨k, hk⟩ := Set.mem_iUnion.mp hx + have hsub : (⋃ j, B j) ∩ Set.Iic x ⊆ ⋃ j ∈ Finset.range (k + 1), B j := by + rintro y ⟨hy, hyx⟩ + obtain ⟨j, hj⟩ := Set.mem_iUnion.mp hy + refine Set.mem_iUnion.mpr ⟨j, Set.mem_iUnion.mpr ⟨?_, hj⟩⟩ + rw [Finset.mem_range] + by_contra hjk + rw [not_lt, Nat.succ_le_iff] at hjk + exact absurd (hord k j hjk x hk y hj) (not_lt.mpr hyx) + calc (hU.mono (s := (⋃ j, B j) ∩ Set.Iic x) Set.inter_subset_left).orderType + ≤ (isPWO_iUnion_lt hB (k + 1)).orderType := + Set.IsPWO.orderType_mono _ _ hsub + _ < (ω^ e).val := hfin (k + 1) + +end Set.IsPWO diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/LeastTerm.lean b/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/LeastTerm.lean new file mode 100644 index 0000000000..2ee50cb2f2 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/LeastTerm.lean @@ -0,0 +1,448 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.CantorTermCount +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.FinitePart + +/-! +# Deleting the least Cantor term + +The least additive-principal term of a natural ordinal, its deletion, and the properties of +that deletion: it splits a nonzero grade as `removeLeastTerm a + leastTerm a = a`, it drops +`cantorTermCount` by exactly one, and it agrees with `NatOrdinal.removeNat _ 1` exactly on the +grades carrying a finite part. +-/ + +open Ordinal + +universe u + +public noncomputable section + +namespace NatOrdinal + +/-- The final additive-principal term of the ordinal, or zero when the ordinal is zero. -/ +def leastTerm (a : NatOrdinal.{u}) : NatOrdinal.{u} := + NatOrdinal.of (a.val.additivePrincipalTerms.getLastD 0) + +/-- The ordinal obtained by removing the final additive-principal term from its Cantor +decomposition. -/ +def removeLeastTerm (a : NatOrdinal.{u}) : NatOrdinal.{u} := + NatOrdinal.of a.val.additivePrincipalTerms.dropLast.sum + +@[simp] +theorem val_removeLeastTerm (a : NatOrdinal.{u}) : + (removeLeastTerm a).val = a.val.additivePrincipalTerms.dropLast.sum := by + rw [removeLeastTerm, NatOrdinal.val_of] + +@[simp] +theorem leastTerm_zero : leastTerm (0 : NatOrdinal.{u}) = 0 := by + rw [leastTerm, show (0 : NatOrdinal.{u}).val = 0 from rfl, + Ordinal.additivePrincipalTerms_zero] + rfl + +@[simp] +theorem removeLeastTerm_zero : removeLeastTerm (0 : NatOrdinal.{u}) = 0 := by + rw [removeLeastTerm, show (0 : NatOrdinal.{u}).val = 0 from rfl, + Ordinal.additivePrincipalTerms_zero] + rfl + +theorem additivePrincipalTerms_ne_nil {a : NatOrdinal.{u}} (ha : a ≠ 0) : + a.val.additivePrincipalTerms ≠ [] := by + intro hnil + apply ha + apply NatOrdinal.val.injective + have hsum := Ordinal.additivePrincipalTerms_sum a.val + rw [hnil] at hsum + simpa using hsum.symm + +theorem val_leastTerm {a : NatOrdinal.{u}} (hne : a.val.additivePrincipalTerms ≠ []) : + (leastTerm a).val = a.val.additivePrincipalTerms.getLast hne := by + rw [leastTerm, NatOrdinal.val_of, List.getLastD_eq_getLast?, + List.getLast?_eq_some_getLast hne] + rfl + +theorem isAdditivelyPrincipal_leastTerm {a : NatOrdinal.{u}} (ha : a ≠ 0) : + IsAdditivelyPrincipal (leastTerm a).val := by + rw [val_leastTerm (additivePrincipalTerms_ne_nil ha)] + exact Ordinal.isAdditivelyPrincipal_of_mem_additivePrincipalTerms + (List.getLast_mem _) + +theorem removeLeastTerm_add_leastTerm (a : NatOrdinal.{u}) : + removeLeastTerm a + leastTerm a = a := by + rcases eq_or_ne a 0 with rfl | ha + · simp + have hne : a.val.additivePrincipalTerms ≠ [] := additivePrincipalTerms_ne_nil ha + set l := a.val.additivePrincipalTerms with hl + have hsplit : l.dropLast ++ [l.getLast hne] = l := List.dropLast_append_getLast hne + have hprincipal : ∀ x ∈ l, IsAdditivelyPrincipal x := fun _ hx ↦ + Ordinal.isAdditivelyPrincipal_of_mem_additivePrincipalTerms hx + have hsorted : l.SortedGE := Ordinal.additivePrincipalTerms_sortedGE a.val + have hdropPrincipal : ∀ x ∈ l.dropLast, IsAdditivelyPrincipal x := fun _ hx ↦ + hprincipal _ (List.dropLast_subset _ hx) + have hdropSorted : l.dropLast.SortedGE := by + rw [List.sortedGE_iff_pairwise] at hsorted ⊢ + exact hsorted.sublist (List.dropLast_sublist _) + apply NatOrdinal.val.injective + have hmain : NatOrdinal.of l.sum = removeLeastTerm a + leastTerm a := by + rw [Ordinal.natOrdinal_of_sum_eq_sum_map_of_sorted hprincipal hsorted] + conv_lhs => rw [← hsplit] + rw [List.map_append, List.sum_append] + congr 1 + · rw [removeLeastTerm, ← hl, + Ordinal.natOrdinal_of_sum_eq_sum_map_of_sorted hdropPrincipal hdropSorted] + · show (List.map (⇑NatOrdinal.of) [l.getLast hne]).sum = leastTerm a + simp only [List.map_cons, List.map_nil, List.sum_cons, List.sum_nil, add_zero] + apply NatOrdinal.val.injective + rw [NatOrdinal.val_of, val_leastTerm hne] + rw [← hmain, NatOrdinal.val_of, hl] + exact Ordinal.additivePrincipalTerms_sum a.val + +theorem cantorTermCount_leastTerm {a : NatOrdinal.{u}} (ha : a ≠ 0) : + cantorTermCount (leastTerm a) = 1 := by + have hself : leastTerm a = NatOrdinal.of (leastTerm a).val := rfl + rw [hself, cantorTermCount_of, + Ordinal.additivePrincipalTerms_of_isAdditivelyPrincipal + (isAdditivelyPrincipal_leastTerm ha)] + rfl + +theorem cantorTermCount_removeLeastTerm {a : NatOrdinal.{u}} (ha : a ≠ 0) : + cantorTermCount (removeLeastTerm a) + 1 = cantorTermCount a := by + conv_rhs => rw [← removeLeastTerm_add_leastTerm a] + rw [cantorTermCount_add, cantorTermCount_leastTerm ha] + +theorem cantorTermCount_removeLeastTerm_lt {a : NatOrdinal.{u}} (ha : a ≠ 0) : + cantorTermCount (removeLeastTerm a) < cantorTermCount a := by + rw [← cantorTermCount_removeLeastTerm ha] + omega + +theorem removeLeastTerm_eq_zero_iff {a : NatOrdinal.{u}} (ha : a ≠ 0) : + removeLeastTerm a = 0 ↔ cantorTermCount a = 1 := by + constructor + · intro hzero + have hcount := cantorTermCount_removeLeastTerm ha + rw [hzero, cantorTermCount_zero] at hcount + omega + · intro hone + have hcount := cantorTermCount_removeLeastTerm ha + rw [hone] at hcount + exact cantorTermCount_eq_zero.mp (by omega) + +theorem cantorTermCount_eq_one_iff {a : NatOrdinal.{u}} (ha : a ≠ 0) : + cantorTermCount a = 1 ↔ Ordinal.IsAdditivelyPrincipal a.val := by + constructor + · intro hone + have hne := additivePrincipalTerms_ne_nil ha + have hlen : a.val.additivePrincipalTerms.length = 1 := by + have hself : a = NatOrdinal.of a.val := rfl + rw [hself, cantorTermCount_of] at hone + exact hone + obtain ⟨x, hx⟩ := List.length_eq_one_iff.mp hlen + have hsum := Ordinal.additivePrincipalTerms_sum a.val + rw [hx, List.sum_cons, List.sum_nil, add_zero] at hsum + rw [← hsum] + exact Ordinal.isAdditivelyPrincipal_of_mem_additivePrincipalTerms + (by rw [hx]; simp) + · intro hprin + have hself : a = NatOrdinal.of a.val := rfl + rw [hself, cantorTermCount_of, + Ordinal.additivePrincipalTerms_of_isAdditivelyPrincipal hprin] + rfl + +/-! ### The least term of a sum -/ + +private theorem getLast_le_of_mem : + ∀ (l : List Ordinal.{u}), l.SortedGE → ∀ (hne : l ≠ []) (y : Ordinal.{u}), + y ∈ l → l.getLast hne ≤ y := by + intro l + induction l with + | nil => intro _ hne; exact absurd rfl hne + | cons c t ih => + intro hs hne y hy + cases t with + | nil => + rw [List.mem_singleton] at hy + subst hy + simp + | cons d u => + have hcons : (d :: u) ≠ [] := by simp + rw [List.getLast_cons hcons] + have hpair := List.sortedGE_iff_pairwise.mp hs + have hst : (d :: u).SortedGE := + List.sortedGE_iff_pairwise.mpr hpair.tail + rcases List.mem_cons.mp hy with rfl | hy' + · exact List.rel_of_pairwise_cons hpair (List.getLast_mem hcons) + · exact ih hst hcons y hy' + +theorem val_leastTerm_mem {a : NatOrdinal.{u}} (ha : a ≠ 0) : + (leastTerm a).val ∈ a.val.additivePrincipalTerms := by + rw [val_leastTerm (additivePrincipalTerms_ne_nil ha)] + exact List.getLast_mem _ + +theorem val_leastTerm_le_of_mem {a : NatOrdinal.{u}} (ha : a ≠ 0) + {y : Ordinal.{u}} (hy : y ∈ a.val.additivePrincipalTerms) : + (leastTerm a).val ≤ y := by + rw [val_leastTerm (additivePrincipalTerms_ne_nil ha)] + exact getLast_le_of_mem _ (Ordinal.additivePrincipalTerms_sortedGE a.val) _ y hy + +theorem leastTerm_add {a b : NatOrdinal.{u}} (ha : a ≠ 0) (hb : b ≠ 0) : + leastTerm (a + b) = min (leastTerm a) (leastTerm b) := by + have hab : a + b ≠ 0 := by + intro hzero + apply ha + have := cantorTermCount_add a b + rw [hzero, cantorTermCount_zero] at this + exact cantorTermCount_eq_zero.mp (by omega) + have hperm := additivePrincipalTerms_add_perm a b + have hmemA : (leastTerm a).val ∈ (a + b).val.additivePrincipalTerms := by + rw [hperm.mem_iff, List.mem_append] + exact Or.inl (val_leastTerm_mem ha) + have hmemB : (leastTerm b).val ∈ (a + b).val.additivePrincipalTerms := by + rw [hperm.mem_iff, List.mem_append] + exact Or.inr (val_leastTerm_mem hb) + have hle : (leastTerm (a + b)).val ≤ min (leastTerm a).val (leastTerm b).val := + le_min (val_leastTerm_le_of_mem hab hmemA) (val_leastTerm_le_of_mem hab hmemB) + have hge : min (leastTerm a).val (leastTerm b).val ≤ (leastTerm (a + b)).val := by + have hmem := val_leastTerm_mem hab + rw [hperm.mem_iff, List.mem_append] at hmem + rcases hmem with h | h + · exact (min_le_left _ _).trans (val_leastTerm_le_of_mem ha h) + · exact (min_le_right _ _).trans (val_leastTerm_le_of_mem hb h) + apply NatOrdinal.val.injective + rcases le_total (leastTerm a) (leastTerm b) with hab' | hab' + · rw [min_eq_left hab'] + exact le_antisymm (hle.trans (min_le_left _ _)) + ((le_min (le_refl _) hab').trans hge) + · rw [min_eq_right hab'] + exact le_antisymm (hle.trans (min_le_right _ _)) + ((le_min hab' (le_refl _)).trans hge) + +theorem removeLeastTerm_add_of_leastTerm_le {a b : NatOrdinal.{u}} + (ha : a ≠ 0) (hb : b ≠ 0) (hle : leastTerm a ≤ leastTerm b) : + removeLeastTerm (a + b) = removeLeastTerm a + b := by + have hab : a + b ≠ 0 := by + intro hzero + apply ha + have hcount := cantorTermCount_add a b + rw [hzero, cantorTermCount_zero] at hcount + exact cantorTermCount_eq_zero.mp (by omega) + have hmin : leastTerm (a + b) = leastTerm a := by + rw [leastTerm_add ha hb, min_eq_left hle] + apply _root_.add_right_cancel (b := leastTerm a) + calc removeLeastTerm (a + b) + leastTerm a + = removeLeastTerm (a + b) + leastTerm (a + b) := by rw [hmin] + _ = a + b := removeLeastTerm_add_leastTerm (a + b) + _ = (removeLeastTerm a + leastTerm a) + b := by + rw [removeLeastTerm_add_leastTerm a] + _ = removeLeastTerm a + b + leastTerm a := by ac_rfl + +theorem nsmul_ne_zero_of_ne_zero {a : NatOrdinal.{u}} (ha : a ≠ 0) {r : ℕ} + (hr : 1 ≤ r) : r • a ≠ 0 := by + intro hzero + apply ha + have hcount : r * cantorTermCount a = 0 := by + rw [← cantorTermCount_nsmul, hzero, cantorTermCount_zero] + refine cantorTermCount_eq_zero.mp ?_ + rcases Nat.mul_eq_zero.mp hcount with h | h + · omega + · exact h + +theorem leastTerm_nsmul {a : NatOrdinal.{u}} (ha : a ≠ 0) {r : ℕ} (hr : 1 ≤ r) : + leastTerm (r • a) = leastTerm a := by + induction r with + | zero => omega + | succ r ih => + rcases Nat.eq_zero_or_pos r with rfl | hrpos + · simp + · rw [succ_nsmul, leastTerm_add (nsmul_ne_zero_of_ne_zero ha hrpos) ha, + ih hrpos, min_self] + +theorem removeLeastTerm_nsmul {a : NatOrdinal.{u}} (ha : a ≠ 0) {r : ℕ} + (hr : 1 ≤ r) : + removeLeastTerm a + (r - 1) • a = removeLeastTerm (r • a) := by + obtain ⟨s, rfl⟩ : ∃ s, r = s + 1 := ⟨r - 1, by omega⟩ + have hsimp : s + 1 - 1 = s := by omega + rw [hsimp] + rcases Nat.eq_zero_or_pos s with rfl | hspos + · simp + · have hs : s • a ≠ 0 := nsmul_ne_zero_of_ne_zero ha hspos + have hle : leastTerm a ≤ leastTerm (s • a) := by + rw [leastTerm_nsmul ha hspos] + rw [succ_nsmul, add_comm (s • a) a, + ← removeLeastTerm_add_of_leastTerm_le ha hs hle] + +theorem removeLeastTerm_add_of_leastTerm_ge {a b : NatOrdinal.{u}} + (ha : a ≠ 0) (hb : b ≠ 0) (hle : leastTerm b ≤ leastTerm a) : + removeLeastTerm (a + b) = a + removeLeastTerm b := by + rw [add_comm a b, removeLeastTerm_add_of_leastTerm_le hb ha hle, add_comm] + +theorem leastTerm_eq_self_of_isAdditivelyPrincipal {a : NatOrdinal.{u}} (ha : a ≠ 0) + (hprin : Ordinal.IsAdditivelyPrincipal a.val) : leastTerm a = a := by + have hzero : removeLeastTerm a = 0 := + (removeLeastTerm_eq_zero_iff ha).mpr + ((cantorTermCount_eq_one_iff ha).mpr hprin) + have hsplit := removeLeastTerm_add_leastTerm a + rwa [hzero, zero_add] at hsplit + +/-! ### Deletion on a sum with a repeated summand + +The grade `k • alpha + beta` has least Cantor term `min (leastTerm alpha) (leastTerm beta)`, by +`leastTerm_add` and `leastTerm_nsmul`, so deletion falls on whichever side attains the minimum. +The two lemmas below name the two outcomes, and the third says the second outcome can repeat only +finitely often. -/ + +theorem removeLeastTerm_nsmul_add_of_le {alpha beta : NatOrdinal.{u}} + (ha : alpha ≠ 0) (hb : beta ≠ 0) {k : ℕ} (hk : 1 ≤ k) + (hle : leastTerm alpha ≤ leastTerm beta) : + removeLeastTerm (k • alpha + beta) = + (removeLeastTerm alpha + (k - 1) • alpha) + beta := by + have hk0 : k • alpha ≠ 0 := nsmul_ne_zero_of_ne_zero ha hk + have hle' : leastTerm (k • alpha) ≤ leastTerm beta := by + rwa [leastTerm_nsmul ha hk] + rw [removeLeastTerm_add_of_leastTerm_le hk0 hb hle', removeLeastTerm_nsmul ha hk] + +theorem removeLeastTerm_nsmul_add_of_ge {alpha beta : NatOrdinal.{u}} + (ha : alpha ≠ 0) (hb : beta ≠ 0) {k : ℕ} (hk : 1 ≤ k) + (hle : leastTerm beta ≤ leastTerm alpha) : + removeLeastTerm (k • alpha + beta) = k • alpha + removeLeastTerm beta := by + have hk0 : k • alpha ≠ 0 := nsmul_ne_zero_of_ne_zero ha hk + have hle' : leastTerm beta ≤ leastTerm (k • alpha) := by + rwa [leastTerm_nsmul ha hk] + exact removeLeastTerm_add_of_leastTerm_ge hk0 hb hle' + +theorem exists_iterate_removeLeastTerm (alpha : NatOrdinal.{u}) (beta : NatOrdinal.{u}) : + ∃ j : ℕ, removeLeastTerm^[j] beta = 0 ∨ + leastTerm alpha ≤ leastTerm (removeLeastTerm^[j] beta) := by + generalize hn : cantorTermCount beta = n + induction n using Nat.strong_induction_on generalizing beta with + | _ n ih => + rcases eq_or_ne beta 0 with rfl | hb + · exact ⟨0, Or.inl rfl⟩ + rcases le_or_gt (leastTerm alpha) (leastTerm beta) with hle | hgt + · exact ⟨0, Or.inr hle⟩ + · have hlt : cantorTermCount (removeLeastTerm beta) < n := by + rw [← hn] + exact cantorTermCount_removeLeastTerm_lt hb + obtain ⟨j, hj⟩ := ih _ hlt (removeLeastTerm beta) rfl + refine ⟨j + 1, ?_⟩ + rwa [Function.iterate_succ_apply] + +theorem removeLeastTerm_add_one_eq_self_iff {a : NatOrdinal.{u}} : + removeLeastTerm a + 1 = a ↔ leastTerm a = 1 := by + constructor + · intro h + conv_rhs at h => rw [← removeLeastTerm_add_leastTerm a] + exact (_root_.add_right_injective _ h).symm + · intro h + rw [← h, removeLeastTerm_add_leastTerm] + +theorem add_ne_of_isAdditivelyPrincipal {a i j : NatOrdinal.{u}} + (ha : Ordinal.IsAdditivelyPrincipal a.val) (hi : i ≠ 0) (hj : j ≠ 0) : + i + j ≠ a := by + intro hij + have ha0 : a ≠ 0 := by + intro hzero + rw [hzero] at hij + exact hi (le_antisymm (hij ▸ le_add_right) zero_le) + have hcount : cantorTermCount a = 1 := (cantorTermCount_eq_one_iff ha0).mpr ha + rw [← hij, cantorTermCount_add] at hcount + have hi1 : cantorTermCount i ≠ 0 := fun h ↦ hi (cantorTermCount_eq_zero.mp h) + have hj1 : cantorTermCount j ≠ 0 := fun h ↦ hj (cantorTermCount_eq_zero.mp h) + omega + +theorem leastTerm_ne_zero {a : NatOrdinal.{u}} (ha : a ≠ 0) : leastTerm a ≠ 0 := by + intro hzero + have hcount := cantorTermCount_leastTerm ha + rw [hzero, cantorTermCount_zero] at hcount + omega + +theorem one_le_leastTerm {a : NatOrdinal.{u}} (ha : a ≠ 0) : 1 ≤ leastTerm a := + Order.one_le_iff_ne_zero.mpr (leastTerm_ne_zero ha) + +@[simp] +theorem leastTerm_one : leastTerm (1 : NatOrdinal.{u}) = 1 := + leastTerm_eq_self_of_isAdditivelyPrincipal one_ne_zero + (Ordinal.isAdditivelyPrincipal_iff.mpr ⟨0, by simp⟩) + +@[simp] +theorem removeLeastTerm_one : removeLeastTerm (1 : NatOrdinal.{u}) = 0 := by + have h := removeLeastTerm_add_leastTerm (1 : NatOrdinal.{u}) + rw [leastTerm_one] at h + simpa using h + +theorem removeLeastTerm_add_one {a : NatOrdinal.{u}} : + removeLeastTerm (a + 1) = a := by + rcases eq_or_ne a 0 with rfl | ha + · simp + · rw [removeLeastTerm_add_of_leastTerm_ge ha one_ne_zero + (by rw [leastTerm_one]; exact one_le_leastTerm ha), removeLeastTerm_one, add_zero] + +/-- Deletion is not strictly monotone below a grade whose least Cantor term exceeds `1`: the +grade `removeLeastTerm a + 1` is strictly below `a`, yet deletion sends it to `removeLeastTerm a` +rather than below it. -/ +theorem exists_lt_removeLeastTerm_not_lt {a : NatOrdinal.{u}} (ha : 1 < leastTerm a) : + ∃ b : NatOrdinal.{u}, b ≠ 0 ∧ b < a ∧ removeLeastTerm a ≤ removeLeastTerm b := by + refine ⟨removeLeastTerm a + 1, ?_, ?_, ?_⟩ + · intro hzero + have : (1 : NatOrdinal.{u}) ≤ removeLeastTerm a + 1 := le_add_left + rw [hzero] at this + exact absurd (le_antisymm this zero_le) one_ne_zero + · conv_rhs => rw [← removeLeastTerm_add_leastTerm a] + exact add_lt_add_of_le_of_lt le_rfl ha + · rw [removeLeastTerm_add_one] + +/-! ### Agreement with the finite-part operation -/ + +theorem additivePrincipalTerms_eq_append_one {a : NatOrdinal.{u}} + (ha : 0 < a.constantCoeff) : + (a.removeNat 1).val.additivePrincipalTerms ++ [1] = a.val.additivePrincipalTerms := by + set terms := (a.removeNat 1).val.additivePrincipalTerms with hterms + have hpred : (a.removeNat 1).val + (1 : Ordinal) = a.val := by + have h := congrArg NatOrdinal.val (removeNat_add_natCast (n := 1) ha) + calc + (a.removeNat 1).val + (1 : Ordinal) = + (a.removeNat 1).val + ((1 : ℕ) : Ordinal) := by rw [Nat.cast_one] + _ = (a.removeNat 1 + ((1 : ℕ) : NatOrdinal)).val := + (NatOrdinal.val_add_natCast (a.removeNat 1) 1).symm + _ = a.val := h + have hsum : (terms ++ [1]).sum = a.val := by + rw [List.sum_append, List.sum_singleton, hterms, + Ordinal.additivePrincipalTerms_sum] + exact hpred + have hprincipal : ∀ x ∈ terms ++ [1], IsAdditivelyPrincipal x := by + intro x hx + rw [List.mem_append, List.mem_singleton] at hx + rcases hx with hx | rfl + · exact Ordinal.isAdditivelyPrincipal_of_mem_additivePrincipalTerms hx + · simpa using Ordinal.isAdditivelyPrincipal_omega0_opow 0 + have hsorted : (terms ++ [1]).SortedGE := by + rw [List.sortedGE_iff_pairwise, List.pairwise_append] + refine ⟨List.sortedGE_iff_pairwise.mp (Ordinal.additivePrincipalTerms_sortedGE _), + by simp, ?_⟩ + intro x hx y hy + simp only [List.mem_singleton] at hy + subst y + exact Order.one_le_iff_ne_zero.mpr + (Ordinal.isAdditivelyPrincipal_of_mem_additivePrincipalTerms hx).ne_zero + exact Ordinal.additivePrincipalTerms_unique hsum hprincipal hsorted + +theorem leastTerm_eq_one_of_constantCoeff_pos {a : NatOrdinal.{u}} + (ha : 0 < a.constantCoeff) : leastTerm a = 1 := by + apply NatOrdinal.val.injective + rw [leastTerm, NatOrdinal.val_of, ← additivePrincipalTerms_eq_append_one ha] + simp + +theorem removeLeastTerm_eq_removeNat_one {a : NatOrdinal.{u}} + (ha : 0 < a.constantCoeff) : removeLeastTerm a = a.removeNat 1 := by + apply NatOrdinal.val.injective + rw [removeLeastTerm, NatOrdinal.val_of, ← additivePrincipalTerms_eq_append_one ha, + List.dropLast_concat] + exact Ordinal.additivePrincipalTerms_sum _ + +end NatOrdinal + +end diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/LeastTermSup.lean b/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/LeastTermSup.lean new file mode 100644 index 0000000000..a6270b336a --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/LeastTermSup.lean @@ -0,0 +1,142 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.LeastTerm +import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.CantorTermCount + +/-! +# Approaching a natural sum from below in one summand + +Let `λ ≠ 0` and let `σ` be an ordinal every term of whose Cantor normal form is at least the last +term `ω^e` of that of `λ`. Then every `τ < λ ⊕ σ` is bounded by some `ρ ⊕ σ` with `ρ < λ`: +`sup_{ρ < λ} (ρ ⊕ σ) = λ ⊕ σ`. Writing `λ = λ' + ω^e`, the natural sum `λ ⊕ σ` is the ordinal sum +`(λ' ⊕ σ) + ω^e`, because all terms of `λ' ⊕ σ` are at least `ω^e`; so `τ < λ' ⊕ σ`, in which +case `ρ = λ'` serves, or `τ = (λ' ⊕ σ) + ξ` with `ξ < ω^e`, in which case `ρ = λ' ⊕ ξ < λ` and +`ρ ⊕ σ ≥ τ`. Without the hypothesis on `σ` the supremum can be smaller: `sup_{ρ < ω} (ρ ⊕ 1) = ω`, +not `ω ⊕ 1`. +-/ + +open Ordinal + +universe u + +public noncomputable section + +namespace NatOrdinal + +/-- Every term of the Cantor normal form of `a ≠ 0`, with repeated terms, is at least its last +term. -/ +theorem leastTerm_le_of_mem {a : NatOrdinal.{u}} (ha : a ≠ 0) {y : Ordinal.{u}} + (hy : y ∈ a.val.additivePrincipalTerms) : leastTerm a ≤ NatOrdinal.of y := + NatOrdinal.val.le_iff_le.mp (by simpa using val_leastTerm_le_of_mem ha hy) + +/-- The terms of a natural sum are the terms of the summands. -/ +theorem mem_additivePrincipalTerms_add_iff (a b : NatOrdinal.{u}) (y : Ordinal.{u}) : + y ∈ (a + b).val.additivePrincipalTerms ↔ + y ∈ a.val.additivePrincipalTerms ∨ y ∈ b.val.additivePrincipalTerms := by + rw [(additivePrincipalTerms_add_perm a b).mem_iff, List.mem_append] + +/-- If every term of `σ` is at least the last term of `λ ≠ 0`, then every term of `λ ⊕ σ` is. -/ +theorem leastTerm_le_of_mem_add {lam sigma : NatOrdinal.{u}} (hlam : lam ≠ 0) + (hsigma : sigma = 0 ∨ leastTerm lam ≤ leastTerm sigma) {y : Ordinal.{u}} + (hy : y ∈ (lam + sigma).val.additivePrincipalTerms) : leastTerm lam ≤ NatOrdinal.of y := by + rcases (mem_additivePrincipalTerms_add_iff lam sigma y).mp hy with h | h + · exact leastTerm_le_of_mem hlam h + · rcases hsigma with rfl | hle + · rw [NatOrdinal.val_zero, additivePrincipalTerms_zero] at h + exact absurd h List.not_mem_nil + · exact hle.trans (leastTerm_le_of_mem (by rintro rfl; simp at h) h) + +/-- Let `λ ≠ 0` and let every term of the Cantor normal form of `σ` be at least the last term of +that of `λ`. Then every `τ < λ ⊕ σ` is at most `ρ ⊕ σ` for some `ρ < λ`. -/ +@[blueprint "lem:natural-sum-approach" + (phase := "Algebraic and ordinal preliminaries") + (title := "Cofinality below a Hessenberg sum") + (statement := /-- + Let $\lambda\neq0$ and $\sigma$ be ordinals such that $\sigma=0$ or every + term of the Cantor normal form of $\sigma$ is at least the last term of the + Cantor normal form of $\lambda$. Then for every $\tau<\lambda\nsum\sigma$ + there is $\rho<\lambda$ with $\tau\le\rho\nsum\sigma$. + -/) + (proof := /-- + Write $\lambda=\lambda'\mathbin\oplus\omega^e$, where $\omega^e$ is its last + Cantor-normal-form term. The hypothesis on $\sigma$ gives + $\lambda\mathbin\oplus\sigma=(\lambda'\mathbin\oplus\sigma)+\omega^e$. + If $\tau$ lies below $\lambda'\mathbin\oplus\sigma$, take $\rho=\lambda'$. + Otherwise write $\tau=(\lambda'\mathbin\oplus\sigma)+\nu$ with + $\nu<\omega^e$ and take $\rho=\lambda'\mathbin\oplus\nu$; strict + monotonicity gives $\rho<\lambda$, and ordinary addition is bounded by the + natural sum. + -/)] +theorem exists_lt_le_add_of_lastCantorTerm_le {lam sigma tau : NatOrdinal.{u}} (hlam : lam ≠ 0) + (hsigma : sigma = 0 ∨ leastTerm lam ≤ leastTerm sigma) (htau : tau < lam + sigma) : + ∃ rho < lam, tau ≤ rho + sigma := by + obtain ⟨L, hL⟩ : ∃ L, leastTerm lam = L := ⟨_, rfl⟩ + obtain ⟨lam', hlam'⟩ : ∃ lam', removeLeastTerm lam = lam' := ⟨_, rfl⟩ + have hsplit : lam' + L = lam := by rw [← hL, ← hlam']; exact removeLeastTerm_add_leastTerm lam + have hLne : L ≠ 0 := hL ▸ leastTerm_ne_zero hlam + have hLprin : IsAdditivelyPrincipal L.val := hL ▸ isAdditivelyPrincipal_leastTerm hlam + have hlam'lt : lam' < lam := by + rw [← hsplit] + exact lt_add_of_pos_right lam' (pos_iff_ne_zero.mpr hLne) + obtain ⟨A, hA⟩ : ∃ A, lam' + sigma = A := ⟨_, rfl⟩ + -- `λ ⊕ σ = A ⊕ L` is the ordinal sum `A.val + L.val`, as every term of `A` is at least `L`. + have hterms : ∀ y ∈ A.val.additivePrincipalTerms, L.val ≤ y := by + intro y hy + have hy' : y ∈ (lam + sigma).val.additivePrincipalTerms := by + rw [← hsplit, add_right_comm, hA, mem_additivePrincipalTerms_add_iff] + exact Or.inl hy + have := leastTerm_le_of_mem_add hlam hsigma hy' + rw [hL] at this + simpa using NatOrdinal.val.le_iff_le.mpr this + have hsum : lam + sigma = NatOrdinal.of (A.val + L.val) := by + rw [natOrdinal_of_add_eq_add_of_forall_le hLprin hterms, NatOrdinal.of_val, NatOrdinal.of_val, + ← hA, ← hsplit, add_right_comm] + have htau' : tau.val < A.val + L.val := by + have := NatOrdinal.val.lt_iff_lt.mpr htau + rwa [hsum, NatOrdinal.val_of] at this + rcases lt_or_ge tau.val A.val with hlt | hge + · -- `τ < A`: take `ρ = λ'`. + exact ⟨lam', hlam'lt, hA ▸ (NatOrdinal.val.lt_iff_lt.mp hlt).le⟩ + · -- `τ = A + ξ` with `ξ < L`: take `ρ = λ' ⊕ ξ`. + obtain ⟨ξ, hξ⟩ : ∃ ξ, tau.val - A.val = ξ := ⟨_, rfl⟩ + have hτξ : A.val + ξ = tau.val := by rw [← hξ]; exact Ordinal.add_sub_cancel_of_le hge + have hξL : ξ < L.val := by + rw [← hξ, Ordinal.sub_lt_of_le hge] + exact htau' + refine ⟨lam' + NatOrdinal.of ξ, ?_, ?_⟩ + · have hξL' : NatOrdinal.of ξ < L := by + rw [← NatOrdinal.val.lt_iff_lt, NatOrdinal.val_of] + exact hξL + calc lam' + NatOrdinal.of ξ < lam' + L := by gcongr + _ = lam := hsplit + · calc tau = NatOrdinal.of (A.val + ξ) := by rw [hτξ, NatOrdinal.of_val] + _ ≤ A + NatOrdinal.of ξ := by + have := oadd_le_add A (NatOrdinal.of ξ) + rwa [NatOrdinal.val_of] at this + _ = lam' + NatOrdinal.of ξ + sigma := by rw [← hA, add_right_comm] + +/-- For a successor `λ`, every `τ < λ ⊕ σ` is at most `ρ ⊕ σ` with `ρ := λ ⊖ 1 < λ`, whatever +`σ`. -/ +theorem exists_lt_le_add_of_constantCoeff_pos {lam sigma tau : NatOrdinal.{u}} + (hlam : 0 < lam.constantCoeff) (htau : tau < lam + sigma) : + ∃ rho < lam, tau ≤ rho + sigma := by + have hrho : lam = removeLeastTerm lam + 1 := by + have := removeLeastTerm_add_leastTerm lam + rwa [leastTerm_eq_one_of_constantCoeff_pos hlam, eq_comm] at this + refine ⟨removeLeastTerm lam, ?_, ?_⟩ + · calc removeLeastTerm lam < removeLeastTerm lam + 1 := lt_add_one _ + _ = lam := hrho.symm + · have htau' : tau < removeLeastTerm lam + sigma + 1 := by + calc tau < lam + sigma := htau + _ = removeLeastTerm lam + 1 + sigma := by rw [← hrho] + _ = removeLeastTerm lam + sigma + 1 := add_right_comm _ _ _ + exact Order.lt_add_one_iff.mp htau' + +end NatOrdinal diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/MultiplicativelyPrincipal.lean b/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/MultiplicativelyPrincipal.lean new file mode 100644 index 0000000000..821c395861 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/MultiplicativelyPrincipal.lean @@ -0,0 +1,610 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.AdditivelyPrincipal + +import LeanPool.ConwayRefinement.CombinatorialGames.NatOrdinal.Pow +import Mathlib.Algebra.Order.SuccPred +import Mathlib.Tactic.NormNum + +/-! +# Multiplicatively principal ordinal factors + +Berarducci, Definition 3.6 calls a positive ordinal multiplicatively principal when the ordinals +strictly below it are closed under ordinary ordinal multiplication. Under that exact definition, +the finite ordinal `2` is multiplicatively principal. Thus Berarducci, Fact 3.8 omits the case `2` +when it lists only `1` and ordinals of the form `ω ^ (ω ^ e)`. This module records the exact +classification, including `2`, and separately names the infinite multiplicatively principal +ordinals used as factors in Definition 6.4. + +For a positive additive-principal ordinal above one, its exponent has a nonempty uncompressed +Cantor normal form. Exponentiating those Cantor terms by `ω` gives the unique nonincreasing list +of multiplicatively principal factors greater than one. The ordinary ordinal product of the list +is the original ordinal. The corresponding Hessenberg product in `NatOrdinal` has the same value, +as asserted in Berarducci, Remark 6.5. + +The subtype `Ordinal.AdditivePrincipalAboveOne` is the exact domain of Berarducci's principal and +residual factor operations. Consequently neither operation uses an arbitrary value outside its +mathematical domain. The residual factor is the product of all but the final factor, so it is one +when the factor list is a singleton. + +Mathlib supplies the ordinary principal-ordinal classification and ordinal logarithm. +CombinatorialGames supplies Hessenberg arithmetic on `NatOrdinal`. Neither dependency supplies the +finite factor list or the principal and residual projections. +-/ + +universe u + +open scoped NatOrdinal + +public noncomputable section + +namespace Ordinal + +/-- Berarducci's positive convention for multiplicatively principal ordinals. -/ +def IsMultiplicativelyPrincipal (o : Ordinal) : Prop := + 0 < o ∧ IsPrincipal (· * ·) o + +/-- The exact relationship with Mathlib's convention, which also includes zero. -/ +theorem isMultiplicativelyPrincipal_iff_pos_and_isPrincipal_mul {o : Ordinal} : + IsMultiplicativelyPrincipal o ↔ 0 < o ∧ IsPrincipal (· * ·) o := + Iff.rfl + +/-- One is multiplicatively principal in Berarducci's convention. -/ +theorem isMultiplicativelyPrincipal_one : + IsMultiplicativelyPrincipal 1 := + ⟨zero_lt_one, isPrincipal_mul_one⟩ + +/-- Two is multiplicatively principal under the predicate printed in Berarducci, Definition 3.6. -/ +theorem isMultiplicativelyPrincipal_two : + IsMultiplicativelyPrincipal 2 := + ⟨by norm_num, isPrincipal_mul_two⟩ + +/-- Every ordinal of the infinite shape in Berarducci, Fact 3.8 is multiplicatively principal. -/ +theorem isMultiplicativelyPrincipal_omega0_opow_opow (e : Ordinal) : + IsMultiplicativelyPrincipal (omega0 ^ omega0 ^ e) := + ⟨opow_pos _ omega0_pos, isPrincipal_mul_omega0_opow_opow e⟩ + +/-- Corrected classification of Berarducci's multiplicatively principal ordinals. The additional +case `2` is forced by the printed predicate. -/ +theorem isMultiplicativelyPrincipal_iff_one_or_two_or_omega0_opow_opow + {o : Ordinal} : + IsMultiplicativelyPrincipal o ↔ + o = 1 ∨ o = 2 ∨ ∃ e : Ordinal, o = omega0 ^ omega0 ^ e := by + rw [IsMultiplicativelyPrincipal, isPrincipal_mul_iff_le_two_or_omega0_opow_opow] + constructor + · rintro ⟨ho, hsmall | ⟨e, he⟩⟩ + · obtain rfl | rfl | rfl := Order.le_two_iff.mp hsmall + · exact (lt_irrefl 0 ho).elim + · exact Or.inl rfl + · exact Or.inr (Or.inl rfl) + · exact Or.inr (Or.inr ⟨e, he.symm⟩) + · rintro (rfl | rfl | ⟨e, rfl⟩) + · exact ⟨zero_lt_one, Or.inl (by norm_num)⟩ + · exact ⟨by norm_num, Or.inl le_rfl⟩ + · exact ⟨opow_pos _ omega0_pos, Or.inr ⟨e, rfl⟩⟩ + +/-- An infinite multiplicatively principal ordinal, namely an ordinal of the form +`ω ^ (ω ^ e)`. These are the factors occurring in Berarducci, Definition 6.4. -/ +def IsInfiniteMultiplicativelyPrincipal (o : Ordinal) : Prop := + ∃ e : Ordinal, o = omega0 ^ omega0 ^ e + +/-- Characterization of infinite multiplicatively principal ordinals by their defining shape. -/ +theorem isInfiniteMultiplicativelyPrincipal_iff {o : Ordinal} : + IsInfiniteMultiplicativelyPrincipal o ↔ ∃ e : Ordinal, o = omega0 ^ omega0 ^ e := + (Iff.rfl) + +/-- Every ordinal of the defining infinite shape is infinite multiplicatively principal. -/ +theorem isInfiniteMultiplicativelyPrincipal_omega0_opow_opow (e : Ordinal) : + IsInfiniteMultiplicativelyPrincipal (omega0 ^ omega0 ^ e) := + ⟨e, rfl⟩ + +/-- Every infinite multiplicatively principal ordinal is a nonzero limit ordinal. -/ +theorem IsInfiniteMultiplicativelyPrincipal.isSuccLimit {o : Ordinal} + (ho : IsInfiniteMultiplicativelyPrincipal o) : + Order.IsSuccLimit o := by + obtain ⟨e, rfl⟩ := ho + exact isSuccLimit_opow_left isSuccLimit_omega0 (opow_ne_zero e omega0_ne_zero) + +/-- Every infinite multiplicatively principal ordinal is additively principal. -/ +theorem IsInfiniteMultiplicativelyPrincipal.isAdditivelyPrincipal {o : Ordinal} + (ho : IsInfiniteMultiplicativelyPrincipal o) : + IsAdditivelyPrincipal o := by + obtain ⟨e, rfl⟩ := ho + exact isAdditivelyPrincipal_omega0_opow (omega0 ^ e) + +/-- Infinite multiplicative principality is multiplicative principality together with exclusion +of the exceptional values one and two. -/ +theorem isInfiniteMultiplicativelyPrincipal_iff_two_lt_and_isMultiplicativelyPrincipal + {o : Ordinal} : + IsInfiniteMultiplicativelyPrincipal o ↔ + 2 < o ∧ IsMultiplicativelyPrincipal o := by + constructor + · rintro ⟨e, rfl⟩ + refine ⟨?_, isMultiplicativelyPrincipal_omega0_opow_opow e⟩ + apply (natCast_lt_omega0 2).trans_le + simpa [opow_one] using + (opow_le_opow_right omega0_pos (Order.one_le_iff_ne_zero.mpr <| + opow_ne_zero e omega0_ne_zero)) + · rintro ⟨htwo, hp⟩ + rcases isMultiplicativelyPrincipal_iff_one_or_two_or_omega0_opow_opow.mp hp with + rfl | rfl | ⟨e, he⟩ + · exact (not_lt_of_ge (by norm_num) htwo).elim + · exact (lt_irrefl 2 htwo).elim + · exact ⟨e, he⟩ + +/-- The multiplicatively principal factors obtained from the uncompressed Cantor normal form of +the exponent of `o`. -/ +noncomputable def multiplicativePrincipalFactors (o : Ordinal) : List Ordinal := + (additivePrincipalTerms (log omega0 o)).map (omega0 ^ ·) + +private theorem prod_map_omega0_opow (l : List Ordinal) : + (l.map (omega0 ^ ·)).prod = omega0 ^ l.sum := by + induction l with + | nil => simp + | cons a l ih => + simp only [List.map_cons, List.prod_cons, List.sum_cons, ih, opow_add] + +/-- The ordinary product of the canonical factors of an additive-principal ordinal is the +original ordinal. -/ +theorem multiplicativePrincipalFactors_prod {o : Ordinal} + (ho : IsAdditivelyPrincipal o) : + o.multiplicativePrincipalFactors.prod = o := by + obtain ⟨e, rfl⟩ := isAdditivelyPrincipal_iff.mp ho + rw [multiplicativePrincipalFactors, log_opow one_lt_omega0, + prod_map_omega0_opow, additivePrincipalTerms_sum] + +/-- An additive-principal ordinal above one has at least one canonical multiplicative factor. -/ +theorem multiplicativePrincipalFactors_ne_nil {o : Ordinal} + (ho : IsAdditivelyPrincipal o) (hone : 1 < o) : + o.multiplicativePrincipalFactors ≠ [] := by + obtain ⟨e, rfl⟩ := isAdditivelyPrincipal_iff.mp ho + have he : e ≠ 0 := by + intro he + subst e + simp at hone + rw [multiplicativePrincipalFactors, log_opow one_lt_omega0] + intro hnil + have hterms : additivePrincipalTerms e = [] := List.map_eq_nil_iff.mp hnil + have hsum := additivePrincipalTerms_sum e + rw [hterms] at hsum + exact he hsum.symm + +/-- The canonical multiplicative factors occur in nonincreasing order. -/ +theorem multiplicativePrincipalFactors_sortedGE (o : Ordinal) : + o.multiplicativePrincipalFactors.SortedGE := by + rw [multiplicativePrincipalFactors, List.sortedGE_iff_pairwise, List.pairwise_map] + have hsorted := additivePrincipalTerms_sortedGE (log omega0 o) + rw [List.sortedGE_iff_pairwise] at hsorted + exact hsorted.imp fun hab ↦ opow_le_opow_right omega0_pos hab + +/-- Every canonical factor is an infinite multiplicatively principal ordinal. -/ +theorem isInfiniteMultiplicativelyPrincipal_of_mem_multiplicativePrincipalFactors + {o f : Ordinal} (hf : f ∈ o.multiplicativePrincipalFactors) : + IsInfiniteMultiplicativelyPrincipal f := by + rw [multiplicativePrincipalFactors, List.mem_map] at hf + obtain ⟨e, he, rfl⟩ := hf + obtain ⟨a, rfl⟩ := + isAdditivelyPrincipal_iff.mp + (isAdditivelyPrincipal_of_mem_additivePrincipalTerms he) + exact ⟨a, rfl⟩ + +/-- Every canonical factor is multiplicatively principal under the exact source predicate. -/ +theorem isMultiplicativelyPrincipal_of_mem_multiplicativePrincipalFactors + {o f : Ordinal} (hf : f ∈ o.multiplicativePrincipalFactors) : + IsMultiplicativelyPrincipal f := + (isInfiniteMultiplicativelyPrincipal_iff_two_lt_and_isMultiplicativelyPrincipal.mp + (isInfiniteMultiplicativelyPrincipal_of_mem_multiplicativePrincipalFactors hf)).2 + +/-- Every canonical factor is strictly greater than one. -/ +theorem one_lt_of_mem_multiplicativePrincipalFactors + {o f : Ordinal} (hf : f ∈ o.multiplicativePrincipalFactors) : + 1 < f := + (show (1 : Ordinal) < 2 by norm_num).trans <| + (isInfiniteMultiplicativelyPrincipal_iff_two_lt_and_isMultiplicativelyPrincipal.mp + (isInfiniteMultiplicativelyPrincipal_of_mem_multiplicativePrincipalFactors hf)).1 + +private theorem multiplicativePrincipalFactors_unique_of_infinite + {o : Ordinal} {l : List Ordinal} + (hsum : l.prod = o) + (hprincipal : ∀ f ∈ l, IsInfiniteMultiplicativelyPrincipal f) + (hsorted : l.SortedGE) : + l = o.multiplicativePrincipalFactors := by + let exponents := l.map (log omega0) + have hprincipalExponents : ∀ e ∈ exponents, IsAdditivelyPrincipal e := by + intro e he + change e ∈ l.map (log omega0) at he + rw [List.mem_map] at he + obtain ⟨f, hf, rfl⟩ := he + obtain ⟨a, rfl⟩ := hprincipal f hf + rw [log_opow one_lt_omega0] + exact isAdditivelyPrincipal_omega0_opow a + have hsortedExponents : exponents.SortedGE := by + change (l.map (log omega0)).SortedGE + rw [List.sortedGE_iff_pairwise, List.pairwise_map] + have hpairwise := List.sortedGE_iff_pairwise.mp hsorted + exact hpairwise.imp fun hab ↦ log_mono_right omega0 hab + have hprod : l.prod = omega0 ^ exponents.sum := by + have hreconstruct : l = l.map (fun f ↦ omega0 ^ log omega0 f) := by + have hmap : l.map id = l.map (fun f ↦ omega0 ^ log omega0 f) := by + apply List.map_congr_left + intro f hf + obtain ⟨a, rfl⟩ := hprincipal f hf + simp [log_opow one_lt_omega0] + simpa using hmap + calc + l.prod = (l.map fun f ↦ omega0 ^ log omega0 f).prod := + congrArg List.prod hreconstruct + _ = omega0 ^ (l.map (log omega0)).sum := by + simpa [Function.comp_def] using + prod_map_omega0_opow (l.map (log omega0)) + _ = omega0 ^ exponents.sum := rfl + have hoPrincipal : IsAdditivelyPrincipal o := + isAdditivelyPrincipal_iff.mpr ⟨exponents.sum, hsum.symm.trans hprod⟩ + obtain ⟨e, rfl⟩ := isAdditivelyPrincipal_iff.mp hoPrincipal + have hexponents : exponents = additivePrincipalTerms e := by + apply additivePrincipalTerms_unique + · apply (opow_right_inj one_lt_omega0).mp + calc + omega0 ^ exponents.sum = l.prod := hprod.symm + _ = omega0 ^ e := hsum + · exact hprincipalExponents + · exact hsortedExponents + rw [multiplicativePrincipalFactors, log_opow one_lt_omega0, ← hexponents] + change l = (l.map (log omega0)).map (omega0 ^ ·) + rw [List.map_map] + have hmap : l.map id = l.map ((omega0 ^ ·) ∘ log omega0) := by + apply List.map_congr_left + intro f hf + obtain ⟨a, rfl⟩ := hprincipal f hf + simp [Function.comp_apply, log_opow one_lt_omega0] + simpa using hmap + +/-- The canonical factor list is the unique nonincreasing list of source-multiplicatively-principal +ordinals greater than one with the prescribed additive-principal product. -/ +theorem multiplicativePrincipalFactors_unique {o : Ordinal} {l : List Ordinal} + (ho : IsAdditivelyPrincipal o) + (hsum : l.prod = o) + (hprincipal : ∀ f ∈ l, IsMultiplicativelyPrincipal f) + (hone : ∀ f ∈ l, 1 < f) + (hsorted : l.SortedGE) : + l = o.multiplicativePrincipalFactors := by + have hnoTwo : (2 : Ordinal) ∉ l := by + intro htwo + have hne : l ≠ [] := List.ne_nil_of_mem htwo + let last := l.getLast hne + have hlastMem : last ∈ l := List.getLast_mem hne + have hpairwise := List.sortedGE_iff_pairwise.mp hsorted + have hlastLe : last ≤ 2 := hpairwise.rel_getLast htwo + have htwoLe : (2 : Ordinal) ≤ last := by + simpa [one_add_one_eq_two] using + (Order.add_one_le_iff.mpr (hone last hlastMem)) + have hlast : last = 2 := le_antisymm hlastLe htwoLe + let front := l.dropLast + have hfrontPos : 0 < front.prod := by + have hprodPos : ∀ (m : List Ordinal), + (∀ f ∈ m, 0 < f) → 0 < m.prod := by + intro m hm + induction m with + | nil => exact zero_lt_one + | cons f m ih => + rw [List.prod_cons] + exact mul_pos (hm f (by simp)) + (ih fun g hg ↦ hm g (by simp [hg])) + apply hprodPos + intro f hf + exact zero_lt_one.trans (hone f (List.mem_of_mem_dropLast hf)) + have hsplit : front.prod * last = l.prod := by + calc + front.prod * last = (front ++ [last]).prod := by simp + _ = l.prod := by + congr 1 + exact List.dropLast_append_getLast hne + have hfrontMulTwo : front.prod * 2 = o := by + rw [← hlast, hsplit, hsum] + have hfrontLt : front.prod < o := by + rw [← hfrontMulTwo] + simpa using mul_lt_mul_of_pos_left (show (1 : Ordinal) < 2 by norm_num) + hfrontPos + have hclosed := + (isAdditivelyPrincipal_iff_ne_zero_and_isPrincipal_add.mp ho).2 hfrontLt hfrontLt + change front.prod + front.prod < o at hclosed + rw [← Ordinal.mul_two, hfrontMulTwo] at hclosed + exact lt_irrefl o hclosed + apply multiplicativePrincipalFactors_unique_of_infinite hsum + · intro f hf + rcases isMultiplicativelyPrincipal_iff_one_or_two_or_omega0_opow_opow.mp + (hprincipal f hf) with rfl | rfl | ⟨e, he⟩ + · exact (lt_irrefl 1 (hone 1 hf)).elim + · exact (hnoTwo hf).elim + · exact ⟨e, he⟩ + · exact hsorted + +/-- An infinite multiplicatively principal ordinal has itself as its sole canonical factor. -/ +theorem multiplicativePrincipalFactors_eq_singleton + {o : Ordinal} (ho : IsInfiniteMultiplicativelyPrincipal o) : + o.multiplicativePrincipalFactors = [o] := by + symm + apply multiplicativePrincipalFactors_unique_of_infinite (o := o) + · simp + · intro f hf + rw [List.mem_singleton] at hf + subst f + exact ho + · simp [List.sortedGE_iff_pairwise] + +private theorem naturalProd_map_omega0_opow (l : List Ordinal) : + (l.map (fun e ↦ NatOrdinal.of (omega0 ^ e))).prod = + ω^ (l.map NatOrdinal.of).sum := by + induction l with + | nil => simp + | cons a l ih => + rw [List.map_cons, List.prod_cons, ih, List.map_cons, List.sum_cons, + NatOrdinal.of_omega0_opow, NatOrdinal.wpow_add] + +private theorem naturalProd_factors_eq_of_ordinaryProd {l : List Ordinal} + (hprincipal : ∀ a ∈ l, IsAdditivelyPrincipal a) + (hsorted : l.SortedGE) : + (l.map (fun e ↦ NatOrdinal.of (omega0 ^ e))).prod = + NatOrdinal.of (l.map (omega0 ^ ·)).prod := by + rw [naturalProd_map_omega0_opow, prod_map_omega0_opow, + NatOrdinal.of_omega0_opow, + natOrdinal_of_sum_eq_sum_map_of_sorted hprincipal hsorted] + +private theorem multiplicativePrincipalFactors_naturalProd_eq_of_prod (o : Ordinal) : + (o.multiplicativePrincipalFactors.map NatOrdinal.of).prod = + NatOrdinal.of o.multiplicativePrincipalFactors.prod := by + rw [multiplicativePrincipalFactors, List.map_map] + apply naturalProd_factors_eq_of_ordinaryProd + · exact fun _ ha ↦ isAdditivelyPrincipal_of_mem_additivePrincipalTerms ha + · exact additivePrincipalTerms_sortedGE _ + +/-- The Hessenberg product of the canonical factors agrees with their ordinary product and equals +the original additive-principal ordinal. This is the product agreement used in Berarducci, +Remark 6.5. -/ +theorem multiplicativePrincipalFactors_naturalProd {o : Ordinal} + (ho : IsAdditivelyPrincipal o) : + (o.multiplicativePrincipalFactors.map NatOrdinal.of).prod = NatOrdinal.of o := by + rw [multiplicativePrincipalFactors_naturalProd_eq_of_prod, + multiplicativePrincipalFactors_prod ho] + +/-- The exact domain on which Berarducci's principal and residual factors are defined. -/ +abbrev AdditivePrincipalAboveOne := + {o : Ordinal // IsAdditivelyPrincipal o ∧ 1 < o} + +namespace AdditivePrincipalAboveOne + +private theorem sortedGE_dropLast {l : List Ordinal} (hl : l.SortedGE) : + l.dropLast.SortedGE := by + rw [List.sortedGE_iff_pairwise] at hl ⊢ + induction l with + | nil => simp + | cons a l ih => + cases l with + | nil => simp + | cons b l => + rw [List.dropLast_cons_of_ne_nil (by simp), List.pairwise_cons] + exact ⟨fun c hc ↦ (List.pairwise_cons.mp hl).1 c + (List.mem_of_mem_dropLast hc), + ih (List.pairwise_cons.mp hl).2⟩ + +/-- The final, hence least, factor in the canonical multiplicative factor list. -/ +noncomputable def principalFactor (o : AdditivePrincipalAboveOne) : Ordinal := + o.1.multiplicativePrincipalFactors.getLast + (multiplicativePrincipalFactors_ne_nil o.2.1 o.2.2) + +/-- The ordinary product of all canonical multiplicative factors except the final one. -/ +noncomputable def residualFactor (o : AdditivePrincipalAboveOne) : Ordinal := + o.1.multiplicativePrincipalFactors.dropLast.prod + +/-- The principal factor is the final element of the nonempty canonical factor list. -/ +theorem principalFactor_eq_getLast (o : AdditivePrincipalAboveOne) : + o.principalFactor = o.1.multiplicativePrincipalFactors.getLast + (multiplicativePrincipalFactors_ne_nil o.2.1 o.2.2) := + (rfl) + +/-- The residual factor is the ordinary product of the canonical factor list without its final +element. -/ +theorem residualFactor_eq_dropLast_prod (o : AdditivePrincipalAboveOne) : + o.residualFactor = o.1.multiplicativePrincipalFactors.dropLast.prod := + (rfl) + +/-- The ordinary product of the residual and principal factors recovers the original ordinal. -/ +theorem residualFactor_mul_principalFactor (o : AdditivePrincipalAboveOne) : + o.residualFactor * o.principalFactor = o.1 := by + let hne := multiplicativePrincipalFactors_ne_nil o.2.1 o.2.2 + calc + o.residualFactor * o.principalFactor = + (o.1.multiplicativePrincipalFactors.dropLast ++ + [o.1.multiplicativePrincipalFactors.getLast hne]).prod := by + simp [residualFactor, principalFactor] + _ = o.1.multiplicativePrincipalFactors.prod := by + rw [List.dropLast_append_getLast hne] + _ = o.1 := multiplicativePrincipalFactors_prod o.2.1 + +/-- The principal factor belongs to the canonical factor list. -/ +theorem principalFactor_mem_factors (o : AdditivePrincipalAboveOne) : + o.principalFactor ∈ o.1.multiplicativePrincipalFactors := by + rw [principalFactor] + exact List.getLast_mem _ + +/-- The principal factor is an infinite multiplicatively principal ordinal. -/ +theorem principalFactor_isInfiniteMultiplicativelyPrincipal + (o : AdditivePrincipalAboveOne) : + IsInfiniteMultiplicativelyPrincipal o.principalFactor := + isInfiniteMultiplicativelyPrincipal_of_mem_multiplicativePrincipalFactors + o.principalFactor_mem_factors + +/-- The principal factor is multiplicatively principal under Berarducci's exact predicate. -/ +theorem principalFactor_isMultiplicativelyPrincipal (o : AdditivePrincipalAboveOne) : + IsMultiplicativelyPrincipal o.principalFactor := + isMultiplicativelyPrincipal_of_mem_multiplicativePrincipalFactors + o.principalFactor_mem_factors + +/-- The principal factor is strictly greater than one. -/ +theorem one_lt_principalFactor (o : AdditivePrincipalAboveOne) : + 1 < o.principalFactor := + one_lt_of_mem_multiplicativePrincipalFactors o.principalFactor_mem_factors + +/-- The residual factor is positive additive principal; in particular, it may equal one. -/ +theorem residualFactor_isAdditivelyPrincipal (o : AdditivePrincipalAboveOne) : + IsAdditivelyPrincipal o.residualFactor := by + apply isAdditivelyPrincipal_iff.mpr + refine ⟨(additivePrincipalTerms (log omega0 o.1)).dropLast.sum, ?_⟩ + have hdrop : + ((additivePrincipalTerms (log omega0 o.1)).map (omega0 ^ ·)).dropLast = + (additivePrincipalTerms (log omega0 o.1)).dropLast.map (omega0 ^ ·) := by + induction additivePrincipalTerms (log omega0 o.1) with + | nil => rfl + | cons a l ih => cases l <;> simp_all + rw [residualFactor, multiplicativePrincipalFactors, hdrop, prod_map_omega0_opow] + +/-- If the original ordinal is already infinite multiplicatively principal, its principal factor +is the ordinal itself. -/ +theorem principalFactor_eq_self_of_isInfiniteMultiplicativelyPrincipal + (o : AdditivePrincipalAboveOne) + (ho : IsInfiniteMultiplicativelyPrincipal o.1) : + o.principalFactor = o.1 := by + rw [principalFactor] + let hne := multiplicativePrincipalFactors_ne_nil o.2.1 o.2.2 + calc + o.1.multiplicativePrincipalFactors.getLast hne = + [o.1].getLast (by simp) := + List.getLast_congr _ _ (multiplicativePrincipalFactors_eq_singleton ho) + _ = o.1 := rfl + +/-- If the original ordinal is already infinite multiplicatively principal, its residual factor +is one, as stipulated in Berarducci, Definition 6.4. -/ +theorem residualFactor_eq_one_of_isInfiniteMultiplicativelyPrincipal + (o : AdditivePrincipalAboveOne) + (ho : IsInfiniteMultiplicativelyPrincipal o.1) : + o.residualFactor = 1 := by + rw [residualFactor, multiplicativePrincipalFactors_eq_singleton ho] + rfl + +private theorem naturalProd_dropLastFactors_eq_residualFactor + (o : AdditivePrincipalAboveOne) : + (o.1.multiplicativePrincipalFactors.dropLast.map NatOrdinal.of).prod = + NatOrdinal.of o.residualFactor := by + let terms := additivePrincipalTerms (log omega0 o.1) + have hdrop : + (terms.map (omega0 ^ ·)).dropLast = terms.dropLast.map (omega0 ^ ·) := by + induction terms with + | nil => rfl + | cons a l ih => cases l <;> simp_all + rw [residualFactor, multiplicativePrincipalFactors, show + additivePrincipalTerms (log omega0 o.1) = terms from rfl, hdrop, List.map_map] + apply naturalProd_factors_eq_of_ordinaryProd + · intro a ha + exact isAdditivelyPrincipal_of_mem_additivePrincipalTerms + (List.mem_of_mem_dropLast ha) + · exact sortedGE_dropLast (additivePrincipalTerms_sortedGE _) + +/-- The Hessenberg product of the residual and principal factors also recovers the original +ordinal. -/ +theorem naturalResidual_mul_naturalPrincipal (o : AdditivePrincipalAboveOne) : + NatOrdinal.of o.residualFactor * NatOrdinal.of o.principalFactor = + NatOrdinal.of o.1 := by + let factors := o.1.multiplicativePrincipalFactors + let hne := multiplicativePrincipalFactors_ne_nil o.2.1 o.2.2 + calc + NatOrdinal.of o.residualFactor * NatOrdinal.of o.principalFactor = + (factors.dropLast.map NatOrdinal.of).prod * + NatOrdinal.of (factors.getLast hne) := by + rw [naturalProd_dropLastFactors_eq_residualFactor, principalFactor] + _ = (factors.dropLast.map NatOrdinal.of ++ + [NatOrdinal.of (factors.getLast hne)]).prod := by simp + _ = (factors.map NatOrdinal.of).prod := by + have hmap : factors.dropLast.map NatOrdinal.of ++ + [NatOrdinal.of (factors.getLast hne)] = factors.map NatOrdinal.of := by + rw [← List.map_singleton, ← List.map_append, + List.dropLast_append_getLast hne] + rw [hmap] + _ = NatOrdinal.of factors.prod := + multiplicativePrincipalFactors_naturalProd_eq_of_prod o.1 + _ = NatOrdinal.of o.1 := by rw [multiplicativePrincipalFactors_prod o.2.1] + +/-- The principal factor is the least canonical factor. -/ +theorem principalFactor_le_of_mem_factors (o : AdditivePrincipalAboveOne) + {f : Ordinal} (hf : f ∈ o.1.multiplicativePrincipalFactors) : + o.principalFactor ≤ f := by + rw [principalFactor] + have hpairwise := List.sortedGE_iff_pairwise.mp + (multiplicativePrincipalFactors_sortedGE o.1) + exact hpairwise.rel_getLast hf + +/-- The canonical multiplicative factors are the powers of `ω` at the Cantor terms of the +logarithm. -/ +theorem multiplicativePrincipalFactors_eq (o : AdditivePrincipalAboveOne) : + o.1.multiplicativePrincipalFactors = + (log omega0 o.1).additivePrincipalTerms.map (omega0 ^ ·) := + (rfl) + +theorem log_principalFactor_le_of_mem_terms (o : AdditivePrincipalAboveOne) + {t : Ordinal} (ht : t ∈ (log omega0 o.1).additivePrincipalTerms) : + log omega0 o.principalFactor ≤ t := by + have hmem : omega0 ^ t ∈ o.1.multiplicativePrincipalFactors := by + rw [multiplicativePrincipalFactors_eq] + exact List.mem_map_of_mem ht + have hle := o.principalFactor_le_of_mem_factors hmem + have hprin : IsAdditivelyPrincipal o.principalFactor := + o.principalFactor_isInfiniteMultiplicativelyPrincipal.isAdditivelyPrincipal + rw [← hprin.opow_log_self] at hle + exact (opow_le_opow_iff_right one_lt_omega0).mp hle + +theorem log_principalFactor_mem_terms (o : AdditivePrincipalAboveOne) : + log omega0 o.principalFactor ∈ (log omega0 o.1).additivePrincipalTerms := by + have hmem := o.principalFactor_mem_factors + rw [multiplicativePrincipalFactors_eq, List.mem_map] at hmem + obtain ⟨t, ht, hteq⟩ := hmem + rw [← hteq, log_opow one_lt_omega0] + exact ht + +theorem mem_terms_of_mem_terms_log_residualFactor (o : AdditivePrincipalAboveOne) + {t : Ordinal} (ht : t ∈ (log omega0 o.residualFactor).additivePrincipalTerms) : + t ∈ (log omega0 o.1).additivePrincipalTerms := by + set L := (log omega0 o.1).additivePrincipalTerms with hLdef + have hdrop : (L.map (omega0 ^ ·)).dropLast = L.dropLast.map (omega0 ^ ·) := by + induction L with + | nil => rfl + | cons a l ih => cases l <;> simp_all + have hres : o.residualFactor = omega0 ^ L.dropLast.sum := by + rw [residualFactor_eq_dropLast_prod, multiplicativePrincipalFactors_eq, ← hLdef, hdrop, + prod_map_omega0_opow] + have hlog : log omega0 o.residualFactor = L.dropLast.sum := by + rw [hres, log_opow one_lt_omega0] + have hsub : L.dropLast.Sublist L := List.dropLast_sublist L + have hsorted : L.dropLast.SortedGE := + List.sortedGE_iff_pairwise.mpr + ((List.sortedGE_iff_pairwise.mp (additivePrincipalTerms_sortedGE _)).sublist hsub) + have hprin : ∀ a ∈ L.dropLast, IsAdditivelyPrincipal a := fun a ha ↦ + isAdditivelyPrincipal_of_mem_additivePrincipalTerms (hsub.mem ha) + have huniq := additivePrincipalTerms_unique (o := L.dropLast.sum) rfl hprin hsorted + rw [hlog, ← huniq] at ht + exact hsub.mem ht + +/-- Berarducci, Remark 6.7: the principal factor of the residual factor is at least the principal +factor itself. -/ +theorem principalFactor_le_principalFactor_of_eq_residualFactor + (o r : AdditivePrincipalAboveOne) (hr : r.1 = o.residualFactor) : + o.principalFactor ≤ r.principalFactor := by + have hmem := r.principalFactor_mem_factors + rw [multiplicativePrincipalFactors_eq] at hmem + obtain ⟨t, ht, hteq⟩ := List.mem_map.mp hmem + rw [hr] at ht + have htO : t ∈ (log omega0 o.1).additivePrincipalTerms := + o.mem_terms_of_mem_terms_log_residualFactor ht + have hle := o.log_principalFactor_le_of_mem_terms htO + have hprin : IsAdditivelyPrincipal o.principalFactor := + o.principalFactor_isInfiniteMultiplicativelyPrincipal.isAdditivelyPrincipal + calc o.principalFactor = omega0 ^ log omega0 o.principalFactor := hprin.opow_log_self.symm + _ ≤ omega0 ^ t := opow_le_opow_right omega0_pos hle + _ = r.principalFactor := hteq + +end AdditivePrincipalAboveOne + +end Ordinal diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/NaturalOrder.lean b/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/NaturalOrder.lean new file mode 100644 index 0000000000..8ab07f471c --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/NaturalOrder.lean @@ -0,0 +1,27 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.CombinatorialGames.NatOrdinal.Basic +public import Mathlib.Algebra.Order.GroupWithZero.Canonical + +/-! +# The ordered multiplicative monoid of natural ordinals + +Natural ordinal multiplication is commutative and strictly order-preserving away from zero. +This supplies the bundled ordered monoid with zero used by Mathlib valuations, retaining the +existing natural operations and order. +-/ + +public noncomputable section +namespace NatOrdinal + +instance instLinearOrderedCommMonoidWithZero : LinearOrderedCommMonoidWithZero NatOrdinal where + bot := 0 + bot_le := fun _ ↦ zero_le + isBot_zero := fun _ ↦ zero_le + +end NatOrdinal diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/NaturalPowerFactorization.lean b/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/NaturalPowerFactorization.lean new file mode 100644 index 0000000000..3a54204552 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/NaturalPowerFactorization.lean @@ -0,0 +1,140 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.MultiplicativelyPrincipal + +/-! +# Canonical factors in natural powers + +The natural power of an additive-principal ordinal, multiplied by its residual factor, +has no canonical multiplicative factor below the original principal factor. Ordinary and natural +multiplication by that principal factor therefore agree. An additional ordinal with a larger +principal factor preserves this assertion. + +These are the ordinal calculations used in the cancellation argument of Berarducci, Lemma 8.2; +they do not depend on a series ring or a valuation. +-/ + +public noncomputable section +open Ordinal +universe u + +namespace Ordinal +private def GoodAt (w : Ordinal.{u}) (Y : NatOrdinal.{u}) : Prop := + IsAdditivelyPrincipal Y.val ∧ + ∀ t ∈ (log omega0 Y.val).additivePrincipalTerms, w ≤ t + +private theorem GoodAt.one (w : Ordinal.{u}) : GoodAt w 1 := by + refine ⟨isAdditivelyPrincipal_iff.mpr ⟨0, by simp⟩, fun t ht ↦ ?_⟩ + rw [show ((1 : NatOrdinal.{u}).val) = 1 from rfl, log_one_right, + additivePrincipalTerms_zero] at ht + exact absurd ht List.not_mem_nil + +private theorem GoodAt.mul {w : Ordinal.{u}} {Y Z : NatOrdinal.{u}} + (hY : GoodAt w Y) (hZ : GoodAt w Z) : GoodAt w (Y * Z) := by + have hprod : (NatOrdinal.of Y.val * NatOrdinal.of Z.val).val = (Y * Z).val := by + rw [NatOrdinal.of_val, NatOrdinal.of_val] + constructor + · obtain ⟨e, he⟩ := isAdditivelyPrincipal_iff.mp hY.1 + obtain ⟨f, hf⟩ := isAdditivelyPrincipal_iff.mp hZ.1 + refine isAdditivelyPrincipal_iff.mpr ⟨(NatOrdinal.of e + NatOrdinal.of f).val, ?_⟩ + rw [← hprod, he, hf, NatOrdinal.of_omega0_opow, NatOrdinal.of_omega0_opow, + ← NatOrdinal.wpow_add, NatOrdinal.val_wpow] + · intro t ht + rw [← hprod] at ht + rcases mem_additivePrincipalTerms_log_natMul hY.1 hZ.1 ht with h | h + · exact hY.2 t h + · exact hZ.2 t h + +private theorem GoodAt.pow {w : Ordinal.{u}} {Y : NatOrdinal.{u}} (hY : GoodAt w Y) (n : ℕ) : + GoodAt w (Y ^ n) := by + induction n with + | zero => simpa using GoodAt.one w + | succ n ih => rw [pow_succ]; exact ih.mul hY + +namespace AdditivePrincipalAboveOne +private theorem goodAt_value (B : AdditivePrincipalAboveOne.{u}) : + GoodAt (log omega0 B.principalFactor) (NatOrdinal.of B.val) := + ⟨B.2.1, fun _ ht ↦ B.log_principalFactor_le_of_mem_terms ht⟩ + +private theorem goodAt_residual (B : AdditivePrincipalAboveOne.{u}) : + GoodAt (log omega0 B.principalFactor) (NatOrdinal.of B.residualFactor) := + ⟨B.residualFactor_isAdditivelyPrincipal, + fun _ ht ↦ B.log_principalFactor_le_of_mem_terms + (B.mem_terms_of_mem_terms_log_residualFactor ht)⟩ + +/-- A natural power times the residual factor is additive principal, and ordinary multiplication +by the principal factor agrees with natural multiplication. -/ +theorem power_residual_factorization (B : AdditivePrincipalAboveOne.{u}) (m : ℕ) : + IsAdditivelyPrincipal (NatOrdinal.of B.val ^ m * NatOrdinal.of B.residualFactor).val ∧ + ((NatOrdinal.of B.val ^ m * NatOrdinal.of B.residualFactor) * + NatOrdinal.of B.principalFactor).val = + (NatOrdinal.of B.val ^ m * NatOrdinal.of B.residualFactor).val * B.principalFactor := by + have h := (B.goodAt_value.pow m).mul B.goodAt_residual + refine ⟨h.1, ?_⟩ + obtain ⟨e, he⟩ := isInfiniteMultiplicativelyPrincipal_iff.mp + B.principalFactor_isInfiniteMultiplicativelyPrincipal + have hp : IsAdditivelyPrincipal (log omega0 B.principalFactor) := by + rw [he, log_opow one_lt_omega0] + exact isAdditivelyPrincipal_omega0_opow e + have hh := natOrdinal_of_mul_wpow_eq_mul_of_log_terms hp h.1 h.2 + rw [B.principalFactor_isInfiniteMultiplicativelyPrincipal.isAdditivelyPrincipal.opow_log_self, + NatOrdinal.of_val] at hh + exact (congrArg NatOrdinal.val hh).symm + +/-- The same factorisation holds after adjoining a factor with no smaller principal factor. -/ +theorem power_residual_mul_factorization (B C : AdditivePrincipalAboveOne.{u}) + (hp : B.principalFactor ≤ C.principalFactor) (m : ℕ) : + IsAdditivelyPrincipal + (NatOrdinal.of B.val ^ m * NatOrdinal.of B.residualFactor * NatOrdinal.of C.val).val ∧ + ((NatOrdinal.of B.val ^ m * NatOrdinal.of B.residualFactor * NatOrdinal.of C.val) * + NatOrdinal.of B.principalFactor).val = + (NatOrdinal.of B.val ^ m * NatOrdinal.of B.residualFactor * NatOrdinal.of C.val).val * + B.principalFactor := by + have hC : GoodAt (log omega0 B.principalFactor) (NatOrdinal.of C.val) := + ⟨C.2.1, fun _ ht ↦ (log_mono_right omega0 hp).trans + (C.log_principalFactor_le_of_mem_terms ht)⟩ + have h := ((B.goodAt_value.pow m).mul B.goodAt_residual).mul hC + refine ⟨h.1, ?_⟩ + obtain ⟨e, he⟩ := isInfiniteMultiplicativelyPrincipal_iff.mp + B.principalFactor_isInfiniteMultiplicativelyPrincipal + have hb : IsAdditivelyPrincipal (log omega0 B.principalFactor) := by + rw [he, log_opow one_lt_omega0] + exact isAdditivelyPrincipal_omega0_opow e + have hh := natOrdinal_of_mul_wpow_eq_mul_of_log_terms hb h.1 h.2 + rw [B.principalFactor_isInfiniteMultiplicativelyPrincipal.isAdditivelyPrincipal.opow_log_self, + NatOrdinal.of_val] at hh + exact (congrArg NatOrdinal.val hh).symm +/-- A natural product of factors with no smaller principal factor also has no smaller principal +factor, whenever that product is greater than one. -/ +theorem principalFactor_le_of_naturalProd (B C : AdditivePrincipalAboveOne.{u}) + (l : Multiset AdditivePrincipalAboveOne.{u}) + (hl : ∀ y ∈ l, B.principalFactor ≤ y.principalFactor) + (hC : NatOrdinal.of C.val = (l.map fun y ↦ NatOrdinal.of y.val).prod) : + B.principalFactor ≤ C.principalFactor := by + have hgood : GoodAt (log omega0 B.principalFactor) + (l.map fun y ↦ NatOrdinal.of y.val).prod := by + clear hC + induction l using Multiset.induction with + | empty => simpa using GoodAt.one (log omega0 B.principalFactor) + | cons a t ih => + rw [Multiset.map_cons, Multiset.prod_cons] + apply GoodAt.mul + · exact ⟨a.2.1, fun z hz ↦ + (log_mono_right omega0 (hl a (Multiset.mem_cons_self a t))).trans + (a.log_principalFactor_le_of_mem_terms hz)⟩ + · exact ih fun y hy ↦ hl y (Multiset.mem_cons_of_mem hy) + rw [← hC] at hgood + have h := hgood.2 _ C.log_principalFactor_mem_terms + have hpow := opow_le_opow_right omega0_pos h + simpa only + [B.principalFactor_isInfiniteMultiplicativelyPrincipal.isAdditivelyPrincipal.opow_log_self, + C.principalFactor_isInfiniteMultiplicativelyPrincipal.isAdditivelyPrincipal.opow_log_self] + using hpow + +end AdditivePrincipalAboveOne +end Ordinal diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/NaturalPrincipal.lean b/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/NaturalPrincipal.lean new file mode 100644 index 0000000000..ed97df5b95 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/NaturalPrincipal.lean @@ -0,0 +1,135 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.CombinatorialGames.NatOrdinal.Pow +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.MultiplicativelyPrincipal + +import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.Degree +import Mathlib.Tactic.Ring + +/-! +# Principality of the natural operations + +Berarducci, Fact 3.7: an additive-principal ordinal is closed under the natural sum of two +strictly smaller ordinals, and a multiplicative-principal ordinal is closed under their natural +product. Both statements are strictly stronger than the closure under the ordinary operations used +to define the two predicates, and both are what the ordinal estimates in Berarducci, Lemma 7.7 and +Lemma 8.2 actually require. + +The natural operations are carried by `NatOrdinal`, so each statement converts its arguments with +`NatOrdinal.of` and reads the result back with `NatOrdinal.val`. Convenience forms stated entirely +inside `NatOrdinal` are supplied alongside. + +The multiplicative case reduces to `NatOrdinal.cantorDegree_mul` and `NatOrdinal.add_lt_wpow` +through the corrected classification of Berarducci's multiplicative-principal predicate, whose +finite cases `1` and `2` are handled directly. +-/ + +universe u + +open scoped NatOrdinal + +public noncomputable section + +namespace NatOrdinal + +/-- A power of `ω` whose exponent is again a power of `ω` is closed under Hessenberg products. -/ +theorem mul_lt_wpow_wpow {a b e : NatOrdinal.{u}} + (ha : a < ω^ (ω^ e)) (hb : b < ω^ (ω^ e)) : a * b < ω^ (ω^ e) := by + obtain rfl | ha0 := eq_or_ne a 0 + · simp [wpow_pos] + obtain rfl | hb0 := eq_or_ne b 0 + · simp [wpow_pos] + rw [← cantorDegree_lt_coe_iff] at ha hb ⊢ + rw [cantorDegree_mul] + obtain ⟨x, hx⟩ := WithBot.ne_bot_iff_exists.mp (cantorDegree_eq_bot.not.mpr ha0) + obtain ⟨y, hy⟩ := WithBot.ne_bot_iff_exists.mp (cantorDegree_eq_bot.not.mpr hb0) + rw [← hx] at ha ⊢ + rw [← hy] at hb ⊢ + rw [← WithBot.coe_add, WithBot.coe_lt_coe] at * + exact add_lt_wpow ha hb + +end NatOrdinal + +namespace Ordinal + +/-- Berarducci, Fact 3.7, additive case: an additive-principal ordinal is closed under the natural +sum of two strictly smaller ordinals. -/ +theorem IsAdditivelyPrincipal.naturalAdd_lt {o b c : Ordinal.{u}} + (ho : IsAdditivelyPrincipal o) (hb : b < o) (hc : c < o) : + (NatOrdinal.of b + NatOrdinal.of c).val < o := by + obtain ⟨e, rfl⟩ := isAdditivelyPrincipal_iff.mp ho + rw [show (omega0 ^ e) = (NatOrdinal.of (omega0 ^ e)).val from + (NatOrdinal.val_of _).symm, NatOrdinal.val.lt_iff_lt] + simp only [NatOrdinal.of_omega0_opow] + exact NatOrdinal.add_lt_wpow (by simpa using NatOrdinal.of.lt_iff_lt.mpr hb) + (by simpa using NatOrdinal.of.lt_iff_lt.mpr hc) + +/-- Berarducci, Fact 3.7, multiplicative case: a multiplicative-principal ordinal is closed under +the natural product of two strictly smaller ordinals. -/ +theorem IsMultiplicativelyPrincipal.naturalMul_lt {o b c : Ordinal.{u}} + (ho : IsMultiplicativelyPrincipal o) (hb : b < o) (hc : c < o) : + (NatOrdinal.of b * NatOrdinal.of c).val < o := by + rw [show o = (NatOrdinal.of o).val from (NatOrdinal.val_of o).symm, + NatOrdinal.val.lt_iff_lt] + rcases isMultiplicativelyPrincipal_iff_one_or_two_or_omega0_opow_opow.mp ho with + rfl | rfl | ⟨e, rfl⟩ + · rw [Order.lt_one_iff] at hb hc + subst hb + subst hc + simp + · have hb1 : NatOrdinal.of b ≤ 1 := by + have h : b ≤ 1 := + Order.lt_succ_iff.mp (by rwa [Order.succ_eq_add_one, one_add_one_eq_two]) + simpa using NatOrdinal.of.monotone h + have hc1 : NatOrdinal.of c ≤ 1 := by + have h : c ≤ 1 := + Order.lt_succ_iff.mp (by rwa [Order.succ_eq_add_one, one_add_one_eq_two]) + simpa using NatOrdinal.of.monotone h + calc NatOrdinal.of b * NatOrdinal.of c ≤ 1 := by simpa using mul_le_mul' hb1 hc1 + _ < NatOrdinal.of 2 := by simp + · simp only [NatOrdinal.of_omega0_opow] + exact NatOrdinal.mul_lt_wpow_wpow (by simpa using NatOrdinal.of.lt_iff_lt.mpr hb) + (by simpa using NatOrdinal.of.lt_iff_lt.mpr hc) + +end Ordinal + +namespace NatOrdinal + +/-- Berarducci, Fact 3.7, additive case, stated inside `NatOrdinal`. -/ +theorem add_lt_of_isAdditivelyPrincipal {o a b : NatOrdinal.{u}} + (ho : Ordinal.IsAdditivelyPrincipal o.val) (ha : a < o) (hb : b < o) : a + b < o := by + have h := ho.naturalAdd_lt (val.lt_iff_lt.mpr ha) (val.lt_iff_lt.mpr hb) + simpa using val.lt_iff_lt.mp (by simpa using h) + +/-- Berarducci, Fact 3.7, multiplicative case, stated inside `NatOrdinal`. -/ +theorem mul_lt_of_isMultiplicativelyPrincipal {o a b : NatOrdinal.{u}} + (ho : Ordinal.IsMultiplicativelyPrincipal o.val) (ha : a < o) (hb : b < o) : a * b < o := by + have h := ho.naturalMul_lt (val.lt_iff_lt.mpr ha) (val.lt_iff_lt.mpr hb) + simpa using val.lt_iff_lt.mp (by simpa using h) + +/-- The natural product of two ordinary products stays strictly below the natural +product of the two multipliers with a multiplicative-principal bound. This is the ordinal +estimate of Berarducci, Lemma 7.7 and Lemma 8.2. -/ +theorem naturalMul_mul_lt_of_lt {ρ₁ ρ₂ π₁ π₂ α₁ α₂ : NatOrdinal} + (hmp : Ordinal.IsMultiplicativelyPrincipal π₂.val) + (hπ : π₁ ≤ π₂) (hα₁ : α₁ < π₁) (hα₂ : α₂ < π₂) + (hρ : 0 < ρ₁ * ρ₂) : + NatOrdinal.of (ρ₁.val * α₁.val) * NatOrdinal.of (ρ₂.val * α₂.val) < + ρ₁ * ρ₂ * π₂ := by + have h₁ : NatOrdinal.of (ρ₁.val * α₁.val) ≤ ρ₁ * α₁ := by + simpa using NatOrdinal.of.le_iff_le.mpr (NatOrdinal.omul_le_mul' ρ₁.val α₁.val) + have h₂ : NatOrdinal.of (ρ₂.val * α₂.val) ≤ ρ₂ * α₂ := by + simpa using NatOrdinal.of.le_iff_le.mpr (NatOrdinal.omul_le_mul' ρ₂.val α₂.val) + calc NatOrdinal.of (ρ₁.val * α₁.val) * NatOrdinal.of (ρ₂.val * α₂.val) + ≤ (ρ₁ * α₁) * (ρ₂ * α₂) := mul_le_mul' h₁ h₂ + _ = (ρ₁ * ρ₂) * (α₁ * α₂) := by ring + _ < (ρ₁ * ρ₂) * π₂ := by + refine mul_lt_mul_of_pos_left ?_ hρ + exact mul_lt_of_isMultiplicativelyPrincipal hmp (hα₁.trans_le hπ) hα₂ + +end NatOrdinal diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/OrderedUnion.lean b/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/OrderedUnion.lean new file mode 100644 index 0000000000..296c336e6e --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/OrderedUnion.lean @@ -0,0 +1,164 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.SetOrderType +public import Mathlib.SetTheory.Ordinal.Arithmetic + +/-! +# Order type of a separated indexed union + +This module formalizes the order-theoretic estimate in Berarducci, Lemma 4.7. A family indexed by +a limit ordinal has union of order type at least `ρ * l` when every nonempty final segment of +each member has order type at least `ρ` and every later member contains an element strictly above +each earlier member. The product is ordinary ordinal multiplication, with the within-block order +in the left factor and the index order in the right factor. + +The proof uses the successor indices and replaces each corresponding member by its final segment +strictly above all earlier members. Strictness makes the resulting blocks disjoint and ordered even +when the original family members overlap. + +-/ + +universe u + +open Function Order Ordinal + +public noncomputable section + +namespace Ordinal + +/-- The successor positions in the canonical well-order of a limit ordinal have the same order +type as the ordinal. This is Berarducci, Lemma 4.6. -/ +theorem typeLT_range_succ_toType (l : Ordinal.{u}) (hl : IsSuccLimit l) : + typeLT (Set.range (Order.succ : l.ToType → l.ToType)) = l := by + have hpre : IsSuccPrelimit (typeLT l.ToType) := by + rw [type_toType] + exact hl.isSuccPrelimit + let : NoMaxOrder l.ToType := isSuccPrelimit_type_lt_iff.mp hpre + let f : l.ToType → Set.range (Order.succ : l.ToType → l.ToType) := + fun i ↦ ⟨Order.succ i, ⟨i, rfl⟩⟩ + have hf : StrictMono f := fun _ _ hij ↦ Order.succ_strictMono hij + have hsurjective : Surjective f := by + rintro ⟨_, i, rfl⟩ + exact ⟨i, rfl⟩ + let e : l.ToType ≃o Set.range (Order.succ : l.ToType → l.ToType) := + hf.orderIsoOfSurjective f hsurjective + calc + typeLT (Set.range (Order.succ : l.ToType → l.ToType)) = typeLT l.ToType := + e.symm.toRelIsoLT.ordinalType_congr + _ = l := type_toType l + +end Ordinal + +namespace Set.IsPWO + +private abbrev successorRange (l : Ordinal.{u}) : Set l.ToType := + Set.range Order.succ + +private theorem successorRange_orderType (l : Ordinal.{u}) (hl : IsSuccLimit l) : + typeLT (successorRange l) = l := by + simpa only [successorRange] using Ordinal.typeLT_range_succ_toType l hl + +private def separatedBlock {α ι : Type u} [LinearOrder α] [LinearOrder ι] + (B : ι → Set α) (i : ι) : Set α := + {x | x ∈ B i ∧ ∀ j < i, ∀ y ∈ B j, y < x} + +/-- Let `l` be a limit ordinal and let `B` be an `l`-indexed family of well-ordered subsets. If +every later member contains an element strictly above every element of each earlier member, every +nonempty final segment of every member has order type at least `ρ`, and the union is well ordered, +then its order type is at least the ordinary ordinal product `ρ * l`. This is Berarducci, +Lemma 4.7. -/ +theorem mul_le_orderType_iUnion_of_isSuccLimit + {α : Type u} [LinearOrder α] {l ρ : Ordinal.{u}} + (hl : IsSuccLimit l) (B : l.ToType → Set α) + (hB : ∀ i, (B i).IsPWO) + (hseparated : ∀ {i j}, i < j → ∃ y ∈ B j, ∀ x ∈ B i, x < y) + (hfinal : ∀ (i : l.ToType) (C : Set α) + (hC : IsRelUpperSet C (· ∈ B i)), C.Nonempty → + ρ ≤ ((hB i).mono fun _ hx ↦ (hC hx).1).orderType) + (hUnion : (⋃ i, B i).IsPWO) : + ρ * l ≤ hUnion.orderType := by + have hpre : IsSuccPrelimit (typeLT l.ToType) := by + rw [type_toType] + exact hl.isSuccPrelimit + let : NoMaxOrder l.ToType := isSuccPrelimit_type_lt_iff.mp hpre + let predecessor : successorRange l → l.ToType := + fun i ↦ Classical.choose i.2 + have successor_predecessor (i : successorRange l) : + Order.succ (predecessor i) = i.1 := + Classical.choose_spec i.2 + have predecessor_lt (i : successorRange l) : predecessor i < i.1 := by + rw [← successor_predecessor i] + exact Order.lt_succ _ + have block_upper (i : successorRange l) : + IsRelUpperSet (separatedBlock B i.1) (· ∈ B i.1) := by + intro x hx + refine ⟨hx.1, fun y hxy hy ↦ ⟨hy, ?_⟩⟩ + intro j hji z hz + exact (hx.2 j hji z hz).trans_le hxy + have block_nonempty (i : successorRange l) : + (separatedBlock B i.1).Nonempty := by + obtain ⟨x, hx, hxabove⟩ := hseparated (predecessor_lt i) + refine ⟨x, hx, ?_⟩ + intro j hji y hy + have hjle : j ≤ predecessor i := by + rw [← successor_predecessor i] at hji + exact Order.le_of_lt_succ hji + rcases hjle.eq_or_lt with rfl | hjlt + · exact hxabove y hy + · obtain ⟨z, hz, hzabove⟩ := hseparated hjlt + exact (hzabove y hy).trans (hxabove z hz) + have block_isPWO (i : successorRange l) : + (separatedBlock B i.1).IsPWO := + (hB i.1).mono fun _ hx ↦ hx.1 + have block_embedding_exists (i : successorRange l) : + Nonempty (ρ.ToType ↪o separatedBlock B i.1) := by + let hblock := block_isPWO i + let : WellFoundedLT (separatedBlock B i.1) := hblock.isWF + have hle : typeLT ρ.ToType ≤ typeLT (separatedBlock B i.1) := by + calc + typeLT ρ.ToType = ρ := type_toType ρ + _ ≤ hblock.orderType := hfinal i.1 _ (block_upper i) (block_nonempty i) + _ = typeLT (separatedBlock B i.1) := + hblock.orderType_eq_typeLT_of_orderIso (OrderIso.refl _) + obtain ⟨e⟩ := Ordinal.type_le_iff'.mp hle + exact ⟨e.orderEmbeddingOfLTEmbedding⟩ + let blockEmbedding (i : successorRange l) : + ρ.ToType ↪o separatedBlock B i.1 := + Classical.choice (block_embedding_exists i) + have block_lt_block {i j : successorRange l} (hij : i < j) + {x y : α} (hx : x ∈ separatedBlock B i.1) + (hy : y ∈ separatedBlock B j.1) : x < y := + hy.2 i.1 hij x hx.1 + let unionEmbedding : successorRange l ×ₗ ρ.ToType ↪o (⋃ i, B i) := + OrderEmbedding.ofStrictMono + (fun p ↦ + let q := ofLex p + let x := blockEmbedding q.1 q.2 + ⟨x.1, Set.mem_iUnion.mpr ⟨q.1.1, x.2.1⟩⟩) + (by + intro p q hpq + rw [Prod.Lex.lt_iff] at hpq + rcases hpq with hpq | ⟨hpq, hpq'⟩ + · exact block_lt_block hpq (blockEmbedding (ofLex p).1 (ofLex p).2).2 + (blockEmbedding (ofLex q).1 (ofLex q).2).2 + · change ((blockEmbedding (ofLex p).1 (ofLex p).2).1 : α) < + (blockEmbedding (ofLex q).1 (ofLex q).2).1 + rw [hpq] + exact (blockEmbedding (ofLex q).1).strictMono hpq') + have hdomain : typeLT (successorRange l ×ₗ ρ.ToType) = ρ * l := by + change type (Prod.Lex (· < · : successorRange l → successorRange l → Prop) + (· < · : ρ.ToType → ρ.ToType → Prop)) = ρ * l + rw [type_prod_lex, type_toType, successorRange_orderType l hl] + let : WellFoundedLT (⋃ i, B i) := hUnion.isWF + calc + ρ * l = typeLT (successorRange l ×ₗ ρ.ToType) := hdomain.symm + _ ≤ typeLT (⋃ i, B i) := unionEmbedding.ltEmbedding.ordinal_type_le + _ = hUnion.orderType := + (hUnion.orderType_eq_typeLT_of_orderIso (OrderIso.refl _)).symm + +end Set.IsPWO diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/PairBounds.lean b/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/PairBounds.lean new file mode 100644 index 0000000000..d0e7d57bec --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/PairBounds.lean @@ -0,0 +1,434 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.AlgebraicOrder +import Mathlib.Tactic.Abel + +/-! +# Natural sums with two summands lowered + +Let `μ = O ⊕ t₁ ⊕ t₂` with `t₁, t₂ ≠ 0`, and let `ω^{e₁}`, `ω^{e₂}` be the last terms of the Cantor +normal forms of `t₁`, `t₂`. The natural sums `O ⊕ ρ₁ ⊕ ρ₂` with `ρ₁ < t₁`, `ρ₂ < t₂` are bounded +strictly below `μ` (`exists_lt_forall_add_add_le`), and an upper bound `λ₀ < μ` of all of them +has `(λ₀)_{≥e₂} = μ_{≥e₂}` when `e₁ < e₂`—so `t₂ ≼ λ₀` in the algebraic order—and both `t₁` +and `t₂` precede `λ₀` in that order when `e₁ = e₂ ≠ 0` (`partGE_eq_of_forall_add_add_le`, +`algebraicLE_of_forall_add_add_le`, `algebraicLE_left_of_forall_add_add_le`). +-/ + +universe u + +open Ordinal + +public noncomputable section + +namespace NatOrdinal + +/-! ### Tools -/ + +theorem removeLeastTerm_lt {a : NatOrdinal.{u}} (ha : a ≠ 0) : removeLeastTerm a < a := by + conv_rhs => rw [← removeLeastTerm_add_leastTerm a] + exact lt_add_of_pos_right _ (pos_iff_ne_zero.mpr (leastTerm_ne_zero ha)) + +/-- Removing the last term `ω^e` of the Cantor normal form of `a` leaves an ordinal all of whose +terms are at least `ω^e`: it is its own part at or above `e`. -/ +theorem partGE_removeLeastTerm {a e : NatOrdinal.{u}} (ha : a ≠ 0) (he : leastTerm a = ω^ e) : + partGE e (removeLeastTerm a) = removeLeastTerm a := by + refine partGE_eq_self_of_forall_le fun t ht ↦ ?_ + refine wpow_le_of_mem_additivePrincipalTerms_of_leastTerm_eq ha he ?_ + rw [← removeLeastTerm_add_leastTerm a, mem_additivePrincipalTerms_add_iff] + exact Or.inl ht + +/-- Removing the last term `ω^e`, `e < e'`, does not change the part at or above `e'`. -/ +theorem partGE_removeLeastTerm_of_lt {a e e' : NatOrdinal.{u}} (he : leastTerm a = ω^ e) + (hlt : e < e') : partGE e' (removeLeastTerm a) = partGE e' a := by + conv_rhs => rw [← removeLeastTerm_add_leastTerm a] + rw [partGE_add, he, partGE_eq_zero_of_lt (wpow_lt_wpow.mpr hlt), add_zero] + +/-- `ω^e` is a limit for `e ≠ 0`: `x < ω^e` gives `x + 1 < ω^e`. -/ +theorem add_one_lt_wpow_of_lt {x e : NatOrdinal.{u}} (he : e ≠ 0) (hx : x < ω^ e) : + x + 1 < ω^ e := + add_lt_wpow hx (by rw [← wpow_zero]; exact wpow_lt_wpow.mpr (pos_iff_ne_zero.mpr he)) + +/-- Every natural ordinal is below its part at or above `e`, plus `ω^e`. -/ +theorem lt_partGE_add_wpow (e a : NatOrdinal.{u}) : a < partGE e a + ω^ e := by + conv_lhs => rw [← partGE_add_partLT e a] + exact add_lt_add_right (partLT_lt e a) _ + +/-- Between two distinct parts at or above `e` there is room for `ω^e`. -/ +theorem partGE_add_wpow_le_of_partGE_lt {e a b : NatOrdinal.{u}} + (h : partGE e a < partGE e b) : partGE e a + ω^ e ≤ partGE e b := by + have h1 := add_le_of_dvd_of_lt (exists_val_partGE_eq_mul e a) + (exists_val_partGE_eq_mul e b) (NatOrdinal.val.lt_iff_lt.mpr h) + rw [partGE_add_wpow, ← NatOrdinal.of_val (partGE e b), NatOrdinal.of.le_iff_le] + exact h1 + +/-- An ordinal with all terms at or above `e` that lies in `[C, C + ω^e]`, `C` likewise, is `C` or +`C + ω^e`. -/ +theorem eq_or_eq_add_wpow_of_le_of_le {e C X : NatOrdinal.{u}} (hC : partGE e C = C) + (hX : partGE e X = X) (h1 : C ≤ X) (h2 : X ≤ C + ω^ e) : X = C ∨ X = C + ω^ e := by + rcases eq_or_lt_of_le h1 with h | h + · exact Or.inl h.symm + · right + refine le_antisymm h2 ?_ + have := partGE_add_wpow_le_of_partGE_lt (e := e) (a := C) (b := X) (by rwa [hC, hX]) + rwa [hC, hX] at this + +/-- Below `A_{≥e} + ω^e` every ordinal is exceeded by `A ⊕ ξ` for some `ξ < ω^e`. -/ +theorem exists_lt_add_of_lt_partGE_add_wpow {A l e : NatOrdinal.{u}} (he : e ≠ 0) + (h : l < partGE e A + ω^ e) : ∃ ξ, ξ < ω^ e ∧ l < A + ξ := by + rcases lt_or_ge l (partGE e A) with hlt | hge + · exact ⟨0, wpow_pos e, by rw [add_zero]; exact hlt.trans_le (partGE_le e A)⟩ + · -- `l = A_{≥e} + ξ₀` with `ξ₀ < ω^e` + set ξ₀ : Ordinal := l.val - (partGE e A).val with hξ₀def + have hξ₀ : (partGE e A).val + ξ₀ = l.val := + Ordinal.add_sub_cancel_of_le (NatOrdinal.val.le_iff_le.mpr hge) + have hξ₀lt : ξ₀ < (ω^ e).val := by + rw [hξ₀def, Ordinal.sub_lt_of_le (NatOrdinal.val.le_iff_le.mpr hge)] + have := NatOrdinal.val.lt_iff_lt.mpr h + rwa [partGE_add_wpow, NatOrdinal.val_of] at this + have hξ₀' : NatOrdinal.of ξ₀ < ω^ e := by + rw [← NatOrdinal.of_val (ω^ e)] + exact NatOrdinal.of.lt_iff_lt.mpr hξ₀lt + have hl : l = partGE e A + NatOrdinal.of ξ₀ := by + have := of_add_of_eq_add_of_forall_lt (w := (ω^ e).val) + (u := (partGE e A).val) (t := ξ₀) + (fun _ hs ↦ wpow_le_of_mem_additivePrincipalTerms_partGE hs) + (fun s hs ↦ by + have h1 : NatOrdinal.of s ≤ NatOrdinal.of ξ₀ := + of_le_of_mem_additivePrincipalTerms (a := NatOrdinal.of ξ₀) hs + exact (NatOrdinal.of.le_iff_le.mp h1).trans_lt hξ₀lt) + rw [NatOrdinal.of_val, hξ₀, NatOrdinal.of_val] at this + exact this.symm + refine ⟨NatOrdinal.of ξ₀ + 1, add_one_lt_wpow_of_lt he hξ₀', ?_⟩ + calc l < l + 1 := lt_add_one l + _ = partGE e A + NatOrdinal.of ξ₀ + 1 := by rw [hl] + _ ≤ A + NatOrdinal.of ξ₀ + 1 := + add_le_add_left (add_le_add_left (partGE_le e A) _) _ + _ = A + (NatOrdinal.of ξ₀ + 1) := add_assoc _ _ _ + +/-! ### Lowering one summand -/ + +variable {t e : NatOrdinal.{u}} + +/-- If `ω^e` is the last term of the Cantor normal form of `t` and `ρ < t`, then +`ρ_{≥e} ⊕ ω^e ≤ t`. -/ +theorem partGE_add_wpow_le_of_lt_of_leastTerm_eq (ht : t ≠ 0) (he : leastTerm t = ω^ e) + {ρ : NatOrdinal.{u}} (hρ : ρ < t) : partGE e ρ + ω^ e ≤ t := + partGE_add_wpow_le_of_lt + (fun _ hs ↦ wpow_le_of_mem_additivePrincipalTerms_of_leastTerm_eq ht he hs) hρ + +theorem partGE_eq_self_of_leastTerm_eq (ht : t ≠ 0) (he : leastTerm t = ω^ e) : + partGE e t = t := + partGE_eq_self_of_forall_le + fun _ hs ↦ wpow_le_of_mem_additivePrincipalTerms_of_leastTerm_eq ht he hs +theorem removeLeastTerm_add_wpow (he : leastTerm t = ω^ e) : + removeLeastTerm t + ω^ e = t := by + rw [← he]; exact removeLeastTerm_add_leastTerm t + +/-! ### Lowering two summands -/ + +variable {O t₁ t₂ e₁ e₂ : NatOrdinal.{u}} + +/-- With the last term of `t₂` equal to `ω^{e₂}`, every `O ⊕ ρ₁ ⊕ ρ₂` with `ρ₁ ≤ t₁`, `ρ₂ < t₂` +lies below `(O ⊕ t₁ ⊕ t₂)_{≥e₂}`. -/ +theorem add_add_lt_partGE_of_lt (ht₂ : t₂ ≠ 0) (he₂ : leastTerm t₂ = ω^ e₂) + {ρ₁ ρ₂ : NatOrdinal.{u}} (hρ₁ : ρ₁ ≤ t₁) (hρ₂ : ρ₂ < t₂) : + O + ρ₁ + ρ₂ < partGE e₂ (O + t₁ + t₂) := by + refine (lt_partGE_add_wpow e₂ _).trans_le ?_ + rw [partGE_add, partGE_add, partGE_add, partGE_add, add_assoc, + partGE_eq_self_of_leastTerm_eq ht₂ he₂] + exact add_le_add (add_le_add_right (partGE_mono hρ₁) _) + (partGE_add_wpow_le_of_lt_of_leastTerm_eq ht₂ he₂ hρ₂) + +/-- `t₁` has a term below `ω^{e₂}` when its last term `ω^{e₁}` has `e₁ < e₂`. -/ +theorem partLT_ne_zero_of_leastTerm_lt (ht₁ : t₁ ≠ 0) (he₁ : leastTerm t₁ = ω^ e₁) + (hlt : e₁ < e₂) : partLT e₂ t₁ ≠ 0 := by + intro h0 + have hGE : partGE e₂ t₁ = t₁ := by + have := partGE_add_partLT e₂ t₁ + rwa [h0, add_zero] at this + have hmem := val_leastTerm_mem ht₁ + rw [he₁] at hmem + have hmem' : (ω^ e₁).val ∈ (partGE e₂ t₁).val.additivePrincipalTerms := by + rw [hGE]; exact hmem + have := wpow_le_of_mem_additivePrincipalTerms_partGE hmem' + exact absurd (NatOrdinal.val.le_iff_le.mp this) (not_le.mpr (wpow_lt_wpow.mpr hlt)) + +/-- **Two summands lowered, `e₁ ≤ e₂`.** The sums `O ⊕ ρ₁ ⊕ ρ₂`, `ρ₁ < t₁`, `ρ₂ < t₂`, are +bounded strictly below `O ⊕ t₁ ⊕ t₂`. -/ +theorem exists_lt_forall_add_add_le_of_le (ht₁ : t₁ ≠ 0) (ht₂ : t₂ ≠ 0) + (he₁ : leastTerm t₁ = ω^ e₁) (he₂ : leastTerm t₂ = ω^ e₂) (hle : e₁ ≤ e₂) : + ∃ B, B < O + t₁ + t₂ ∧ ∀ ρ₁ ρ₂ : NatOrdinal.{u}, ρ₁ < t₁ → ρ₂ < t₂ → O + ρ₁ + ρ₂ ≤ B := by + rcases eq_or_lt_of_le hle with heq | hlt + · -- equal last terms: each of `ρ₁ < t₁`, `ρ₂ < t₂` loses a whole `ω^e` + subst heq + refine ⟨partGE e₁ O + removeLeastTerm t₁ + removeLeastTerm t₂ + ω^ e₁, ?_, ?_⟩ + · -- `B + ω^e = (O ⊕ t₁ ⊕ t₂)_{≥e} ≤ O ⊕ t₁ ⊕ t₂` + have : partGE e₁ O + removeLeastTerm t₁ + removeLeastTerm t₂ + ω^ e₁ + ω^ e₁ = + partGE e₁ (O + t₁ + t₂) := by + rw [partGE_add, partGE_add, partGE_eq_self_of_leastTerm_eq ht₁ he₁, + partGE_eq_self_of_leastTerm_eq ht₂ he₂] + conv_rhs => rw [← removeLeastTerm_add_wpow he₁, ← removeLeastTerm_add_wpow he₂] + abel + calc partGE e₁ O + removeLeastTerm t₁ + removeLeastTerm t₂ + ω^ e₁ + < partGE e₁ O + removeLeastTerm t₁ + removeLeastTerm t₂ + ω^ e₁ + ω^ e₁ := + lt_add_of_pos_right _ (wpow_pos e₁) + _ = partGE e₁ (O + t₁ + t₂) := this + _ ≤ O + t₁ + t₂ := partGE_le e₁ _ + · intro ρ₁ ρ₂ hρ₁ hρ₂ + have h1 := partGE_add_wpow_le_of_lt_of_leastTerm_eq ht₁ he₁ hρ₁ + have h2 := partGE_add_wpow_le_of_lt_of_leastTerm_eq ht₂ he₂ hρ₂ + rw [← removeLeastTerm_add_wpow he₁] at h1 + rw [← removeLeastTerm_add_wpow he₂] at h2 + have h1' := le_of_add_le_add_right h1 + have h2' := le_of_add_le_add_right h2 + refine (lt_partGE_add_wpow e₁ _).le.trans ?_ + rw [partGE_add, partGE_add] + exact add_le_add_left (add_le_add (add_le_add_right h1' _) h2') _ + · -- `e₁ < e₂`: `(O ⊕ t₁ ⊕ t₂)_{≥e₂}` is already below `O ⊕ t₁ ⊕ t₂` + refine ⟨partGE e₂ (O + t₁ + t₂), ?_, fun ρ₁ ρ₂ hρ₁ hρ₂ ↦ + (add_add_lt_partGE_of_lt ht₂ he₂ hρ₁.le hρ₂).le⟩ + have hne : partLT e₂ (O + t₁ + t₂) ≠ 0 := by + have hle : partLT e₂ t₁ ≤ partLT e₂ (O + t₁ + t₂) := by + rw [partLT_add, partLT_add] + exact (le_add_of_nonneg_left zero_le).trans (le_add_of_nonneg_right zero_le) + exact (lt_of_lt_of_le (pos_iff_ne_zero.mpr + (partLT_ne_zero_of_leastTerm_lt ht₁ he₁ hlt)) hle).ne' + conv_rhs => rw [← partGE_add_partLT e₂ (O + t₁ + t₂)] + exact lt_add_of_pos_right _ (pos_iff_ne_zero.mpr hne) + +/-- If `t₁` and `t₂` are nonzero, the sums `O ⊕ ρ₁ ⊕ ρ₂` with `ρ₁ < t₁` and `ρ₂ < t₂` +have a common upper bound strictly below `O ⊕ t₁ ⊕ t₂`. -/ +@[blueprint "lem:two-lowerings-have-strict-bound" + (phase := "Algebraic and ordinal preliminaries") + (title := "Uniform bound for simultaneous decreases in a Hessenberg sum") + (statement := /-- + Let $\sigma_1,\sigma_2\neq0$, with last Cantor terms + $\omega^{e_1}$ and $\omega^{e_2}$. There is + $\mu'<\rho\oplus\sigma_1\oplus\sigma_2$ such that + \[ + \rho\oplus\theta_1\oplus\theta_2\le\mu' + \] + for all $\theta_1<\sigma_1$ and $\theta_2<\sigma_2$. + -/) + (proof := /-- + Interchange the indices if necessary so that $e_1\le e_2$. If $e_1=e_2$, + retain the terms of $\rho$ at exponents at least $e_1$, remove the last + term from each $\sigma_i$, and retain one copy of $\omega^{e_1}$. If + $e_1 rw [← removeLeastTerm_add_wpow he₁, ← removeLeastTerm_add_wpow he₂] + abel + have hCt₂ : AlgebraicLE t₂ C := by + rw [hCdef, hAGE, add_assoc, removeLeastTerm_add_wpow he₂] + exact algebraicLE_add_left _ _ + -- `C ≤ (λ₀)_{≥e}` + have hCl : C ≤ partGE e l := by + by_contra h + rw [not_le] at h + have h1 : partGE e l + ω^ e ≤ C := by + have := partGE_add_wpow_le_of_partGE_lt (e := e) (a := l) (b := C) (by rwa [hCGE]) + rwa [hCGE] at this + have hl' : l < partGE e A + ω^ e := + (lt_partGE_add_wpow e l).trans_le (h1.trans hCdef.le) + obtain ⟨ξ, hξ, hlξ⟩ := exists_lt_add_of_lt_partGE_add_wpow he hl' + have := hall (removeLeastTerm t₁ + ξ) (removeLeastTerm t₂) (by + calc removeLeastTerm t₁ + ξ < removeLeastTerm t₁ + ω^ e := add_lt_add_right hξ _ + _ = t₁ := removeLeastTerm_add_wpow he₁) (removeLeastTerm_lt ht₂) + have hre : A + ξ = O + (removeLeastTerm t₁ + ξ) + removeLeastTerm t₂ := by rw [hAdef]; abel + rw [hre] at hlξ + exact absurd hlξ (not_lt.mpr this) + -- `(λ₀)_{≥e} ≤ C + ω^e`, so it is `C` or `C + ω^e` + have hlC : partGE e l ≤ C + ω^ e := by rw [hCμ]; exact partGE_mono hl.le + rcases eq_or_eq_add_wpow_of_le_of_le hCGE (partGE_partGE e l) hCl hlC with h | h + · rw [← h] at hCt₂ + exact hCt₂.trans (algebraicLE_partGE e l) + · exact (hCt₂.trans (algebraicLE_add_right _ _)).trans (h ▸ algebraicLE_partGE e l) + +/-- Suppose `t₁` and `t₂` are nonzero with the same last Cantor term `ω^e`, where `e ≠ 0`. +If `λ₀ < O ⊕ t₁ ⊕ t₂` bounds every `O ⊕ ρ₁ ⊕ ρ₂` with `ρᵢ < tᵢ`, then +`t₁ ⊕ ν = λ₀` for some `ν`. -/ +theorem algebraicLE_left_of_forall_add_add_le (ht₁ : t₁ ≠ 0) (ht₂ : t₂ ≠ 0) + (he₁ : leastTerm t₁ = ω^ e) (he₂ : leastTerm t₂ = ω^ e) (he : e ≠ 0) {l : NatOrdinal.{u}} + (hl : l < O + t₁ + t₂) (hall : ∀ ρ₁ ρ₂ : NatOrdinal.{u}, ρ₁ < t₁ → ρ₂ < t₂ → O + ρ₁ + ρ₂ ≤ l) : + AlgebraicLE t₁ l := + algebraicLE_of_forall_add_add_le (O := O) ht₂ ht₁ he₂ he₁ he (by rwa [add_right_comm] at hl) + fun ρ₂ ρ₁ hρ₂ hρ₁ ↦ by rw [add_right_comm]; exact hall ρ₁ ρ₂ hρ₁ hρ₂ + +/-! ### The comparison forced by failure of the algebraic-order relation -/ + +/-- **The exponents are strictly ordered, and the bound agrees above the larger one.** Suppose +`λ₀ < O ⊕ t₁ ⊕ t₂` bounds every `O ⊕ ρ₁ ⊕ ρ₂` with `ρ₁ < t₁` and `ρ₂ < t₂`, that the last Cantor +terms of `t₁` and `t₂` are `ω^{e₁}` and `ω^{e₂}` with `e₁ ≠ 0`, and that `t₁` is *not* a natural +summand of `λ₀`. Then `e₁ < e₂`, and `(λ₀)_{≥e₂} = (O ⊕ t₁ ⊕ t₂)_{≥e₂}`. + +Equal exponents would give `t₁ ≼ λ₀`, and so would the reverse comparison, so +the failure forces the order; the agreement above the larger exponent then follows. -/ +theorem lt_and_partGE_eq_of_not_algebraicLE (ht₁ : t₁ ≠ 0) (ht₂ : t₂ ≠ 0) + (he₁ : leastTerm t₁ = ω^ e₁) (he₂ : leastTerm t₂ = ω^ e₂) (he₁0 : e₁ ≠ 0) + {l : NatOrdinal.{u}} (hl : l < O + t₁ + t₂) + (hall : ∀ ρ₁ ρ₂ : NatOrdinal.{u}, ρ₁ < t₁ → ρ₂ < t₂ → O + ρ₁ + ρ₂ ≤ l) + (hdiff : ¬ AlgebraicLE t₁ l) : + e₁ < e₂ ∧ partGE e₂ l = partGE e₂ (O + t₁ + t₂) := by + have hl' : l < O + t₂ + t₁ := by rwa [add_right_comm] at hl + have hall' : ∀ ρ₂ ρ₁ : NatOrdinal.{u}, ρ₂ < t₂ → ρ₁ < t₁ → O + ρ₂ + ρ₁ ≤ l := + fun ρ₂ ρ₁ hρ₂ hρ₁ ↦ by rw [add_right_comm]; exact hall ρ₁ ρ₂ hρ₁ hρ₂ + have hlt : e₁ < e₂ := by + rcases lt_trichotomy e₁ e₂ with h | h | h + · exact h + · subst h + exact absurd + (algebraicLE_of_forall_add_add_le (O := O) ht₂ ht₁ he₂ he₁ he₁0 hl' hall') hdiff + · exact absurd + (algebraicLE_right_of_forall_add_add_le (O := O) ht₂ ht₁ he₂ he₁ h hl' hall') hdiff + exact ⟨hlt, partGE_eq_of_forall_add_add_le ht₁ ht₂ he₁ he₂ hlt hl hall⟩ + +/-! ### A uniform bound over a finite family -/ + +/-- **Finitely many bounds below a common ceiling have a common bound below it.** For a property +that only weakens as the bound grows, a family of bounds indexed by a finite set can be replaced by +their maximum. -/ +theorem exists_lt_forall_of_forall_exists_lt {ι' : Type*} (s : Finset ι') {μ : NatOrdinal.{u}} + (hμ : 0 < μ) (P : ι' → NatOrdinal.{u} → Prop) + (hmono : ∀ x, ∀ {B B' : NatOrdinal.{u}}, B ≤ B' → P x B → P x B') + (h : ∀ x ∈ s, ∃ B, B < μ ∧ P x B) : + ∃ B, B < μ ∧ ∀ x ∈ s, P x B := by + classical + revert h + induction s using Finset.induction_on with + | empty => exact fun _ ↦ ⟨0, hμ, fun x hx ↦ absurd hx (Finset.notMem_empty x)⟩ + | insert a s ha ih => + intro h + obtain ⟨B₁, hB₁, hP₁⟩ := h a (Finset.mem_insert_self a s) + obtain ⟨B₂, hB₂, hP₂⟩ := ih fun x hx ↦ h x (Finset.mem_insert_of_mem hx) + refine ⟨max B₁ B₂, max_lt hB₁ hB₂, fun x hx ↦ ?_⟩ + rcases Finset.mem_insert.mp hx with rfl | hx + · exact hmono x (le_max_left _ _) hP₁ + · exact hmono x (le_max_right _ _) (hP₂ x hx) + +end NatOrdinal diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/Separation.lean b/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/Separation.lean new file mode 100644 index 0000000000..461dd57928 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/Separation.lean @@ -0,0 +1,277 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.Split +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.LeastTermSup + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint + +/-! +# The separation condition + +For ordinals `b`, `c`, `τ` with `c ≠ 0` (in the vocabulary of degrees: `b` the degree of a cofactor, +`c` the degree of a generator) the *separation condition* (n) reads + + (n) `b ⊕ θ < τ` for every `θ < c`. + +Writing `ω^β` for the last term of the Cantor normal form of `c`, the condition (n) forces +`(b ⊕ c)_{≥β} ≤ τ` (`partGE_add_wpow_le_of_forall_add_lt`): the natural sums `b ⊕ θ`, `θ < c`, +approach `(b ⊕ c)_{≥β}` from below. Consequently every degree `h'` with `τ < h' ≤ b ⊕ c` has the +same part at or above `β` as `b ⊕ c`, and `c ≼ h'` in the algebraic order: `h' = b' ⊕ c` with +`b' = b_{≥β} ⊕ h'_{<β} ≤ b` (`exists_le_add_eq_of_forall_add_lt`). The condition can hold with +`τ < b ⊕ c` only because `sup_{θ < c} (b ⊕ θ)` may fall short of `b ⊕ c`, as for +`sup_{θ < ω} (θ ⊕ 1) = ω < ω ⊕ 1`. +-/ + +universe u + +open Ordinal + +public noncomputable section + +namespace NatOrdinal + +/-- The natural sum of an ordinal all of whose Cantor terms are at least `w` and an ordinal all of +whose Cantor terms are at most `w` is their ordinal sum. -/ +theorem of_add_of_eq_add_of_forall_le {u t : Ordinal.{u}} {w : Ordinal.{u}} + (hu : ∀ s ∈ u.additivePrincipalTerms, w ≤ s) (ht : ∀ s ∈ t.additivePrincipalTerms, s ≤ w) : + NatOrdinal.of u + NatOrdinal.of t = NatOrdinal.of (u + t) := by + have hsorted : (u.additivePrincipalTerms ++ t.additivePrincipalTerms).SortedGE := by + rw [List.sortedGE_iff_pairwise, List.pairwise_append] + refine ⟨List.sortedGE_iff_pairwise.mp (additivePrincipalTerms_sortedGE u), + List.sortedGE_iff_pairwise.mp (additivePrincipalTerms_sortedGE t), fun s hs s' hs' ↦ ?_⟩ + exact (ht s' hs').trans (hu s hs) + have hprincipal : ∀ s ∈ u.additivePrincipalTerms ++ t.additivePrincipalTerms, + IsAdditivelyPrincipal s := fun s hs ↦ by + rcases List.mem_append.mp hs with h | h + · exact isAdditivelyPrincipal_of_mem_additivePrincipalTerms h + · exact isAdditivelyPrincipal_of_mem_additivePrincipalTerms h + have h := natOrdinal_of_sum_eq_sum_map_of_sorted hprincipal hsorted + have hu' := sum_map_of_additivePrincipalTerms (NatOrdinal.of u) + have ht' := sum_map_of_additivePrincipalTerms (NatOrdinal.of t) + rw [NatOrdinal.val_of] at hu' ht' + rw [List.sum_append, additivePrincipalTerms_sum, additivePrincipalTerms_sum, List.map_append, + List.sum_append, hu', ht'] at h + exact h.symm + +/-- If every term of the Cantor normal form of `a` is at least `ω^β`, the part of `a` below `β` +is `0`. -/ +theorem partLT_eq_zero_of_forall_le {β a : NatOrdinal.{u}} + (h : ∀ t ∈ a.val.additivePrincipalTerms, (ω^ β).val ≤ t) : partLT β a = 0 := by + by_contra hne + have hmem : (leastTerm (partLT β a)).val ∈ + (partGE β a + partLT β a).val.additivePrincipalTerms := + (mem_additivePrincipalTerms_add_iff _ _ _).mpr (Or.inr (val_leastTerm_mem hne)) + rw [partGE_add_partLT] at hmem + exact absurd (h _ hmem) + (not_le.mpr (lt_wpow_of_mem_additivePrincipalTerms_partLT (val_leastTerm_mem hne))) + +/-- If every term of the Cantor normal form of `a` is at least `ω^β`, then `a` is its own part at +or above `β`. -/ +theorem partGE_eq_self_of_forall_le {β a : NatOrdinal.{u}} + (h : ∀ t ∈ a.val.additivePrincipalTerms, (ω^ β).val ≤ t) : partGE β a = a := by + have := partGE_add_partLT β a + rwa [partLT_eq_zero_of_forall_le h, add_zero] at this + +/-- Taking the part at or above `β` is idempotent. -/ +theorem partGE_partGE (β a : NatOrdinal.{u}) : + partGE β (partGE β a) = partGE β a := + partGE_eq_self_of_forall_le fun _ ht ↦ wpow_le_of_mem_additivePrincipalTerms_partGE ht + +/-- The part of `a` at or above `β` is at most `a`. -/ +theorem partGE_le (β a : NatOrdinal.{u}) : partGE β a ≤ a := by + conv_rhs => rw [← partGE_add_partLT β a] + exact le_add_of_nonneg_right zero_le + +/-- The natural sum of the two parts of `a` at `β` is their ordinal sum. -/ +theorem val_partGE_add_val_partLT (β a : NatOrdinal.{u}) : + partGE β a + partLT β a = NatOrdinal.of ((partGE β a).val + (partLT β a).val) := + of_add_of_eq_add_of_forall_lt + (fun _ hs ↦ wpow_le_of_mem_additivePrincipalTerms_partGE hs) + (fun _ hs ↦ lt_wpow_of_mem_additivePrincipalTerms_partLT hs) + +/-- A power of `ω` divides an ordinal exactly when the lower part of its Cantor normal form +vanishes. -/ +theorem wpow_dvd_val_iff_partLT_eq_zero (β a : NatOrdinal.{u}) : + (ω^ β).val ∣ a.val ↔ partLT β a = 0 := by + rw [Ordinal.dvd_iff_mod_eq_zero] + obtain ⟨q, hq⟩ := exists_val_partGE_eq_mul β a + have hsplit := val_eq_val_partGE_add_val_partLT β a + have hlt : (partLT β a).val < (ω^ β).val := + NatOrdinal.val.lt_iff_lt.mpr (partLT_lt β a) + rw [hsplit, hq, Ordinal.mul_add_mod_self, Ordinal.mod_eq_of_lt hlt] + exact NatOrdinal.val_eq_zero + +/-- Adding `ω^β` to a part at or above `β` is an ordinal sum. -/ +theorem partGE_add_wpow (β a : NatOrdinal.{u}) : + partGE β a + ω^ β = NatOrdinal.of ((partGE β a).val + (ω^ β).val) := + of_add_of_eq_add_of_forall_le + (fun _ hs ↦ wpow_le_of_mem_additivePrincipalTerms_partGE hs) + (fun s hs ↦ by + have hs' : s ∈ (ω ^ β.val).additivePrincipalTerms := hs + rw [additivePrincipalTerms_of_isAdditivelyPrincipal + (Ordinal.isAdditivelyPrincipal_iff.mpr ⟨β.val, rfl⟩), List.mem_singleton] at hs' + exact hs'.le) + +/-- `ω^β` is its own part at or above `β`. -/ +theorem partGE_wpow (β : NatOrdinal.{u}) : partGE β (ω^ β) = ω^ β := + partGE_eq_self_of_forall_le fun s hs ↦ by + have hs' : s ∈ (ω ^ β.val).additivePrincipalTerms := hs + rw [additivePrincipalTerms_of_isAdditivelyPrincipal + (Ordinal.isAdditivelyPrincipal_iff.mpr ⟨β.val, rfl⟩), List.mem_singleton] at hs' + exact hs'.ge + +/-- Every term of the Cantor normal form of `a ≠ 0` is at least its last term, written `ω^β`. -/ +theorem wpow_le_of_mem_additivePrincipalTerms_of_leastTerm_eq {a β : NatOrdinal.{u}} (ha : a ≠ 0) + (hβ : leastTerm a = ω^ β) {t : Ordinal.{u}} (ht : t ∈ a.val.additivePrincipalTerms) : + (ω^ β).val ≤ t := by + have := leastTerm_le_of_mem ha ht + rw [hβ] at this + exact NatOrdinal.val.le_iff_le.mpr this + +/-- The last term of the Cantor normal form of `a ≠ 0` is a power `ω^β`. -/ +theorem exists_leastTerm_eq_wpow {a : NatOrdinal.{u}} (ha : a ≠ 0) : + ∃ β : NatOrdinal.{u}, leastTerm a = ω^ β := by + obtain ⟨e, he⟩ := Ordinal.isAdditivelyPrincipal_iff.mp (isAdditivelyPrincipal_leastTerm ha) + exact ⟨NatOrdinal.of e, NatOrdinal.val.injective (by rw [he]; rfl)⟩ + +/-- If `g ⊕ x < τ` for every `x < ω^β`, then the sum of the terms in the Cantor normal form of +`g ⊕ ω^β` whose exponents are at least `β` is at most `τ`. -/ +@[blueprint "lem:separation-bounds-high-part" + (phase := "Algebraic and ordinal preliminaries") + (title := "Upper Cantor-term bound for a Hessenberg sum") + (statement := /-- + If $\rho\oplus\theta<\tau$ for every $\theta<\omega^\beta$, then the + sum of the terms in the Cantor normal form of $\rho\oplus\omega^\beta$ + whose exponents are at least $\beta$ is at most $\tau$. + -/) + (proof := /-- + If this sum exceeded $\tau$, monotonicity would force the sums of the + terms in the Cantor normal forms of $\rho$ and $\tau$ at exponents at + least $\beta$ to agree. + Decomposing $\tau$ at $\beta$ would then give + $\tau\le\rho\oplus\tau_{<\beta}$, where $\tau_{<\beta}<\omega^\beta$ + is the sum of its remaining terms, contradicting the hypothesis. + -/)] +theorem partGE_add_wpow_le_of_forall_add_lt {g β τ : NatOrdinal.{u}} + (h : ∀ x, x < ω^ β → g + x < τ) : partGE β (g + ω^ β) ≤ τ := by + by_contra hlt + rw [not_le, partGE_add, partGE_wpow] at hlt + -- `g ≤ τ`, so the part of `τ` at or above `β` is at least that of `g`; it cannot exceed it. + have hgτ : g ≤ τ := by + have := h 0 (NatOrdinal.wpow_pos β) + rw [add_zero] at this + exact this.le + have hτg : partGE β τ = partGE β g := by + refine le_antisymm ?_ (partGE_mono hgτ) + by_contra hgt + rw [not_le] at hgt + have h1 := add_le_of_dvd_of_lt (exists_val_partGE_eq_mul β g) + (exists_val_partGE_eq_mul β τ) (NatOrdinal.val.lt_iff_lt.mpr hgt) + have h2 : partGE β g + ω^ β ≤ partGE β τ := by + rw [partGE_add_wpow, ← NatOrdinal.of_val (partGE β τ), NatOrdinal.of.le_iff_le] + exact h1 + exact absurd (h2.trans (partGE_le β τ)) (not_le.mpr hlt) + -- write `τ = τ_{≥β} + τ_{<β}` and compare with `g ⊕ τ_{<β}`. + have hτ : partGE β g + partLT β τ = τ := by + rw [← hτg, val_partGE_add_val_partLT, ← val_eq_val_partGE_add_val_partLT, + NatOrdinal.of_val] + have h3 : partGE β g + partLT β τ ≤ g + partLT β τ := + add_le_add_left (partGE_le β g) _ + rw [hτ] at h3 + exact absurd h3 (not_le.mpr (h _ (partLT_lt β τ))) + +/-- If `c ≠ 0`, `b ⊕ θ < τ` for every `θ < c`, and `τ < h' ≤ b ⊕ c`, then +`h' = b' ⊕ c` for some `b' ≤ b`. -/ +@[blueprint "lem:intermediate-ordinal-hessenberg-decomposition" + (phase := "Algebraic and ordinal preliminaries") + (title := "Intermediate ordinals below a Hessenberg sum") + (statement := /-- + Let $\sigma\ne0$ and suppose + $\rho\oplus\theta<\tau$ for every $\theta<\sigma$. If + $\tau rw [← partGE_add_partLT β a] + rw [constantCoeff_add, constantCoeff_partGE hβ, zero_add] + + +/-- The last term of the Cantor normal form of a nonzero limit natural ordinal is `ω^e` with +`e ≠ 0`. -/ +theorem exists_leastTerm_eq_wpow_ne_zero {a : NatOrdinal} (ha : a ≠ 0) (hcc : a.constantCoeff = 0) : + ∃ e, e ≠ 0 ∧ leastTerm a = ω^ e := by + obtain ⟨e, he⟩ := exists_leastTerm_eq_wpow ha + refine ⟨e, fun he0 ↦ ?_, he⟩ + rw [he0, wpow_zero, ← removeLeastTerm_add_one_eq_self_iff] at he + rw [← he, show (1 : NatOrdinal) = ((1 : ℕ) : NatOrdinal) by rw [Nat.cast_one], + constantCoeff_add_natCast] at hcc + omega + +end NatOrdinal diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/SetOrderType.lean b/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/SetOrderType.lean new file mode 100644 index 0000000000..7740e5570d --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/SetOrderType.lean @@ -0,0 +1,613 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.CombinatorialGames.NatOrdinal.Basic +public import Mathlib.Order.WellFoundedSet +public import Mathlib.SetTheory.Ordinal.Principal +public import Mathlib.SetTheory.Cardinal.Aleph + +import Mathlib.Data.Sum.Order +import Mathlib.Order.Hom.Set + +/-! +# Order type of a partially well-ordered set + +A partially well-ordered subset of a linear order is well-ordered by the induced strict order. +This module assigns it that ordinary ordinal order type. The order is always the ambient order, +with no reversal. + +The union theorem proves a slightly more general form of LM24, Fact 2.2.3(2): the two sets need not +first be exhibited as subsets of a common well-ordered set. Its right-hand side uses addition in +`NatOrdinal`, hence Hessenberg's natural sum rather than ordinary ordinal addition. + +Mathlib supplies `Ordinal.type_sum_lex`, `Ordinal.type_eq`, `OrderIso.sumLexIioIci`, and ordinal +enumeration, but no theorem equivalent to LM24, Fact 2.2.3(1), nor its uniqueness consequence. +The proof reuses the lexicographic-sum and order-isomorphism infrastructure rather than defining +a new ordinal representation. +-/ + +universe u + +public noncomputable section + +namespace Set.IsPWO + +open Ordinal + +variable {α : Type u} [LinearOrder α] {s t : Set α} + +private theorem isWellOrder (hs : s.IsPWO) : + IsWellOrder s (Subrel (· < ·) (· ∈ s)) := + { wf := hs.isWF + trichotomous := fun _ _ hab hba ↦ + Subtype.ext (le_antisymm (le_of_not_gt hba) (le_of_not_gt hab)) } + +/-- The ordinary ordinal order type of a partially well-ordered subset of a linear order. -/ +def orderType (hs : s.IsPWO) : Ordinal.{u} := + @Ordinal.type s (Subrel (· < ·) (· ∈ s)) (isWellOrder hs) + +/-- A countable partially well-ordered set has order type below `ω₁`. -/ +theorem orderType_lt_omega_one_of_countable (hs : s.IsPWO) (hc : s.Countable) : + hs.orderType < ω₁ := by + rw [orderType, Cardinal.lt_omega_iff_card_lt, card_type, Cardinal.lt_aleph_one_iff, + Cardinal.le_aleph0_iff_set_countable] + exact hc + +/-- The order type does not depend on the proof that the set is partially well-ordered. -/ +theorem orderType_proof_irrel (hs ht : s.IsPWO) : hs.orderType = ht.orderType := by + rfl + +/-- A partially well-ordered set has order type zero exactly when it is empty. -/ +@[simp] +theorem orderType_eq_zero (hs : s.IsPWO) : hs.orderType = 0 ↔ s = ∅ := by + let := isWellOrder hs + rw [orderType, Ordinal.type_eq_zero_iff_isEmpty, isEmpty_subtype] + exact Set.eq_empty_iff_forall_notMem.symm + +/-- For a globally well-ordered ambient type, `orderType` agrees with `typeLT` on the subtype. -/ +theorem orderType_eq_typeLT [WellFoundedLT α] (hs : s.IsPWO) : + hs.orderType = typeLT s := by + rfl + +/-- Compute the order type through an order isomorphism from the set to a well-ordered type. -/ +theorem orderType_eq_typeLT_of_orderIso {A : Type u} [LinearOrder A] [WellFoundedLT A] + (hs : s.IsPWO) (e : s ≃o A) : hs.orderType = typeLT A := by + let := isWellOrder hs + let er : Subrel (· < ·) (· ∈ s) ≃r (· < · : A → A → Prop) := + e.toRelIsoLT + exact er.ordinalType_congr + +/-- A partially well-ordered set is order-isomorphic to the canonical well order of its ordinary +order type. -/ +theorem nonempty_orderIso_toType (hs : s.IsPWO) : Nonempty (hs.orderType.ToType ≃o s) := by + let : WellFoundedLT s := hs.isWF + have htypes : typeLT hs.orderType.ToType = typeLT s := by + rw [type_toType] + exact hs.orderType_eq_typeLT_of_orderIso (OrderIso.refl s) + exact ⟨OrderIso.ofRelIsoLT (Classical.choice (Ordinal.type_eq.mp htypes))⟩ + +/-- Compute the order type through a relation isomorphism from the set to an arbitrary +well-order. -/ +theorem orderType_eq_type_of_relIso {A : Type u} {r : A → A → Prop} + [IsWellOrder A r] (hs : s.IsPWO) + (e : Subrel (· < ·) (· ∈ s) ≃r r) : + hs.orderType = Ordinal.type r := by + let := isWellOrder hs + exact e.ordinalType_congr + +/-- Equal subsets have equal order types. -/ +theorem orderType_congr (hs : s.IsPWO) (ht : t.IsPWO) (h : s = t) : + hs.orderType = ht.orderType := by + subst t + rfl + +/-- Inclusion of partially well-ordered subsets cannot decrease their ordinary order type. -/ +theorem orderType_mono (hs : s.IsPWO) (ht : t.IsPWO) (h : s ⊆ t) : + hs.orderType ≤ ht.orderType := by + let := isWellOrder hs + let := isWellOrder ht + exact (Subrel.inclusionEmbedding (· < ·) h).ordinal_type_le + +/-- A strictly increasing image has the same ordinary order type as the original partially +well-ordered set. -/ +theorem orderType_image_of_strictMonoOn {B : Type u} [LinearOrder B] + (hs : s.IsPWO) {f : α → B} (hf : StrictMonoOn f s) : + (hs.image_of_monotoneOn hf.monotoneOn).orderType = hs.orderType := by + let : WellFoundedLT s := hs.isWF + let e : s ≃o f '' s := + StrictMonoOn.orderIso f s hf + exact + ((hs.image_of_monotoneOn hf.monotoneOn).orderType_eq_typeLT_of_orderIso e.symm).trans + (hs.orderType_eq_typeLT_of_orderIso (OrderIso.refl s)).symm + +/-- A well-ordered set has order type `a + b` exactly when it is the union of a set of order +type `a` followed strictly by a set of order type `b`. This is LM24, Fact 2.2.3(1). -/ +theorem orderType_eq_add_iff (hs : s.IsPWO) (a b : Ordinal.{u}) : + hs.orderType = a + b ↔ + ∃ (s₀ s₁ : Set α) (hs₀ : s₀.IsPWO) (hs₁ : s₁.IsPWO), + s₀ ⊆ s ∧ + s₁ ⊆ s ∧ + (∀ x ∈ s₀, ∀ y ∈ s₁, x < y) ∧ + hs₀.orderType = a ∧ + hs₁.orderType = b ∧ + s = s₀ ∪ s₁ := by + constructor + · intro htype + let : WellFoundedLT s := hs.isWF + let : WellFoundedLT (a.ToType ⊕ₗ b.ToType) := + Sum.lex_wf wellFounded_lt wellFounded_lt + have htypes : typeLT s = typeLT (a.ToType ⊕ₗ b.ToType) := by + calc + typeLT s = hs.orderType := + (hs.orderType_eq_typeLT_of_orderIso (OrderIso.refl s)).symm + _ = a + b := htype + _ = typeLT (a.ToType ⊕ₗ b.ToType) := by + symm + calc + typeLT (a.ToType ⊕ₗ b.ToType) = + Ordinal.type (Sum.Lex (· < · : a.ToType → a.ToType → Prop) + (· < · : b.ToType → b.ToType → Prop)) := + (Sum.Lex.toLexRelIsoLT (α := a.ToType) + (β := b.ToType)).ordinalType_congr.symm + _ = a + b := by + rw [Ordinal.type_sum_lex, Ordinal.type_toType, Ordinal.type_toType] + let e : s ≃o a.ToType ⊕ₗ b.ToType := + OrderIso.ofRelIsoLT (Classical.choice (Ordinal.type_eq.mp htypes)) + let left : a.ToType ↪o α := + OrderEmbedding.ofStrictMono + (fun x ↦ (e.symm (Sum.inlₗ x)).1) + (fun _ _ hxy ↦ e.symm.strictMono (Sum.Lex.inl_strictMono hxy)) + let right : b.ToType ↪o α := + OrderEmbedding.ofStrictMono + (fun x ↦ (e.symm (Sum.inrₗ x)).1) + (fun _ _ hxy ↦ e.symm.strictMono (Sum.Lex.inr_strictMono hxy)) + let s₀ : Set α := Set.range left + let s₁ : Set α := Set.range right + have hs₀s : s₀ ⊆ s := by + rintro x ⟨y, rfl⟩ + exact (e.symm (Sum.inlₗ y)).2 + have hs₁s : s₁ ⊆ s := by + rintro x ⟨y, rfl⟩ + exact (e.symm (Sum.inrₗ y)).2 + let hs₀ : s₀.IsPWO := hs.mono hs₀s + let hs₁ : s₁.IsPWO := hs.mono hs₁s + have hs₀type : hs₀.orderType = a := by + rw [hs₀.orderType_eq_typeLT_of_orderIso left.orderIso.symm, + Ordinal.type_toType] + have hs₁type : hs₁.orderType = b := by + rw [hs₁.orderType_eq_typeLT_of_orderIso right.orderIso.symm, + Ordinal.type_toType] + have hbefore : ∀ x ∈ s₀, ∀ y ∈ s₁, x < y := by + rintro _ ⟨x, rfl⟩ _ ⟨y, rfl⟩ + exact e.symm.strictMono (Sum.Lex.inl_lt_inr x y) + have hunion : s = s₀ ∪ s₁ := by + apply Set.Subset.antisymm + · intro x hx + rcases heq : e ⟨x, hx⟩ with y | y + · left + refine ⟨y, ?_⟩ + change (e.symm (Sum.inlₗ y)).1 = x + have h := e.symm_apply_apply ⟨x, hx⟩ + rw [heq] at h + exact congrArg Subtype.val h + · right + refine ⟨y, ?_⟩ + change (e.symm (Sum.inrₗ y)).1 = x + have h := e.symm_apply_apply ⟨x, hx⟩ + rw [heq] at h + exact congrArg Subtype.val h + · exact Set.union_subset hs₀s hs₁s + exact ⟨s₀, s₁, hs₀, hs₁, hs₀s, hs₁s, hbefore, hs₀type, hs₁type, hunion⟩ + · rintro ⟨s₀, s₁, hs₀, hs₁, hs₀s, hs₁s, hbefore, hs₀type, hs₁type, hunion⟩ + let f : s₀ ⊕ₗ s₁ → s + | Sum.inlₗ x => ⟨x, hs₀s x.2⟩ + | Sum.inrₗ x => ⟨x, hs₁s x.2⟩ + have hf : StrictMono f := by + intro x y hxy + rcases x with x | x <;> rcases y with y | y + · have hxy' : x < y := + (Sum.Lex.inl_lt_inl_iff (α := s₀) (β := s₁)).mp hxy + exact hxy' + · exact hbefore x x.2 y y.2 + · exact (Sum.Lex.not_inr_lt_inl hxy).elim + · have hxy' : x < y := + (Sum.Lex.inr_lt_inr_iff (α := s₀) (β := s₁)).mp hxy + exact hxy' + have hsurj : Function.Surjective f := by + rintro ⟨x, hx⟩ + rw [hunion] at hx + rcases hx with hx | hx + · exact ⟨Sum.inlₗ ⟨x, hx⟩, rfl⟩ + · exact ⟨Sum.inrₗ ⟨x, hx⟩, rfl⟩ + let e : s₀ ⊕ₗ s₁ ≃o s := hf.orderIsoOfSurjective f hsurj + let : WellFoundedLT s₀ := hs₀.isWF + let : WellFoundedLT s₁ := hs₁.isWF + let : WellFoundedLT (s₀ ⊕ₗ s₁) := + Sum.lex_wf wellFounded_lt wellFounded_lt + calc + hs.orderType = typeLT (s₀ ⊕ₗ s₁) := + hs.orderType_eq_typeLT_of_orderIso e.symm + _ = typeLT s₀ + typeLT s₁ := Ordinal.type_sum_lex _ _ + _ = hs₀.orderType + hs₁.orderType := by + rw [hs₀.orderType_eq_typeLT_of_orderIso (OrderIso.refl s₀), + hs₁.orderType_eq_typeLT_of_orderIso (OrderIso.refl s₁)] + _ = a + b := by rw [hs₀type, hs₁type] + +/-- A partially well-ordered set is finite exactly when its order type is below `ω`. -/ +theorem finite_iff_orderType_lt_omega (hs : s.IsPWO) : + s.Finite ↔ hs.orderType < Ordinal.omega0 := by + let := isWellOrder hs + rw [Set.Finite, ← Cardinal.mk_lt_aleph0_iff] + rw [orderType, ← Ordinal.card_type (Subrel (· < ·) (· ∈ s)), Ordinal.card_lt_aleph0] + +/-- Every infinite partially well-ordered set is an initial block of nonzero limit order type +followed by a finite final block. The split removes the finite remainder after ordinal division of +the order type by `ω`. -/ +theorem finite_or_exists_limit_initial_finite_final (hs : s.IsPWO) : + s.Finite ∨ + ∃ (s₀ s₁ : Set α) (hs₀ : s₀.IsPWO) (_ : s₁.IsPWO), + s₀ ⊆ s ∧ + s₁ ⊆ s ∧ + (∀ x ∈ s₀, ∀ y ∈ s₁, x < y) ∧ + Order.IsSuccLimit hs₀.orderType ∧ + s₁.Finite ∧ + s = s₀ ∪ s₁ := by + by_cases hfinite : s.Finite + · exact Or.inl hfinite + · right + have homega : Ordinal.omega0 ≤ hs.orderType := by + exact le_of_not_gt (hfinite ∘ hs.finite_iff_orderType_lt_omega.mpr) + have hdivpos : 0 < hs.orderType / Ordinal.omega0 := by + exact (Ordinal.div_pos Ordinal.omega0_ne_zero).mpr homega + have hlimit : Order.IsSuccLimit + (Ordinal.omega0 * (hs.orderType / Ordinal.omega0)) := + Ordinal.isSuccLimit_mul_left Ordinal.isSuccLimit_omega0 hdivpos + have hmodlt : hs.orderType % Ordinal.omega0 < Ordinal.omega0 := + Ordinal.mod_lt hs.orderType Ordinal.omega0_ne_zero + have hdecomp : + hs.orderType = Ordinal.omega0 * (hs.orderType / Ordinal.omega0) + + hs.orderType % Ordinal.omega0 := + (Ordinal.div_add_mod hs.orderType Ordinal.omega0).symm + obtain ⟨s₀, s₁, hs₀, hs₁, hs₀s, hs₁s, hbefore, hs₀type, hs₁type, hunion⟩ := + (hs.orderType_eq_add_iff + (Ordinal.omega0 * (hs.orderType / Ordinal.omega0)) + (hs.orderType % Ordinal.omega0)).mp hdecomp + refine ⟨s₀, s₁, hs₀, hs₁, hs₀s, hs₁s, hbefore, ?_, ?_, hunion⟩ + · rwa [hs₀type] + · rw [hs₁.finite_iff_orderType_lt_omega, hs₁type] + exact hmodlt + +private def belowRelIso {x : α} (hx : x ∈ s) : + Subrel (· < ·) (· ∈ s ∩ Set.Iio x) ≃r + Subrel (Subrel (· < ·) (· ∈ s)) + (Subrel (· < ·) (· ∈ s) · ⟨x, hx⟩) where + toFun a := ⟨⟨a.1, a.2.1⟩, a.2.2⟩ + invFun a := ⟨a.1.1, a.1.2, a.2⟩ + left_inv _ := rfl + right_inv _ := rfl + map_rel_iff' := Iff.rfl + +private def interIioOrderIso {x : α} (hx : x ∈ s) : + ↥(s ∩ Set.Iio x) ≃o Set.Iio (⟨x, hx⟩ : s) where + toFun z := ⟨⟨z.1, z.2.1⟩, z.2.2⟩ + invFun z := ⟨z.1.1, z.1.2, z.2⟩ + left_inv _ := rfl + right_inv _ := rfl + map_rel_iff' := Iff.rfl + +private def interIciOrderIso {x : α} (hx : x ∈ s) : + ↥(s ∩ Set.Ici x) ≃o Set.Ici (⟨x, hx⟩ : s) where + toFun z := ⟨⟨z.1, z.2.1⟩, z.2.2⟩ + invFun z := ⟨z.1.1, z.1.2, z.2⟩ + left_inv _ := rfl + right_inv _ := rfl + map_rel_iff' := Iff.rfl + +/-- The part of a partially well-ordered set strictly below one of its elements has order type +equal to the index of that element. -/ +theorem orderType_inter_Iio_eq_typein [WellFoundedLT s] + (hs : s.IsPWO) {x : α} (hx : x ∈ s) : + (hs.mono (s := s ∩ Set.Iio x) Set.inter_subset_left).orderType = + Ordinal.typein (· < · : s → s → Prop) ⟨x, hx⟩ := by + let : WellFoundedLT s := hs.isWF + rw [orderType_eq_typeLT_of_orderIso _ (interIioOrderIso hx), ← Ordinal.type_Iio_lt] + +/-- Splitting a partially well-ordered set at one of its elements splits its order type. -/ +theorem orderType_inter_Iio_add_inter_Ici [WellFoundedLT s] + (hs : s.IsPWO) {x : α} (hx : x ∈ s) : + (hs.mono (s := s ∩ Set.Iio x) Set.inter_subset_left).orderType + + (hs.mono (s := s ∩ Set.Ici x) Set.inter_subset_left).orderType = + hs.orderType := by + let : WellFoundedLT (Set.Iio (⟨x, hx⟩ : s) ⊕ₗ Set.Ici (⟨x, hx⟩ : s)) := + Sum.lex_wf wellFounded_lt wellFounded_lt + rw [orderType_eq_typeLT_of_orderIso _ (interIioOrderIso hx), + orderType_eq_typeLT_of_orderIso _ (interIciOrderIso hx), + ← Ordinal.type_sum_lex] + calc + _ = typeLT s := + (OrderIso.sumLexIioIci (⟨x, hx⟩ : s)).toRelIsoLT.ordinalType_congr + _ = hs.orderType := + (orderType_eq_typeLT_of_orderIso hs (OrderIso.refl s)).symm + +/-- Every ordinal below the order type is realized as the order type of the part strictly below +some element. -/ +theorem exists_orderType_inter_Iio_eq (hs : s.IsPWO) {k : Ordinal.{u}} + (hk : k < hs.orderType) : + ∃ x, ∃ _ : x ∈ s, + (hs.mono (s := s ∩ Set.Iio x) Set.inter_subset_left).orderType = k := by + let : WellFoundedLT s := hs.isWF + have htype : k < Ordinal.type (· < · : s → s → Prop) := by + rwa [← hs.orderType_eq_typeLT_of_orderIso (OrderIso.refl s)] + obtain ⟨y, hy⟩ := Ordinal.typein_surj (· < · : s → s → Prop) htype + exact ⟨y.1, y.2, (orderType_inter_Iio_eq_typein hs y.2).trans (by simpa using hy)⟩ + +/-- The part of a partially well-ordered set strictly below one of its elements has strictly smaller +order type. -/ +theorem orderType_inter_Iio_lt (hs : s.IsPWO) {x : α} (hx : x ∈ s) : + (hs.mono (s := s ∩ Set.Iio x) Set.inter_subset_left).orderType < hs.orderType := by + let := isWellOrder hs + let hbelow := hs.mono (s := s ∩ Set.Iio x) Set.inter_subset_left + let := isWellOrder hbelow + calc + hbelow.orderType = Ordinal.type + (Subrel (Subrel (· < ·) (· ∈ s)) + (Subrel (· < ·) (· ∈ s) · ⟨x, hx⟩)) := + (belowRelIso hx).ordinalType_congr + _ = Ordinal.typein (Subrel (· < ·) (· ∈ s)) ⟨x, hx⟩ := + Ordinal.type_subrel _ _ + _ < hs.orderType := Ordinal.typein_lt_type _ _ + +/-- If every closed initial segment has order type below `o`, then the whole partially +well-ordered set has order type at most `o`. -/ +theorem orderType_le_of_forall_inter_Iic_lt (hs : s.IsPWO) {o : Ordinal} + (h : ∀ x ∈ s, + (hs.mono (s := s ∩ Set.Iic x) Set.inter_subset_left).orderType < o) : + hs.orderType ≤ o := by + by_contra hle + have ho : o < hs.orderType := lt_of_not_ge hle + let := isWellOrder hs + obtain ⟨x, hx⟩ := + Ordinal.typein_surj (Subrel (· < ·) (· ∈ s)) ho + let hbelow := hs.mono (s := s ∩ Set.Iio x.1) Set.inter_subset_left + let := isWellOrder hbelow + have hiio : + (hs.mono (s := s ∩ Set.Iio x.1) Set.inter_subset_left).orderType = o := by + calc + hbelow.orderType = Ordinal.type + (Subrel (Subrel (· < ·) (· ∈ s)) + (Subrel (· < ·) (· ∈ s) · x)) := + (belowRelIso x.2).ordinalType_congr + _ = Ordinal.typein (Subrel (· < ·) (· ∈ s)) x := + Ordinal.type_subrel _ _ + _ = o := hx + have hsubset : s ∩ Set.Iio x.1 ⊆ s ∩ Set.Iic x.1 := by + intro y hy + exact ⟨hy.1, hy.2.le⟩ + have hmono := + (hs.mono (s := s ∩ Set.Iio x.1) Set.inter_subset_left).orderType_mono + (hs.mono (s := s ∩ Set.Iic x.1) Set.inter_subset_left) hsubset + exact (not_lt_of_ge (hiio ▸ hmono)) (h x.1 x.2) + +/-- If the ordinary order type is a limit ordinal, every member has a strictly larger member. -/ +theorem exists_gt_of_isSuccLimit_orderType + (hs : s.IsPWO) (hlimit : Order.IsSuccLimit hs.orderType) + {x : α} (hx : x ∈ s) : + ∃ y ∈ s, x < y := by + let : WellFoundedLT s := hs.isWF + have hprelimit : Order.IsSuccPrelimit + (Ordinal.type (fun x y : s ↦ x < y)) := by + rw [← hs.orderType_eq_typeLT_of_orderIso (OrderIso.refl s)] + exact hlimit.isSuccPrelimit + let : NoMaxOrder s := + Ordinal.isSuccPrelimit_type_lt_iff.mp hprelimit + obtain ⟨y, hxy⟩ : ∃ y : s, (⟨x, hx⟩ : s) < y := + exists_gt (⟨x, hx⟩ : s) + exact ⟨y.1, y.2, hxy⟩ + +/-- A nonempty partially well-ordered set with no maximum has successor-limit order type. This is +the converse of `Set.IsPWO.exists_gt_of_isSuccLimit_orderType`. -/ +theorem isSuccLimit_orderType_of_forall_exists_gt + (hs : s.IsPWO) (hne : s.Nonempty) (hgt : ∀ x ∈ s, ∃ y ∈ s, x < y) : + Order.IsSuccLimit hs.orderType := by + let : WellFoundedLT s := hs.isWF + have hnomax : NoMaxOrder s := by + constructor + rintro ⟨x, hx⟩ + obtain ⟨y, hy, hxy⟩ := hgt x hx + exact ⟨⟨y, hy⟩, hxy⟩ + refine ⟨?_, ?_⟩ + · rw [isMin_iff_eq_bot, Ordinal.bot_eq_zero, hs.orderType_eq_zero] + obtain ⟨x, hx⟩ := hne + intro hempty + rw [hempty] at hx + exact hx + · rw [hs.orderType_eq_typeLT_of_orderIso (OrderIso.refl s)] + exact Ordinal.isSuccPrelimit_type_lt_iff.mpr hnomax + +/-- A nonempty final segment of a partially well-ordered set of additively principal order type +has the same order type as the whole set. -/ +theorem orderType_inter_Ioi_eq_of_isPrincipal + (hs : s.IsPWO) (hprincipal : IsPrincipal (fun a b ↦ a + b) hs.orderType) + {x : α} (hupper : ∃ y ∈ s, x < y) : + (hs.mono (s := s ∩ Set.Ioi x) Set.inter_subset_left).orderType = hs.orderType := by + let lower : Set α := s ∩ Set.Iic x + let upper : Set α := s ∩ Set.Ioi x + let hlower : lower.IsPWO := hs.mono Set.inter_subset_left + let hupperPWO : upper.IsPWO := hs.mono Set.inter_subset_left + change hupperPWO.orderType = hs.orderType + have hlowerBeforeUpper : ∀ a ∈ lower, ∀ b ∈ upper, a < b := by + intro a ha b hb + exact ha.2.trans_lt hb.2 + have hsUnion : s = lower ∪ upper := by + ext a + simp only [lower, upper, Set.mem_union, Set.mem_inter_iff, Set.mem_Iic, Set.mem_Ioi] + constructor + · intro ha + rcases le_or_gt a x with hax | hxa + · exact Or.inl ⟨ha, hax⟩ + · exact Or.inr ⟨ha, hxa⟩ + · rintro (⟨ha, _⟩ | ⟨ha, _⟩) <;> exact ha + have hsplit : hs.orderType = hlower.orderType + hupperPWO.orderType := by + apply (hs.orderType_eq_add_iff hlower.orderType hupperPWO.orderType).mpr + exact ⟨lower, upper, hlower, hupperPWO, Set.inter_subset_left, + Set.inter_subset_left, hlowerBeforeUpper, rfl, rfl, hsUnion⟩ + obtain ⟨y, hyS, hxy⟩ := hupper + have hlowerSubset : lower ⊆ s ∩ Set.Iio y := by + intro a ha + exact ⟨ha.1, ha.2.trans_lt hxy⟩ + have hlowerLt : hlower.orderType < hs.orderType := + (hlower.orderType_mono + (hs.mono (s := s ∩ Set.Iio y) Set.inter_subset_left) hlowerSubset).trans_lt + (hs.orderType_inter_Iio_lt hyS) + apply le_antisymm + · exact hupperPWO.orderType_mono hs Set.inter_subset_left + · apply le_of_not_gt + intro hupperLt + have hsumLt := hprincipal hlowerLt hupperLt + change hlower.orderType + hupperPWO.orderType < hs.orderType at hsumLt + rw [← hsplit] at hsumLt + exact (lt_irrefl hs.orderType) hsumLt + +/-- Two decompositions into a first part followed strictly by a second part are equal when their +first parts have the same order type. -/ +theorem orderType_split_unique {s₀ s₁ t₀ t₁ : Set α} + (hs₀ : s₀.IsPWO) (ht₀ : t₀.IsPWO) + (hsBefore : ∀ x ∈ s₀, ∀ y ∈ s₁, x < y) + (htBefore : ∀ x ∈ t₀, ∀ y ∈ t₁, x < y) + (hsUnion : s = s₀ ∪ s₁) (htUnion : s = t₀ ∪ t₁) + (htype : hs₀.orderType = ht₀.orderType) : + s₀ = t₀ ∧ s₁ = t₁ := by + have hs₀t₀ : s₀ ⊆ t₀ := by + intro x hx + by_contra hxt₀ + have hxs : x ∈ s := by + rw [hsUnion] + exact Set.mem_union_left s₁ hx + rw [htUnion] at hxs + have hxt₁ : x ∈ t₁ := hxs.resolve_left hxt₀ + have ht₀sub : t₀ ⊆ s₀ ∩ Set.Iio x := by + intro y hyt₀ + have hyx : y < x := htBefore y hyt₀ x hxt₁ + have hys : y ∈ s := by + rw [htUnion] + exact Set.mem_union_left t₁ hyt₀ + rw [hsUnion] at hys + refine ⟨?_, hyx⟩ + exact hys.resolve_right fun hys₁ ↦ (hsBefore x hx y hys₁).not_gt hyx + have hlt : ht₀.orderType < hs₀.orderType := + (orderType_mono ht₀ + (hs₀.mono (s := s₀ ∩ Set.Iio x) Set.inter_subset_left) ht₀sub).trans_lt + (orderType_inter_Iio_lt hs₀ hx) + exact hlt.ne htype.symm + have ht₀s₀ : t₀ ⊆ s₀ := by + intro x hx + by_contra hxs₀ + have hxs : x ∈ s := by + rw [htUnion] + exact Set.mem_union_left t₁ hx + rw [hsUnion] at hxs + have hxs₁ : x ∈ s₁ := hxs.resolve_left hxs₀ + have hs₀sub : s₀ ⊆ t₀ ∩ Set.Iio x := by + intro y hys₀ + have hyx : y < x := hsBefore y hys₀ x hxs₁ + have hys : y ∈ s := by + rw [hsUnion] + exact Set.mem_union_left s₁ hys₀ + rw [htUnion] at hys + refine ⟨?_, hyx⟩ + exact hys.resolve_right fun hyt₁ ↦ (htBefore x hx y hyt₁).not_gt hyx + have hlt : hs₀.orderType < ht₀.orderType := + (orderType_mono hs₀ + (ht₀.mono (s := t₀ ∩ Set.Iio x) Set.inter_subset_left) hs₀sub).trans_lt + (orderType_inter_Iio_lt ht₀ hx) + exact hlt.ne htype + have hs₀eq : s₀ = t₀ := Set.Subset.antisymm hs₀t₀ ht₀s₀ + refine ⟨hs₀eq, Set.Subset.antisymm ?_ ?_⟩ + · intro x hxs₁ + have hxs : x ∈ s := by + rw [hsUnion] + exact Set.mem_union_right s₀ hxs₁ + rw [htUnion] at hxs + exact hxs.resolve_left fun hxt₀ ↦ + (hsBefore x (hs₀eq ▸ hxt₀) x hxs₁).false + · intro x hxt₁ + have hxs : x ∈ s := by + rw [htUnion] + exact Set.mem_union_right t₀ hxt₁ + rw [hsUnion] at hxs + exact hxs.resolve_left fun hxs₀ ↦ + (htBefore x (hs₀eq ▸ hxs₀) x hxt₁).false + +private theorem orderType_inter_Iio_mono (hs : s.IsPWO) {x y : α} (hxy : x ≤ y) : + (hs.mono Set.inter_subset_left (s := s ∩ Set.Iio x)).orderType ≤ + (hs.mono Set.inter_subset_left (s := s ∩ Set.Iio y)).orderType := by + apply orderType_mono + intro z hz + exact ⟨hz.1, hz.2.trans_le hxy⟩ + +private theorem orderType_inter_Iio_lt_inter_Iio (hs : s.IsPWO) {x y : α} + (hx : x ∈ s) (hxy : x < y) : + (hs.mono Set.inter_subset_left (s := s ∩ Set.Iio x)).orderType < + (hs.mono Set.inter_subset_left (s := s ∩ Set.Iio y)).orderType := by + let hsy : (s ∩ Set.Iio y).IsPWO := hs.mono Set.inter_subset_left + have hxsy : x ∈ s ∩ Set.Iio y := ⟨hx, hxy⟩ + have hlt := hsy.orderType_inter_Iio_lt hxsy + have heq : (s ∩ Set.Iio y) ∩ Set.Iio x = s ∩ Set.Iio x := by + ext z + constructor + · exact fun hz ↦ ⟨hz.1.1, hz.2⟩ + · exact fun hz ↦ ⟨⟨hz.1, hz.2.trans hxy⟩, hz.2⟩ + rw [orderType_congr _ _ heq] at hlt + exact hlt + +/-- The order type of a union is at most the Hessenberg sum of the two order types. This +specializes to LM24, Fact 2.2.3(2). -/ +theorem orderType_union_le_naturalAdd (hs : s.IsPWO) (ht : t.IsPWO) : + (hs.union ht).orderType ≤ + (NatOrdinal.of hs.orderType + NatOrdinal.of ht.orderType).val := by + let hsBelow (x : α) : (s ∩ Set.Iio x).IsPWO := + hs.mono Set.inter_subset_left + let htBelow (x : α) : (t ∩ Set.Iio x).IsPWO := + ht.mono Set.inter_subset_left + let rankS (x : α) : NatOrdinal := NatOrdinal.of (hsBelow x).orderType + let rankT (x : α) : NatOrdinal := NatOrdinal.of (htBelow x).orderType + let total : NatOrdinal := NatOrdinal.of hs.orderType + NatOrdinal.of ht.orderType + have rank_lt_total (x : α) (hx : x ∈ s ∪ t) : rankS x + rankT x < total := by + have hsle : rankS x ≤ NatOrdinal.of hs.orderType := + NatOrdinal.of.monotone (orderType_mono (hsBelow x) hs Set.inter_subset_left) + have htle : rankT x ≤ NatOrdinal.of ht.orderType := + NatOrdinal.of.monotone (orderType_mono (htBelow x) ht Set.inter_subset_left) + rcases hx with hxs | hxt + · exact add_lt_add_of_lt_of_le + (NatOrdinal.of.strictMono (orderType_inter_Iio_lt hs hxs)) htle + · exact add_lt_add_of_le_of_lt hsle + (NatOrdinal.of.strictMono (orderType_inter_Iio_lt ht hxt)) + let rank (x : ↥(s ∪ t)) : total.val.ToType := + Ordinal.ToType.mk ⟨(rankS x.1 + rankT x.1).val, + NatOrdinal.val.lt_iff_lt.mpr (rank_lt_total x.1 x.2)⟩ + have rank_strict {x y : ↥(s ∪ t)} (hxy : x < y) : rank x < rank y := by + have hsle : rankS x.1 ≤ rankS y.1 := + NatOrdinal.of.monotone (orderType_inter_Iio_mono hs hxy.le) + have htle : rankT x.1 ≤ rankT y.1 := + NatOrdinal.of.monotone (orderType_inter_Iio_mono ht hxy.le) + have hsum : rankS x.1 + rankT x.1 < rankS y.1 + rankT y.1 := by + rcases x.2 with hxs | hxt + · exact add_lt_add_of_lt_of_le + (NatOrdinal.of.strictMono + (orderType_inter_Iio_lt_inter_Iio hs hxs hxy)) htle + · exact add_lt_add_of_le_of_lt hsle + (NatOrdinal.of.strictMono + (orderType_inter_Iio_lt_inter_Iio ht hxt hxy)) + exact Ordinal.ToType.mk.lt_iff_lt.mpr (NatOrdinal.val.lt_iff_lt.mpr hsum) + let e : Subrel (· < ·) (· ∈ s ∪ t) ↪r + (· < · : total.val.ToType → total.val.ToType → Prop) := + RelEmbedding.ofMonotone rank fun _ _ hxy ↦ rank_strict hxy + let := isWellOrder (hs.union ht) + change Ordinal.type (Subrel (· < ·) (· ∈ s ∪ t)) ≤ total.val + simpa only [Ordinal.type_toType] using e.ordinal_type_le + +end Set.IsPWO diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/Split.lean b/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/Split.lean new file mode 100644 index 0000000000..2141c92403 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/Split.lean @@ -0,0 +1,322 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.CantorTermCount +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.NaturalPrincipal +public import Mathlib.Algebra.Order.BigOperators.Group.List + +/-! +# The parts of an ordinal at or above, and below, an exponent + +For a natural ordinal `a` and an exponent `β`, write the Cantor normal form of `a` with repeated +terms [LM24, §2.2] as `a = ω^{e_1} + ⋯ + ω^{e_r}` with `e_1 ≥ ⋯ ≥ e_r`, and let `a_{≥β}` be the sum +of the terms with `e_i ≥ β` and `a_{<β}` the sum of those with `e_i < β` — the *part of `a` at or +above `β`* (Lean `partGE β a`) and the *part of `a` below `β`* (`partLT β a`). Then +`a = a_{≥β} + a_{<β} = a_{≥β} ⊕ a_{<β}`, `a_{<β} < ω^β`, `a_{≥β}` is a multiple of `ω^β`, and both +parts are additive for the natural sum `⊕`, the Cantor normal form of a natural sum being the merge +of the two normal forms. This is the bookkeeping used when a grading by ordinals is split at an +exponent. +-/ + +universe u + +open Ordinal + +public noncomputable section + +namespace NatOrdinal + +open scoped Classical in +/-- The part `a_{≥β}` of `a` at or above `β`: the sum of the terms `ω^e` of the Cantor normal form +of `a` with `e ≥ β`. -/ +def partGE (β a : NatOrdinal.{u}) : NatOrdinal.{u} := + ((a.val.additivePrincipalTerms.filter fun t ↦ (ω^ β).val ≤ t).map NatOrdinal.of).sum + +open scoped Classical in +/-- The part `a_{<β}` of `a` below `β`: the sum of the terms `ω^e` of the Cantor normal form of `a` +with `e < β`. -/ +def partLT (β a : NatOrdinal.{u}) : NatOrdinal.{u} := + ((a.val.additivePrincipalTerms.filter fun t ↦ t < (ω^ β).val).map NatOrdinal.of).sum + +/-- A natural ordinal is the natural sum of its Cantor terms. -/ +theorem sum_map_of_additivePrincipalTerms (a : NatOrdinal.{u}) : + (a.val.additivePrincipalTerms.map NatOrdinal.of).sum = a := by + rw [← natOrdinal_of_sum_eq_sum_map_of_sorted + (fun t ht ↦ isAdditivelyPrincipal_of_mem_additivePrincipalTerms ht) + (additivePrincipalTerms_sortedGE _), additivePrincipalTerms_sum, NatOrdinal.of_val] + +/-- Splitting a list sum along a predicate. -/ +theorem sum_map_filter_add_sum_map_filter_not {l : List Ordinal.{u}} (p : Ordinal.{u} → Prop) + [DecidablePred p] : + ((l.filter p).map NatOrdinal.of).sum + ((l.filter fun t ↦ ¬ p t).map NatOrdinal.of).sum = + (l.map NatOrdinal.of).sum := by + induction l with + | nil => simp + | cons a l ih => + by_cases ha : p a + · rw [List.filter_cons_of_pos (by simpa using ha), List.filter_cons_of_neg (by simpa using ha), + List.map_cons, List.sum_cons, List.map_cons, List.sum_cons, add_assoc, ih] + · rw [List.filter_cons_of_neg (by simpa using ha), List.filter_cons_of_pos (by simpa using ha), + List.map_cons, List.sum_cons, List.map_cons, List.sum_cons, add_left_comm, ih] + +/-- `a = a_{≥β} + a_{<β}`. -/ +theorem partGE_add_partLT (β a : NatOrdinal.{u}) : + partGE β a + partLT β a = a := by + classical + rw [partGE, partLT] + have h := sum_map_filter_add_sum_map_filter_not (l := a.val.additivePrincipalTerms) + fun t ↦ (ω^ β).val ≤ t + simp only [not_le] at h + rw [h, sum_map_of_additivePrincipalTerms] + +/-- The sum of the `of` of a list of ordinals is invariant under permutation. -/ +theorem sum_map_of_perm {l l' : List Ordinal.{u}} (h : l.Perm l') : + (l.map NatOrdinal.of).sum = (l'.map NatOrdinal.of).sum := + (h.map NatOrdinal.of).sum_eq + +/-- The part at or above `β` is additive for the natural sum. -/ +theorem partGE_add (β a b : NatOrdinal.{u}) : + partGE β (a + b) = partGE β a + partGE β b := by + classical + rw [partGE, partGE, partGE, ← List.sum_append, ← List.map_append, + ← List.filter_append] + exact sum_map_of_perm ((additivePrincipalTerms_add_perm a b).filter _) + +/-- The part below `β` is additive for the natural sum. -/ +theorem partLT_add (β a b : NatOrdinal.{u}) : + partLT β (a + b) = partLT β a + partLT β b := by + classical + rw [partLT, partLT, partLT, ← List.sum_append, ← List.map_append, + ← List.filter_append] + exact sum_map_of_perm ((additivePrincipalTerms_add_perm a b).filter _) + +/-- A natural sum of finitely many ordinals below `ω^β` is below `ω^β`. -/ +theorem sum_map_of_lt_wpow {l : List Ordinal.{u}} {β : NatOrdinal.{u}} + (h : ∀ t ∈ l, t < (ω^ β).val) : (l.map NatOrdinal.of).sum < ω^ β := by + induction l with + | nil => simp [NatOrdinal.wpow_pos] + | cons a l ih => + rw [List.map_cons, List.sum_cons] + refine add_lt_of_isAdditivelyPrincipal ?_ ?_ (ih fun t ht ↦ h t (List.mem_cons_of_mem a ht)) + · rw [NatOrdinal.val_wpow] + exact isAdditivelyPrincipal_omega0_opow _ + · rw [← NatOrdinal.of_val (ω^ β)] + exact NatOrdinal.of.lt_iff_lt.mpr (h a (List.mem_cons_self ..)) + +/-- The part of `a` below `β` is below `ω^β`. -/ +theorem partLT_lt (β a : NatOrdinal.{u}) : partLT β a < ω^ β := by + classical + rw [partLT] + exact sum_map_of_lt_wpow fun t ht ↦ of_decide_eq_true (List.mem_filter.mp ht).2 + +@[simp] +theorem partGE_zero (β : NatOrdinal.{u}) : partGE β 0 = 0 := by + classical + simp [partGE] + +@[simp] +theorem partLT_zero (β : NatOrdinal.{u}) : partLT β 0 = 0 := by + classical + simp [partLT] + +/-- Taking the part at or above `β`, as an endomorphism of the natural-sum monoid. -/ +def partGEAddMonoidHom (β : NatOrdinal.{u}) : NatOrdinal.{u} →+ NatOrdinal.{u} where + toFun := partGE β + map_zero' := partGE_zero β + map_add' := partGE_add β + +/-- Taking the part below `β`, as an endomorphism of the natural-sum monoid. -/ +def partLTAddMonoidHom (β : NatOrdinal.{u}) : NatOrdinal.{u} →+ NatOrdinal.{u} where + toFun := partLT β + map_zero' := partLT_zero β + map_add' := partLT_add β + +@[simp] +theorem partGEAddMonoidHom_apply (β a : NatOrdinal.{u}) : partGEAddMonoidHom β a = partGE β a := + (rfl) + +@[simp] +theorem partLTAddMonoidHom_apply (β a : NatOrdinal.{u}) : partLTAddMonoidHom β a = partLT β a := + (rfl) + +theorem partGE_nsmul (β : NatOrdinal.{u}) (n : ℕ) (a : NatOrdinal.{u}) : + partGE β (n • a) = n • partGE β a := by + simpa using (partGEAddMonoidHom β).map_nsmul n a + +theorem partLT_nsmul (β : NatOrdinal.{u}) (n : ℕ) (a : NatOrdinal.{u}) : + partLT β (n • a) = n • partLT β a := by + simpa using (partLTAddMonoidHom β).map_nsmul n a + +theorem partGE_sum {ι : Type*} (β : NatOrdinal.{u}) (s : Finset ι) (f : ι → NatOrdinal.{u}) : + partGE β (∑ i ∈ s, f i) = ∑ i ∈ s, partGE β (f i) := by + rw [← partGEAddMonoidHom_apply β (∑ i ∈ s, f i), map_sum] + exact Finset.sum_congr rfl fun i _ ↦ partGEAddMonoidHom_apply β (f i) + +theorem partLT_sum {ι : Type*} (β : NatOrdinal.{u}) (s : Finset ι) (f : ι → NatOrdinal.{u}) : + partLT β (∑ i ∈ s, f i) = ∑ i ∈ s, partLT β (f i) := by + rw [← partLTAddMonoidHom_apply β (∑ i ∈ s, f i), map_sum] + exact Finset.sum_congr rfl fun i _ ↦ partLTAddMonoidHom_apply β (f i) + +/-- Every Cantor term of `a` is at most `a`. -/ +theorem of_le_of_mem_additivePrincipalTerms {a : NatOrdinal.{u}} {t : Ordinal.{u}} + (ht : t ∈ a.val.additivePrincipalTerms) : NatOrdinal.of t ≤ a := by + have h := sum_map_of_additivePrincipalTerms a + rw [← h] + exact List.single_le_sum (fun _ _ ↦ zero_le) _ (List.mem_map_of_mem ht) + +/-- An ordinal below `ω^β` has part `0` at or above `β`. -/ +theorem partGE_eq_zero_of_lt {β a : NatOrdinal.{u}} (ha : a < ω^ β) : partGE β a = 0 := by + classical + rw [partGE, List.filter_eq_nil_iff.mpr, List.map_nil, List.sum_nil] + intro t ht + rw [decide_eq_true_eq, not_le] + have h := (of_le_of_mem_additivePrincipalTerms ht).trans_lt ha + rw [← NatOrdinal.of_val (ω^ β)] at h + exact NatOrdinal.of.lt_iff_lt.mp h + +/-- An ordinal below `ω^β` is its own part below `β`. -/ +theorem partLT_eq_self_of_lt {β a : NatOrdinal.{u}} (ha : a < ω^ β) : partLT β a = a := by + have h := partGE_add_partLT β a + rwa [partGE_eq_zero_of_lt ha, zero_add] at h + +/-! ### The part at or above `β` is a multiple of `ω^β`; the two parts add as an ordinal sum -/ + +/-- The part of `a` at or above `β` is a multiple of `ω^β`: all its terms are at least `ω^β`. -/ +theorem exists_val_partGE_eq_mul (β a : NatOrdinal.{u}) : + ∃ q : Ordinal.{u}, (partGE β a).val = (ω^ β).val * q := by + classical + rw [partGE] + have hsorted : (a.val.additivePrincipalTerms.filter fun t ↦ (ω^ β).val ≤ t).SortedGE := + List.sortedGE_iff_pairwise.mpr + ((List.sortedGE_iff_pairwise.mp (additivePrincipalTerms_sortedGE _)).sublist + List.filter_sublist) + have hprincipal : ∀ t ∈ a.val.additivePrincipalTerms.filter fun t ↦ (ω^ β).val ≤ t, + IsAdditivelyPrincipal t := fun t ht ↦ + isAdditivelyPrincipal_of_mem_additivePrincipalTerms (List.mem_of_mem_filter ht) + rw [← natOrdinal_of_sum_eq_sum_map_of_sorted hprincipal hsorted, NatOrdinal.val_of] + -- every term is a power `ω^e` with `e ≥ β` + have hterm : ∀ t ∈ a.val.additivePrincipalTerms.filter fun t ↦ (ω^ β).val ≤ t, + ∃ q, t = (ω^ β).val * q := fun t ht ↦ by + have hle : (ω^ β).val ≤ t := of_decide_eq_true (List.mem_filter.mp ht).2 + obtain ⟨e, rfl⟩ := isAdditivelyPrincipal_iff.mp (hprincipal t ht) + rw [NatOrdinal.val_wpow] at hle ⊢ + have hβe : β.val ≤ e := (opow_le_opow_iff_right one_lt_omega0).mp hle + exact ⟨ω ^ (e - β.val), by rw [← opow_add, Ordinal.add_sub_cancel_of_le hβe]⟩ + have hmul : ∀ l : List Ordinal.{u}, (∀ t ∈ l, ∃ q, t = (ω^ β).val * q) → + ∃ q, l.sum = (ω^ β).val * q := by + intro l hl + induction l with + | nil => exact ⟨0, by simp⟩ + | cons t l ih => + obtain ⟨q₁, hq₁⟩ := hl t (List.mem_cons_self ..) + obtain ⟨q₂, hq₂⟩ := ih fun t' ht' ↦ hl t' (List.mem_cons_of_mem t ht') + exact ⟨q₁ + q₂, by rw [List.sum_cons, hq₁, hq₂, mul_add]⟩ + exact hmul _ hterm + +/-- Two multiples of `w` are at least `w` apart. -/ +theorem add_le_of_dvd_of_lt {w u v : Ordinal.{u}} (hu : ∃ q, u = w * q) (hv : ∃ q, v = w * q) + (huv : u < v) : u + w ≤ v := by + obtain ⟨qu, rfl⟩ := hu + obtain ⟨qv, rfl⟩ := hv + have hw : 0 < w := by + rcases eq_or_ne w 0 with rfl | h + · simp at huv + · exact pos_iff_ne_zero.mpr h + have hq : qu < qv := by + by_contra hle + rw [not_lt] at hle + exact absurd huv (not_lt.mpr (mul_le_mul_right hle w)) + calc w * qu + w = w * Order.succ qu := (Ordinal.mul_succ w qu).symm + _ ≤ w * qv := mul_le_mul_right (Order.succ_le_of_lt hq) w + +/-- The natural sum of an ordinal all of whose Cantor terms are at least `w` and an ordinal all of +whose Cantor terms are below `w` is their ordinal sum. -/ +theorem of_add_of_eq_add_of_forall_lt {u t : Ordinal.{u}} {w : Ordinal.{u}} + (hu : ∀ s ∈ u.additivePrincipalTerms, w ≤ s) (ht : ∀ s ∈ t.additivePrincipalTerms, s < w) : + NatOrdinal.of u + NatOrdinal.of t = NatOrdinal.of (u + t) := by + have hsorted : (u.additivePrincipalTerms ++ t.additivePrincipalTerms).SortedGE := by + rw [List.sortedGE_iff_pairwise, List.pairwise_append] + refine ⟨List.sortedGE_iff_pairwise.mp (additivePrincipalTerms_sortedGE u), + List.sortedGE_iff_pairwise.mp (additivePrincipalTerms_sortedGE t), fun s hs s' hs' ↦ ?_⟩ + exact ((ht s' hs').trans_le (hu s hs)).le + have hprincipal : ∀ s ∈ u.additivePrincipalTerms ++ t.additivePrincipalTerms, + IsAdditivelyPrincipal s := fun s hs ↦ by + rcases List.mem_append.mp hs with h | h + · exact isAdditivelyPrincipal_of_mem_additivePrincipalTerms h + · exact isAdditivelyPrincipal_of_mem_additivePrincipalTerms h + have h := natOrdinal_of_sum_eq_sum_map_of_sorted hprincipal hsorted + have hu' := sum_map_of_additivePrincipalTerms (NatOrdinal.of u) + have ht' := sum_map_of_additivePrincipalTerms (NatOrdinal.of t) + rw [NatOrdinal.val_of] at hu' ht' + rw [List.sum_append, additivePrincipalTerms_sum, additivePrincipalTerms_sum, List.map_append, + List.sum_append, hu', ht'] at h + exact h.symm + +/-- The terms of the Cantor normal form of `a_{≥β}` are at least `ω^β`. -/ +theorem wpow_le_of_mem_additivePrincipalTerms_partGE {β a : NatOrdinal.{u}} {s : Ordinal.{u}} + (hs : s ∈ (partGE β a).val.additivePrincipalTerms) : (ω^ β).val ≤ s := by + classical + have hmem := mem_of_mem_additivePrincipalTerms_natSum + (L := a.val.additivePrincipalTerms.filter fun t ↦ (ω^ β).val ≤ t) + (fun t ht ↦ isAdditivelyPrincipal_of_mem_additivePrincipalTerms (List.mem_of_mem_filter ht)) + (by rwa [partGE] at hs) + exact of_decide_eq_true (List.mem_filter.mp hmem).2 + +/-- The terms of the Cantor normal form of `a_{<β}` are below `ω^β`. -/ +theorem lt_wpow_of_mem_additivePrincipalTerms_partLT {β a : NatOrdinal.{u}} {s : Ordinal.{u}} + (hs : s ∈ (partLT β a).val.additivePrincipalTerms) : s < (ω^ β).val := by + classical + have hmem := mem_of_mem_additivePrincipalTerms_natSum + (L := a.val.additivePrincipalTerms.filter fun t ↦ t < (ω^ β).val) + (fun t ht ↦ isAdditivelyPrincipal_of_mem_additivePrincipalTerms (List.mem_of_mem_filter ht)) + (by rwa [partLT] at hs) + exact of_decide_eq_true (List.mem_filter.mp hmem).2 + +/-- `a = a_{≥β} + a_{<β}` as an ordinal sum. -/ +theorem val_eq_val_partGE_add_val_partLT (β a : NatOrdinal.{u}) : + a.val = (partGE β a).val + (partLT β a).val := by + have h := of_add_of_eq_add_of_forall_lt (w := (ω^ β).val) + (fun s hs ↦ wpow_le_of_mem_additivePrincipalTerms_partGE (β := β) (a := a) hs) + (fun s hs ↦ lt_wpow_of_mem_additivePrincipalTerms_partLT (β := β) (a := a) hs) + rw [NatOrdinal.of_val, NatOrdinal.of_val, partGE_add_partLT] at h + have := congrArg NatOrdinal.val h + rwa [NatOrdinal.val_of] at this + +/-- The part at or above `β` is monotone. -/ +theorem partGE_mono {β a b : NatOrdinal.{u}} (hab : a ≤ b) : + partGE β a ≤ partGE β b := by + by_contra hlt + rw [not_le] at hlt + have h1 := add_le_of_dvd_of_lt (exists_val_partGE_eq_mul β b) + (exists_val_partGE_eq_mul β a) (NatOrdinal.val.lt_iff_lt.mpr hlt) + have h2 : b.val < a.val := by + calc b.val = (partGE β b).val + (partLT β b).val := + val_eq_val_partGE_add_val_partLT β b + _ < (partGE β b).val + (ω^ β).val := + (add_lt_add_iff_left _).mpr (NatOrdinal.val.lt_iff_lt.mpr (partLT_lt β b)) + _ ≤ (partGE β a).val := h1 + _ ≤ a.val := by + rw [val_eq_val_partGE_add_val_partLT β a] + exact le_self_add + exact absurd (NatOrdinal.val.lt_iff_lt.mp h2) (not_lt.mpr hab) + +/-- Ordinals with the same part at or above `β` are ordered by their parts below `β`. -/ +theorem partLT_lt_of_lt_of_partGE_eq {β a b : NatOrdinal.{u}} (hab : a < b) + (hGE : partGE β a = partGE β b) : partLT β a < partLT β b := by + have h := NatOrdinal.val.lt_iff_lt.mpr hab + rw [val_eq_val_partGE_add_val_partLT β a, val_eq_val_partGE_add_val_partLT β b, + hGE, add_lt_add_iff_left] at h + exact NatOrdinal.val.lt_iff_lt.mp h + +/-- A smaller part at or above `β` forces a smaller ordinal. -/ +theorem lt_of_partGE_lt {β a b : NatOrdinal.{u}} (h : partGE β a < partGE β b) : + a < b := + lt_of_not_ge fun hba ↦ absurd (partGE_mono (β := β) hba) (not_le.mpr h) + +end NatOrdinal + +end diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/SuccessorFactorization.lean b/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/SuccessorFactorization.lean new file mode 100644 index 0000000000..80a4c83d1d --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/SuccessorFactorization.lean @@ -0,0 +1,180 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.FinitePart +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.MultiplicativelyPrincipal + +import Mathlib.Tactic.NormNum + +/-! +# Multiplicative factors at successor exponents + +Let `alpha` be a natural ordinal whose constant Cantor coefficient is positive. The final +multiplicatively principal factor of `omega ^ alpha` is `omega`; deleting that factor leaves +`omega ^ (alpha.removeNat 1)`. These are the ordinal identities behind Berarducci's principal +and residual values for a principal series of successor degree. + +The proof uses the canonical factorisation from Berarducci, Definition 6.4. It appends `omega` +to the factorisation at the predecessor exponent and invokes the uniqueness theorem for the +nonincreasing factor list. +-/ + +open scoped NatOrdinal + +public noncomputable section + +namespace Ordinal + +private theorem omega0_isMultiplicativelyPrincipal : + IsMultiplicativelyPrincipal omega0 := by + simpa using isMultiplicativelyPrincipal_omega0_opow_opow 0 + +private theorem multiplicativePrincipalFactors_wpow_eq_append_omega0 + (alpha : NatOrdinal) (halpha : 0 < alpha.constantCoeff) : + (omega0 ^ alpha.val).multiplicativePrincipalFactors = + (omega0 ^ (alpha.removeNat 1).val).multiplicativePrincipalFactors ++ [omega0] := by + let factors := (omega0 ^ (alpha.removeNat 1).val).multiplicativePrincipalFactors + have halphaOne : 1 ≤ alpha.constantCoeff := halpha + have hpred : (alpha.removeNat 1).val + ((1 : ℕ) : Ordinal) = alpha.val := by + have h := congrArg NatOrdinal.val (NatOrdinal.removeNat_add_natCast halphaOne) + calc + (alpha.removeNat 1).val + ((1 : ℕ) : Ordinal) = + (alpha.removeNat 1 + (1 : ℕ)).val := + (NatOrdinal.val_add_natCast (alpha.removeNat 1) 1).symm + _ = alpha.val := h + have htargetPrincipal : IsAdditivelyPrincipal (omega0 ^ alpha.val) := + isAdditivelyPrincipal_omega0_opow alpha.val + have hfactorsProd : factors.prod = omega0 ^ (alpha.removeNat 1).val := + multiplicativePrincipalFactors_prod + (isAdditivelyPrincipal_omega0_opow (alpha.removeNat 1).val) + have hprod : (factors ++ [omega0]).prod = omega0 ^ alpha.val := by + rw [List.prod_append, List.prod_singleton, hfactorsProd] + calc + omega0 ^ (alpha.removeNat 1).val * omega0 = + omega0 ^ (alpha.removeNat 1).val * omega0 ^ (1 : Ordinal) := by + congr 1 + exact (opow_one omega0).symm + _ = omega0 ^ ((alpha.removeNat 1).val + (1 : Ordinal)) := + (opow_add _ _ _).symm + _ = omega0 ^ alpha.val := by + apply congrArg (omega0 ^ ·) + simpa using hpred + have hprincipal : ∀ f ∈ factors ++ [omega0], IsMultiplicativelyPrincipal f := by + intro f hf + rw [List.mem_append, List.mem_singleton] at hf + rcases hf with hf | rfl + · exact isMultiplicativelyPrincipal_of_mem_multiplicativePrincipalFactors hf + · exact omega0_isMultiplicativelyPrincipal + have hone : ∀ f ∈ factors ++ [omega0], 1 < f := by + intro f hf + rw [List.mem_append, List.mem_singleton] at hf + rcases hf with hf | rfl + · exact one_lt_of_mem_multiplicativePrincipalFactors hf + · exact one_lt_omega0 + have hsorted : (factors ++ [omega0]).SortedGE := by + rw [List.sortedGE_iff_pairwise, List.pairwise_append] + refine ⟨List.sortedGE_iff_pairwise.mp + (multiplicativePrincipalFactors_sortedGE _), by simp, ?_⟩ + intro f hf g hg + simp only [List.mem_singleton] at hg + subst g + have hinfinite := + isInfiniteMultiplicativelyPrincipal_of_mem_multiplicativePrincipalFactors hf + exact hinfinite.isAdditivelyPrincipal.omega0_le_of_one_lt + (one_lt_of_mem_multiplicativePrincipalFactors hf) + exact + (multiplicativePrincipalFactors_unique + htargetPrincipal hprod hprincipal hone hsorted).symm + +/-- A positive constant Cantor coefficient contributes a final term `1` to the uncompressed +Cantor normal form. -/ +theorem one_mem_additivePrincipalTerms_of_constantCoeff_pos + (alpha : NatOrdinal) (halpha : 0 < alpha.constantCoeff) : + (1 : Ordinal) ∈ alpha.val.additivePrincipalTerms := by + let terms := (alpha.removeNat 1).val.additivePrincipalTerms + have halphaOne : 1 ≤ alpha.constantCoeff := halpha + have hpred : (alpha.removeNat 1).val + (1 : Ordinal) = alpha.val := by + have h := congrArg NatOrdinal.val (NatOrdinal.removeNat_add_natCast halphaOne) + calc + (alpha.removeNat 1).val + (1 : Ordinal) = + (alpha.removeNat 1).val + ((1 : ℕ) : Ordinal) := by norm_num + _ = (alpha.removeNat 1 + (1 : ℕ)).val := + (NatOrdinal.val_add_natCast (alpha.removeNat 1) 1).symm + _ = alpha.val := h + have hsum : (terms ++ [1]).sum = alpha.val := by + rw [List.sum_append, List.sum_singleton, additivePrincipalTerms_sum] + exact hpred + have hprincipal : ∀ a ∈ terms ++ [1], IsAdditivelyPrincipal a := by + intro a ha + rw [List.mem_append, List.mem_singleton] at ha + rcases ha with ha | rfl + · exact isAdditivelyPrincipal_of_mem_additivePrincipalTerms ha + · simpa using isAdditivelyPrincipal_omega0_opow 0 + have hsorted : (terms ++ [1]).SortedGE := by + rw [List.sortedGE_iff_pairwise, List.pairwise_append] + refine ⟨List.sortedGE_iff_pairwise.mp (additivePrincipalTerms_sortedGE _), by simp, ?_⟩ + intro a ha b hb + simp only [List.mem_singleton] at hb + subst b + exact Order.one_le_iff_ne_zero.mpr + (isAdditivelyPrincipal_of_mem_additivePrincipalTerms ha).ne_zero + have hterms : terms ++ [1] = alpha.val.additivePrincipalTerms := + additivePrincipalTerms_unique hsum hprincipal hsorted + rw [← hterms] + simp + +/-- The principal factor of `omega ^ alpha` is `omega` when `alpha` has positive constant +Cantor coefficient. -/ +theorem AdditivePrincipalAboveOne.principalFactor_wpow_of_constantCoeff_pos + (alpha : NatOrdinal) (halpha : 0 < alpha.constantCoeff) + (hadd : IsAdditivelyPrincipal (omega0 ^ alpha.val)) + (hone : 1 < omega0 ^ alpha.val) : + AdditivePrincipalAboveOne.principalFactor + (⟨omega0 ^ alpha.val, hadd, hone⟩ : AdditivePrincipalAboveOne) = omega0 := by + rw [AdditivePrincipalAboveOne.principalFactor_eq_getLast] + let source := (omega0 ^ alpha.val).multiplicativePrincipalFactors + let target := + (omega0 ^ (alpha.removeNat 1).val).multiplicativePrincipalFactors ++ [omega0] + have hsource : source = target := + multiplicativePrincipalFactors_wpow_eq_append_omega0 alpha halpha + calc + source.getLast (multiplicativePrincipalFactors_ne_nil hadd hone) = + target.getLast (by simp [target]) := + List.getLast_congr _ _ hsource + _ = omega0 := by + simp [target] + +/-- The residual factor of `omega ^ alpha` is the power at the predecessor exponent when +`alpha` has positive constant Cantor coefficient. -/ +theorem AdditivePrincipalAboveOne.residualFactor_wpow_of_constantCoeff_pos + (alpha : NatOrdinal) (halpha : 0 < alpha.constantCoeff) + (hadd : IsAdditivelyPrincipal (omega0 ^ alpha.val)) + (hone : 1 < omega0 ^ alpha.val) : + AdditivePrincipalAboveOne.residualFactor + (⟨omega0 ^ alpha.val, hadd, hone⟩ : AdditivePrincipalAboveOne) = + omega0 ^ (alpha.removeNat 1).val := by + rw [AdditivePrincipalAboveOne.residualFactor_eq_dropLast_prod] + let factors := (omega0 ^ (alpha.removeNat 1).val).multiplicativePrincipalFactors + have hsource : (omega0 ^ alpha.val).multiplicativePrincipalFactors = + factors ++ [omega0] := + multiplicativePrincipalFactors_wpow_eq_append_omega0 alpha halpha + rw [hsource] + have hdrop : (factors ++ [omega0]).dropLast = factors := by + induction factors with + | nil => rfl + | cons a factors ih => + cases factors with + | nil => rfl + | cons b factors => + change (a :: b :: (factors ++ [omega0])).dropLast = a :: b :: factors + rw [List.dropLast_cons_cons] + exact congrArg (List.cons a) ih + rw [hdrop] + exact multiplicativePrincipalFactors_prod + (isAdditivelyPrincipal_omega0_opow (alpha.removeNat 1).val) + +end Ordinal diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/Sumset.lean b/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/Sumset.lean new file mode 100644 index 0000000000..a658f101bb --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/Sumset.lean @@ -0,0 +1,334 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.SetOrderType +public import Mathlib.Data.Finset.MulAntidiagonal + +import LeanPool.ConwayRefinement.CombinatorialGames.NatOrdinal.Pow +import Mathlib.Data.Sum.Order +import Mathlib.Order.Hom.Lex +import Mathlib.SetTheory.Ordinal.Principal + +/-! +# Order type of a sumset + +For partially well-ordered subsets of a linearly ordered cancellative commutative additive monoid, +this module bounds the ordinary order type of their pointwise sum by the Hessenberg product of +their order types. The result specializes to LM24, Fact 2.2.3(3), where the ambient type is an +ordered abelian group. + +The proof follows the principal-block induction underlying the cited result. If both order types +are additive principal, every proper initial segment of the sumset is covered by two smaller +sumsets. Otherwise, a nonprincipal factor is split after its leading Cantor monomial, compatibly +with Hessenberg addition, and distributivity reduces the claim to strictly smaller products. +-/ + +universe u + +public noncomputable section + +open scoped Pointwise + +namespace Set.IsPWO + +open Ordinal + +variable {α : Type u} [LinearOrder α] {s : Set α} + +private theorem orderType_le_of_forall_inter_Iio_lt (hs : s.IsPWO) {o : Ordinal} + (h : ∀ x ∈ s, + (hs.mono (s := s ∩ Set.Iio x) Set.inter_subset_left).orderType < o) : + hs.orderType ≤ o := by + apply le_of_forall_lt + intro c hc + let : WellFoundedLT s := hs.isWF + have hType : typeLT s = hs.orderType := + (orderType_eq_typeLT_of_orderIso hs (OrderIso.refl s)).symm + have hc' : c < typeLT s := hc.trans_eq hType.symm + let x : s := Ordinal.enum (· < ·) ⟨c, hc'⟩ + have hxRank : Ordinal.typein (· < · : s → s → Prop) x = c := + Ordinal.typein_enum _ hc' + simpa only [orderType_inter_Iio_eq_typein hs x.2, hxRank] using h x.1 x.2 + +private theorem exists_naturalAdd_split (hs : s.IsPWO) (hzero : hs.orderType ≠ 0) + (hnot : ¬Ordinal.IsPrincipal (· + ·) hs.orderType) : + ∃ (s₀ s₁ : Set α) (hs₀ : s₀.IsPWO) (hs₁ : s₁.IsPWO), + s₀ ∪ s₁ = s ∧ + NatOrdinal.of hs.orderType = + NatOrdinal.of hs₀.orderType + NatOrdinal.of hs₁.orderType ∧ + hs₀.orderType < hs.orderType ∧ hs₁.orderType < hs.orderType := by + let d : Ordinal := Ordinal.log Ordinal.omega0 hs.orderType + let p : Ordinal := Ordinal.omega0 ^ d + have hp_le : p ≤ hs.orderType := Ordinal.opow_log_le_self Ordinal.omega0 hzero + have hp_ne : p ≠ hs.orderType := by + intro hp + apply hnot + rw [hp.symm] + exact Ordinal.isPrincipal_add_omega0_opow d + have hp_lt : p < hs.orderType := hp_le.lt_of_ne hp_ne + let : WellFoundedLT s := hs.isWF + have hType : typeLT s = hs.orderType := + (orderType_eq_typeLT_of_orderIso hs (OrderIso.refl s)).symm + have hp_type : p < typeLT s := hp_lt.trans_eq hType.symm + let x : s := Ordinal.enum (· < ·) ⟨p, hp_type⟩ + let s₀ : Set α := s ∩ Set.Iio x.1 + let s₁ : Set α := s ∩ Set.Ici x.1 + let hs₀ : s₀.IsPWO := hs.mono Set.inter_subset_left + let hs₁ : s₁.IsPWO := hs.mono Set.inter_subset_left + have hs₀_orderType : hs₀.orderType = p := by + rw [orderType_inter_Iio_eq_typein hs x.2] + exact Ordinal.typein_enum _ hp_type + have hsplit : hs₀.orderType + hs₁.orderType = hs.orderType := + orderType_inter_Iio_add_inter_Ici hs x.2 + have hs₁_orderType : hs₁.orderType = hs.orderType - p := by + rw [hs₀_orderType] at hsplit + exact (Ordinal.sub_eq_of_add_eq hsplit).symm + have hs₁_lt : hs₁.orderType < hs.orderType := by + rw [hs₁_orderType] + exact (Ordinal.isLeast_sub_lt_omega0_opow_log hzero).1 + have htail_bound : hs.orderType - p < Ordinal.omega0 ^ (d + 1) := by + apply (Ordinal.sub_le_self _ _).trans_lt + exact Ordinal.lt_opow_succ_log_self Ordinal.one_lt_omega0 hs.orderType + have hnatural : NatOrdinal.of hs.orderType = + NatOrdinal.of hs₀.orderType + NatOrdinal.of hs₁.orderType := by + have htail_bound' : NatOrdinal.of (hs.orderType - p) < + ω^ (NatOrdinal.of d + 1) := by + simpa only [NatOrdinal.of_omega0_opow, NatOrdinal.of_add_one] using + NatOrdinal.of.strictMono htail_bound + calc + NatOrdinal.of hs.orderType = NatOrdinal.of (p + (hs.orderType - p)) := by + rw [Ordinal.add_sub_cancel_of_le hp_le] + _ = ω^ NatOrdinal.of d + NatOrdinal.of (hs.orderType - p) := by + exact (NatOrdinal.wpow_add_of_lt htail_bound').symm + _ = NatOrdinal.of hs₀.orderType + NatOrdinal.of hs₁.orderType := by + rw [hs₀_orderType, hs₁_orderType, NatOrdinal.of_omega0_opow] + refine ⟨s₀, s₁, hs₀, hs₁, ?_, hnatural, hs₀_orderType ▸ hp_lt, hs₁_lt⟩ + ext z + simp only [s₀, s₁, Set.mem_union, Set.mem_inter_iff, Set.mem_Iio, Set.mem_Ici] + constructor + · rintro (⟨hz, -⟩ | ⟨hz, -⟩) <;> exact hz + · intro hz + exact (lt_or_ge z x.1).imp (And.intro hz) (And.intro hz) + +/-- Covering a proper initial segment of a sumset: every element of `s + t` below `x + y` lies in +`(s ∩ Iio x) + t` or in `s + (t ∩ Iio y)`. -/ +private theorem add_inter_Iio_subset_union [AddCommMonoid α] [IsOrderedCancelAddMonoid α] + {s t : Set α} (x y : α) : + (s + t) ∩ Set.Iio (x + y) ⊆ (s ∩ Set.Iio x + t) ∪ (s + t ∩ Set.Iio y) := by + rintro z ⟨hz, hzlt⟩ + rcases Set.mem_add.mp hz with ⟨x', hx's, y', hy't, rfl⟩ + by_cases hx' : x' < x + · left + exact Set.mem_add.mpr ⟨x', ⟨hx's, hx'⟩, y', hy't, rfl⟩ + · right + apply Set.mem_add.mpr + refine ⟨x', hx's, y', ⟨hy't, ?_⟩, rfl⟩ + by_contra hy' + exact (not_le_of_gt hzlt) (add_le_add (le_of_not_gt hx') (le_of_not_gt hy')) + +/-- The principal case of the sumset bound. If both order types are additive principal, hence +powers `ω ^ d` and `ω ^ e`, every proper initial segment of `s + t` is covered by two sumsets +whose Hessenberg products are strictly below `ω ^ d ⊗ ω ^ e = ω ^ (d ⊕ e)`, and that power is +closed under Hessenberg addition. The bounds for the smaller products are the induction +hypothesis `ih`. -/ +private theorem orderType_add_le_naturalMul_of_isPrincipal [AddCommMonoid α] + [IsOrderedCancelAddMonoid α] {s t : Set α} (hs : s.IsPWO) (ht : t.IsPWO) + (hsZero : hs.orderType ≠ 0) (htZero : ht.orderType ≠ 0) + (hsPrincipal : Ordinal.IsPrincipal (· + ·) hs.orderType) + (htPrincipal : Ordinal.IsPrincipal (· + ·) ht.orderType) + (ih : ∀ {s' t' : Set α} (hs' : s'.IsPWO) (ht' : t'.IsPWO), + NatOrdinal.of hs'.orderType * NatOrdinal.of ht'.orderType < + NatOrdinal.of hs.orderType * NatOrdinal.of ht.orderType → + (hs'.add ht').orderType ≤ + (NatOrdinal.of hs'.orderType * NatOrdinal.of ht'.orderType).val) : + (hs.add ht).orderType ≤ + (NatOrdinal.of hs.orderType * NatOrdinal.of ht.orderType).val := by + let a : NatOrdinal := NatOrdinal.of hs.orderType + let b : NatOrdinal := NatOrdinal.of ht.orderType + change (hs.add ht).orderType ≤ (a * b).val + have ha : 0 < a := pos_iff_ne_zero.mpr (NatOrdinal.of_ne_zero.mpr hsZero) + have hb : 0 < b := pos_iff_ne_zero.mpr (NatOrdinal.of_ne_zero.mpr htZero) + rcases Ordinal.isPrincipal_add_iff_zero_or_omega0_opow.mp hsPrincipal with + hsZero' | ⟨d, hd⟩ + · exact (hsZero hsZero').elim + rcases Ordinal.isPrincipal_add_iff_zero_or_omega0_opow.mp htPrincipal with + htZero' | ⟨e, he⟩ + · exact (htZero htZero').elim + have hsPower : hs.orderType = Ordinal.omega0 ^ d := hd.symm + have htPower : ht.orderType = Ordinal.omega0 ^ e := he.symm + have hproduct : a * b = ω^ (NatOrdinal.of d + NatOrdinal.of e) := by + simp only [a, b, hsPower, htPower, NatOrdinal.of_omega0_opow] + exact (NatOrdinal.wpow_add _ _).symm + apply orderType_le_of_forall_inter_Iio_lt (hs.add ht) + intro z hz + rcases Set.mem_add.mp hz with ⟨x, hxs, y, hyt, rfl⟩ + let sx : Set α := s ∩ Set.Iio x + let ty : Set α := t ∩ Set.Iio y + let hsx : sx.IsPWO := hs.mono Set.inter_subset_left + let hty : ty.IsPWO := ht.mono Set.inter_subset_left + let hInitial : ((s + t) ∩ Set.Iio (x + y)).IsPWO := + (hs.add ht).mono Set.inter_subset_left + have hsx_lt : hsx.orderType < hs.orderType := orderType_inter_Iio_lt hs hxs + have hty_lt : hty.orderType < ht.orderType := orderType_inter_Iio_lt ht hyt + have hleftProduct : NatOrdinal.of hsx.orderType * b < a * b := + mul_lt_mul_of_pos_right (NatOrdinal.of.strictMono hsx_lt) hb + have hrightProduct : a * NatOrdinal.of hty.orderType < a * b := + mul_lt_mul_of_pos_left (NatOrdinal.of.strictMono hty_lt) ha + have hleft' : NatOrdinal.of (hsx.add ht).orderType ≤ + NatOrdinal.of hsx.orderType * b := by + simpa only [b, NatOrdinal.of_val] using NatOrdinal.of.monotone (ih hsx ht hleftProduct) + have hright' : NatOrdinal.of (hs.add hty).orderType ≤ + a * NatOrdinal.of hty.orderType := by + simpa only [a, NatOrdinal.of_val] using NatOrdinal.of.monotone (ih hs hty hrightProduct) + calc + hInitial.orderType ≤ ((hsx.add ht).union (hs.add hty)).orderType := + orderType_mono hInitial ((hsx.add ht).union (hs.add hty)) + (add_inter_Iio_subset_union x y) + _ ≤ (NatOrdinal.of (hsx.add ht).orderType + + NatOrdinal.of (hs.add hty).orderType).val := + orderType_union_le_naturalAdd (hsx.add ht) (hs.add hty) + _ ≤ (NatOrdinal.of hsx.orderType * b + + a * NatOrdinal.of hty.orderType).val := by + apply NatOrdinal.val.monotone + exact add_le_add hleft' hright' + _ < (a * b).val := by + apply NatOrdinal.val.lt_iff_lt.mpr + rw [hproduct] + exact NatOrdinal.add_lt_wpow (hleftProduct.trans_eq hproduct) + (hrightProduct.trans_eq hproduct) + +/-- The distributivity step of the sumset bound, splitting the left factor. If `s = s₀ ∪ s₁` +with `ot(s) = ot(s₀) ⊕ ot(s₁)` and both pieces of strictly smaller order type, then +`s + t = (s₀ + t) ∪ (s₁ + t)`, and the union bound together with the induction hypothesis `ih` +for the two smaller products gives the bound for `s + t`. -/ +private theorem orderType_add_le_naturalMul_of_union_left [AddCommMonoid α] + [IsOrderedCancelAddMonoid α] {s t : Set α} (hs : s.IsPWO) (ht : t.IsPWO) + {s₀ s₁ : Set α} (hs₀ : s₀.IsPWO) (hs₁ : s₁.IsPWO) (hsUnion : s₀ ∪ s₁ = s) + (hsNatural : NatOrdinal.of hs.orderType = + NatOrdinal.of hs₀.orderType + NatOrdinal.of hs₁.orderType) + (hs₀_lt : hs₀.orderType < hs.orderType) (hs₁_lt : hs₁.orderType < hs.orderType) + (htZero : ht.orderType ≠ 0) + (ih : ∀ {s' t' : Set α} (hs' : s'.IsPWO) (ht' : t'.IsPWO), + NatOrdinal.of hs'.orderType * NatOrdinal.of ht'.orderType < + NatOrdinal.of hs.orderType * NatOrdinal.of ht.orderType → + (hs'.add ht').orderType ≤ + (NatOrdinal.of hs'.orderType * NatOrdinal.of ht'.orderType).val) : + (hs.add ht).orderType ≤ + (NatOrdinal.of hs.orderType * NatOrdinal.of ht.orderType).val := by + let a : NatOrdinal := NatOrdinal.of hs.orderType + let b : NatOrdinal := NatOrdinal.of ht.orderType + change (hs.add ht).orderType ≤ (a * b).val + have hb : 0 < b := pos_iff_ne_zero.mpr (NatOrdinal.of_ne_zero.mpr htZero) + have h₀Measure : NatOrdinal.of hs₀.orderType * b < a * b := + mul_lt_mul_of_pos_right (NatOrdinal.of.strictMono hs₀_lt) hb + have h₁Measure : NatOrdinal.of hs₁.orderType * b < a * b := + mul_lt_mul_of_pos_right (NatOrdinal.of.strictMono hs₁_lt) hb + have h₀' : NatOrdinal.of (hs₀.add ht).orderType ≤ + NatOrdinal.of hs₀.orderType * b := by + simpa only [b, NatOrdinal.of_val] using NatOrdinal.of.monotone (ih hs₀ ht h₀Measure) + have h₁' : NatOrdinal.of (hs₁.add ht).orderType ≤ + NatOrdinal.of hs₁.orderType * b := by + simpa only [b, NatOrdinal.of_val] using NatOrdinal.of.monotone (ih hs₁ ht h₁Measure) + calc + (hs.add ht).orderType = ((hs₀.add ht).union (hs₁.add ht)).orderType := by + apply orderType_congr + rw [← Set.union_add, hsUnion] + _ ≤ (NatOrdinal.of (hs₀.add ht).orderType + + NatOrdinal.of (hs₁.add ht).orderType).val := + orderType_union_le_naturalAdd (hs₀.add ht) (hs₁.add ht) + _ ≤ (NatOrdinal.of hs₀.orderType * b + + NatOrdinal.of hs₁.orderType * b).val := by + apply NatOrdinal.val.monotone + exact add_le_add h₀' h₁' + _ = (a * b).val := by rw [← add_mul, ← hsNatural] + +/-- The distributivity step of the sumset bound, splitting the right factor. If `t = t₀ ∪ t₁` +with `ot(t) = ot(t₀) ⊕ ot(t₁)` and both pieces of strictly smaller order type, then +`s + t = (s + t₀) ∪ (s + t₁)`, and the union bound together with the induction hypothesis `ih` +for the two smaller products gives the bound for `s + t`. -/ +private theorem orderType_add_le_naturalMul_of_union_right [AddCommMonoid α] + [IsOrderedCancelAddMonoid α] {s t : Set α} (hs : s.IsPWO) (ht : t.IsPWO) + {t₀ t₁ : Set α} (ht₀ : t₀.IsPWO) (ht₁ : t₁.IsPWO) (htUnion : t₀ ∪ t₁ = t) + (htNatural : NatOrdinal.of ht.orderType = + NatOrdinal.of ht₀.orderType + NatOrdinal.of ht₁.orderType) + (ht₀_lt : ht₀.orderType < ht.orderType) (ht₁_lt : ht₁.orderType < ht.orderType) + (hsZero : hs.orderType ≠ 0) + (ih : ∀ {s' t' : Set α} (hs' : s'.IsPWO) (ht' : t'.IsPWO), + NatOrdinal.of hs'.orderType * NatOrdinal.of ht'.orderType < + NatOrdinal.of hs.orderType * NatOrdinal.of ht.orderType → + (hs'.add ht').orderType ≤ + (NatOrdinal.of hs'.orderType * NatOrdinal.of ht'.orderType).val) : + (hs.add ht).orderType ≤ + (NatOrdinal.of hs.orderType * NatOrdinal.of ht.orderType).val := by + let a : NatOrdinal := NatOrdinal.of hs.orderType + let b : NatOrdinal := NatOrdinal.of ht.orderType + change (hs.add ht).orderType ≤ (a * b).val + have ha : 0 < a := pos_iff_ne_zero.mpr (NatOrdinal.of_ne_zero.mpr hsZero) + have h₀Measure : a * NatOrdinal.of ht₀.orderType < a * b := + mul_lt_mul_of_pos_left (NatOrdinal.of.strictMono ht₀_lt) ha + have h₁Measure : a * NatOrdinal.of ht₁.orderType < a * b := + mul_lt_mul_of_pos_left (NatOrdinal.of.strictMono ht₁_lt) ha + have h₀' : NatOrdinal.of (hs.add ht₀).orderType ≤ + a * NatOrdinal.of ht₀.orderType := by + simpa only [a, NatOrdinal.of_val] using NatOrdinal.of.monotone (ih hs ht₀ h₀Measure) + have h₁' : NatOrdinal.of (hs.add ht₁).orderType ≤ + a * NatOrdinal.of ht₁.orderType := by + simpa only [a, NatOrdinal.of_val] using NatOrdinal.of.monotone (ih hs ht₁ h₁Measure) + calc + (hs.add ht).orderType = ((hs.add ht₀).union (hs.add ht₁)).orderType := by + apply orderType_congr + rw [← Set.add_union, htUnion] + _ ≤ (NatOrdinal.of (hs.add ht₀).orderType + + NatOrdinal.of (hs.add ht₁).orderType).val := + orderType_union_le_naturalAdd (hs.add ht₀) (hs.add ht₁) + _ ≤ (a * NatOrdinal.of ht₀.orderType + + a * NatOrdinal.of ht₁.orderType).val := by + apply NatOrdinal.val.monotone + exact add_le_add h₀' h₁' + _ = (a * b).val := by rw [← mul_add, ← htNatural] + +/-- The order type of a pointwise sum is at most the Hessenberg product of the two order types. +This specializes to LM24, Fact 2.2.3(3). -/ +theorem orderType_add_le_naturalMul [AddCommMonoid α] [IsOrderedCancelAddMonoid α] + {s t : Set α} (hs : s.IsPWO) (ht : t.IsPWO) : + (hs.add ht).orderType ≤ + (NatOrdinal.of hs.orderType * NatOrdinal.of ht.orderType).val := by + by_cases hsZero : hs.orderType = 0 + · have hsEmpty : s = ∅ := hs.orderType_eq_zero.mp hsZero + have hsumEmpty : s + t = ∅ := by rw [hsEmpty, Set.empty_add] + rw [(hs.add ht).orderType_eq_zero.mpr hsumEmpty, hsZero] + simp + by_cases htZero : ht.orderType = 0 + · have htEmpty : t = ∅ := ht.orderType_eq_zero.mp htZero + have hsumEmpty : s + t = ∅ := by rw [htEmpty, Set.add_empty] + rw [(hs.add ht).orderType_eq_zero.mpr hsumEmpty, htZero] + simp + have ih : ∀ {s' t' : Set α} (hs' : s'.IsPWO) (ht' : t'.IsPWO), + NatOrdinal.of hs'.orderType * NatOrdinal.of ht'.orderType < + NatOrdinal.of hs.orderType * NatOrdinal.of ht.orderType → + (hs'.add ht').orderType ≤ + (NatOrdinal.of hs'.orderType * NatOrdinal.of ht'.orderType).val := + fun hs' ht' _ ↦ orderType_add_le_naturalMul hs' ht' + by_cases hsPrincipal : Ordinal.IsPrincipal (· + ·) hs.orderType + · by_cases htPrincipal : Ordinal.IsPrincipal (· + ·) ht.orderType + · exact orderType_add_le_naturalMul_of_isPrincipal hs ht hsZero htZero + hsPrincipal htPrincipal ih + · obtain ⟨t₀, t₁, ht₀, ht₁, htUnion, htNatural, ht₀_lt, ht₁_lt⟩ := + exists_naturalAdd_split ht htZero htPrincipal + exact orderType_add_le_naturalMul_of_union_right hs ht ht₀ ht₁ htUnion htNatural + ht₀_lt ht₁_lt hsZero ih + · obtain ⟨s₀, s₁, hs₀, hs₁, hsUnion, hsNatural, hs₀_lt, hs₁_lt⟩ := + exists_naturalAdd_split hs hsZero hsPrincipal + exact orderType_add_le_naturalMul_of_union_left hs ht hs₀ hs₁ hsUnion hsNatural + hs₀_lt hs₁_lt htZero ih +termination_by NatOrdinal.of hs.orderType * NatOrdinal.of ht.orderType +decreasing_by + all_goals + change _ < _ + assumption + +end Set.IsPWO diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/Tests.lean b/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/Tests.lean new file mode 100644 index 0000000000..632eb92268 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/Tests.lean @@ -0,0 +1,18 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.Tests.GeneralFactorization +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.Tests.NaturalPrincipal +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.Tests.OrderedUnion +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.Tests.OrdinalFactors +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.Tests.OrdinalFinitePart +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.Tests.OrdinalSuccessorFactorization +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.Tests.SetOrderType +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.Tests.Sumset + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/Tests/GeneralFactorization.lean b/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/Tests/GeneralFactorization.lean new file mode 100644 index 0000000000..28a91a080b --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/Tests/GeneralFactorization.lean @@ -0,0 +1,63 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.GeneralFactorization + +/-! +# Certificate: the residual factor deletes the least Cantor term, not `1` + +The nearest plausible wrong reading of `residualFactor_omega0_opow` is the shape proved in +`ConwayRefinement.SetTheory.Ordinal.SuccessorFactorization`, where the residual factor +is `ω ^ (α.removeNat 1)`. That deletes a finite amount from the exponent, so at `α = ω` it must +leave `ω` and predict residual factor `ω ^ ω`. + +The theorem gives `1`, and `1 ≠ ω ^ ω` is checked below. The limit case is therefore not an +instance of the successor shape but a genuine strengthening, and it is what makes truncation a +descent at a grade with no finite part. + +The degenerate case `α = 1` is included because there the two readings agree, so it certifies +that the generalization did not break the case it generalizes. +-/ + +open Ordinal + +public noncomputable section + +namespace Tests + +theorem one_lt_omega0_opow {a : Ordinal} (ha : a ≠ 0) : 1 < Ordinal.omega0 ^ a := + calc (1 : Ordinal) < Ordinal.omega0 := one_lt_omega0 + _ = Ordinal.omega0 ^ (1 : Ordinal) := (opow_one _).symm + _ ≤ Ordinal.omega0 ^ a := + opow_le_opow_right omega0_pos (Order.one_le_iff_ne_zero.mpr ha) + +theorem residualFactor_omega0_opow_omega0 : + AdditivePrincipalAboveOne.residualFactor + ⟨Ordinal.omega0 ^ Ordinal.omega0, isAdditivelyPrincipal_omega0_opow _, + one_lt_omega0_opow omega0_ne_zero⟩ = 1 := by + rw [residualFactor_omega0_opow Ordinal.omega0 (isAdditivelyPrincipal_omega0_opow _) + (one_lt_omega0_opow omega0_ne_zero)] + have hw : (Ordinal.omega0 : Ordinal) = Ordinal.omega0 ^ (1 : Ordinal) := (opow_one _).symm + rw [hw, additivePrincipalTerms_of_isAdditivelyPrincipal (isAdditivelyPrincipal_omega0_opow 1)] + simp + +theorem one_ne_omega0_opow_omega0 : (1 : Ordinal) ≠ Ordinal.omega0 ^ Ordinal.omega0 := + (one_lt_omega0_opow omega0_ne_zero).ne + +theorem residualFactor_omega0_opow_one : + AdditivePrincipalAboveOne.residualFactor + ⟨Ordinal.omega0 ^ (1 : Ordinal), isAdditivelyPrincipal_omega0_opow _, + one_lt_omega0_opow one_ne_zero⟩ = 1 := by + rw [residualFactor_omega0_opow (1 : Ordinal) (isAdditivelyPrincipal_omega0_opow _) + (one_lt_omega0_opow one_ne_zero)] + have h1 : (1 : Ordinal) = Ordinal.omega0 ^ (0 : Ordinal) := by simp + rw [h1, additivePrincipalTerms_of_isAdditivelyPrincipal (isAdditivelyPrincipal_omega0_opow 0)] + simp + +end Tests + +end diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/Tests/NaturalPrincipal.lean b/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/Tests/NaturalPrincipal.lean new file mode 100644 index 0000000000..c4b2e524d5 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/Tests/NaturalPrincipal.lean @@ -0,0 +1,72 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.AdditivelyPrincipal + +import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.NaturalPrincipal + +/-! +# API checks for principality of the natural operations + +These certificates separate Berarducci, Fact 3.7 from two weaker readings: the multiplicative case +with only additive principality assumed, and either case read with the ordinary ordinal operations +in place of the natural ones. +-/ + +universe u + +open scoped NatOrdinal + +public noncomputable section + +namespace Tests + +/-- `ω ^ ω` is multiplicative principal, so it is closed under natural products. -/ +theorem naturalMul_lt_omega0_opow_omega0 {b c : Ordinal} + (hb : b < Ordinal.omega0 ^ Ordinal.omega0) + (hc : c < Ordinal.omega0 ^ Ordinal.omega0) : + (NatOrdinal.of b * NatOrdinal.of c).val < Ordinal.omega0 ^ Ordinal.omega0 := by + have hmp := Ordinal.isMultiplicativelyPrincipal_omega0_opow_opow 1 + rw [Ordinal.opow_one] at hmp + exact hmp.naturalMul_lt hb hc + +/-- Additive principality alone does not give closure under natural products, since +`ω ⊙ ω = ω ^ 2`. -/ +theorem naturalMul_lt_needs_multiplicativelyPrincipal : + ∃ o a : Ordinal, + Ordinal.IsAdditivelyPrincipal o ∧ a < o ∧ + ¬(NatOrdinal.of a * NatOrdinal.of a).val < o := by + refine ⟨Ordinal.omega0 ^ (2 : Ordinal), Ordinal.omega0, + Ordinal.isAdditivelyPrincipal_omega0_opow 2, ?_, ?_⟩ + · calc Ordinal.omega0 = Ordinal.omega0 ^ (1 : Ordinal) := (Ordinal.opow_one _).symm + _ < Ordinal.omega0 ^ (2 : Ordinal) := + (Ordinal.opow_lt_opow_iff_right Ordinal.one_lt_omega0).mpr one_lt_two + · have hval : (NatOrdinal.of Ordinal.omega0 * NatOrdinal.of Ordinal.omega0).val = + Ordinal.omega0 ^ (2 : Ordinal) := by + have hof : NatOrdinal.of Ordinal.omega0 = ω^ (1 : NatOrdinal) := by + rw [← Ordinal.opow_one Ordinal.omega0, NatOrdinal.of_omega0_opow] + simp + rw [hof, ← NatOrdinal.wpow_add, NatOrdinal.val_wpow] + congr 1 + rw [one_add_one_eq_two] + rfl + rw [hval] + exact lt_irrefl _ + +/-- Fact 3.7 is stated for the natural sum, which differs from the ordinary ordinal sum on the +same arguments: `1 ⊕ ω = ω + 1` while `1 + ω = ω`. -/ +theorem naturalAdd_ne_ordinalAdd : + ∃ b c : Ordinal, (NatOrdinal.of b + NatOrdinal.of c).val ≠ b + c := by + refine ⟨1, Ordinal.omega0, ?_⟩ + rw [Ordinal.one_add_omega0] + have hlt : NatOrdinal.of Ordinal.omega0 < + NatOrdinal.of 1 + NatOrdinal.of Ordinal.omega0 := by + refine lt_add_of_pos_left _ ?_ + simp + exact (NatOrdinal.val.lt_iff_lt.mpr hlt).ne' + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/Tests/OrderedUnion.lean b/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/Tests/OrderedUnion.lean new file mode 100644 index 0000000000..1e108ac689 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/Tests/OrderedUnion.lean @@ -0,0 +1,69 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.SetOrderType + +import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.OrderedUnion +import Mathlib.SetTheory.Ordinal.Principal + +/-! +# API certificate for the separated indexed-union estimate + +This client applies Berarducci's ordered-union estimate at the infinite factors +`ρ = ω` and `l = ω * 2`. It also proves that the source conclusion `ρ * l` differs from the +reversed product `l * ρ` at these values. Thus the certificate detects a silent reversal of +ordinary ordinal multiplication; a finite or symmetric test would not. +-/ + +universe u + +open Order Ordinal + +public noncomputable section + +namespace Tests + +/-- At `ρ = ω` and `l = ω * 2`, the ordinary product in Berarducci, Lemma 4.7 differs +from the product with its factors reversed. -/ +theorem omega_mul_omega_mul_two_ne_omega_mul_two_mul_omega : + Ordinal.omega0.{u} * (Ordinal.omega0 * 2) ≠ + (Ordinal.omega0 * 2) * Ordinal.omega0 := by + have htwo : (2 : Ordinal.{u}) * Ordinal.omega0 = Ordinal.omega0 := + Ordinal.natCast_mul_omega0 (n := 2) (by simp) + have hright : (Ordinal.omega0 * 2) * Ordinal.omega0 = + Ordinal.omega0 * Ordinal.omega0 := by + calc + (Ordinal.omega0 * 2) * Ordinal.omega0 = + Ordinal.omega0 * (2 * Ordinal.omega0) := mul_assoc _ _ _ + _ = Ordinal.omega0 * Ordinal.omega0 := by rw [htwo] + have hpos : 0 < Ordinal.omega0.{u} * Ordinal.omega0.{u} := + mul_pos Ordinal.omega0_pos Ordinal.omega0_pos + have hleft : Ordinal.omega0 * Ordinal.omega0 < + Ordinal.omega0 * (Ordinal.omega0 * 2) := by + rw [← mul_assoc] + simpa only [mul_one] using + (mul_lt_mul_of_pos_left (show (1 : Ordinal.{u}) < 2 by simp) hpos) + exact hright ▸ ne_of_gt hleft + +/-- The public ordered-union interface produces the source's ordinary product in the +noncommuting test case `ρ = ω` and `l = ω * 2`. -/ +theorem omega_mul_omega_mul_two_le_orderType_iUnion + {α : Type u} [LinearOrder α] + (B : (Ordinal.omega0.{u} * 2).ToType → Set α) + (hB : ∀ i, (B i).IsPWO) + (hseparated : ∀ {i j}, i < j → ∃ y ∈ B j, ∀ x ∈ B i, x < y) + (hfinal : ∀ (i : (Ordinal.omega0.{u} * 2).ToType) (C : Set α) + (hC : IsRelUpperSet C (· ∈ B i)), C.Nonempty → + Ordinal.omega0 ≤ ((hB i).mono fun _ hx ↦ (hC hx).1).orderType) + (hUnion : (⋃ i, B i).IsPWO) : + Ordinal.omega0.{u} * (Ordinal.omega0 * 2) ≤ hUnion.orderType := by + exact Set.IsPWO.mul_le_orderType_iUnion_of_isSuccLimit + (l := Ordinal.omega0.{u} * 2) (ρ := Ordinal.omega0.{u}) + (Ordinal.isSuccLimit_mul_left Ordinal.isSuccLimit_omega0 (by simp)) + B hB hseparated hfinal hUnion + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/Tests/OrdinalFactors.lean b/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/Tests/OrdinalFactors.lean new file mode 100644 index 0000000000..b61ff3cfd6 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/Tests/OrdinalFactors.lean @@ -0,0 +1,186 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.MultiplicativelyPrincipal + +import Mathlib.Tactic.NormNum + +/-! +# API checks for multiplicatively principal ordinal factors + +The first certificate exposes the exceptional ordinal `2`: it satisfies Berarducci's printed +multiplicative-principality predicate but is not one of the infinite factors described in the +paper's classification. This prevents the exact source predicate from being silently replaced by +the incomplete classification. + +The value `ω ^ 3` has three equal factors, while `ω ^ (ω + 1)` has the asymmetric factor list +`[ω ^ ω, ω]`. The latter example distinguishes the final principal factor from the initial +factor and verifies the residual factor simultaneously. A singleton example checks Berarducci's +convention that the residual factor is one when the value is already infinite multiplicatively +principal. The final certificate exercises the equality between ordinary and Hessenberg products. +-/ + +open scoped NatOrdinal + +public noncomputable section + +namespace Tests + +open Ordinal + +/-- The finite ordinal two separates Berarducci's exact predicate from the infinite factor +shape asserted by the paper's incomplete classification. -/ +theorem two_multiplicativePrincipal_boundary : + IsMultiplicativelyPrincipal (2 : Ordinal) ∧ + ¬IsInfiniteMultiplicativelyPrincipal 2 := by + constructor + · exact isMultiplicativelyPrincipal_two + · rw [isInfiniteMultiplicativelyPrincipal_iff_two_lt_and_isMultiplicativelyPrincipal] + simp + +private theorem omegaCubed_product : + [omega0, omega0, omega0].prod = omega0 ^ (3 : Ordinal) := by + simp only [List.prod_cons, List.prod_nil, mul_one] + rw [← opow_one omega0, ← opow_add, ← opow_add] + norm_num + +/-- The canonical multiplicative factor list of `ω ^ 3` consists of three copies of `ω`. -/ +theorem omegaCubed_multiplicativePrincipalFactors : + [omega0, omega0, omega0] = + (omega0 ^ (3 : Ordinal)).multiplicativePrincipalFactors := by + apply multiplicativePrincipalFactors_unique + · exact isAdditivelyPrincipal_omega0_opow 3 + · exact omegaCubed_product + · intro f hf + rw [List.mem_cons, List.mem_cons, List.mem_singleton] at hf + rcases hf with rfl | rfl | rfl + all_goals simpa [opow_zero, opow_one] using + isMultiplicativelyPrincipal_omega0_opow_opow 0 + · intro f hf + rw [List.mem_cons, List.mem_cons, List.mem_singleton] at hf + rcases hf with rfl | rfl | rfl + all_goals exact one_lt_omega0 + · simp [List.sortedGE_iff_pairwise] + +/-- The additive-principal value `ω ^ 3`, packaged in the exact domain of the principal and +residual factor operations. -/ +def omegaCubedValue : AdditivePrincipalAboveOne.{0} := + ⟨omega0 ^ (3 : Ordinal), isAdditivelyPrincipal_omega0_opow 3, + by rw [one_lt_opow]; exact ⟨one_lt_omega0, by norm_num⟩⟩ + +/-- Berarducci's example `ω ^ 3` has principal factor `ω` and residual factor `ω ^ 2`. -/ +theorem omegaCubed_principal_residual : + omegaCubedValue.principalFactor = omega0 ∧ + omegaCubedValue.residualFactor = omega0 ^ (2 : Ordinal) := by + constructor + · rw [omegaCubedValue.principalFactor_eq_getLast] + change (omega0 ^ (3 : Ordinal)).multiplicativePrincipalFactors.getLast _ = omega0 + calc + (omega0 ^ (3 : Ordinal)).multiplicativePrincipalFactors.getLast _ = + [omega0, omega0, omega0].getLast (by simp) := + List.getLast_congr _ _ omegaCubed_multiplicativePrincipalFactors.symm + _ = omega0 := rfl + · rw [omegaCubedValue.residualFactor_eq_dropLast_prod] + change (omega0 ^ (3 : Ordinal)).multiplicativePrincipalFactors.dropLast.prod = + omega0 ^ (2 : Ordinal) + rw [omegaCubed_multiplicativePrincipalFactors.symm] + simp only [List.dropLast_cons_cons, List.dropLast_singleton, List.prod_cons, + List.prod_nil, mul_one] + rw [← opow_one omega0, ← opow_add] + norm_num + +private theorem omegaOmegaMulOmega_product : + [omega0 ^ omega0, omega0].prod = + omega0 ^ (omega0 + 1) := by + simp only [List.prod_cons, List.prod_nil, mul_one] + simp + +/-- The canonical factor list of `ω ^ (ω + 1)` is the asymmetric list `[ω ^ ω, ω]`. -/ +theorem omegaOmegaAddOne_multiplicativePrincipalFactors : + [omega0 ^ omega0, omega0] = + (omega0 ^ (omega0 + 1)).multiplicativePrincipalFactors := by + apply multiplicativePrincipalFactors_unique + · exact isAdditivelyPrincipal_omega0_opow (omega0 + 1) + · exact omegaOmegaMulOmega_product + · intro f hf + rw [List.mem_cons, List.mem_singleton] at hf + rcases hf with rfl | rfl + · simpa [opow_one] using isMultiplicativelyPrincipal_omega0_opow_opow 1 + · simpa [opow_zero, opow_one] using + isMultiplicativelyPrincipal_omega0_opow_opow 0 + · intro f hf + rw [List.mem_cons, List.mem_singleton] at hf + rcases hf with rfl | rfl + · rw [one_lt_opow] + exact ⟨one_lt_omega0, omega0_ne_zero⟩ + · exact one_lt_omega0 + · rw [List.sortedGE_iff_pairwise, List.pairwise_cons] + constructor + · intro f hf + rw [List.mem_singleton] at hf + subst f + simpa [opow_one] using + opow_le_opow_right omega0_pos (show (1 : Ordinal) ≤ omega0 by + exact one_lt_omega0.le) + · exact List.pairwise_singleton _ _ + +/-- The additive-principal value `ω ^ (ω + 1)`, packaged in the exact factor domain. -/ +def omegaOmegaAddOneValue : AdditivePrincipalAboveOne.{0} := + ⟨omega0 ^ (omega0 + 1), + isAdditivelyPrincipal_omega0_opow (omega0 + 1), + by rw [one_lt_opow]; exact ⟨one_lt_omega0, by simp⟩⟩ + +/-- The asymmetric example has final principal factor `ω` and residual factor `ω ^ ω`. -/ +theorem omegaOmegaAddOne_principal_residual : + omegaOmegaAddOneValue.principalFactor = omega0 ∧ + omegaOmegaAddOneValue.residualFactor = omega0 ^ omega0 := by + constructor + · rw [omegaOmegaAddOneValue.principalFactor_eq_getLast] + change (omega0 ^ (omega0 + 1)).multiplicativePrincipalFactors.getLast _ = + omega0 + calc + (omega0 ^ (omega0 + 1)).multiplicativePrincipalFactors.getLast _ = + [omega0 ^ omega0, omega0].getLast (by simp) := + List.getLast_congr _ _ + omegaOmegaAddOne_multiplicativePrincipalFactors.symm + _ = omega0 := rfl + · rw [omegaOmegaAddOneValue.residualFactor_eq_dropLast_prod] + change (omega0 ^ (omega0 + 1)).multiplicativePrincipalFactors.dropLast.prod = + omega0 ^ omega0 + rw [omegaOmegaAddOne_multiplicativePrincipalFactors.symm] + simp + +/-- The infinite multiplicatively principal value `ω ^ ω`, packaged in the exact factor +domain. -/ +def omegaOmegaValue : AdditivePrincipalAboveOne.{0} := + ⟨omega0 ^ omega0, isAdditivelyPrincipal_omega0_opow omega0, + by rw [one_lt_opow]; exact ⟨one_lt_omega0, omega0_ne_zero⟩⟩ + +/-- A singleton factor list gives principal factor equal to the value and residual factor one. -/ +theorem omegaOmega_principal_residual : + omegaOmegaValue.principalFactor = omega0 ^ omega0 ∧ + omegaOmegaValue.residualFactor = 1 := by + have hprincipal : IsInfiniteMultiplicativelyPrincipal (omega0 ^ omega0) := by + simpa [opow_one] using isInfiniteMultiplicativelyPrincipal_omega0_opow_opow 1 + have hprincipal' : IsInfiniteMultiplicativelyPrincipal omegaOmegaValue.1 := by + simpa [omegaOmegaValue] using hprincipal + exact ⟨omegaOmegaValue.principalFactor_eq_self_of_isInfiniteMultiplicativelyPrincipal + hprincipal', + omegaOmegaValue.residualFactor_eq_one_of_isInfiniteMultiplicativelyPrincipal + hprincipal'⟩ + +/-- In the asymmetric example, the Hessenberg product of the residual and principal factors +equals the same ordinal as their ordinary product. -/ +theorem omegaOmegaAddOne_natural_factorization : + NatOrdinal.of ((omega0 : Ordinal.{0}) ^ omega0) * NatOrdinal.of omega0 = + NatOrdinal.of ((omega0 : Ordinal.{0}) ^ (omega0 + 1)) := by + have h := omegaOmegaAddOneValue.naturalResidual_mul_naturalPrincipal + rw [omegaOmegaAddOne_principal_residual.1, + omegaOmegaAddOne_principal_residual.2] at h + simpa [omegaOmegaAddOneValue] using h + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/Tests/OrdinalFinitePart.lean b/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/Tests/OrdinalFinitePart.lean new file mode 100644 index 0000000000..2b002a3c4e --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/Tests/OrdinalFinitePart.lean @@ -0,0 +1,134 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.FinitePart + +import Mathlib.Tactic.NormNum + +/-! +# API checks for finite Cantor coefficients + +The first two fixtures have constant Cantor coefficients five and seven. Their Hessenberg sum has +constant coefficient twelve; ordinary ordinal addition would instead discard the first constant +coefficient and produce seven. The first fixture is also checked directly against Mathlib's +Cantor-normal-form coefficient. + +Finite removal is exercised away from both zero and the entire constant coefficient. The product +fixture has exact value `ω ^ 3 * 6`: it satisfies the proved `ω ^ 4` bound but is not below +`ω ^ 3`, distinguishing the required `p + q + 1` exponent from the nearby off-by-one bound. +-/ + +public noncomputable section + +namespace Tests + +/-- A natural ordinal with a nonzero degree-two term and constant coefficient five. -/ +def degreeTwoWithFive : NatOrdinal := + ω^ (2 : NatOrdinal) + 5 + +/-- A natural ordinal with a nonzero degree-one term and constant coefficient seven. -/ +def degreeOneWithSeven : NatOrdinal := + ω^ (1 : NatOrdinal) + 7 + +theorem degreeTwoWithFive_constantCoeff : degreeTwoWithFive.constantCoeff = 5 := by + rw [degreeTwoWithFive] + change (ω^ (2 : NatOrdinal) + (5 : ℕ)).constantCoeff = 5 + rw [NatOrdinal.constantCoeff_add_natCast, + NatOrdinal.constantCoeff_wpow] + norm_num + +theorem degreeOneWithSeven_constantCoeff : degreeOneWithSeven.constantCoeff = 7 := by + rw [degreeOneWithSeven] + change (ω^ (1 : NatOrdinal) + (7 : ℕ)).constantCoeff = 7 + rw [NatOrdinal.constantCoeff_add_natCast, + NatOrdinal.constantCoeff_wpow] + norm_num + +/-- Hessenberg addition adds both nonzero constant Cantor coefficients. -/ +theorem asymmetricSum_constantCoeff : + (degreeTwoWithFive + degreeOneWithSeven).constantCoeff = 12 := by + rw [NatOrdinal.constantCoeff_add, degreeTwoWithFive_constantCoeff, + degreeOneWithSeven_constantCoeff] + +/-- The remainder agrees concretely with Mathlib's Cantor-normal-form +coefficient. -/ +theorem degreeTwoWithFive_CNF_coeff_zero : + Ordinal.CNF.coeff Ordinal.omega0 degreeTwoWithFive.val 0 = 5 := by + rw [← NatOrdinal.coe_constantCoeff_eq_CNF_coeff, + degreeTwoWithFive_constantCoeff] + norm_num + +/-- Removing three constant terms leaves exactly two constant terms. -/ +theorem degreeTwoWithFive_removeThree : + degreeTwoWithFive.removeNat 3 = ω^ (2 : NatOrdinal) + 2 := by + symm + apply (NatOrdinal.eq_removeNat_iff_add_natCast_eq (a := degreeTwoWithFive) + (eta := ω^ (2 : NatOrdinal) + 2) (n := 3) (by + rw [degreeTwoWithFive_constantCoeff] + norm_num)).mpr + rw [degreeTwoWithFive] + rw [add_assoc] + congr 1 + norm_num + +/-- Removing the predecessor term from the left summand commutes with adding the right +summand. -/ +theorem asymmetricSum_removeOne : + (degreeTwoWithFive + degreeOneWithSeven).removeNat 1 = + degreeTwoWithFive.removeNat 1 + degreeOneWithSeven := by + apply NatOrdinal.removeOne_add_right + rw [degreeTwoWithFive_constantCoeff] + norm_num + +/-- A degree-two natural ordinal with leading coefficient two. -/ +def productLeft : NatOrdinal := + ω^ (2 : NatOrdinal) * 2 + +/-- A degree-one natural ordinal with leading coefficient three. -/ +def productRight : NatOrdinal := + ω^ (1 : NatOrdinal) * 3 + +theorem productLeft_lt_wpow_three : productLeft < ω^ (3 : NatOrdinal) := by + rw [productLeft] + exact NatOrdinal.wpow_mul_natCast_lt (by norm_num) 2 + +theorem productRight_lt_wpow_two : productRight < ω^ (2 : NatOrdinal) := by + rw [productRight] + exact NatOrdinal.wpow_mul_natCast_lt (by norm_num) 3 + +/-- The asymmetric product has a nonzero term at exponent three. -/ +theorem product_exact : + productLeft * productRight = ω^ (3 : NatOrdinal) * 6 := by + rw [productLeft, productRight] + calc + (ω^ (2 : NatOrdinal) * 2) * (ω^ (1 : NatOrdinal) * 3) = + (ω^ (2 : NatOrdinal) * ω^ (1 : NatOrdinal)) * (2 * 3) := by + ac_rfl + _ = ω^ ((2 : NatOrdinal) + 1) * 6 := by + rw [NatOrdinal.wpow_add] + norm_num + _ = ω^ (3 : NatOrdinal) * 6 := by norm_num + +/-- The product is not below the nearby incorrect ceiling `ω ^ 3`. -/ +theorem product_not_lt_wpow_three : + ¬productLeft * productRight < ω^ (3 : NatOrdinal) := by + rw [product_exact] + apply not_lt_of_ge + calc + ω^ (3 : NatOrdinal) = ω^ (3 : NatOrdinal) * 1 := (mul_one _).symm + _ ≤ ω^ (3 : NatOrdinal) * 6 := + mul_le_mul_right (show (1 : NatOrdinal) ≤ 6 by norm_num) _ + +/-- The finite-degree product estimate places the same product strictly below `ω ^ 4`. -/ +theorem product_lt_wpow_four : + productLeft * productRight < ω^ (4 : NatOrdinal) := by + have h := NatOrdinal.mul_lt_wpow_natCast_add_one + (p := 2) (q := 1) productLeft_lt_wpow_three productRight_lt_wpow_two + norm_num at h + exact h + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/Tests/OrdinalSuccessorFactorization.lean b/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/Tests/OrdinalSuccessorFactorization.lean new file mode 100644 index 0000000000..7d445764a1 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/Tests/OrdinalSuccessorFactorization.lean @@ -0,0 +1,133 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.SuccessorFactorization + +import Mathlib.Tactic.NormNum + +/-! +# API checks for successor-exponent factorisation + +The successor fixture has exponent `omega + 1`. Its principal factor is `omega`, while its +residual factor is `omega ^ omega`. This separates the intended last-factor convention from +using the entire power as the principal factor or assigning residual value one at every +successor exponent. + +The neighboring limit fixture has exponent `omega`; its full power is already infinitely +multiplicatively principal and is therefore its own principal factor. This checks that the +positive-constant-coefficient hypothesis is essential. +-/ + +open scoped NatOrdinal +open Ordinal + +public noncomputable section + +namespace Tests + +/-- The limit exponent `omega`. -/ +abbrev successorFactorLimitExponent : NatOrdinal := ω^ (1 : NatOrdinal) + +/-- The successor exponent `omega + 1`. -/ +abbrev successorFactorLimitSuccessorExponent : NatOrdinal := + successorFactorLimitExponent + (1 : ℕ) + +theorem successorFactorLimitSuccessorExponent_constantCoeff : + successorFactorLimitSuccessorExponent.constantCoeff = 1 := by + rw [successorFactorLimitSuccessorExponent, NatOrdinal.constantCoeff_add_natCast] + rw [successorFactorLimitExponent, NatOrdinal.constantCoeff_wpow] + simp + +theorem successorFactorLimitSuccessorExponent_removeOne : + successorFactorLimitSuccessorExponent.removeNat 1 = successorFactorLimitExponent := by + symm + apply (NatOrdinal.eq_removeNat_iff_add_natCast_eq + (a := successorFactorLimitSuccessorExponent) + (eta := successorFactorLimitExponent) (n := 1) (by + rw [successorFactorLimitSuccessorExponent_constantCoeff])).mpr + rfl + +private theorem successorFactorLimitSuccessorExponent_ne_zero : + successorFactorLimitSuccessorExponent ≠ 0 := by + intro hzero + have h := congrArg NatOrdinal.constantCoeff hzero + rw [successorFactorLimitSuccessorExponent_constantCoeff, + NatOrdinal.constantCoeff_zero] at h + norm_num at h + +/-- The power at exponent `omega + 1` lies in the domain of the factor projections. -/ +theorem one_lt_wpow_successorFactorLimitSuccessor : + 1 < Ordinal.omega0 ^ successorFactorLimitSuccessorExponent.val := by + rw [Ordinal.one_lt_opow] + exact ⟨Ordinal.one_lt_omega0, + NatOrdinal.val_ne_zero.mpr successorFactorLimitSuccessorExponent_ne_zero⟩ + +/-- At exponent `omega + 1`, the final multiplicatively principal factor is `omega`. -/ +theorem principalFactor_wpow_successorFactorLimitSuccessor : + Ordinal.AdditivePrincipalAboveOne.principalFactor + (⟨Ordinal.omega0 ^ successorFactorLimitSuccessorExponent.val, + Ordinal.isAdditivelyPrincipal_omega0_opow + successorFactorLimitSuccessorExponent.val, + one_lt_wpow_successorFactorLimitSuccessor⟩ : + Ordinal.AdditivePrincipalAboveOne) = Ordinal.omega0 := + Ordinal.AdditivePrincipalAboveOne.principalFactor_wpow_of_constantCoeff_pos + successorFactorLimitSuccessorExponent + (by rw [successorFactorLimitSuccessorExponent_constantCoeff]; norm_num) + (Ordinal.isAdditivelyPrincipal_omega0_opow + successorFactorLimitSuccessorExponent.val) + one_lt_wpow_successorFactorLimitSuccessor + +/-- At exponent `omega + 1`, deleting the final factor leaves `omega ^ omega`. -/ +theorem residualFactor_wpow_successorFactorLimitSuccessor : + Ordinal.AdditivePrincipalAboveOne.residualFactor + (⟨Ordinal.omega0 ^ successorFactorLimitSuccessorExponent.val, + Ordinal.isAdditivelyPrincipal_omega0_opow + successorFactorLimitSuccessorExponent.val, + one_lt_wpow_successorFactorLimitSuccessor⟩ : + Ordinal.AdditivePrincipalAboveOne) = + Ordinal.omega0 ^ successorFactorLimitExponent.val := by + rw [Ordinal.AdditivePrincipalAboveOne.residualFactor_wpow_of_constantCoeff_pos + successorFactorLimitSuccessorExponent + (by rw [successorFactorLimitSuccessorExponent_constantCoeff]; norm_num) + (Ordinal.isAdditivelyPrincipal_omega0_opow + successorFactorLimitSuccessorExponent.val) + one_lt_wpow_successorFactorLimitSuccessor] + rw [successorFactorLimitSuccessorExponent_removeOne] + +private theorem successorFactorLimitExponent_ne_zero : successorFactorLimitExponent ≠ 0 := + NatOrdinal.wpow_ne_zero 1 + +/-- The power at exponent `omega` lies in the domain of the factor projections. -/ +theorem one_lt_wpow_successorFactorLimit : + 1 < Ordinal.omega0 ^ successorFactorLimitExponent.val := by + rw [Ordinal.one_lt_opow] + exact ⟨Ordinal.one_lt_omega0, + NatOrdinal.val_ne_zero.mpr successorFactorLimitExponent_ne_zero⟩ + +private theorem wpow_successorFactorLimit_isInfiniteMultiplicativelyPrincipal : + Ordinal.IsInfiniteMultiplicativelyPrincipal + (Ordinal.omega0 ^ successorFactorLimitExponent.val) := by + simpa only [NatOrdinal.val_wpow, NatOrdinal.val_one] using + Ordinal.isInfiniteMultiplicativelyPrincipal_omega0_opow_opow 1 + +/-- At the neighboring limit exponent `omega`, the principal factor is not `omega`; it is the +entire power `omega ^ omega`. -/ +theorem principalFactor_wpow_successorFactorLimit_ne_omega0 : + Ordinal.AdditivePrincipalAboveOne.principalFactor + (⟨Ordinal.omega0 ^ successorFactorLimitExponent.val, + Ordinal.isAdditivelyPrincipal_omega0_opow successorFactorLimitExponent.val, + one_lt_wpow_successorFactorLimit⟩ : Ordinal.AdditivePrincipalAboveOne) ≠ + Ordinal.omega0 := by + rw [AdditivePrincipalAboveOne.principalFactor_eq_self_of_isInfiniteMultiplicativelyPrincipal + _ wpow_successorFactorLimit_isInfiniteMultiplicativelyPrincipal] + apply ne_of_gt + change Ordinal.omega0 < Ordinal.omega0 ^ (Ordinal.omega0 ^ (1 : Ordinal)) + simpa only [Ordinal.opow_one] using + (Ordinal.opow_lt_opow_iff_right Ordinal.one_lt_omega0).mpr + Ordinal.one_lt_omega0 + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/Tests/SetOrderType.lean b/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/Tests/SetOrderType.lean new file mode 100644 index 0000000000..feb7ccc71c --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/Tests/SetOrderType.lean @@ -0,0 +1,101 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.SetOrderType +public import Mathlib.Data.Sum.Order + +/-! +# API check for order type of a union + +This client partitions the well-order `ω + 1` into its final point and its initial copy of `ω`. +Listing the final point first gives ordinary ordinal sum `1 + ω = ω`, which is too small to bound +the union. The Hessenberg sum is `1 ⊕ ω = ω + 1`, and the generic union theorem is sharp. + +The example therefore distinguishes the theorem from the plausible but false replacement of +Hessenberg addition by ordinary ordinal addition. It imports only the public set-order-type API. +-/ + +public noncomputable section + +namespace Tests + +open Ordinal + +private instance : WellFoundedLT (ℕ ⊕ₗ Unit) := + (Sum.Lex.toLexRelIsoLT (α := ℕ) (β := Unit)).symm.toRelEmbedding.wellFounded' + +private def initialOmega : Set (ℕ ⊕ₗ Unit) := + Set.range (fun n : ℕ ↦ Sum.inlₗ n) + +private def finalPoint : Set (ℕ ⊕ₗ Unit) := + Set.range (fun u : Unit ↦ Sum.inrₗ u) + +private def initialOmegaOrderIso : ℕ ≃o initialOmega where + toEquiv := Equiv.ofInjective (fun n : ℕ ↦ Sum.inlₗ n) + Sum.Lex.inl_strictMono.injective + map_rel_iff' := Sum.Lex.inl_le_inl_iff + +private def finalPointOrderIso : Unit ≃o finalPoint where + toEquiv := Equiv.ofInjective (fun u : Unit ↦ Sum.inrₗ u) + Sum.Lex.inr_strictMono.injective + map_rel_iff' := Sum.Lex.inr_le_inr_iff + +private theorem finalPoint_union_initialOmega : + finalPoint ∪ initialOmega = Set.univ := by + ext x + induction x using Lex.rec with + | h x => + cases x <;> simp [finalPoint, initialOmega] + +private def unionOrderIso : ↥(finalPoint ∪ initialOmega) ≃o (ℕ ⊕ₗ Unit) := + (Set.orderIsoOfEq _ _ finalPoint_union_initialOmega).trans OrderIso.Set.univ + +private theorem initialOmega_orderType : + (Set.IsPWO.of_linearOrder initialOmega).orderType = Ordinal.omega0 := by + rw [Set.IsPWO.orderType_eq_typeLT_of_orderIso _ initialOmegaOrderIso.symm, + Ordinal.type_nat_lt] + +private theorem finalPoint_orderType : + (Set.IsPWO.of_linearOrder finalPoint).orderType = 1 := by + rw [Set.IsPWO.orderType_eq_typeLT_of_orderIso _ finalPointOrderIso.symm] + simp + +private theorem union_orderType : + ((Set.IsPWO.of_linearOrder finalPoint).union + (Set.IsPWO.of_linearOrder initialOmega)).orderType = + Ordinal.omega0 + 1 := by + rw [Set.IsPWO.orderType_eq_typeLT_of_orderIso _ unionOrderIso] + calc + typeLT (ℕ ⊕ₗ Unit) = + Ordinal.type (Sum.Lex (· < · : ℕ → ℕ → Prop) + (· < · : Unit → Unit → Prop)) := + (Sum.Lex.toLexRelIsoLT (α := ℕ) (β := Unit)).ordinalType_congr.symm + _ = Ordinal.omega0 + 1 := by + rw [Ordinal.type_sum_lex, Ordinal.type_nat_lt] + simp + +/-- The Hessenberg union bound can be sharp when the corresponding ordinary ordinal sum is too +small. -/ +theorem naturalUnionBound_distinguishes_ordinaryAdd : + ∃ (s t : Set (ℕ ⊕ₗ Unit)) (hs : s.IsPWO) (ht : t.IsPWO), + (hs.union ht).orderType = + (NatOrdinal.of hs.orderType + NatOrdinal.of ht.orderType).val ∧ + ¬(hs.union ht).orderType ≤ hs.orderType + ht.orderType := by + let hs : finalPoint.IsPWO := Set.IsPWO.of_linearOrder finalPoint + let ht : initialOmega.IsPWO := Set.IsPWO.of_linearOrder initialOmega + refine ⟨finalPoint, initialOmega, hs, ht, ?_, ?_⟩ + · apply le_antisymm + · exact Set.IsPWO.orderType_union_le_naturalAdd hs ht + · rw [union_orderType, finalPoint_orderType, initialOmega_orderType] + rw [add_comm] + change (NatOrdinal.of Ordinal.omega0 + 1).val ≤ Ordinal.omega0 + 1 + rw [← NatOrdinal.of_add_one, NatOrdinal.val_of] + · rw [union_orderType, finalPoint_orderType, initialOmega_orderType, + Ordinal.one_add_omega0] + exact not_le_of_gt (lt_add_one Ordinal.omega0) + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/Tests/Sumset.lean b/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/Tests/Sumset.lean new file mode 100644 index 0000000000..bc51308a74 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/Ordinal/Tests/Sumset.lean @@ -0,0 +1,279 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.SetOrderType +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.Sumset +public import Mathlib.Algebra.Order.Group.Int +public import Mathlib.Algebra.Order.Monoid.Prod +public import Mathlib.Data.Finset.MulAntidiagonal + +import LeanPool.ConwayRefinement.CombinatorialGames.NatOrdinal.Pow +import Mathlib.Data.Sum.Order + +/-! +# API check for order type of a sumset + +This client embeds supports of order types `ω + 1` and `ω` into the lexicographically +ordered group `ℤ ×ₗ (ℤ ×ₗ ℤ)`. Their pointwise sum has order type `ω² + ω`, so the +Hessenberg-product bound of LM24, Fact 2.2.3(3), is attained. Ordinary ordinal multiplication +would instead give `(ω + 1) * ω = ω²`, which is too small. + +The example therefore distinguishes the theorem from the plausible but false replacement of +Hessenberg multiplication by ordinary ordinal multiplication. Its auxiliary supports and order +isomorphisms are private. +-/ + +public noncomputable section + +open Ordinal +open scoped Pointwise + +namespace Tests + +private instance : WellFoundedLT (ℕ ⊕ₗ Unit) := + (Sum.Lex.toLexRelIsoLT (α := ℕ) (β := Unit)).symm.toRelEmbedding.wellFounded' + +private instance : WellFoundedLT ((ℕ ×ₗ ℕ) ⊕ₗ ℕ) := + (Sum.Lex.toLexRelIsoLT (α := ℕ ×ₗ ℕ) (β := ℕ)).symm.toRelEmbedding.wellFounded' + +private abbrev SumsetExponentGroup := ℤ ×ₗ (ℤ ×ₗ ℤ) + +private def triple (a b c : ℤ) : SumsetExponentGroup := + toLex (a, toLex (b, c)) + +private def leftMap (q : ℕ ⊕ₗ Unit) : SumsetExponentGroup := + match ofLex q with + | Sum.inl n => triple 0 n 0 + | Sum.inr _ => triple 1 0 0 + +private def rightMap (m : ℕ) : SumsetExponentGroup := + triple 0 0 m + +private def sumMap (q : (ℕ ×ₗ ℕ) ⊕ₗ ℕ) : SumsetExponentGroup := + match ofLex q with + | Sum.inl p => triple 0 (ofLex p).1 (ofLex p).2 + | Sum.inr m => triple 1 0 m + +private def leftSupport : Set SumsetExponentGroup := + Set.range leftMap + +private def rightSupport : Set SumsetExponentGroup := + Set.range rightMap + +private def sumSupport : Set SumsetExponentGroup := + Set.range sumMap + +private theorem triple_add (a b c a' b' c' : ℤ) : + triple a b c + triple a' b' c' = triple (a + a') (b + b') (c + c') := by + rfl + +private theorem leftMap_strictMono : StrictMono leftMap := by + intro a b hab + induction a using Lex.rec with + | h a => + induction b using Lex.rec with + | h b => + cases a with + | inl n => + cases b with + | inl m => + simp only [Sum.Lex.toLex_lt_toLex, lt_self_iff_false, + Sum.lex_inl_inl, leftMap, ofLex_toLex, triple, + Prod.Lex.lt_iff, and_false, or_false, true_and, + false_or] at hab ⊢ + exact_mod_cast hab + | inr u => + simp only [Sum.Lex.toLex_lt_toLex, lt_self_iff_false, + Sum.Lex.sep, leftMap, ofLex_toLex, triple, + Prod.Lex.lt_iff, zero_lt_one, zero_ne_one, + Int.natCast_eq_zero, and_false, or_false, + false_and] at hab ⊢ + | inr u => + cases b with + | inl n => + simp only [Sum.Lex.toLex_lt_toLex, lt_self_iff_false, + Sum.lex_inr_inl] at hab + | inr v => simp only [lt_self_iff_false] at hab + +private theorem rightMap_strictMono : StrictMono rightMap := by + intro a b hab + simpa [rightMap, triple, Prod.Lex.lt_iff] using hab + +private theorem sumMap_strictMono : StrictMono sumMap := by + intro a b hab + induction a using Lex.rec with + | h a => + induction b using Lex.rec with + | h b => + cases a with + | inl p => + cases b with + | inl q => + simp only [Sum.Lex.toLex_lt_toLex, Prod.Lex.lt_iff, + Sum.lex_inl_inl, sumMap, ofLex_toLex, triple, + lt_self_iff_false, true_and, false_or] at hab ⊢ + exact_mod_cast hab + | inr m => + simp only [Sum.Lex.toLex_lt_toLex, Prod.Lex.lt_iff, + Sum.Lex.sep, sumMap, ofLex_toLex, triple, + zero_lt_one, zero_ne_one, Int.natCast_eq_zero, + false_and, or_false] at hab ⊢ + | inr m => + cases b with + | inl p => + simp only [Sum.Lex.toLex_lt_toLex, Prod.Lex.lt_iff, + Sum.lex_inr_inl] at hab + | inr n => + simp only [Sum.Lex.toLex_lt_toLex, Prod.Lex.lt_iff, + Sum.lex_inr_inr, sumMap, ofLex_toLex, triple, + lt_self_iff_false, true_and, + false_or] at hab ⊢ + exact_mod_cast hab + +private def leftOrderIso : (ℕ ⊕ₗ Unit) ≃o leftSupport where + toEquiv := Equiv.ofInjective leftMap leftMap_strictMono.injective + map_rel_iff' := leftMap_strictMono.le_iff_le + +private def rightOrderIso : ℕ ≃o rightSupport where + toEquiv := Equiv.ofInjective rightMap rightMap_strictMono.injective + map_rel_iff' := rightMap_strictMono.le_iff_le + +private def sumOrderIso : ((ℕ ×ₗ ℕ) ⊕ₗ ℕ) ≃o sumSupport where + toEquiv := Equiv.ofInjective sumMap sumMap_strictMono.injective + map_rel_iff' := sumMap_strictMono.le_iff_le + +private theorem leftSupport_isPWO : leftSupport.IsPWO := by + simpa [leftSupport] using + (Set.IsPWO.of_linearOrder (Set.univ : Set (ℕ ⊕ₗ Unit))).image_of_monotone + leftMap_strictMono.monotone + +private theorem rightSupport_isPWO : rightSupport.IsPWO := by + simpa [rightSupport] using + (Set.IsPWO.of_linearOrder (Set.univ : Set ℕ)).image_of_monotone + rightMap_strictMono.monotone + +private theorem sumSupport_isPWO : sumSupport.IsPWO := by + simpa [sumSupport] using + (Set.IsPWO.of_linearOrder + (Set.univ : Set ((ℕ ×ₗ ℕ) ⊕ₗ ℕ))).image_of_monotone + sumMap_strictMono.monotone + +private theorem add_supports : leftSupport + rightSupport = sumSupport := by + ext z + constructor + · rintro ⟨x, ⟨a, rfl⟩, y, ⟨b, rfl⟩, rfl⟩ + induction a using Lex.rec with + | h a => + cases a with + | inl n => + refine ⟨Sum.inlₗ (toLex (n, b)), ?_⟩ + simp only [sumMap, leftMap, rightMap, ofLex_toLex] + rw [triple_add] + simp + | inr u => + refine ⟨Sum.inrₗ b, ?_⟩ + simp only [sumMap, leftMap, rightMap, ofLex_toLex] + rw [triple_add] + simp + · rintro ⟨q, rfl⟩ + induction q using Lex.rec with + | h q => + cases q with + | inl p => + apply Set.mem_add.mpr + refine ⟨leftMap (Sum.inlₗ (ofLex p).1), ⟨_, rfl⟩, + rightMap (ofLex p).2, ⟨_, rfl⟩, ?_⟩ + simp only [leftMap, rightMap, sumMap, ofLex_toLex] + rw [triple_add] + simp + | inr m => + apply Set.mem_add.mpr + refine ⟨leftMap (Sum.inrₗ ()), ⟨_, rfl⟩, + rightMap m, ⟨_, rfl⟩, ?_⟩ + simp only [leftMap, rightMap, sumMap, ofLex_toLex] + rw [triple_add] + simp + +private theorem left_orderType : + leftSupport_isPWO.orderType = Ordinal.omega0 + 1 := by + rw [Set.IsPWO.orderType_eq_typeLT_of_orderIso + leftSupport_isPWO leftOrderIso.symm] + calc + typeLT (ℕ ⊕ₗ Unit) = + Ordinal.type (Sum.Lex (· < · : ℕ → ℕ → Prop) + (· < · : Unit → Unit → Prop)) := + (Sum.Lex.toLexRelIsoLT (α := ℕ) (β := Unit)).ordinalType_congr.symm + _ = Ordinal.omega0 + 1 := by + rw [Ordinal.type_sum_lex, Ordinal.type_nat_lt] + simp + +private theorem right_orderType : + rightSupport_isPWO.orderType = Ordinal.omega0 := by + rw [Set.IsPWO.orderType_eq_typeLT_of_orderIso + rightSupport_isPWO rightOrderIso.symm, + Ordinal.type_nat_lt] + +private theorem sum_orderType : + sumSupport_isPWO.orderType = + Ordinal.omega0 ^ (2 : Ordinal) + Ordinal.omega0 := by + rw [Set.IsPWO.orderType_eq_typeLT_of_orderIso + sumSupport_isPWO sumOrderIso.symm] + calc + typeLT ((ℕ ×ₗ ℕ) ⊕ₗ ℕ) = + typeLT (ℕ ×ₗ ℕ) + typeLT ℕ := by + rw [← Ordinal.type_sum_lex] + exact (Sum.Lex.toLexRelIsoLT (α := ℕ ×ₗ ℕ) (β := ℕ)).ordinalType_congr.symm + _ = (typeLT ℕ) * (typeLT ℕ) + typeLT ℕ := by + congr 1 + _ = Ordinal.omega0 * Ordinal.omega0 + Ordinal.omega0 := by + rw [Ordinal.type_nat_lt] + _ = Ordinal.omega0 ^ (2 : Ordinal) + Ordinal.omega0 := by + have hsucc : (1 : Ordinal) + 1 = 2 := one_add_one_eq_two + rw [← hsucc, Ordinal.opow_add_one, Ordinal.opow_one] + +private theorem naturalProduct_value : + (NatOrdinal.of (Ordinal.omega0 + 1) * NatOrdinal.of Ordinal.omega0).val = + Ordinal.omega0 ^ (2 : Ordinal) + Ordinal.omega0 := by + have homega : NatOrdinal.of Ordinal.omega0 = ω^ (1 : NatOrdinal) := by + rw [NatOrdinal.wpow_def, NatOrdinal.val_one, Ordinal.opow_one] + rw [NatOrdinal.of_add_one, homega, add_mul, one_mul, + ← NatOrdinal.wpow_add, one_add_one_eq_two, + NatOrdinal.wpow_add_wpow (show (1 : NatOrdinal) ≤ 2 by simp)] + rw [NatOrdinal.val_of] + change Ordinal.omega0 ^ (2 : Ordinal) + + Ordinal.omega0 ^ (1 : Ordinal) = _ + rw [Ordinal.opow_one] + +/-- The Hessenberg sumset bound is sharp when the corresponding ordinary ordinal product is too +small. -/ +theorem naturalSumsetBound_distinguishes_ordinaryMul : + ∃ (s t : Set (ℤ ×ₗ (ℤ ×ₗ ℤ))) (hs : s.IsPWO) (ht : t.IsPWO), + (hs.add ht).orderType = + (NatOrdinal.of hs.orderType * NatOrdinal.of ht.orderType).val ∧ + ¬(hs.add ht).orderType ≤ hs.orderType * ht.orderType := by + let hs : leftSupport.IsPWO := leftSupport_isPWO + let ht : rightSupport.IsPWO := rightSupport_isPWO + refine ⟨leftSupport, rightSupport, hs, ht, ?_, ?_⟩ + · apply le_antisymm + · exact Set.IsPWO.orderType_add_le_naturalMul hs ht + · rw [Set.IsPWO.orderType_congr (hs.add ht) + sumSupport_isPWO add_supports, + sum_orderType, left_orderType, right_orderType] + exact naturalProduct_value.le + · rw [Set.IsPWO.orderType_congr (hs.add ht) + sumSupport_isPWO add_supports, + sum_orderType, left_orderType, right_orderType] + have hordinary : (Ordinal.omega0 + 1) * Ordinal.omega0 = + Ordinal.omega0 ^ (2 : Ordinal) := by + rw [Ordinal.add_mul_of_isSuccLimit Ordinal.one_add_omega0 + Ordinal.isSuccLimit_omega0] + have hsucc : (1 : Ordinal) + 1 = 2 := one_add_one_eq_two + rw [← hsucc, Ordinal.opow_add_one, Ordinal.opow_one] + rw [hordinary] + exact not_le_of_gt (lt_add_of_pos_right _ Ordinal.omega0_pos) + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/ZFC.lean b/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/ZFC.lean new file mode 100644 index 0000000000..f355129a74 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/ZFC.lean @@ -0,0 +1,13 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.ZFC.Game +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.ZFC.GameOperations +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.ZFC.Tests + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/ZFC/Game.lean b/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/ZFC/Game.lean new file mode 100644 index 0000000000..47bb53434f --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/ZFC/Game.lean @@ -0,0 +1,211 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.CombinatorialGames.Game.IGame +public import Mathlib.SetTheory.ZFC.Basic + +/-! +# Games coded by ZFC sets + +A game code is a Kuratowski ordered pair of sets of game codes, representing its left and right +options. This grammar is stated independently of `IGame`. Coding and decoding preserve literal +pregame equality, not just equality of game values. +-/ + +universe u + +public noncomputable section + +namespace ZFSet + +/-- A well-founded game tree coded as an ordered pair of sets of game codes. -/ +inductive IsGameCode : ZFSet.{u} → Prop + | mk (L R : ZFSet.{u}) + (left : ∀ x ∈ L, IsGameCode x) (right : ∀ x ∈ R, IsGameCode x) : + IsGameCode (pair L R) + +/-- A game code has a left-option set and a right-option set of game codes. -/ +theorem IsGameCode.exists_eq_pair {z : ZFSet.{u}} (h : IsGameCode z) : + ∃ L R, z = pair L R ∧ (∀ x ∈ L, IsGameCode x) ∧ (∀ x ∈ R, IsGameCode x) := by + cases h with + | mk L R hL hR => exact ⟨L, R, rfl, hL, hR⟩ + +@[simp] +theorem isGameCode_pair_iff (L R : ZFSet.{u}) : + IsGameCode (pair L R) ↔ (∀ x ∈ L, IsGameCode x) ∧ (∀ x ∈ R, IsGameCode x) := by + constructor + · intro h + obtain ⟨L', R', heq, hL, hR⟩ := h.exists_eq_pair + obtain ⟨rfl, rfl⟩ := pair_inj.1 heq + exact ⟨hL, hR⟩ + · rintro ⟨hL, hR⟩ + exact .mk L R hL hR + +/-- The ZFC sets satisfying the independent game-code grammar. -/ +def GameCode : Type (u + 1) := {x : ZFSet.{u} // IsGameCode x} + +namespace GameCode + +/-- Make a game code from a ZFC set satisfying the grammar. -/ +def mk (x : ZFSet.{u}) (h : IsGameCode x) : GameCode.{u} := ⟨x, h⟩ + +/-- The underlying ZFC set of a game code. -/ +def val (x : GameCode.{u}) : ZFSet.{u} := x.1 + +instance : Coe GameCode.{u} ZFSet.{u} := ⟨val⟩ + +@[simp] +theorem coe_mk (x : ZFSet.{u}) (h : IsGameCode x) : (mk x h : ZFSet.{u}) = x := (rfl) + +/-- Every game code satisfies its defining grammar. -/ +theorem isGameCode (x : GameCode.{u}) : IsGameCode (x : ZFSet.{u}) := x.2 + +@[ext] +theorem ext {x y : GameCode.{u}} (h : (x : ZFSet.{u}) = (y : ZFSet.{u})) : x = y := + Subtype.ext h + +@[simp] +theorem mk_coe (x : GameCode.{u}) : mk (x : ZFSet.{u}) x.isGameCode = x := by + apply ext + rfl + +end GameCode +end ZFSet + +namespace IGame + +/-- Encode a game as an ordered pair of the ZFC sets of recursively encoded options. -/ +def toZFSet (x : IGame.{u}) : ZFSet.{u} := + IGame.moveRecOn x fun z ih ↦ + ZFSet.pair (ZFSet.range fun y : z.moves left ↦ ih left y.1 y.2) + (ZFSet.range fun y : z.moves right ↦ ih right y.1 y.2) + +/-- The set of codes of a game's options for one player. -/ +def optionsZFSet (p : Player) (x : IGame.{u}) : ZFSet.{u} := + ZFSet.range fun y : x.moves p ↦ toZFSet y.1 + +@[simp] +theorem mem_optionsZFSet {p : Player} {x : IGame.{u}} {z : ZFSet.{u}} : + z ∈ optionsZFSet p x ↔ ∃ y ∈ x.moves p, toZFSet y = z := by + simp [optionsZFSet] + +/-- The code's first and second components encode the left and right options. -/ +theorem toZFSet_eq_pair (x : IGame.{u}) : + toZFSet x = ZFSet.pair (optionsZFSet left x) (optionsZFSet right x) := by + rw [toZFSet, IGame.moveRecOn_eq] + rfl + +@[simp] +theorem toZFSet_ofSets (s t : Set IGame.{u}) [Small.{u} s] [Small.{u} t] : + toZFSet !{s | t} = ZFSet.pair + (ZFSet.range fun y : s ↦ toZFSet y.1) (ZFSet.range fun y : t ↦ toZFSet y.1) := by + rw [toZFSet_eq_pair] + apply congrArg₂ ZFSet.pair <;> apply ZFSet.ext <;> intro z <;> + simp [mem_optionsZFSet] + +@[simp] +theorem toZFSet_zero : toZFSet (0 : IGame.{u}) = ZFSet.pair ∅ ∅ := by + rw [toZFSet_eq_pair] + apply congrArg₂ ZFSet.pair <;> apply ZFSet.ext <;> intro z <;> + simp + +/-- Every encoded game satisfies the independent ZFC grammar. -/ +theorem isGameCode_toZFSet (x : IGame.{u}) : ZFSet.IsGameCode (toZFSet x) := by + induction x using IGame.moveRecOn with + | ind x ih => + rw [toZFSet_eq_pair] + apply ZFSet.IsGameCode.mk + · intro z hz + obtain ⟨y, hy, rfl⟩ := mem_optionsZFSet.1 hz + exact ih left y hy + · intro z hz + obtain ⟨y, hy, rfl⟩ := mem_optionsZFSet.1 hz + exact ih right y hy + +/-- Coding distinguishes literal games, including their complete option sets. -/ +theorem toZFSet_injective : Function.Injective (toZFSet.{u}) := by + intro x + induction x using IGame.moveRecOn with + | ind x ih => + intro y h + have hp : ∀ p, optionsZFSet p x = optionsZFSet p y := by + rw [toZFSet_eq_pair x, toZFSet_eq_pair y, ZFSet.pair_inj] at h + intro p + cases p + · exact h.1 + · exact h.2 + apply IGame.ext + intro p + ext a + constructor + · intro ha + have hcode : toZFSet a ∈ optionsZFSet p y := by + rw [← hp p] + exact mem_optionsZFSet.2 ⟨a, ha, rfl⟩ + obtain ⟨b, hb, hab⟩ := mem_optionsZFSet.1 hcode + exact (ih p a ha hab.symm) ▸ hb + · intro ha + have hcode : toZFSet a ∈ optionsZFSet p x := by + rw [hp p] + exact mem_optionsZFSet.2 ⟨a, ha, rfl⟩ + obtain ⟨b, hb, hab⟩ := mem_optionsZFSet.1 hcode + exact (ih p b hb hab) ▸ hb + +/-- Every set generated by the ZFC grammar is the code of a game. -/ +theorem exists_toZFSet_eq_of_isGameCode {z : ZFSet.{u}} (hz : ZFSet.IsGameCode z) : + ∃ x : IGame.{u}, toZFSet x = z := by + induction hz with + | mk L R _ _ ihL ihR => + let l : L → IGame.{u} := fun a ↦ Classical.choose (ihL a.1 a.2) + let r : R → IGame.{u} := fun a ↦ Classical.choose (ihR a.1 a.2) + have hl (a : L) : toZFSet (l a) = a.1 := Classical.choose_spec (ihL a.1 a.2) + have hr (a : R) : toZFSet (r a) = a.1 := Classical.choose_spec (ihR a.1 a.2) + refine ⟨!{Set.range l | Set.range r}, ?_⟩ + rw [toZFSet_eq_pair] + apply congrArg₂ ZFSet.pair + · apply ZFSet.ext + intro z + simp only [mem_optionsZFSet, moves_ofSets, Set.mem_range] + constructor + · rintro ⟨g, ⟨a, rfl⟩, h⟩ + rw [hl a] at h + exact h ▸ a.2 + · intro h + exact ⟨l ⟨z, h⟩, ⟨⟨z, h⟩, rfl⟩, hl ⟨z, h⟩⟩ + · apply ZFSet.ext + intro z + simp only [mem_optionsZFSet, moves_ofSets, Set.mem_range] + constructor + · rintro ⟨g, ⟨a, rfl⟩, h⟩ + rw [hr a] at h + exact h ▸ a.2 + · intro h + exact ⟨r ⟨z, h⟩, ⟨⟨z, h⟩, rfl⟩, hr ⟨z, h⟩⟩ + +/-- Literal games are equivalent to the ZFC sets satisfying the independent game-code grammar. -/ +def zfSetEquiv : IGame.{u} ≃ ZFSet.GameCode.{u} where + toFun x := ZFSet.GameCode.mk (toZFSet x) (isGameCode_toZFSet x) + invFun z := Classical.choose (exists_toZFSet_eq_of_isGameCode z.isGameCode) + left_inv x := toZFSet_injective + (Classical.choose_spec (exists_toZFSet_eq_of_isGameCode (isGameCode_toZFSet x))) + right_inv z := ZFSet.GameCode.ext + (Classical.choose_spec (exists_toZFSet_eq_of_isGameCode z.isGameCode)) + +@[simp] +theorem coe_zfSetEquiv (x : IGame.{u}) : (zfSetEquiv x : ZFSet.{u}) = toZFSet x := (rfl) + +@[simp] +theorem toZFSet_zfSetEquiv_symm (z : ZFSet.GameCode.{u}) : + toZFSet (zfSetEquiv.symm z) = (z : ZFSet.{u}) := + Classical.choose_spec (exists_toZFSet_eq_of_isGameCode z.isGameCode) + +@[simp] +theorem zfSetEquiv_symm_mk (x : IGame.{u}) : + zfSetEquiv.symm (ZFSet.GameCode.mk (toZFSet x) (isGameCode_toZFSet x)) = x := + zfSetEquiv.symm_apply_apply x + +end IGame diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/ZFC/GameOperations.lean b/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/ZFC/GameOperations.lean new file mode 100644 index 0000000000..d369fd33a9 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/ZFC/GameOperations.lean @@ -0,0 +1,303 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.ZFC.Game +public import LeanPool.ConwayRefinement.CombinatorialGames.Game.Classes + +import LeanPool.ConwayRefinement.CombinatorialGames.Surreal.Multiplication + +/-! +# Comparison and arithmetic of ZFC game codes + +The coding equivalence transports comparison and the raw game operations. These are operations on +pregames: game equivalence is `AntisymmRel (· ≤ ·)`, and no ring structure is asserted on raw codes. +-/ + +universe u + +public noncomputable section + +open Set + +namespace ZFSet.GameCode + +/-- Encode a literal game as a valid ZFC game code. -/ +def ofIGame (x : IGame.{u}) : GameCode.{u} := IGame.zfSetEquiv x + +/-- Decode a valid ZFC game code as a literal game. -/ +def toIGame (x : GameCode.{u}) : IGame.{u} := IGame.zfSetEquiv.symm x + +@[simp] +theorem toIGame_ofIGame (x : IGame.{u}) : toIGame (ofIGame x) = x := + IGame.zfSetEquiv.symm_apply_apply x + +@[simp] +theorem ofIGame_toIGame (x : GameCode.{u}) : ofIGame (toIGame x) = x := + IGame.zfSetEquiv.apply_symm_apply x + +@[simp] +theorem coe_ofIGame (x : IGame.{u}) : (ofIGame x : ZFSet.{u}) = IGame.toZFSet x := + IGame.coe_zfSetEquiv x + +@[simp] +theorem toZFSet_toIGame (x : GameCode.{u}) : IGame.toZFSet x.toIGame = (x : ZFSet.{u}) := + IGame.toZFSet_zfSetEquiv_symm x + +/-- Decoding game codes is injective. -/ +theorem toIGame_injective : Function.Injective (toIGame.{u}) := + IGame.zfSetEquiv.symm.injective + +@[simp] +theorem toIGame_inj {x y : GameCode.{u}} : x.toIGame = y.toIGame ↔ x = y := + toIGame_injective.eq_iff + +@[simp] +theorem ofIGame_inj {x y : IGame.{u}} : ofIGame x = ofIGame y ↔ x = y := + IGame.zfSetEquiv.injective.eq_iff + +instance : Preorder GameCode.{u} := Preorder.lift toIGame + +@[simp] +theorem toIGame_le_toIGame (x y : GameCode.{u}) : x.toIGame ≤ y.toIGame ↔ x ≤ y := (Iff.rfl) + +@[simp] +theorem toIGame_lt_toIGame (x y : GameCode.{u}) : x.toIGame < y.toIGame ↔ x < y := (Iff.rfl) + +@[simp] +theorem ofIGame_le_ofIGame (x y : IGame.{u}) : ofIGame x ≤ ofIGame y ↔ x ≤ y := by + change toIGame (ofIGame x) ≤ toIGame (ofIGame y) ↔ x ≤ y + simp + +@[simp] +theorem ofIGame_lt_ofIGame (x y : IGame.{u}) : ofIGame x < ofIGame y ↔ x < y := by + change toIGame (ofIGame x) < toIGame (ofIGame y) ↔ x < y + simp + +@[simp] +theorem toIGame_equiv_toIGame (x y : GameCode.{u}) : x.toIGame ≈ y.toIGame ↔ x ≈ y := (Iff.rfl) + +instance : Zero GameCode.{u} := ⟨ofIGame 0⟩ +instance : One GameCode.{u} := ⟨ofIGame 1⟩ +instance : Neg GameCode.{u} := ⟨fun x ↦ ofIGame (-x.toIGame)⟩ +instance : Add GameCode.{u} := ⟨fun x y ↦ ofIGame (x.toIGame + y.toIGame)⟩ +instance : Sub GameCode.{u} := ⟨fun x y ↦ ofIGame (x.toIGame - y.toIGame)⟩ +instance : Mul GameCode.{u} := ⟨fun x y ↦ ofIGame (x.toIGame * y.toIGame)⟩ + +@[simp] theorem toIGame_zero : (0 : GameCode.{u}).toIGame = 0 := toIGame_ofIGame _ +@[simp] theorem toIGame_one : (1 : GameCode.{u}).toIGame = 1 := toIGame_ofIGame _ + +@[simp] +theorem toIGame_neg (x : GameCode.{u}) : (-x).toIGame = -x.toIGame := toIGame_ofIGame _ + +@[simp] +theorem toIGame_add (x y : GameCode.{u}) : (x + y).toIGame = x.toIGame + y.toIGame := + toIGame_ofIGame _ + +@[simp] +theorem toIGame_sub (x y : GameCode.{u}) : (x - y).toIGame = x.toIGame - y.toIGame := + toIGame_ofIGame _ + +@[simp] +theorem toIGame_mul (x y : GameCode.{u}) : (x * y).toIGame = x.toIGame * y.toIGame := + toIGame_ofIGame _ + +@[simp] +theorem ofIGame_neg (x : IGame.{u}) : ofIGame (-x) = -ofIGame x := by + apply toIGame_injective + simp + +@[simp] +theorem ofIGame_add (x y : IGame.{u}) : ofIGame (x + y) = ofIGame x + ofIGame y := by + apply toIGame_injective + simp + +@[simp] +theorem ofIGame_sub (x y : IGame.{u}) : ofIGame (x - y) = ofIGame x - ofIGame y := by + apply toIGame_injective + simp + +@[simp] +theorem ofIGame_mul (x y : IGame.{u}) : ofIGame (x * y) = ofIGame x * ofIGame y := by + apply toIGame_injective + simp + +/-- A code is numeric when all its game positions are numbers in Conway's sense. -/ +def IsNumeric (x : GameCode.{u}) : Prop := IGame.Numeric x.toIGame + +theorem isNumeric_iff (x : GameCode.{u}) : IsNumeric x ↔ IGame.Numeric x.toIGame := (Iff.rfl) + +@[simp] +theorem isNumeric_ofIGame (x : IGame.{u}) : IsNumeric (ofIGame x) ↔ IGame.Numeric x := by + simp [IsNumeric] + +@[simp] +theorem isNumeric_zero : IsNumeric (0 : GameCode.{u}) := by + simp [IsNumeric] + +@[simp] +theorem isNumeric_one : IsNumeric (1 : GameCode.{u}) := by + simp [IsNumeric] + +/-- Negation preserves numeric game codes. -/ +theorem IsNumeric.neg {x : GameCode.{u}} (h : IsNumeric x) : IsNumeric (-x) := by + let : IGame.Numeric x.toIGame := (isNumeric_iff x).1 h + simpa [IsNumeric] using (inferInstance : IGame.Numeric (-x.toIGame)) + +/-- Addition preserves numeric game codes. -/ +theorem IsNumeric.add {x y : GameCode.{u}} (hx : IsNumeric x) (hy : IsNumeric y) : + IsNumeric (x + y) := by + let : IGame.Numeric x.toIGame := (isNumeric_iff x).1 hx + let : IGame.Numeric y.toIGame := (isNumeric_iff y).1 hy + simpa [IsNumeric] using (inferInstance : IGame.Numeric (x.toIGame + y.toIGame)) + +/-- Subtraction preserves numeric game codes. -/ +theorem IsNumeric.sub {x y : GameCode.{u}} (hx : IsNumeric x) (hy : IsNumeric y) : + IsNumeric (x - y) := by + let : IGame.Numeric x.toIGame := (isNumeric_iff x).1 hx + let : IGame.Numeric y.toIGame := (isNumeric_iff y).1 hy + simpa [IsNumeric] using (inferInstance : IGame.Numeric (x.toIGame - y.toIGame)) + +/-- Multiplication preserves numeric game codes. -/ +theorem IsNumeric.mul {x y : GameCode.{u}} (hx : IsNumeric x) (hy : IsNumeric y) : + IsNumeric (x * y) := by + let : IGame.Numeric x.toIGame := (isNumeric_iff x).1 hx + let : IGame.Numeric y.toIGame := (isNumeric_iff y).1 hy + simpa [IsNumeric] using (inferInstance : IGame.Numeric (x.toIGame * y.toIGame)) + +/-- The option codes for one player, with no identification of equivalent options. -/ +def moves (p : Player) (x : GameCode.{u}) : Set GameCode.{u} := + ofIGame '' x.toIGame.moves p + +instance (p : Player) (x : GameCode.{u}) : Small.{u} (x.moves p) := + inferInstanceAs (Small.{u} (ofIGame '' x.toIGame.moves p)) + +@[simp] +theorem mem_moves {p : Player} {x y : GameCode.{u}} : + y ∈ x.moves p ↔ y.toIGame ∈ x.toIGame.moves p := by + constructor + · rintro ⟨z, hz, rfl⟩ + simpa using hz + · intro h + exact ⟨y.toIGame, h, ofIGame_toIGame y⟩ + +/-- Form a code from small left- and right-option sets. -/ +def ofSets (s t : Set GameCode.{u}) [Small.{u} s] [Small.{u} t] : GameCode.{u} := + ofIGame !{toIGame '' s | toIGame '' t} + +@[simp] +theorem toIGame_ofSets (s t : Set GameCode.{u}) [Small.{u} s] [Small.{u} t] : + (ofSets s t).toIGame = !{toIGame '' s | toIGame '' t} := toIGame_ofIGame _ + +@[simp] +theorem moves_ofSets_left (s t : Set GameCode.{u}) [Small.{u} s] [Small.{u} t] : + (ofSets s t).moves Player.left = s := by + simp [moves, image_image] + +@[simp] +theorem moves_ofSets_right (s t : Set GameCode.{u}) [Small.{u} s] [Small.{u} t] : + (ofSets s t).moves Player.right = t := by + simp [moves, image_image] + +/-- The ZFC set of option codes for one player. -/ +def optionCodes (p : Player) (x : GameCode.{u}) : ZFSet.{u} := + ZFSet.range fun y : x.moves p ↦ (y.1 : ZFSet.{u}) + +@[simp] +theorem mem_optionCodes {p : Player} {x : GameCode.{u}} {z : ZFSet.{u}} : + z ∈ optionCodes p x ↔ ∃ y ∈ x.moves p, (y : ZFSet.{u}) = z := by + simp [optionCodes] + +/-- A code is an option exactly when its underlying set belongs to the corresponding option set. -/ +theorem coe_mem_optionCodes {p : Player} {x y : GameCode.{u}} : + (y : ZFSet.{u}) ∈ optionCodes p x ↔ y ∈ x.moves p := by + rw [mem_optionCodes] + constructor + · rintro ⟨z, hz, h⟩ + exact (GameCode.ext h) ▸ hz + · intro h + exact ⟨y, h, rfl⟩ + +/-- The intrinsic option sets agree with the components of the pregame encoding. -/ +theorem optionCodes_eq_optionsZFSet (p : Player) (x : GameCode.{u}) : + optionCodes p x = IGame.optionsZFSet p x.toIGame := by + apply ZFSet.ext + intro z + rw [mem_optionCodes, IGame.mem_optionsZFSet] + constructor + · rintro ⟨y, hy, h⟩ + exact ⟨y.toIGame, mem_moves.1 hy, (toZFSet_toIGame y).trans h⟩ + · rintro ⟨y, hy, h⟩ + refine ⟨ofIGame y, ?_, ?_⟩ + · simpa using hy + · simpa using h + +/-- A code's Kuratowski-pair components are exactly its option sets. -/ +theorem coe_eq_pair (x : GameCode.{u}) : + (x : ZFSet.{u}) = ZFSet.pair (optionCodes Player.left x) (optionCodes Player.right x) := by + rw [optionCodes_eq_optionsZFSet, optionCodes_eq_optionsZFSet, ← IGame.toZFSet_eq_pair] + exact (toZFSet_toIGame x).symm + +/-- Membership in an option set can be read directly from the code's ordered-pair components. -/ +theorem mem_moves_of_coe_eq_pair {x y : GameCode.{u}} {L R : ZFSet.{u}} + (h : (x : ZFSet.{u}) = ZFSet.pair L R) (p : Player) : + y ∈ x.moves p ↔ (y : ZFSet.{u}) ∈ Player.cases L R p := by + obtain ⟨hL, hR⟩ := ZFSet.pair_inj.1 ((coe_eq_pair x).symm.trans h) + cases p + · rw [← hL] + exact coe_mem_optionCodes.symm + · rw [← hR] + exact coe_mem_optionCodes.symm + +/-- Forming a game code from option sets produces their intrinsic Kuratowski ordered pair. -/ +theorem coe_ofSets (s t : Set GameCode.{u}) [Small.{u} s] [Small.{u} t] : + (ofSets s t : ZFSet.{u}) = ZFSet.pair + (ZFSet.range fun y : s ↦ (y.1 : ZFSet.{u})) + (ZFSet.range fun y : t ↦ (y.1 : ZFSet.{u})) := by + rw [coe_eq_pair] + apply congrArg₂ ZFSet.pair <;> apply ZFSet.ext <;> intro z <;> simp + +/-- Conway comparison is the recursive comparison of the two option sets. -/ +theorem le_iff_forall_not_le (x y : GameCode.{u}) : + x ≤ y ↔ (∀ z ∈ x.moves Player.left, ¬ y ≤ z) ∧ + (∀ z ∈ y.moves Player.right, ¬ z ≤ x) := by + rw [← toIGame_le_toIGame, IGame.le_iff_forall_lf] + simp only [moves, Set.forall_mem_image, ← toIGame_le_toIGame, toIGame_ofIGame] + +/-- Numeric codes have numeric options, with every left option below every right option. -/ +theorem isNumeric_iff_options (x : GameCode.{u}) : + IsNumeric x ↔ + (∀ y ∈ x.moves Player.left, ∀ z ∈ x.moves Player.right, y < z) ∧ + (∀ p, ∀ y ∈ x.moves p, IsNumeric y) := by + rw [isNumeric_iff, IGame.numeric_def] + simp only [moves, Set.forall_mem_image, ofIGame_lt_ofIGame, isNumeric_ofIGame] + +@[simp] +theorem moves_neg (p : Player) (x : GameCode.{u}) : + (-x).moves p = Neg.neg '' x.moves (-p) := by + simp only [moves, toIGame_neg, IGame.moves_neg, ← Set.image_neg_eq_neg, image_image] + exact Set.image_congr fun a _ ↦ ofIGame_neg a + +@[simp] +theorem moves_add (p : Player) (x y : GameCode.{u}) : + (x + y).moves p = (· + y) '' x.moves p ∪ (x + ·) '' y.moves p := by + simp [moves, image_union, image_image] + +/-- The usual option expression for the product of two game codes. -/ +def mulOption (x y a b : GameCode.{u}) : GameCode.{u} := a * y + x * b - a * b + +@[simp] +theorem toIGame_mulOption (x y a b : GameCode.{u}) : + (mulOption x y a b).toIGame = IGame.mulOption x.toIGame y.toIGame a.toIGame b.toIGame := by + simp [mulOption, IGame.mulOption] + +@[simp] +theorem moves_mul (p : Player) (x y : GameCode.{u}) : + (x * y).moves p = (fun a ↦ mulOption x y a.1 a.2) '' + (x.moves Player.left ×ˢ y.moves p ∪ x.moves Player.right ×ˢ y.moves (-p)) := by + simp [moves, mulOption, IGame.mulOption, image_union, prod_image_image_eq, image_image] + +end ZFSet.GameCode diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/ZFC/Tests.lean b/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/ZFC/Tests.lean new file mode 100644 index 0000000000..715ef9472e --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/ZFC/Tests.lean @@ -0,0 +1,12 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.ZFC.Tests.Game +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.ZFC.Tests.GameOperations + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/ZFC/Tests/Game.lean b/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/ZFC/Tests/Game.lean new file mode 100644 index 0000000000..273fadaaa5 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/ZFC/Tests/Game.lean @@ -0,0 +1,57 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.ZFC.Game +import LeanPool.ConwayRefinement.CombinatorialGames.Game.Basic +import Mathlib.Data.Set.Finite.Basic + +/-! +# Public interface checks for ZFC game codes + +The grammar excludes arbitrary ZFC sets. Its coding distinguishes complete pregame trees and +supports genuinely infinite option sets, not just finite trees or numeral examples. +-/ + +universe u + +noncomputable section + +example : ZFSet.IsGameCode (ZFSet.pair (∅ : ZFSet.{u}) ∅) := by simp + +example : ¬ ZFSet.IsGameCode (∅ : ZFSet.{u}) := by + intro h + obtain ⟨L, R, heq, _, _⟩ := h.exists_eq_pair + have hm : ({L} : ZFSet.{u}) ∈ (∅ : ZFSet.{u}) := by rw [heq]; simp [ZFSet.pair] + exact ZFSet.notMem_empty _ hm + +example (z : ZFSet.{u}) (hz : ZFSet.IsGameCode z) : + IGame.toZFSet (IGame.zfSetEquiv.symm (ZFSet.GameCode.mk z hz)) = z := by + simp + +example (g : IGame.{u}) : IGame.zfSetEquiv.symm (IGame.zfSetEquiv g) = g := by + simp + +example {x y : ZFSet.GameCode.{u}} (h : (x : ZFSet.{u}) = (y : ZFSet.{u})) : x = y := + ZFSet.GameCode.ext h + +example (n : ℕ) : + IGame.toZFSet (n : IGame.{u}) ∈ IGame.optionsZFSet Player.left + !{Set.range (fun k : ℕ ↦ (k : IGame.{u})) | ∅} := by + simp + +example : + Set.Infinite (IGame.optionsZFSet Player.left + !{Set.range (fun k : ℕ ↦ (k : IGame.{u})) | ∅} : Set ZFSet.{u}) := by + have heq : + (IGame.optionsZFSet Player.left + !{Set.range (fun k : ℕ ↦ (k : IGame.{u})) | ∅} : Set ZFSet.{u}) = + Set.range (fun k : ℕ ↦ IGame.toZFSet (k : IGame.{u})) := by + ext z + simp + rw [heq] + exact Set.infinite_range_of_injective + (IGame.toZFSet_injective.comp (Nat.cast_injective (R := IGame.{u}))) diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/ZFC/Tests/GameOperations.lean b/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/ZFC/Tests/GameOperations.lean new file mode 100644 index 0000000000..045422f727 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/SetTheory/ZFC/Tests/GameOperations.lean @@ -0,0 +1,60 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.ZFC.GameOperations + +/-! +# ZFC game-operation interface checks + +These checks distinguish Conway comparison from a vacuous relation, numeric codes from arbitrary +game codes, and literal pregame equality from equality of game values. +-/ + +universe u + +noncomputable section + +open ZFSet.GameCode + +example (x y : ZFSet.GameCode.{u}) : + (x + y * x).toIGame = x.toIGame + y.toIGame * x.toIGame := by + simp + +example (x y : ZFSet.GameCode.{u}) (hx : IsNumeric x) (hy : IsNumeric y) : + IsNumeric (-x + y * x) := hx.neg.add (hy.mul hx) + +example : (0 : ZFSet.GameCode.{u}) < 1 := by + rw [← toIGame_lt_toIGame] + simp + +example : ¬ IsNumeric (ofSets ({0} : Set ZFSet.GameCode.{u}) {0}) := by + rw [isNumeric_iff_options] + simp + +example : (ofSets ({-1} : Set ZFSet.GameCode.{u}) {1}) ≈ 0 := by + rw [← toIGame_equiv_toIGame] + simp only [toIGame_ofSets, toIGame_zero, Set.image_singleton, toIGame_neg, toIGame_one] + simp only [AntisymmRel] + constructor <;> rw [IGame.le_iff_forall_lf] <;> simp + +example : ofSets ({-1} : Set ZFSet.GameCode.{u}) {1} ≠ 0 := by + intro h + have hm : (-1 : ZFSet.GameCode.{u}) ∈ (0 : ZFSet.GameCode.{u}).moves Player.left := by + rw [← h] + simp + simp at hm + +example (x y : ZFSet.GameCode.{u}) (L R : ZFSet.{u}) + (h : (x : ZFSet.{u}) = ZFSet.pair L R) : + y ∈ x.moves Player.left ↔ (y : ZFSet.{u}) ∈ L := + mem_moves_of_coe_eq_pair h Player.left + +example (x y a b : ZFSet.GameCode.{u}) + (ha : a ∈ x.moves Player.left) (hb : b ∈ y.moves Player.right) : + mulOption x y a b ∈ (x * y).moves Player.right := by + rw [moves_mul] + exact ⟨(a, b), Or.inl ⟨ha, hb⟩, rfl⟩ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Standalone.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone.lean new file mode 100644 index 0000000000..c13a4393c7 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone.lean @@ -0,0 +1,12 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames.lean new file mode 100644 index 0000000000..44264f4664 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames.lean @@ -0,0 +1,16 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.ConwayRefinement +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.ConwayRefinementProof +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Examples +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.PrincipalRVAlgebraicIndependence +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.PrincipalRVAlgebraicIndependenceProof +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Support + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/ConwayRefinement.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/ConwayRefinement.lean new file mode 100644 index 0000000000..892a63f061 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/ConwayRefinement.lean @@ -0,0 +1,57 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.CombinatorialGames.Surreal.Multiplication + +/-! +# Conway's refinement conjecture for cut-defined omnific integers + +An omnific integer is a surreal number satisfying Conway's cut equation +`x = {x - 1 | x + 1}`. Conway's refinement conjecture says that every equation +`a * b = c * d` among +omnific integers admits the four-factor decomposition displayed below. Zero inputs are allowed; +there are no support, reducedness, or cardinality hypotheses. +-/ + +public noncomputable section + +universe u + +namespace ConwayRefinement.Standalone.Oz + + +/-- Conway's definition: `x` is an omnific integer when it is the cut with sole left option +`x - 1` and sole right option `x + 1`. -/ +abbrev IsConwayOmnificInteger (x : Surreal.{u}) : Prop := + x = !{{x - 1} | {x + 1}}' (by + simp only [Set.mem_singleton_iff] + rintro _ rfl _ rfl + simp [sub_eq_add_neg]) + +/-- Conway's refinement conjecture: every equality `a * b = c * d` of +cut-defined omnific integers has an omnific refinement +`a = e * f`, `b = g * h`, `c = e * g`, `d = f * h`. +All four inputs may be zero. -/ +abbrev ConwayConjecture : Prop := + ∀ a b c d : Surreal.{u}, + IsConwayOmnificInteger a → IsConwayOmnificInteger b → + IsConwayOmnificInteger c → IsConwayOmnificInteger d → a * b = c * d → + ∃ e f g h : Surreal.{u}, + IsConwayOmnificInteger e ∧ IsConwayOmnificInteger f ∧ + IsConwayOmnificInteger g ∧ IsConwayOmnificInteger h ∧ + a = e * f ∧ b = g * h ∧ c = e * g ∧ d = f * h + + +end ConwayRefinement.Standalone.Oz + +/-! +## Formal proof + +Proof module: `ConwayRefinementProof`. + +* `ConwayConjecture` → `ConwayConjecture.proof` +-/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/ConwayRefinementProof.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/ConwayRefinementProof.lean new file mode 100644 index 0000000000..6bc764e0f2 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/ConwayRefinementProof.lean @@ -0,0 +1,47 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.ConwayRefinement +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint +import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Support.ConwayNormalForm +import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.OmnificInteger.Refinement.ConwayRefinement +/-! +# Proof of Conway's refinement conjecture + +The native omnific-integer theorem is transported to Conway's cut definition. +-/ + +public noncomputable section + +universe u + +namespace ConwayRefinement.Standalone.Oz.ConwayConjecture + +/-- Every equality of products of cut-defined omnific integers has an omnific four-factor +refinement. -/ +@[blueprint "thm:conway-refinement" + (phase := "Surreal numbers and omnific integers") + (title := "Conway's refinement theorem for omnific integers") + (statement := /-- + Let $a,b,c,d$ be surreal numbers satisfying Conway's cut equation + $x=\{x-1\mid x+1\}$. If $ab=cd$, then there are surreal numbers + $e,f,g,h$, each satisfying the same cut equation, such that + \[ + a=ef,\qquad b=gh,\qquad c=eg,\qquad d=fh. + \] + -/) + (proof := /-- + By \ref{thm:conway-cut-subring-equivalence}, Conway's cut-defined + statement is equivalent to the refinement property of the omnific-integer + subring. Apply \ref{thm:omnific-integer-refinement-property}. + -/) + (highlight)] +theorem proof : ConwayRefinement.Standalone.Oz.ConwayConjecture.{u} := by + rw [ConwayRefinement.Standalone.Oz.conwayConjecture_iff_native] + exact Surreal.OmnificInteger.conwayRefinement + +end ConwayRefinement.Standalone.Oz.ConwayConjecture diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/Examples.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/Examples.lean new file mode 100644 index 0000000000..0ea17ade82 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/Examples.lean @@ -0,0 +1,22 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Examples.DegreeTwoPrime +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Examples.DegreeTwoPrimeProof +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Examples.FiniteDegreeFamily +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Examples.FiniteDegreeFamilyProof +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Examples.OmegaOmegaBoundary +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Examples.OmegaOmegaBoundaryProof +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Examples.OmegaRoots +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Examples.OmegaRootsProof +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Examples.OmnificFactorization +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Examples.OmnificFactorizationProof +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Examples.OneRowPrime +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Examples.OneRowPrimeProof + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/Examples/DegreeTwoPrime.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/Examples/DegreeTwoPrime.lean new file mode 100644 index 0000000000..0421b295cd --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/Examples/DegreeTwoPrime.lean @@ -0,0 +1,93 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Support.DegreeTwoExample +public import Mathlib.Algebra.Prime.Defs + +/-! +# An explicit degree-two prime in `Oz` + +Let + +`x = 1 + ∑ m n, ω ^ (1 / (m + 1) + 1 / ((m + 1) * (m + 2) * (n + 1)))`, + +where every coefficient in the Conway normal form is one. For each `m`, the `n`-th row decreases +to `1 / (m + 1)`, and the rows decrease to zero. Thus its support has exact order type +`ω ^ 2 + 1`, and hence it has degree two. + +This literal omnific integer is prime. The mathematical inputs are the PS06 three-germ +irreducibility criterion and the LM24 transfer from one Archimedean class. Every claim is stated +in the surreal numbers of an arbitrary universe `u`. + +For comparison, `degreeTwoFoil = 2 * x` has exactly the same support and merely replaces every +displayed coefficient by two. Both factors are nonunits, so the foil is reducible. The pair shows +that the two-dimensional support geometry alone does not force primeness: the coefficient germs +distinguished by PS06 carry essential information. + +## References + +* J. Pommersheim, S. Shahriari, *Unique factorization in generalized power series rings*, +Proc. Amer. Math. Soc. 134 (2006), 1277–1287, cited as [PS06]. +* S. L'Innocente, V. Mantova, *A factorisation theory for generalised power series and omnific + integers*, Adv. Math. 442 (2024) 109513, cited as [LM24]. +-/ + +universe u + +@[expose] public noncomputable section + +namespace ConwayRefinement.Standalone.Oz.DegreeTwoExample + +open Ordinal + +/-- The exponents displayed in the normal form: zero and the row-column exponents above. -/ +def IsDisplayedExponent (i : Surreal.{u}) : Prop := + i = 0 ∨ ∃ m n : ℕ, + i = ((1 / (m + 1 : ℝ) + + 1 / ((m + 1 : ℝ) * (m + 2 : ℝ) * (n + 1 : ℝ)) : ℝ) : Surreal) + +/-- The named omnific integer is exactly the normal form displayed above: its coefficients are +one at zero and at the row-column exponents, and zero everywhere else. -/ +def HasDisplayedCoefficients : Prop := + (∀ i : Surreal.{u}, IsDisplayedExponent i → degreeTwoOz.{u}.1.coeff i = 1) ∧ + ∀ i : Surreal.{u}, ¬ IsDisplayedExponent i → degreeTwoOz.{u}.1.coeff i = 0 + +/-- The displayed normal form has exact support order type `ω ^ 2 + 1`. -/ +def HasExactSupportOrderType : Prop := + degreeTwoOz.{u}.1.length = ω ^ (2 : Ordinal) + 1 + +/-- The displayed omnific integer is prime. -/ +def IsPrime : Prop := + Prime degreeTwoOz.{u} + +/-- The coefficient-doubled foil still has exact support order type `ω ^ 2 + 1`. -/ +def FoilHasExactSupportOrderType : Prop := + degreeTwoFoil.{u}.1.length = ω ^ (2 : Ordinal) + 1 + +/-- The comparison element is literally twice the displayed prime. -/ +def FoilIsCoefficientDouble : Prop := + degreeTwoFoil.{u} = 2 * degreeTwoOz.{u} + +/-- The coefficient-doubled foil admits a factorisation into two nonunits. -/ +def FoilHasNontrivialFactorization : Prop := + ∃ a b : Oz.OmnificInteger.{u}, + degreeTwoFoil = a * b ∧ ¬ IsUnit a ∧ ¬ IsUnit b + +end ConwayRefinement.Standalone.Oz.DegreeTwoExample + +/-! +## Formal proof + +Proof module: `DegreeTwoPrimeProof`. + +* `HasExactSupportOrderType` → `HasExactSupportOrderType.proof` +* `HasDisplayedCoefficients` → `HasDisplayedCoefficients.proof` +* `IsPrime` → `IsPrime.proof` +* `FoilHasExactSupportOrderType` → `FoilHasExactSupportOrderType.proof` +* `FoilIsCoefficientDouble` → `FoilIsCoefficientDouble.proof` +* `FoilHasNontrivialFactorization` → `FoilHasNontrivialFactorization.proof` +-/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/Examples/DegreeTwoPrimeProof.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/Examples/DegreeTwoPrimeProof.lean new file mode 100644 index 0000000000..95760ec164 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/Examples/DegreeTwoPrimeProof.lean @@ -0,0 +1,143 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Examples.DegreeTwoPrime +public import LeanPool.ConwayRefinement.ConwayRefinement.Examples.OmnificInteger.DegreeTwoPrime + +import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Support.ConwayNormalForm + +/-! +# Proofs for the explicit degree-two prime + +The normal-form ring equivalence identifies the displayed series with the reduced omnific +integer whose irreducibility and primeness follow from the PS06 criterion and the one-class +transfer. +-/ + +universe u + +public noncomputable section + +namespace ConwayRefinement.Standalone.Oz.DegreeTwoExample + +/-- The independent displayed normal form agrees with the one used by the main proof. -/ +private theorem normalForm_eq_main : DegreeTwoExample.normalForm.{u} = + Surreal.OmnificInteger.DegreeTwoExample.normalForm := by + rfl + +namespace HasExactSupportOrderType + +/-- The displayed normal form has support order type `ω ^ 2 + 1`. -/ +theorem proof : DegreeTwoExample.HasExactSupportOrderType.{u} := by + rw [DegreeTwoExample.HasExactSupportOrderType, DegreeTwoExample.degreeTwoOz_val] + rw [normalForm_eq_main] + rw [← Surreal.OmnificInteger.DegreeTwoExample.degreeTwoOz_toHahnSeries, + Surreal.length_toHahnSeries] + exact Surreal.OmnificInteger.DegreeTwoExample.degreeTwoOz_length + +end HasExactSupportOrderType + +private theorem normalFormRingEquiv_degreeTwoOz : + ConwayRefinement.Standalone.Oz.normalFormRingEquiv + DegreeTwoExample.degreeTwoOz.{u} = + Surreal.OmnificInteger.DegreeTwoExample.degreeTwoOz := by + apply Subtype.ext + rw [← Surreal.toHahnSeries_inj] + rw [ConwayRefinement.Standalone.Oz.toHahnSeries_normalFormRingEquiv, + DegreeTwoExample.degreeTwoOz_val, + normalForm_eq_main, + Surreal.OmnificInteger.DegreeTwoExample.degreeTwoOz_toHahnSeries] + +namespace IsPrime + +/-- The displayed degree-two omnific integer is prime. -/ +theorem proof : DegreeTwoExample.IsPrime.{u} := by + rw [DegreeTwoExample.IsPrime] + have hmap : Prime + (ConwayRefinement.Standalone.Oz.normalFormRingEquiv + DegreeTwoExample.degreeTwoOz) := by + rw [normalFormRingEquiv_degreeTwoOz] + exact Surreal.OmnificInteger.DegreeTwoExample.degreeTwoOz_prime + exact (MulEquiv.prime_iff + ConwayRefinement.Standalone.Oz.normalFormRingEquiv.toMulEquiv).mp hmap + +end IsPrime + +namespace FoilHasExactSupportOrderType + +/-- The coefficient-doubled foil has the same exact support order type. -/ +theorem proof : DegreeTwoExample.FoilHasExactSupportOrderType.{u} := by + rw [DegreeTwoExample.FoilHasExactSupportOrderType] + have hlength : DegreeTwoExample.degreeTwoFoil.1.length = + DegreeTwoExample.degreeTwoOz.1.length := by + apply le_antisymm + · apply SurrealHahnSeries.length_mono + rw [DegreeTwoExample.degreeTwoFoil_support] + · apply SurrealHahnSeries.length_mono + rw [DegreeTwoExample.degreeTwoFoil_support] + exact hlength.trans HasExactSupportOrderType.proof.{u} + +end FoilHasExactSupportOrderType + +private theorem two_not_isUnit : + ¬ IsUnit (2 : Oz.OmnificInteger.{u}) := by + intro h + have hmap : IsUnit + (Oz.integerConstantCoeffRingHom (2 : Oz.OmnificInteger)) := + h.map Oz.integerConstantCoeffRingHom + have heq : Oz.integerConstantCoeffRingHom + (2 : Oz.OmnificInteger) = 2 := + map_natCast Oz.integerConstantCoeffRingHom 2 + rw [heq, Int.isUnit_iff] at hmap + omega + +namespace FoilHasNontrivialFactorization + +/-- The displayed factorisation has the nonunits `2` and `degreeTwoOz`. -/ +theorem proof : DegreeTwoExample.FoilHasNontrivialFactorization.{u} := by + rw [DegreeTwoExample.FoilHasNontrivialFactorization] + exact ⟨2, DegreeTwoExample.degreeTwoOz, rfl, two_not_isUnit, + IsPrime.proof.not_isUnit⟩ + +end FoilHasNontrivialFactorization + +namespace FoilIsCoefficientDouble + +/-- The foil's defining equation is `degreeTwoFoil = 2 * degreeTwoOz`. -/ +theorem proof : DegreeTwoExample.FoilIsCoefficientDouble.{u} := rfl + +end FoilIsCoefficientDouble + +namespace HasDisplayedCoefficients + +/-- The concrete construction has the displayed coefficient function. -/ +theorem proof : HasDisplayedCoefficients.{u} := by + classical + have hcoeff (i : Surreal.{u}) : degreeTwoOz.{u}.1.coeff i = + if IsDisplayedExponent i then 1 else 0 := by + rw [degreeTwoOz_val, normalForm_coeff] + unfold coefficient IsDisplayedExponent + congr 1 + apply propext + constructor + · rintro ⟨p, rfl⟩ + induction p using WithTop.recTopCoe with + | top => exact Or.inl rfl + | coe p => exact Or.inr ⟨(ofLex p).1, (ofLex p).2, by simp [exponentAtIndex]⟩ + · rintro (rfl | ⟨m, n, rfl⟩) + · exact ⟨⊤, by simp [exponentAtIndex]⟩ + · exact ⟨((toLex (m, n) : Lex (ℕ × ℕ)) : Index), + by simp [exponentAtIndex, exponent_apply]⟩ + constructor + · intro i hi + rw [hcoeff, ite_eq_left hi] + · intro i hi + rw [hcoeff, ite_eq_right hi] + +end HasDisplayedCoefficients + +end ConwayRefinement.Standalone.Oz.DegreeTwoExample diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/Examples/FiniteDegreeFamily.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/Examples/FiniteDegreeFamily.lean new file mode 100644 index 0000000000..d58f0f037e --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/Examples/FiniteDegreeFamily.lean @@ -0,0 +1,38 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Support.FinitePowerFamily + +/-! +# Omnific integers at every finite power of omega + +For every natural number `n`, there is an omnific integer whose Conway normal form has support +order type exactly `ω ^ n + 1` and which is primal. Thus primality occurs at every finite degree; +the statement does not assert that these examples are irreducible. +-/ + +@[expose] public noncomputable section + +namespace ConwayRefinement.Standalone.Oz.FiniteDegreeExamples + +open Ordinal + +/-- Every finite power `ω ^ n + 1` occurs as the exact Conway length of a primal omnific +integer. -/ +def EveryFinitePowerOccurs : Prop := + ∀ n : ℕ, ∃ x : Oz.OmnificInteger.{0}, + x.1.length = (omega0 : Ordinal.{0}) ^ (n : Ordinal.{0}) + 1 ∧ IsPrimal x + +end ConwayRefinement.Standalone.Oz.FiniteDegreeExamples + +/-! +## Formal proof + +Proof module: `FiniteDegreeFamilyProof`. + +* `EveryFinitePowerOccurs` → `EveryFinitePowerOccurs.proof` +-/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/Examples/FiniteDegreeFamilyProof.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/Examples/FiniteDegreeFamilyProof.lean new file mode 100644 index 0000000000..5157edcca1 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/Examples/FiniteDegreeFamilyProof.lean @@ -0,0 +1,25 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Examples.FiniteDegreeFamily +import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Support.FinitePowerFamilyProof + +/-! # Finite Degree Family Proof -/ + +public noncomputable section + +namespace ConwayRefinement.Standalone.Oz.FiniteDegreeExamples.EveryFinitePowerOccurs + +/-- The coefficient-one finite-power family supplies the examples. -/ +theorem proof : FiniteDegreeExamples.EveryFinitePowerOccurs := by + rw [FiniteDegreeExamples.EveryFinitePowerOccurs] + intro n + refine ⟨FinitePowerFamily.finitePowerOz n, ?_, FinitePowerFamily.PrimalFamily.proof n⟩ + rw [FinitePowerFamily.finitePowerOz_val, + FinitePowerFamily.finitePowerNormalForm_length] + +end ConwayRefinement.Standalone.Oz.FiniteDegreeExamples.EveryFinitePowerOccurs diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/Examples/OmegaOmegaBoundary.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/Examples/OmegaOmegaBoundary.lean new file mode 100644 index 0000000000..39b354dae6 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/Examples/OmegaOmegaBoundary.lean @@ -0,0 +1,53 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Support.OmegaOmegaBoundary + +/-! +# The boundary at Conway length `ω ^ ω` + +There is a reduced, nonordinary omnific integer whose Conway normal form has support order type +exactly `ω ^ ω`. It therefore lies exactly at the first limit excluded by the strict +finite-degree hypothesis. This statement makes no primality or nonprimality claim about it. +-/ + +@[expose] public noncomputable section + +namespace ConwayRefinement.Standalone.Oz.OmegaOmegaBoundaryExample + +open Ordinal + +/-- An omnific integer is ordinary when its normal form is an integer constant. -/ +def IsOrdinary (x : Oz.OmnificInteger.{0}) : Prop := + ∃ z : ℤ, x.1 = (z : SurrealHahnSeries) + +/-- Reducedness means that `x` is nonzero and the exponents shared by `x` and `x - 1` lie in one +Archimedean class. -/ +def IsReduced (x : Oz.OmnificInteger.{0}) : Prop := + x ≠ 0 ∧ ∃ c : ArchimedeanClass Surreal, + x.1.support ∩ (x.1 - 1).support ⊆ {i | ArchimedeanClass.mk i = c} + +/-- Finite degree is the strict Conway-length bound below `ω ^ ω`. -/ +def HasFiniteDegree (x : Oz.OmnificInteger.{0}) : Prop := + Ordinal.lift.{1, 0} x.1.length < (omega0 : Ordinal.{1}) ^ (omega0 : Ordinal.{1}) + +/-- A reduced nonordinary omnific integer exists exactly at the `ω ^ ω` boundary. -/ +def ExistsAtBoundary : Prop := + ∃ x : Oz.OmnificInteger.{0}, + ¬ IsOrdinary x ∧ IsReduced x ∧ + x.1.length = (omega0 : Ordinal.{0}) ^ (omega0 : Ordinal.{0}) ∧ + ¬ HasFiniteDegree x + +end ConwayRefinement.Standalone.Oz.OmegaOmegaBoundaryExample + +/-! +## Formal proof + +Proof module: `OmegaOmegaBoundaryProof`. + +* `ExistsAtBoundary` → `ExistsAtBoundary.proof` +-/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/Examples/OmegaOmegaBoundaryProof.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/Examples/OmegaOmegaBoundaryProof.lean new file mode 100644 index 0000000000..495db9a707 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/Examples/OmegaOmegaBoundaryProof.lean @@ -0,0 +1,28 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Examples.OmegaOmegaBoundary + +/-! # Omega Omega Boundary Proof -/ + +public noncomputable section + +namespace ConwayRefinement.Standalone.Oz.OmegaOmegaBoundaryExample.ExistsAtBoundary + +/-- The coefficient-one boundary normal form supplies the example. -/ +theorem proof : OmegaOmegaBoundaryExample.ExistsAtBoundary := by + rw [OmegaOmegaBoundaryExample.ExistsAtBoundary] + refine ⟨OmegaOmegaBoundary.boundaryOz, ?_, ?_, ?_, ?_⟩ + · simpa only [OmegaOmegaBoundaryExample.IsOrdinary, Oz.IsOrdinaryInteger] using + OmegaOmegaBoundary.boundaryOz_not_isOrdinaryInteger + · simpa only [OmegaOmegaBoundaryExample.IsReduced, Oz.IsReduced] using + OmegaOmegaBoundary.boundaryOz_isReduced + · exact OmegaOmegaBoundary.boundaryOz_length + · simpa only [OmegaOmegaBoundaryExample.HasFiniteDegree, Oz.HasFiniteDegree] using + OmegaOmegaBoundary.boundaryOz_not_hasFiniteDegree + +end ConwayRefinement.Standalone.Oz.OmegaOmegaBoundaryExample.ExistsAtBoundary diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/Examples/OmegaRoots.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/Examples/OmegaRoots.lean new file mode 100644 index 0000000000..0de82b4720 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/Examples/OmegaRoots.lean @@ -0,0 +1,55 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Support.OmnificIntegers + +/-! +# Roots of omega in the omnific integers + +In Conway normal form, `ω` is the monomial with exponent `1`. For every positive integer `n`, +the monomial with exponent `1/n` is a nonunit omnific integer whose `n`th power is `ω`. +Thus one element admits factorisations into arbitrarily many nonunits. +-/ + +public noncomputable section + +namespace ConwayRefinement.Standalone.Oz.OmegaRoots + +universe u + +/-- The coefficient-one Conway monomial `ω^x`, as an omnific integer. -/ +def monomial (x : Surreal.{u}) (hx : 0 ≤ x) : Oz.OmnificInteger.{u} := + ⟨SurrealHahnSeries.single x 1, Oz.single_one_mem_omnificIntegers x hx⟩ + +/-- The Conway monomial `ω`. -/ +def omega : Oz.OmnificInteger.{u} := monomial 1 zero_le_one + +/-- The normal form of `omega` is the coefficient-one monomial at exponent `1`. -/ +theorem coe_omega : omega.1 = SurrealHahnSeries.single 1 1 := (rfl) + +/-- The Conway monomial `ω^(1/n)`. -/ +def nthRoot (n : ℕ) : Oz.OmnificInteger.{u} := + monomial (n : Surreal)⁻¹ (inv_nonneg.mpr (Nat.cast_nonneg n)) + +/-- The normal form of `nthRoot n` is the coefficient-one monomial at exponent `1/n`. -/ +theorem coe_nthRoot (n : ℕ) : + (nthRoot.{u} n).1 = SurrealHahnSeries.single (n : Surreal)⁻¹ 1 := (rfl) + +/-- The omnific integer `ω` has a nonunit `n`th root for every positive integer `n`. -/ +abbrev OmegaHasRootsOfEveryPositiveOrder : Prop := + ∀ (n : ℕ), 0 < n → + ¬IsUnit (nthRoot.{u} n) ∧ nthRoot.{u} n ^ n = omega.{u} + +end ConwayRefinement.Standalone.Oz.OmegaRoots + +/-! +## Formal proof + +Proof module: `OmegaRootsProof`. + +* `OmegaHasRootsOfEveryPositiveOrder` → `OmegaHasRootsOfEveryPositiveOrder.proof` +-/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/Examples/OmegaRootsProof.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/Examples/OmegaRootsProof.lean new file mode 100644 index 0000000000..55a1a0f133 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/Examples/OmegaRootsProof.lean @@ -0,0 +1,40 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Examples.OmegaRoots + +/-! # Omega Roots Proof -/ + +public noncomputable section + +namespace ConwayRefinement.Standalone.Oz.OmegaRoots.OmegaHasRootsOfEveryPositiveOrder + +universe u + +/-- The exponent identity `(ω^(1/n))^n = ω` gives the roots; the zero constant coefficient +prevents them from being units. -/ +theorem proof : OmegaHasRootsOfEveryPositiveOrder.{u} := by + intro n hn + constructor + · intro hunit + have hcoeff : Oz.integerConstantCoeff (nthRoot n) = 0 := by + apply Int.cast_injective (α := ℝ) + rw [Oz.coe_integerConstantCoeff] + rw [coe_nthRoot, SurrealHahnSeries.coeff_single_of_ne] + · simp + · exact inv_ne_zero (Nat.cast_ne_zero.mpr hn.ne') + have := hunit.map Oz.integerConstantCoeffRingHom + rw [Oz.integerConstantCoeffRingHom_apply, hcoeff] at this + exact not_isUnit_zero this + · apply Subtype.ext + change (nthRoot n).1 ^ n = omega.1 + rw [coe_nthRoot, coe_omega] + rw [Oz.single_one_pow] + congr 2 + simp [nsmul_eq_mul, Nat.cast_ne_zero.mpr hn.ne'] + +end ConwayRefinement.Standalone.Oz.OmegaRoots.OmegaHasRootsOfEveryPositiveOrder diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/Examples/OmnificFactorization.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/Examples/OmnificFactorization.lean new file mode 100644 index 0000000000..0fc52e53b1 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/Examples/OmnificFactorization.lean @@ -0,0 +1,81 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Support.OmnificIntegers +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.ConwayRefinement +public import Mathlib.Algebra.Prime.Defs + +/-! +# Factorisation in the omnific integers + +CombinatorialGames provides the types `Surreal` and `SurrealHahnSeries`, but not the normal-form +ring equivalence between them or the subring `Oz`. + +**Identification.** Conway defines `Oz` by `x = {x - 1 | x + 1}`. The normal-form ring +equivalence sends precisely these surreals to the series with nonnegative exponents and an integer +constant coefficient. + +**Primality.** Every omnific integer is primal: whenever it divides a product, it splits as a +product of one divisor of each factor. This is the pre-Schreier form of Conway's refinement +conjecture. + +**Factorisation.** Every irreducible omnific integer is prime, and two factorisations of an +omnific integer into irreducibles agree up to order and units. + +## References + +* S. L'Innocente, V. Mantova, *A factorisation theory for generalised power series and omnific + integers*, Adv. Math. 442 (2024) 109513, , cited + as [LM24]. +-/ + +universe u + +@[expose] public noncomputable section + +namespace ConwayRefinement.Standalone.Oz + +/-- Membership in the normal-form ring `Oz`: nonnegative support and an integer coefficient at +exponent zero. -/ +theorem mem_normalFormOmnificIntegers_iff (x : SurrealHahnSeries.{u}) : + x ∈ omnificIntegers ↔ + x.support ⊆ Set.Ici 0 ∧ ∃ z : ℤ, (z : ℝ) = x.coeff 0 := by + rw [mem_omnificIntegers, Set.mem_range] + +/-- A ring equivalence from surreal numbers to surreal Hahn series identifies Conway's +cut-defined omnific integers with the normal-form subring `omnificIntegers`. -/ +def NormalFormIdentifiesOmnificIntegers : Prop := + ∃ e : Surreal.{u} ≃+* SurrealHahnSeries.{u}, + ∀ x : Surreal.{u}, IsConwayOmnificInteger x ↔ e x ∈ omnificIntegers + +/-- Every omnific integer is primal. Equivalently, `Oz` is a pre-Schreier ring. -/ +def EveryOmnificIntegerIsPrimal : Prop := + ∀ x : (omnificIntegers : Subring SurrealHahnSeries.{u}), IsPrimal x + +/-- Every irreducible omnific integer is prime. -/ +def IrreducibleIsPrime : Prop := + ∀ x : (omnificIntegers : Subring SurrealHahnSeries.{u}), Irreducible x → Prime x + +/-- Unique factorisation: two products of irreducible omnific integers that agree up to a unit +have the same factors up to order and association. -/ +def IrreducibleFactorizationsAreUnique : Prop := + ∀ f g : Multiset (omnificIntegers : Subring SurrealHahnSeries.{u}), + (∀ x ∈ f, Irreducible x) → (∀ x ∈ g, Irreducible x) → + Associated f.prod g.prod → Multiset.Rel Associated f g + +end ConwayRefinement.Standalone.Oz + +/-! +## Formal proof + +Proof module: `OmnificFactorizationProof`. + +* `NormalFormIdentifiesOmnificIntegers` → `NormalFormIdentifiesOmnificIntegers.proof` +* `EveryOmnificIntegerIsPrimal` → `EveryOmnificIntegerIsPrimal.proof` +* `IrreducibleIsPrime` → `IrreducibleIsPrime.proof` +* `IrreducibleFactorizationsAreUnique` → `IrreducibleFactorizationsAreUnique.proof` +-/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/Examples/OmnificFactorizationProof.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/Examples/OmnificFactorizationProof.lean new file mode 100644 index 0000000000..a56c720a3e --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/Examples/OmnificFactorizationProof.lean @@ -0,0 +1,51 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Examples.OmnificFactorization +import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Support.OmnificFactorizationProof + +/-! # Omnific Factorization Proof -/ + +public noncomputable section + +universe u + +namespace ConwayRefinement.Standalone.Oz + +namespace NormalFormIdentifiesOmnificIntegers + +/-- Conway's cut definition and the normal-form definition determine the same subring. -/ +theorem proof : Oz.NormalFormIdentifiesOmnificIntegers.{u} := + of_normalForm + +end NormalFormIdentifiesOmnificIntegers + +namespace EveryOmnificIntegerIsPrimal + +/-- Every omnific integer is primal. -/ +theorem proof : Oz.EveryOmnificIntegerIsPrimal.{u} := + of_refinement + +end EveryOmnificIntegerIsPrimal + +namespace IrreducibleIsPrime + +/-- Every irreducible omnific integer is prime. -/ +theorem proof : Oz.IrreducibleIsPrime.{u} := + of_primality + +end IrreducibleIsPrime + +namespace IrreducibleFactorizationsAreUnique + +/-- Irreducible factorisations in `Oz` are unique up to order and units. -/ +theorem proof : Oz.IrreducibleFactorizationsAreUnique.{u} := + of_primality + +end IrreducibleFactorizationsAreUnique + +end ConwayRefinement.Standalone.Oz diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/Examples/OneRowPrime.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/Examples/OneRowPrime.lean new file mode 100644 index 0000000000..27839dd4d4 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/Examples/OneRowPrime.lean @@ -0,0 +1,64 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Support.OneRowExample +public import Mathlib.Algebra.Prime.Defs + +/-! +# Conway's one-row prime in `Oz` + +Let + +`x = 1 + Σ n : ℕ, ω ^ (1 / (n + 1))`, + +with every coefficient in the Conway normal form equal to one. The positive exponents decrease +to zero, so the support is a single row of order type `ω` followed by the constant term. + +This omnific integer has exact support order type `ω + 1` and is prime, the concrete form of +LM24, Example 9.2.8. + +## References + +* S. L'Innocente, V. Mantova, *A factorisation theory for generalised power series and omnific + integers*, Adv. Math. 442 (2024) 109513, cited as [LM24]. +-/ + +@[expose] public noncomputable section + +namespace ConwayRefinement.Standalone.Oz.OneRowExample + +open Ordinal + +/-- The exponents displayed in the normal form: zero and `1/(n+1)` for `n ≥ 0`. -/ +def IsDisplayedExponent (i : Surreal) : Prop := + i = 0 ∨ ∃ n : ℕ, i = ((1 / (n + 1 : ℝ) : ℝ) : Surreal) + +/-- The named omnific integer is exactly the normal form displayed above: its coefficients are +one at zero and at the exponents `1/(n+1)`, and zero everywhere else. -/ +def HasDisplayedCoefficients : Prop := + (∀ i : Surreal, IsDisplayedExponent i → oneRowOz.1.coeff i = 1) ∧ + ∀ i : Surreal, ¬ IsDisplayedExponent i → oneRowOz.1.coeff i = 0 + +/-- The displayed normal form has exact support order type `ω + 1`. -/ +def HasExactSupportOrderType : Prop := + oneRowOz.1.length = omega0 + 1 + +/-- Conway's displayed one-row omnific integer is prime. -/ +def IsPrime : Prop := + Prime oneRowOz + +end ConwayRefinement.Standalone.Oz.OneRowExample + +/-! +## Formal proof + +Proof module: `OneRowPrimeProof`. + +* `HasExactSupportOrderType` → `HasExactSupportOrderType.proof` +* `HasDisplayedCoefficients` → `HasDisplayedCoefficients.proof` +* `IsPrime` → `IsPrime.proof` +-/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/Examples/OneRowPrimeProof.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/Examples/OneRowPrimeProof.lean new file mode 100644 index 0000000000..87bf6af0ef --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/Examples/OneRowPrimeProof.lean @@ -0,0 +1,95 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Examples.OneRowPrime +public import LeanPool.ConwayRefinement.ConwayRefinement.Examples.OmnificInteger.OneRowPrime + +import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Support.ConwayNormalForm + +/-! +# Proofs for Conway's one-row prime + +The normal-form ring equivalence identifies the displayed series with the +cut-defined omnific integer whose irreducibility and primeness are proved from Berarducci's +theorem and the finite-degree primality theorem. +-/ + +public noncomputable section + +namespace ConwayRefinement.Standalone.Oz.OneRowExample + +/-- The independent displayed normal form agrees with the one used by the main proof. -/ +private theorem normalForm_eq_main : OneRowExample.normalForm = + Surreal.OmnificInteger.OneRowExample.normalForm := by + rfl + +namespace HasDisplayedCoefficients + +/-- The concrete construction has the displayed coefficient function. -/ +theorem proof : HasDisplayedCoefficients := by + classical + have hcoeff (i : Surreal) : oneRowOz.1.coeff i = + if IsDisplayedExponent i then 1 else 0 := by + rw [oneRowOz_val, normalForm_coeff] + unfold coefficient IsDisplayedExponent + congr 1 + apply propext + constructor + · rintro ⟨p, rfl⟩ + induction p using WithTop.recTopCoe with + | top => exact Or.inl rfl + | coe n => exact Or.inr ⟨n, by simp [exponentAtIndex]⟩ + · rintro (rfl | ⟨n, rfl⟩) + · exact ⟨⊤, by simp [exponentAtIndex]⟩ + · exact ⟨(n : Index), by simp [exponentAtIndex, exponent_apply]⟩ + constructor + · intro i hi + rw [hcoeff, ite_eq_left hi] + · intro i hi + rw [hcoeff, ite_eq_right hi] + +end HasDisplayedCoefficients + +namespace HasExactSupportOrderType + +/-- The displayed normal form has support order type `ω + 1`. -/ +theorem proof : OneRowExample.HasExactSupportOrderType := by + rw [OneRowExample.HasExactSupportOrderType, OneRowExample.oneRowOz_val] + rw [normalForm_eq_main] + rw [← Surreal.OmnificInteger.OneRowExample.oneRowOz_toHahnSeries, + Surreal.length_toHahnSeries] + exact Surreal.OmnificInteger.OneRowExample.oneRowOz_length + +end HasExactSupportOrderType + +private theorem normalFormRingEquiv_oneRowOz : + ConwayRefinement.Standalone.Oz.normalFormRingEquiv + OneRowExample.oneRowOz = + Surreal.OmnificInteger.OneRowExample.oneRowOz := by + apply Subtype.ext + rw [← Surreal.toHahnSeries_inj] + rw [ConwayRefinement.Standalone.Oz.toHahnSeries_normalFormRingEquiv, + OneRowExample.oneRowOz_val, + normalForm_eq_main, + Surreal.OmnificInteger.OneRowExample.oneRowOz_toHahnSeries] + +namespace IsPrime + +/-- Conway's displayed one-row omnific integer is prime. -/ +theorem proof : OneRowExample.IsPrime := by + rw [OneRowExample.IsPrime] + have hmap : Prime + (ConwayRefinement.Standalone.Oz.normalFormRingEquiv + OneRowExample.oneRowOz) := by + rw [normalFormRingEquiv_oneRowOz] + exact Surreal.OmnificInteger.OneRowExample.oneRowOz_prime + exact (MulEquiv.prime_iff + ConwayRefinement.Standalone.Oz.normalFormRingEquiv.toMulEquiv).mp hmap + +end IsPrime + +end ConwayRefinement.Standalone.Oz.OneRowExample diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/PrincipalRVAlgebraicIndependence.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/PrincipalRVAlgebraicIndependence.lean new file mode 100644 index 0000000000..91a6db8fd5 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/PrincipalRVAlgebraicIndependence.lean @@ -0,0 +1,162 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import Mathlib.Basic.Real.Basic +public import Mathlib.RingTheory.HahnSeries.Multiplication +public import Mathlib.RingTheory.MvPolynomial.WeightedHomogeneous +public import Mathlib.Algebra.MvPolynomial.Eval +public import Mathlib.Order.WellFoundedSet +public import LeanPool.ConwayRefinement.CombinatorialGames.NatOrdinal.Pow + +/-! +# Algebraic independence in $\widehat{\mathrm P}$ + +`K((ℝ^{≤0}))` is the ring of Hahn series with real exponents `≤ 0` over a field `K` +[LM24, §1.2]. Berarducci's *ordinal value* `v_J` [Ber00, Def. 5.2] is determined by the class of +a series modulo `J + K`: `v_J(b) = 0` if `b ∈ J`, the ideal generated by the monomials `t^x`, +`x < 0` [Ber00, Def. 5.1]; `v_J(b) = 1` if `b ∈ (J + K) \ J`; otherwise `v_J(b)` is the least +order type of the support of a series congruent to `b` modulo `J + K`. Its values are `0` or +additively principal ordinals `ω^α`, and `J_{ω^α} := {b : v_J(b) < ω^α}`. + +For each `α`, `P_α := J_{ω^(α+1)} / J_{ω^α}` is the vector space of principal RV-elements of +degree `α`. In characteristic zero, Berarducci's multiplicativity theorem gives +`v_J(bc) = v_J(b) ⊙ v_J(c)`, using the natural product of ordinals +[Ber00, Thm. 9.7; LM24, Fact 2.7.1]. Since `ω^α ⊙ ω^β = ω^(α ⊕ β)`, the direct sum +`P̂ := ⨁_α P_α` is graded by natural addition of the exponent degrees: the product of +classes of degrees `α` and `β` has degree `α ⊕ β`. +A *minimal homogeneous family* in `P̂` is a family of classes `B ∈ P_{deg B}` of positive +degrees whose members of each degree `β` are linearly independent modulo +`(P̂_+)² ∩ P_β = ∑_{i ⊕ j = β, i, j ≠ 0} P_i P_j`, the square of the ideal of positive degree in +degree `β` (the decomposable elements, `IsDecomposable`). + +**Algebraic independence** (the injective half of the polynomiality of `P̂`). Every minimal +homogeneous family `𝓑` is algebraically independent. Thus the +subalgebra it generates is a polynomial algebra; if `𝓑` generates `P̂`, then `P̂` itself is a +polynomial algebra. In terms of series: a polynomial `F` homogeneous of degree `α` (for +`deg X_B = deg B`) with `v_J(F(b_𝓑)) < ω^α`, where `b_B` represents `B`, is zero. + +The proposition `MinimalFamiliesAlgebraicallyIndependent` expresses this statement through +representatives: a class of degree `α` is a series `b` with `v_J(b) < ω^(α+1)`, and two such +series represent the same class exactly when their difference lies in `J_{ω^α}`. + +## References + +* A. Berarducci, *Factorization in generalized power series*, Trans. Amer. Math. Soc. 352 (2000) + 553–577, cited as [Ber00]. +* S. L'Innocente, V. Mantova, *A factorisation theory for generalised power series and omnific + integers*, Adv. Math. 442 (2024) 109513, cited as [LM24]; + [Fact 2.7.1 in arXiv:1710.07304v5](https://arxiv.org/html/1710.07304v5#S2.SS7). +-/ + +open Ordinal +open scoped NatOrdinal + +@[expose] public noncomputable section + +namespace ConwayRefinement.Standalone.PrincipalRVAlgebraicIndependence + +universe u v + +variable {K : Type u} [Field K] + +/-! ### The ring -/ + +variable (K) in +/-- `K((ℝ^{≤0}))`: Hahn series with real exponents `≤ 0` [LM24, §1.2], as a `K`-subalgebra of +`K((ℝ))`. -/ +def nonpos : Subalgebra K (HahnSeries ℝ K) where + carrier := {x | x.support ⊆ Set.Iic 0} + algebraMap_mem' k := by + intro g hg + rw [HahnSeries.algebraMap_apply] at hg + have hg0 : g = 0 := HahnSeries.support_single_subset hg + simp [hg0] + add_mem' := fun {x y} hx hy g hg ↦ by + rcases HahnSeries.support_add_subset x y hg with h | h + exacts [hx h, hy h] + mul_mem' := fun {x y} hx hy g hg ↦ by + obtain ⟨i, hi, j, hj, rfl⟩ := HahnSeries.support_mul_subset hg + exact Set.mem_Iic.mpr (add_nonpos (Set.mem_Iic.mp (hx hi)) (Set.mem_Iic.mp (hy hj))) + +/-- `<` well-orders the support, as a generalised power series requires [LM24, §1.2]. -/ +theorem supportIsWellOrder (x : HahnSeries ℝ K) : + IsWellOrder x.support (Subrel (· < ·) (· ∈ x.support)) := by + refine { wf := x.isPWO_support.isWF, trichotomous := fun _ _ hab hba ↦ ?_ } + exact Subtype.ext (le_antisymm (le_of_not_gt hba) (le_of_not_gt hab)) + +/-- The order type of the well-ordered support of `x` [LM24, §2.2]. -/ +def ot (x : HahnSeries ℝ K) : Ordinal.{0} := + @Ordinal.type x.support (Subrel (· < ·) (· ∈ x.support)) (supportIsWellOrder x) + +/-! ### The ordinal value -/ + +/-- The ideal `J` generated by the monomials `t^x`, `x < 0` [Ber00, Def. 5.1]: the series whose +support is bounded away from `0`. -/ +def MemJ (x : nonpos K) : Prop := + ∃ s < (0 : ℝ), (x : HahnSeries ℝ K).support ⊆ Set.Iic s + +/-- Congruence to a constant modulo `J`: membership in Berarducci's subgroup `J + K`. -/ +def IsNearConstant (x : nonpos K) : Prop := + ∃ k : K, MemJ (x - algebraMap K (nonpos K) k) + +open scoped Classical in +/-- **Berarducci's ordinal value** `v_J` [Ber00, Def. 5.2]: `0` on `J`, `1` on `(J + K) \ J`, and +otherwise the least order type of the support of a series congruent to `x` modulo `J + K`. -/ +def ordinalValue (x : nonpos K) : NatOrdinal := + if MemJ x then 0 + else if IsNearConstant x then 1 + else sInf {o | ∃ c : nonpos K, + IsNearConstant (x - c) ∧ NatOrdinal.of (ot (c : HahnSeries ℝ K)) = o} + +/-! ### Classes, decomposables, and minimal homogeneous families -/ + +variable {ι : Type v} + +/-- `x` is *decomposable at degree `α`*: modulo `J_{ω^α}`, a finite sum of products `u_k w_k` of +representatives of classes of positive degrees `β_k ⊕ β'_k = α` — a representative of an element +of `(P̂_+)² ∩ P_α = ∑_{i ⊕ j = α, i, j ≠ 0} P_i P_j`, the square of the ideal of positive degree +in degree `α`. -/ +def IsDecomposable (α : NatOrdinal) (x : nonpos K) : Prop := + ∃ (n : ℕ) (β β' : Fin n → NatOrdinal) (u w : Fin n → nonpos K), + (∀ k, β k ≠ 0 ∧ β' k ≠ 0 ∧ β k + β' k = α) ∧ + (∀ k, ordinalValue (u k) < ω^ (β k + 1)) ∧ (∀ k, ordinalValue (w k) < ω^ (β' k + 1)) ∧ + ordinalValue (x - ∑ k, u k * w k) < ω^ α + +/-- A minimal homogeneous family in `P̂`, through representatives: `b i` represents a class of +positive degree `deg i`, and the classes of any fixed degree are linearly independent modulo the +decomposables of that degree. -/ +structure IsMinimalHomogeneousFamily (deg : ι → NatOrdinal) (b : ι → nonpos K) : Prop where + /-- Every generator has positive degree. -/ + ne_zero : ∀ i, deg i ≠ 0 + /-- `b i` represents a class of degree `deg i`. -/ + mem : ∀ i, ordinalValue (b i) < ω^ (deg i + 1) + /-- The generators of degree `β` are linearly independent modulo the decomposables. -/ + independent : ∀ (β : NatOrdinal) (c : ι →₀ K), (∀ i ∈ c.support, deg i = β) → + IsDecomposable β (c.sum fun i k ↦ algebraMap K (nonpos K) k * b i) → c = 0 + +variable (K) in +/-- **Algebraic independence in `P̂`.** For every minimal homogeneous family, given through +representatives `b i` of classes of degrees `deg i`, a polynomial `F ∈ K[X_i]` homogeneous of +degree `α` whose evaluation `F(b)` lies in `J_{ω^α}` is zero. + +The conclusion is asserted in characteristic zero. -/ +abbrev MinimalFamiliesAlgebraicallyIndependent : Prop := + CharZero K → + ∀ {ι : Type} (deg : ι → NatOrdinal) (b : ι → nonpos K), + IsMinimalHomogeneousFamily deg b → + ∀ (α : NatOrdinal) (F : MvPolynomial ι K), MvPolynomial.IsWeightedHomogeneous deg F α → + ordinalValue (MvPolynomial.aeval b F) < ω^ α → F = 0 + +end ConwayRefinement.Standalone.PrincipalRVAlgebraicIndependence + +/-! +## Formal proof + +Proof module: `PrincipalRVAlgebraicIndependenceProof`. + +* `MinimalFamiliesAlgebraicallyIndependent` → `MinimalFamiliesAlgebraicallyIndependent.proof` +-/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/PrincipalRVAlgebraicIndependenceProof.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/PrincipalRVAlgebraicIndependenceProof.lean new file mode 100644 index 0000000000..f1846fa74b --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/PrincipalRVAlgebraicIndependenceProof.lean @@ -0,0 +1,28 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.PrincipalRVAlgebraicIndependence +import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Support.PrincipalRVAlgebraicIndependenceProof + +/-! # Principal RVAlgebraic Independence Proof -/ + +public noncomputable section + +namespace ConwayRefinement.Standalone.PrincipalRVAlgebraicIndependence + +namespace MinimalFamiliesAlgebraicallyIndependent + +universe u + +/-- Every minimal homogeneous family in `P̂` is algebraically independent. -/ +theorem proof (K : Type u) [Field K] : + PrincipalRVAlgebraicIndependence.MinimalFamiliesAlgebraicallyIndependent K := by + exact of_algebraicIndependence K + +end MinimalFamiliesAlgebraicallyIndependent + +end ConwayRefinement.Standalone.PrincipalRVAlgebraicIndependence diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/Support.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/Support.lean new file mode 100644 index 0000000000..4b104ac016 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/Support.lean @@ -0,0 +1,21 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Support.ConwayNormalForm +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Support.ConwayRefinementConsequences +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Support.DegreeTwoExample +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Support.FinitePowerFamily +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Support.FinitePowerFamilyProof +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Support.OmegaOmegaBoundary +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Support.OmnificFactorizationProof +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Support.OmnificFiniteDegree +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Support.OmnificIntegers +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Support.OneRowExample +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Support.PrincipalRVAlgebraicIndependenceProof + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/Support/ConwayNormalForm.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/Support/ConwayNormalForm.lean new file mode 100644 index 0000000000..a39277f0bc --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/Support/ConwayNormalForm.lean @@ -0,0 +1,186 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Examples.OmnificFactorization +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Support.ConwayRefinementConsequences +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Support.OmnificFiniteDegree +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.OmnificInteger.Primality.OrdinaryIntegers +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Reduced +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.OmnificInteger.RefinementConjecture +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Divisibility.DenominatorIdeal + +import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.Degree +import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.HahnSeries.DegreeTransfer +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint + +/-! +# Conway cuts and the normal-form presentation of omnific integers + +Conway normal forms give a ring equivalence between the cut-defined omnific integers and the +generalised-power-series presentation used by the standalone factorisation statements. +-/ + +public noncomputable section + +open Cardinal FiniteArchimedeanClass +open scoped HahnSeries NatOrdinal + +universe u + +namespace ConwayRefinement.Standalone.Oz + +/-- The standalone cut predicate agrees with membership in the omnific-integer subring. -/ +theorem isConwayOmnificInteger_iff_mem {x : Surreal.{u}} : + IsConwayOmnificInteger x ↔ x ∈ Surreal.omnificIntegers := by + rw [isConwayOmnificInteger_iff, Surreal.mem_omnificIntegers, Surreal.isOmnificInteger_iff, + Surreal.omnificIntegerCut_eq] + +/-- The cut-defined and subring formulations of Conway's refinement conjecture are equivalent. -/ +@[blueprint "thm:conway-cut-subring-equivalence" + (phase := "Surreal numbers and omnific integers") + (title := "Equivalence of the cut and subring formulations of Conway's refinement conjecture") + (statement := /-- + Conway's refinement conjecture for cut-defined omnific integers is + equivalent to the refinement property of the omnific-integer subring of + the surreal numbers. + -/) + (proof := /-- + The cut predicate for omnific integers is equivalent to membership in the + omnific-integer subring. Substitute this equivalence into the two + four-factor statements; their equations and quantifiers are identical. + -/)] +theorem conwayConjecture_iff_native : ConwayConjecture.{u} ↔ ConwayRefinementConjecture.{u} := by + rw [conwayConjecture_iff, conwayRefinementConjecture_def, ← hasFourFactorRefinement_def] + simpa only [isConwayOmnificInteger_iff_mem] using + (Subring.hasFourFactorRefinement_iff Surreal.omnificIntegers).symm + +/-- Conway's refinement conjecture is equivalent to primality of every omnific integer. -/ +theorem conwayConjecture_iff_forall_isPrimal : + ConwayConjecture.{u} ↔ ∀ b : Surreal.OmnificInteger.{u}, IsPrimal b := by + rw [conwayConjecture_iff_native, conwayRefinementConjecture_def, + ← hasFourFactorRefinement_def, hasFourFactorRefinement_iff_forall_isPrimal] + +/-- Conway's refinement conjecture is equivalent to the pre-Schreier property of the omnific +integers. -/ +theorem conwayConjecture_iff_decompositionMonoid : + ConwayConjecture.{u} ↔ DecompositionMonoid Surreal.OmnificInteger.{u} := by + rw [conwayConjecture_iff_forall_isPrimal, decompositionMonoid_iff] + +/-- Conway's refinement conjecture is equivalent to the common-divisor criterion for denominator +ideals. -/ +theorem conwayConjecture_iff_forall_denominatorIdeal_exists_commonDivisor : + ConwayConjecture.{u} ↔ + ∀ (ξ : Surreal.{u}) + (x y : Subring.denominatorIdeal Surreal.omnificIntegers ξ), + ∃ s : Subring.denominatorIdeal Surreal.omnificIntegers ξ, + (s : Surreal.OmnificInteger) ∣ (x : Surreal.OmnificInteger) ∧ + (s : Surreal.OmnificInteger) ∣ (y : Surreal.OmnificInteger) := by + rw [conwayConjecture_iff_native, conwayRefinementConjecture_def, + ← hasFourFactorRefinement_def, + Subring.hasFourFactorRefinement_iff_forall_denominatorIdeal_exists_common_divisor] + +/-- The Conway normal-form equivalence identifies the two definitions of omnific integers. -/ +theorem normalFormIdentifiesOmnificIntegers : + NormalFormIdentifiesOmnificIntegers.{u} := by + refine ⟨Surreal.toHahnSeriesRingEquiv, ?_⟩ + intro x + rw [Surreal.toHahnSeriesRingEquiv_apply, isConwayOmnificInteger_iff, + mem_omnificIntegers, Surreal.support_toHahnSeries, + congrFun (Surreal.coeff_toHahnSeries x) 0, + ← Surreal.isOmnificInteger_iff_normalForm, Surreal.isOmnificInteger_iff, + Surreal.omnificIntegerCut_eq] + +/-- The normal-form and cut-defined omnific-integer rings are isomorphic. -/ +def normalFormRingEquiv : OmnificInteger.{u} ≃+* Surreal.OmnificInteger.{u} := + Surreal.toHahnSeriesRingEquiv.symm.restrict + omnificIntegers Surreal.omnificIntegers fun x ↦ by + rw [mem_omnificIntegers, Surreal.mem_omnificIntegers, + Surreal.isOmnificInteger_iff_normalForm] + simp only [Surreal.toHahnSeriesRingEquiv_symm_apply, + SurrealHahnSeries.support_toSurreal, SurrealHahnSeries.coeff_toSurreal] + +@[simp] +theorem coe_normalFormRingEquiv (x : OmnificInteger.{u}) : + (normalFormRingEquiv x : Surreal.{u}) = x.1.toSurreal := + Surreal.toHahnSeriesRingEquiv_symm_apply x.1 + +theorem toHahnSeries_normalFormRingEquiv (x : OmnificInteger.{u}) : + (normalFormRingEquiv x : Surreal.{u}).toHahnSeries = x.1 := by + rw [coe_normalFormRingEquiv] + exact SurrealHahnSeries.toHahnSeries_toSurreal x.1 + +theorem normalFormRingEquiv_not_isOrdinaryInteger + (x : OmnificInteger.{u}) (hx : ¬ IsOrdinaryInteger x) : + ¬ Surreal.OmnificInteger.IsOrdinaryInteger (normalFormRingEquiv x) := by + intro hordinary + apply hx + rw [Surreal.OmnificInteger.isOrdinaryInteger_iff] at hordinary + obtain ⟨z, hz⟩ := hordinary + have htarget : normalFormRingEquiv x = (z : Surreal.OmnificInteger.{u}) := + Subtype.ext hz + have hsource : x = (z : OmnificInteger.{u}) := by + apply normalFormRingEquiv.injective + simpa using htarget + exact ⟨z, congrArg Subtype.val hsource⟩ + +theorem normalFormRingEquiv_isReduced + (x : OmnificInteger.{u}) (hx : IsReduced x) : + HahnSeries.Nonpositive.IsReduced + (normalFormRingEquiv x).toSignedNonpositiveHahn := by + obtain ⟨hx0, c, hclass⟩ := hx + have hy0 : normalFormRingEquiv x ≠ 0 := + normalFormRingEquiv.map_eq_zero_iff.not.mpr hx0 + refine HahnSeries.Nonpositive.isReduced_of_support_inter_support_sub_one_subset + ?_ c ?_ + · intro hzero + apply hy0 + apply Subtype.ext + apply Surreal.toSignedFullHahnSeries_injective + have hraw := congrArg (fun q : HahnSeries.Nonpositive Surreal ℝ ↦ + (q : HahnSeries Surreal ℝ)) hzero + rw [Surreal.OmnificInteger.coe_toSignedNonpositiveHahn] at hraw + exact hraw.trans Surreal.toSignedFullHahnSeries_zero.symm + · intro g hg + have hgSource : g ∈ + (normalFormRingEquiv x).1.toSignedFullHahnSeries.support := by + rw [← Surreal.OmnificInteger.coe_toSignedNonpositiveHahn] + exact hg.1 + have hsub : + ((((normalFormRingEquiv x).toSignedNonpositiveHahn - 1 : + HahnSeries.Nonpositive Surreal ℝ)) : HahnSeries Surreal ℝ) = + ((normalFormRingEquiv x).1 - 1).toSignedFullHahnSeries := by + calc + _ = ((normalFormRingEquiv x).toSignedNonpositiveHahn : + HahnSeries Surreal ℝ) - 1 := rfl + _ = (normalFormRingEquiv x).1.toSignedFullHahnSeries - 1 := by + rw [Surreal.OmnificInteger.coe_toSignedNonpositiveHahn] + _ = ((normalFormRingEquiv x).1 - 1).toSignedFullHahnSeries := by + rw [Surreal.toSignedFullHahnSeries_sub] + congr 1 + simpa using (Surreal.toSignedFullHahnSeries_realCast (1 : ℝ)).symm + have hgSub : g ∈ + ((normalFormRingEquiv x).1 - 1).toSignedFullHahnSeries.support := by + rw [← hsub] + exact hg.2 + have huSource : -g ∈ x.1.support := by + have hu : -g ∈ (normalFormRingEquiv x).1.support := by + simpa using (Surreal.mem_support_toSignedFullHahnSeries.mp hgSource) + rw [← toHahnSeries_normalFormRingEquiv x] + simpa using hu + have hnormalSub : + ((normalFormRingEquiv x).1 - 1).toHahnSeries = x.1 - 1 := by + rw [← Surreal.toHahnSeriesRingEquiv_apply, map_sub, + Surreal.toHahnSeriesRingEquiv_apply, toHahnSeries_normalFormRingEquiv, + map_one] + have huSub : -g ∈ (x.1 - 1).support := by + have hu : -g ∈ ((normalFormRingEquiv x).1 - 1).support := by + simpa using (Surreal.mem_support_toSignedFullHahnSeries.mp hgSub) + rw [← hnormalSub, Surreal.support_toHahnSeries] + exact hu + simpa using hclass ⟨huSource, huSub⟩ + +end ConwayRefinement.Standalone.Oz diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/Support/ConwayRefinementConsequences.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/Support/ConwayRefinementConsequences.lean new file mode 100644 index 0000000000..92636361e6 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/Support/ConwayRefinementConsequences.lean @@ -0,0 +1,37 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.ConwayRefinement + +/-! # Conway Refinement Consequences -/ + +public noncomputable section + +universe u + +namespace ConwayRefinement.Standalone.Oz + +/-- Membership unfolds to Conway's defining cut equation. -/ +theorem isConwayOmnificInteger_iff (x : Surreal.{u}) : + IsConwayOmnificInteger x ↔ + x = !{{x - 1} | {x + 1}}' (by + simp only [Set.mem_singleton_iff] + rintro _ rfl _ rfl + simp [sub_eq_add_neg]) := (Iff.rfl) + +/-- The proposition unfolds to the displayed four-factor refinement. -/ +theorem conwayConjecture_iff : ConwayConjecture.{u} ↔ + ∀ a b c d : Surreal.{u}, + IsConwayOmnificInteger a → IsConwayOmnificInteger b → + IsConwayOmnificInteger c → IsConwayOmnificInteger d → a * b = c * d → + ∃ e f g h : Surreal.{u}, + IsConwayOmnificInteger e ∧ IsConwayOmnificInteger f ∧ + IsConwayOmnificInteger g ∧ IsConwayOmnificInteger h ∧ + a = e * f ∧ b = g * h ∧ c = e * g ∧ d = f * h := + (Iff.rfl) + +end ConwayRefinement.Standalone.Oz diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/Support/DegreeTwoExample.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/Support/DegreeTwoExample.lean new file mode 100644 index 0000000000..1277773952 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/Support/DegreeTwoExample.lean @@ -0,0 +1,221 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Support.OmnificIntegers +public import Mathlib.Data.Prod.Lex +public import Mathlib.SetTheory.Ordinal.Arithmetic + +import all LeanPool.ConwayRefinement.CombinatorialGames.Surreal.HahnSeries.Basic + +/-! +# A concrete degree-two omnific integer + +The nonconstant exponents of the explicit element are + +`1 / (m + 1) + 1 / ((m + 1) * (m + 2) * (n + 1))`, + +for `m n : ℕ`, and every displayed coefficient is one. For fixed `m` these exponents decrease to +`1 / (m + 1)`; the rows themselves decrease to zero. The final constant term is also one. + +The construction is universe-polymorphic: the normal form is written in the surreal numbers of +every universe `u`. Its support order type and primeness are stated in `DegreeTwoPrime`. +-/ + +universe u + +@[expose] public noncomputable section + +namespace ConwayRefinement.Standalone.Oz.DegreeTwoExample + +open Set + +/-- The positive Conway exponent in row `m` and column `n`. -/ +def exponent (m n : ℕ) : ℝ := + 1 / (m + 1 : ℝ) + + 1 / ((m + 1 : ℝ) * (m + 2 : ℝ) * (n + 1 : ℝ)) + +@[simp] +theorem exponent_apply (m n : ℕ) : + exponent m n = + 1 / (m + 1 : ℝ) + + 1 / ((m + 1 : ℝ) * (m + 2 : ℝ) * (n + 1 : ℝ)) := by + rfl + +private def cutoff (m : ℕ) : ℝ := + 1 / (m + 1 : ℝ) + +private theorem exponent_strictAnti_second (m : ℕ) : + StrictAnti (exponent m) := by + apply strictAnti_nat_of_succ_lt + intro n + rw [exponent_apply, exponent_apply] + gcongr + omega + +private theorem cutoff_lt_exponent (m n : ℕ) : + cutoff m < exponent m n := by + rw [cutoff, exponent_apply] + have : 0 < + 1 / ((m + 1 : ℝ) * (m + 2 : ℝ) * (n + 1 : ℝ)) := by + positivity + linarith + +private theorem next_exponent_zero_lt_cutoff (m : ℕ) : + exponent (m + 1) 0 < cutoff m := by + rw [exponent_apply, cutoff] + field_simp + norm_num [Nat.cast_add, Nat.cast_one] + ring_nf + nlinarith + +private theorem exponent_gt_of_first_lt + {m m' n n' : ℕ} (hmm' : m < m') : + exponent m n > exponent m' n' := by + calc + exponent m' n' ≤ exponent (m + 1) 0 := by + by_cases hsucc : m + 1 = m' + · subst m' + exact (exponent_strictAnti_second (m + 1)).antitone (Nat.zero_le n') + · have hfirst : m + 1 < m' := lt_of_le_of_ne (Nat.succ_le_iff.mpr hmm') hsucc + exact (exponent_gt_of_first_lt hfirst).le + _ < cutoff m := next_exponent_zero_lt_cutoff m + _ < exponent m n := cutoff_lt_exponent m n +termination_by m' - m + +private theorem exponent_strictAnti_lex : + StrictAnti (fun p : Lex (ℕ × ℕ) ↦ exponent (ofLex p).1 (ofLex p).2) := by + intro p q hpq + rw [Prod.Lex.lt_iff] at hpq + rcases hpq with hfirst | ⟨hfirst, hsecond⟩ + · exact exponent_gt_of_first_lt hfirst + · change exponent (ofLex p).1 (ofLex p).2 > exponent (ofLex q).1 (ofLex q).2 + rw [hfirst] + exact exponent_strictAnti_second _ hsecond + +/-- The row-column index, followed by one final index for the constant term. -/ +abbrev Index := WithTop (Lex (ℕ × ℕ)) + +/-- The exponent sequence of the concrete Conway normal form. -/ +def exponentAtIndex : Index → Surreal.{u} + | ⊤ => 0 + | (p : Lex (ℕ × ℕ)) => (exponent (ofLex p).1 (ofLex p).2 : ℝ) + +private theorem exponent_pos (m n : ℕ) : 0 < exponent m n := by + rw [exponent_apply] + positivity + +private theorem exponentAtIndex_strictAnti : StrictAnti exponentAtIndex.{u} := by + intro p q hpq + induction p using WithTop.recTopCoe with + | top => exact (not_lt_of_ge le_top hpq).elim + | coe p => + induction q using WithTop.recTopCoe with + | top => + change (0 : Surreal) < (exponent (ofLex p).1 (ofLex p).2 : ℝ) + exact_mod_cast exponent_pos (ofLex p).1 (ofLex p).2 + | coe q => + change ((exponent (ofLex q).1 (ofLex q).2 : ℝ) : Surreal) < + (exponent (ofLex p).1 (ofLex p).2 : ℝ) + exact_mod_cast exponent_strictAnti_lex (WithTop.coe_lt_coe.mp hpq) + +/-- The coefficient function of the explicit normal form. -/ +def coefficient (i : Surreal.{u}) : ℝ := + by + classical + exact if i ∈ range exponentAtIndex then 1 else 0 + +private theorem support_coefficient : + Function.support coefficient.{u} = range exponentAtIndex := by + classical + ext i + simp [Function.support, coefficient] + +/-- The displayed coefficient support is small enough for `SurrealHahnSeries` in every +universe. -/ +theorem small_support_coefficient : + Small.{u} (Function.support coefficient.{u}) := by + rw [support_coefficient] + infer_instance + +/-- The displayed exponents are reverse well-ordered. -/ +theorem wellFoundedOn_support_coefficient : + (Function.support coefficient.{u}).WellFoundedOn (· > ·) := by + rw [support_coefficient, wellFoundedOn_range] + convert wellFounded_lt (α := Index) using 1 + ext p q + exact exponentAtIndex_strictAnti.lt_iff_gt + +/-- The explicit Conway normal form with all coefficients equal to one. -/ +def normalForm : SurrealHahnSeries.{u} := + SurrealHahnSeries.mk coefficient small_support_coefficient + wellFoundedOn_support_coefficient + +@[simp] +theorem normalForm_coeff (i : Surreal.{u}) : + normalForm.coeff i = coefficient i := by + rw [normalForm, SurrealHahnSeries.coeff_mk, coefficient] + +@[simp] +theorem normalForm_support : normalForm.{u}.support = range exponentAtIndex := by + rw [normalForm, SurrealHahnSeries.support_mk, support_coefficient] + +theorem normalForm_coeff_exponent (m n : ℕ) : + normalForm.{u}.coeff (exponent m n : ℝ) = 1 := by + classical + rw [normalForm_coeff, coefficient, ite_eq_left] + exact ⟨(↑(toLex (m, n)) : Index), rfl⟩ + +theorem normalForm_coeff_zero : normalForm.{u}.coeff 0 = 1 := by + classical + rw [normalForm_coeff, coefficient, ite_eq_left] + exact ⟨⊤, rfl⟩ + +private theorem normalForm_support_nonnegative : normalForm.{u}.support ⊆ Ici 0 := by + rw [normalForm_support] + rintro i ⟨p, rfl⟩ + induction p using WithTop.recTopCoe with + | top => exact le_rfl + | coe p => + rw [mem_Ici] + change (0 : Surreal) ≤ (exponent (ofLex p).1 (ofLex p).2 : ℝ) + exact_mod_cast (exponent_pos (ofLex p).1 (ofLex p).2).le + +/-- The explicit normal form, regarded as an omnific integer. -/ +def degreeTwoOz : Oz.OmnificInteger.{u} := + ⟨normalForm, by + rw [Oz.mem_omnificIntegers] + exact ⟨normalForm_support_nonnegative, ⟨1, by simpa using normalForm_coeff_zero.symm⟩⟩⟩ + +@[simp] +theorem degreeTwoOz_val : degreeTwoOz.{u}.1 = normalForm := by + rfl + +/-- The coefficient-doubled comparison element. It has the same support as `degreeTwoOz`, but its +factorisation as `2 * degreeTwoOz` is visible in the definition. -/ +def degreeTwoFoil : Oz.OmnificInteger.{u} := + 2 * degreeTwoOz + +@[simp] +theorem degreeTwoFoil_val : degreeTwoFoil.{u}.1 = 2 * normalForm := by + rfl + +/-- Doubling every nonzero coefficient does not change the Conway support. -/ +theorem degreeTwoFoil_support : + degreeTwoFoil.{u}.1.support = degreeTwoOz.1.support := by + rw [degreeTwoFoil_val, degreeTwoOz_val, two_mul] + ext i + simp only [SurrealHahnSeries.mem_support_iff, + SurrealHahnSeries.coeff_add_apply] + constructor + · intro h hzero + apply h + rw [hzero, zero_add] + · intro h hsum + apply h + linarith + +end ConwayRefinement.Standalone.Oz.DegreeTwoExample diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/Support/FinitePowerFamily.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/Support/FinitePowerFamily.lean new file mode 100644 index 0000000000..41aeb5db55 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/Support/FinitePowerFamily.lean @@ -0,0 +1,624 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Support.OmnificFiniteDegree +public import Mathlib.Data.Prod.Lex +public import Mathlib.Basic.Real.Basic +public import Mathlib.Data.Sum.Order +public import Mathlib.SetTheory.Ordinal.Arithmetic +public import Mathlib.SetTheory.Ordinal.Exponential + +import all LeanPool.ConwayRefinement.CombinatorialGames.Surreal.HahnSeries.Basic +import Mathlib.Tactic.Linarith +import Mathlib.Tactic.NormNum +import Mathlib.Tactic.Positivity + +/-! +# Omnific integers at every finite power of omega + +For each natural number `n`, let `FiniteLex n` be the lexicographic order on natural tuples of +length `n`. Its order type is `ω ^ n`. Define negative real numbers recursively by + +`E 0 * = -1`, + +`E (n + 1) (m, p) = -(1 / 3) ^ m + (1 / 3) ^ (m + 1) E n p`. + +The intervals occupied by successive values of `m` are disjoint, so `E n` is a strict order +embedding. Negating these values and adjoining a final zero gives a strictly decreasing sequence +of Conway exponents of order type `ω ^ n + 1`. + +The normal form `finitePowerOz n` has coefficient one at every exponent in this sequence. It is a +nonordinary reduced omnific integer, its Conway length is exactly `ω ^ n + 1`, and it has finite +degree. Consequently, every member of the family is primal. + +This construction does not assert irreducibility. At degree two, coefficients contain information +not determined by support geometry alone, as illustrated by the PS06 example. Within this family, +doubling every coefficient preserves the support but destroys reducedness. + +## References + +* S. L'Innocente, V. Mantova, *A factorisation theory for generalised power series and omnific + integers*, Adv. Math. 442 (2024) 109513, , cited + as [LM24]. +* J. Pommersheim, S. Shahriari, *Unique factorization in generalized power series rings*, +Proc. Amer. Math. Soc. 134 (2006), 1277–1287, cited as [PS06]. +-/ + +@[expose] public noncomputable section + +namespace ConwayRefinement.Standalone.Oz.FinitePowerFamily + +open Ordinal + +/-- Natural tuples of length `n`, ordered lexicographically from the first coordinate. -/ +abbrev FiniteLex : ℕ → Type + | .zero => Unit + | .succ n => Lex (ℕ × FiniteLex n) + +noncomputable instance finiteLexLinearOrder : (n : ℕ) → LinearOrder (FiniteLex n) + | .zero => inferInstanceAs (LinearOrder Unit) + | .succ n => by + letI : LinearOrder (FiniteLex n) := finiteLexLinearOrder n + exact Prod.Lex.instLinearOrder ℕ (FiniteLex n) + +instance finiteLexWellFoundedLT : (n : ℕ) → WellFoundedLT (FiniteLex n) + | .zero => by + change WellFoundedLT Unit + exact Finite.wellFounded_of_trans_of_irrefl (· < ·) + | .succ n => by + let : WellFoundedLT (FiniteLex n) := finiteLexWellFoundedLT n + exact inferInstanceAs (WellFoundedLT (Lex (ℕ × FiniteLex n))) + +/-- The lexicographic natural tuples of length `n` have order type `ω ^ n`. -/ +theorem typeLT_finiteLex (n : ℕ) : + Ordinal.type ((· < ·) : FiniteLex n → FiniteLex n → Prop) = + (Ordinal.omega0 : Ordinal.{0}) ^ (n : Ordinal.{0}) := by + induction n with + | zero => simp [FiniteLex] + | succ n ih => + change Ordinal.type + (Prod.Lex ((· < ·) : ℕ → ℕ → Prop) + ((· < ·) : FiniteLex n → FiniteLex n → Prop)) = _ + rw [Ordinal.type_prod_lex, Ordinal.type_nat_lt] + rw [ih] + rw [← Ordinal.opow_add_one] + congr 2 + +/-- The contraction factor separating consecutive lexicographic blocks. -/ +def scale : ℝ := 1 / 3 + +@[simp] +theorem scale_eq_one_div_three : scale = (1 / 3 : ℝ) := by + rfl + +private theorem scale_pos : 0 < scale := by norm_num [scale] + +private theorem scale_le_one : scale ≤ 1 := by norm_num [scale] + +/-- A bounded negative real realization of the lexicographic tuple order. -/ +def finitePowerExponent : (n : ℕ) → FiniteLex n → ℝ + | .zero, _ => -1 + | .succ n, p => + -scale ^ (ofLex p).1 + + scale ^ ((ofLex p).1 + 1) * finitePowerExponent n (ofLex p).2 + +@[simp] +theorem finitePowerExponent_zero (p : FiniteLex 0) : + finitePowerExponent 0 p = -1 := by + rfl + +@[simp] +theorem finitePowerExponent_succ (n : ℕ) (p : FiniteLex (n + 1)) : + finitePowerExponent (n + 1) p = + -scale ^ (ofLex p).1 + + scale ^ ((ofLex p).1 + 1) * finitePowerExponent n (ofLex p).2 := by + rfl + +theorem finitePowerExponent_neg : ∀ (n : ℕ) (p : FiniteLex n), + finitePowerExponent n p < 0 + | 0, _ => by simp [finitePowerExponent] + | n + 1, p => by + have htail := finitePowerExponent_neg n (ofLex p).2 + have hpow : 0 < scale ^ ((ofLex p).1 + 1) := pow_pos scale_pos _ + have hmul : + scale ^ ((ofLex p).1 + 1) * finitePowerExponent n (ofLex p).2 < 0 := + mul_neg_of_pos_of_neg hpow htail + have hfirst : 0 < scale ^ (ofLex p).1 := pow_pos scale_pos _ + simp only [finitePowerExponent] + linarith + +/-- Every finite-tuple exponent lies weakly above `-3 / 2`. -/ +theorem finitePowerExponent_lowerBound : + ∀ (n : ℕ) (p : FiniteLex n), + -(3 / 2 : ℝ) ≤ finitePowerExponent n p + | 0, _ => by norm_num [finitePowerExponent] + | n + 1, p => by + have htail := finitePowerExponent_lowerBound n (ofLex p).2 + have hpowNonneg : 0 ≤ scale ^ ((ofLex p).1 + 1) := (pow_pos scale_pos _).le + have htailMul : + scale ^ ((ofLex p).1 + 1) * (-(3 / 2 : ℝ)) ≤ + scale ^ ((ofLex p).1 + 1) * finitePowerExponent n (ofLex p).2 := + mul_le_mul_of_nonneg_left htail hpowNonneg + have hfirst : scale ^ (ofLex p).1 ≤ 1 := by + simpa using pow_le_pow_of_le_one scale_pos.le scale_le_one + (Nat.zero_le (ofLex p).1) + have hsecond : scale ^ ((ofLex p).1 + 1) ≤ scale := by + simpa using pow_le_pow_of_le_one scale_pos.le scale_le_one + (Nat.succ_le_succ (Nat.zero_le (ofLex p).1)) + simp only [finitePowerExponent] + norm_num [scale] at htailMul hfirst hsecond ⊢ + linarith + +private theorem finitePowerExponent_succ_lt_blockLimit + (n : ℕ) (p : FiniteLex (n + 1)) : + finitePowerExponent (n + 1) p < -scale ^ (ofLex p).1 := by + have htail := finitePowerExponent_neg n (ofLex p).2 + have hpow : 0 < scale ^ ((ofLex p).1 + 1) := pow_pos scale_pos _ + simp only [finitePowerExponent] + nlinarith + +private theorem finitePowerExponent_succ_blockLowerBound + (n : ℕ) (p : FiniteLex (n + 1)) : + -(3 / 2 : ℝ) * scale ^ (ofLex p).1 ≤ finitePowerExponent (n + 1) p := by + have htail := finitePowerExponent_lowerBound n (ofLex p).2 + have hpowNonneg : 0 ≤ scale ^ ((ofLex p).1 + 1) := (pow_pos scale_pos _).le + have htailMul : + scale ^ ((ofLex p).1 + 1) * (-(3 / 2 : ℝ)) ≤ + scale ^ ((ofLex p).1 + 1) * finitePowerExponent n (ofLex p).2 := + mul_le_mul_of_nonneg_left htail hpowNonneg + simp only [finitePowerExponent] + rw [pow_succ] at htailMul ⊢ + norm_num [scale] at htailMul ⊢ + linarith + +/-- The real realization preserves the lexicographic order. -/ +theorem finitePowerExponent_strictMono (n : ℕ) : StrictMono (finitePowerExponent n) := by + induction n with + | zero => + intro p q hpq + exact (lt_irrefl p hpq).elim + | succ n ih => + intro p q hpq + induction p using Lex.rec with | h p => + induction q using Lex.rec with | h q => + rcases p with ⟨m, p⟩ + rcases q with ⟨m', q⟩ + rw [Prod.Lex.lt_iff'] at hpq + rcases hpq with ⟨hfirstLe, htailOfEq⟩ + change m ≤ m' at hfirstLe + change m = m' → p < q at htailOfEq + rcases hfirstLe.eq_or_lt with hfirst | hfirst + · have htail := htailOfEq hfirst + change -scale ^ m + scale ^ (m + 1) * finitePowerExponent n p < + -scale ^ m' + scale ^ (m' + 1) * finitePowerExponent n q + subst m' + simpa only [add_comm] using + (add_lt_add_left + (mul_lt_mul_of_pos_left (ih htail) (pow_pos scale_pos (m + 1))) + (-scale ^ m)) + · have hpUpper := finitePowerExponent_succ_lt_blockLimit n (toLex (m, p)) + have hqLower := finitePowerExponent_succ_blockLowerBound n (toLex (m', q)) + have hpow : scale ^ m' ≤ scale ^ (m + 1) := + pow_le_pow_of_le_one scale_pos.le scale_le_one (Nat.succ_le_iff.mpr hfirst) + rw [pow_succ] at hpow + norm_num [scale] at hpow + have hpPowPos : 0 < (1 / 3 : ℝ) ^ m := by positivity + have hsep : -scale ^ m < -(3 / 2 : ℝ) * scale ^ m' := by + norm_num [scale] + nlinarith [hpPowPos] + calc + finitePowerExponent (n + 1) (toLex (m, p)) < -scale ^ m := hpUpper + _ < -(3 / 2 : ℝ) * scale ^ m' := hsep + _ ≤ finitePowerExponent (n + 1) (toLex (m', q)) := hqLower + +/-- The order embedding of the finite lexicographic tuples into the negative reals. -/ +def finitePowerExponentEmbedding (n : ℕ) : FiniteLex n ↪o ℝ := + OrderEmbedding.ofStrictMono _ (finitePowerExponent_strictMono n) + +/-- The all-zero tuple in the `n`-coordinate lexicographic index. -/ +def finitePowerZeroIndex : (n : ℕ) → FiniteLex n + | .zero => () + | .succ n => toLex (0, finitePowerZeroIndex n) + +/-- The positive real Conway exponent attached to a finite tuple. -/ +def finitePowerConwayExponent (n : ℕ) (p : FiniteLex n) : ℝ := + -finitePowerExponent n p + +@[simp] +theorem finitePowerConwayExponent_apply (n : ℕ) (p : FiniteLex n) : + finitePowerConwayExponent n p = -finitePowerExponent n p := by + rfl + +theorem finitePowerConwayExponent_pos (n : ℕ) (p : FiniteLex n) : + 0 < finitePowerConwayExponent n p := by + exact neg_pos.mpr (finitePowerExponent_neg n p) + +theorem finitePowerConwayExponent_strictAnti (n : ℕ) : + StrictAnti (finitePowerConwayExponent n) := by + intro p q hpq + exact neg_lt_neg ((finitePowerExponent_strictMono n) hpq) + +/-- The tuple exponents followed by the constant exponent. -/ +abbrev ConwayIndex (n : ℕ) := WithTop (FiniteLex n) + +theorem typeLT_conwayIndex (n : ℕ) : + Ordinal.type ((· < ·) : ConwayIndex n → ConwayIndex n → Prop) = + (Ordinal.omega0 : Ordinal.{0}) ^ (n : Ordinal.{0}) + 1 := by + let : WellFoundedLT (FiniteLex n ⊕ₗ PUnit) := + (WithTop.orderIsoSumLexPUnit (α := FiniteLex n)).symm.toOrderEmbedding.wellFoundedLT + calc + Ordinal.type ((· < ·) : ConwayIndex n → ConwayIndex n → Prop) = + Ordinal.type ((· < ·) : (FiniteLex n ⊕ₗ PUnit) → + (FiniteLex n ⊕ₗ PUnit) → Prop) := + (WithTop.orderIsoSumLexPUnit (α := FiniteLex n)).toRelIsoLT.ordinalType_congr + _ = (Ordinal.omega0 : Ordinal.{0}) ^ (n : Ordinal.{0}) + 1 := by + change Ordinal.type + (Sum.Lex ((· < ·) : FiniteLex n → FiniteLex n → Prop) + ((· < ·) : PUnit → PUnit → Prop)) = _ + rw [Ordinal.type_sum_lex, typeLT_finiteLex] + simp + +/-- The exponent sequence of the `n`-th Conway normal form. -/ +def finitePowerConwayExponentAtIndex (n : ℕ) : ConwayIndex n → Surreal.{0} + | ⊤ => 0 + | (p : FiniteLex n) => (finitePowerConwayExponent n p : ℝ) + +@[simp] +theorem finitePowerConwayExponentAtIndex_top (n : ℕ) : + finitePowerConwayExponentAtIndex n ⊤ = 0 := by + rfl + +@[simp] +theorem finitePowerConwayExponentAtIndex_coe (n : ℕ) (p : FiniteLex n) : + finitePowerConwayExponentAtIndex n (p : ConwayIndex n) = + (finitePowerConwayExponent n p : ℝ) := by + rfl + +theorem finitePowerConwayExponentAtIndex_strictAnti (n : ℕ) : + StrictAnti (finitePowerConwayExponentAtIndex n) := by + intro p q hpq + induction p using WithTop.recTopCoe with + | top => exact (not_lt_of_ge le_top hpq).elim + | coe p => + induction q using WithTop.recTopCoe with + | top => + change (0 : Surreal) < (finitePowerConwayExponent n p : ℝ) + exact_mod_cast finitePowerConwayExponent_pos n p + | coe q => + change ((finitePowerConwayExponent n q : ℝ) : Surreal) < + (finitePowerConwayExponent n p : ℝ) + exact_mod_cast finitePowerConwayExponent_strictAnti n + (WithTop.coe_lt_coe.mp hpq) + +/-- The coefficient function of the `n`-th Conway normal form. -/ +def finitePowerCoefficient (n : ℕ) (i : Surreal.{0}) : ℝ := + by + classical + exact if i ∈ Set.range (finitePowerConwayExponentAtIndex n) then 1 else 0 + +private theorem support_finitePowerCoefficient (n : ℕ) : + Function.support (finitePowerCoefficient n) = + Set.range (finitePowerConwayExponentAtIndex n) := by + classical + ext i + simp [Function.support, finitePowerCoefficient] + +/-- The coefficient support is a small set. -/ +theorem small_support_finitePowerCoefficient (n : ℕ) : + Small.{0} (Function.support (finitePowerCoefficient n)) := by + rw [support_finitePowerCoefficient] + infer_instance + +/-- The coefficient support is reverse well-ordered. -/ +theorem wellFoundedOn_support_finitePowerCoefficient (n : ℕ) : + (Function.support (finitePowerCoefficient n)).WellFoundedOn (· > ·) := by + rw [support_finitePowerCoefficient, Set.wellFoundedOn_range] + convert wellFounded_lt (α := ConwayIndex n) using 1 + ext p q + exact (finitePowerConwayExponentAtIndex_strictAnti n).lt_iff_gt + +/-- The coefficient-one Conway normal form of support type `ω ^ n + 1`. -/ +def finitePowerNormalForm (n : ℕ) : SurrealHahnSeries.{0} := + SurrealHahnSeries.mk (finitePowerCoefficient n) + (small_support_finitePowerCoefficient n) + (wellFoundedOn_support_finitePowerCoefficient n) + +@[simp] +theorem finitePowerNormalForm_coeff (n : ℕ) (i : Surreal) : + (finitePowerNormalForm n).coeff i = finitePowerCoefficient n i := by + rw [finitePowerNormalForm, SurrealHahnSeries.coeff_mk, finitePowerCoefficient] + +@[simp] +theorem finitePowerNormalForm_support (n : ℕ) : + (finitePowerNormalForm n).support = + Set.range (finitePowerConwayExponentAtIndex n) := by + rw [finitePowerNormalForm, SurrealHahnSeries.support_mk, + support_finitePowerCoefficient] + +/-- The `n`-th Conway normal form has length exactly `ω ^ n + 1`. -/ +theorem finitePowerNormalForm_length (n : ℕ) : + (finitePowerNormalForm n).length = + (Ordinal.omega0 : Ordinal.{0}) ^ (n : Ordinal.{0}) + 1 := by + let f : ConwayIndex n → Surrealᵒᵈ := + fun p ↦ OrderDual.toDual (finitePowerConwayExponentAtIndex n p) + have hf : StrictMono f := by + intro p q hpq + exact finitePowerConwayExponentAtIndex_strictAnti n hpq + let eRange : ConwayIndex n ≃o Set.range f := hf.orderIso f + let eSupport : (finitePowerNormalForm n).support ≃ Set.range f := { + toFun x := ⟨OrderDual.toDual x.1, by + have hx : x.1 ∈ Set.range (finitePowerConwayExponentAtIndex n) := by + rw [← finitePowerNormalForm_support] + exact x.2 + obtain ⟨p, hp⟩ := hx + exact ⟨p, congrArg OrderDual.toDual hp⟩⟩ + invFun x := ⟨OrderDual.ofDual x.1, by + rw [finitePowerNormalForm_support] + obtain ⟨p, hp⟩ := x.2 + exact ⟨p, congrArg OrderDual.ofDual hp⟩⟩ + left_inv x := Subtype.ext rfl + right_inv x := Subtype.ext rfl } + let eSupportRel : + (· > · : (finitePowerNormalForm n).support → + (finitePowerNormalForm n).support → Prop) ≃r + (· < · : Set.range f → Set.range f → Prop) := { + toEquiv := eSupport + map_rel_iff' := by intro x y; rfl } + let e : + (· > · : (finitePowerNormalForm n).support → + (finitePowerNormalForm n).support → Prop) ≃r + (· < · : ConwayIndex n → ConwayIndex n → Prop) := + eSupportRel.trans eRange.symm.toRelIsoLT + have htype : + Ordinal.type (α := (finitePowerNormalForm n).support) (· > ·) = + Ordinal.lift.{1, 0} + (Ordinal.type ((· < ·) : ConwayIndex n → ConwayIndex n → Prop)) := by + simpa only [Ordinal.lift_id'] using e.ordinal_lift_type_eq + have hsupport := SurrealHahnSeries.type_support (finitePowerNormalForm n) + rw [htype, typeLT_conwayIndex] at hsupport + exact Ordinal.lift_inj.mp hsupport.symm + +theorem finitePowerNormalForm_coeff_exponent (n : ℕ) (p : FiniteLex n) : + (finitePowerNormalForm n).coeff (finitePowerConwayExponent n p : ℝ) = 1 := by + classical + rw [finitePowerNormalForm_coeff, finitePowerCoefficient, ite_eq_left] + exact ⟨(↑p : ConwayIndex n), rfl⟩ + +theorem finitePowerNormalForm_coeff_zero (n : ℕ) : + (finitePowerNormalForm n).coeff 0 = 1 := by + classical + rw [finitePowerNormalForm_coeff, finitePowerCoefficient, ite_eq_left] + exact ⟨⊤, rfl⟩ + +private theorem finitePowerNormalForm_support_nonnegative (n : ℕ) : + (finitePowerNormalForm n).support ⊆ Set.Ici 0 := by + rw [finitePowerNormalForm_support] + rintro i ⟨p, rfl⟩ + induction p using WithTop.recTopCoe with + | top => exact Set.mem_Ici.mpr (le_refl (0 : Surreal)) + | coe p => + rw [Set.mem_Ici] + change (0 : Surreal) ≤ (finitePowerConwayExponent n p : ℝ) + exact_mod_cast (finitePowerConwayExponent_pos n p).le + +/-- The `n`-th coefficient-one normal form as an omnific integer. -/ +def finitePowerOz (n : ℕ) : Oz.OmnificInteger.{0} := + ⟨finitePowerNormalForm n, by + rw [Oz.mem_omnificIntegers] + exact ⟨finitePowerNormalForm_support_nonnegative n, + ⟨1, by simpa using (finitePowerNormalForm_coeff_zero n).symm⟩⟩⟩ + +@[simp] +theorem finitePowerOz_val (n : ℕ) : + (finitePowerOz n).1 = finitePowerNormalForm n := by + rfl + +theorem finitePowerOz_support (n : ℕ) : + (finitePowerOz n).1.support = + Set.range (finitePowerConwayExponentAtIndex n) := by + rw [finitePowerOz_val, finitePowerNormalForm_support] + +/-- The `n`-th member of the family has Conway length exactly `ω ^ n + 1`. -/ +theorem finitePowerOz_length (n : ℕ) : + (finitePowerOz n).1.length = + (Ordinal.omega0 : Ordinal.{0}) ^ (n : Ordinal.{0}) + 1 := by + rw [finitePowerOz_val, finitePowerNormalForm_length] + +/-- Distinct natural numbers give distinct omnific integers in the family. -/ +theorem finitePowerOz_injective : Function.Injective finitePowerOz := by + intro m n hmn + have hlength := congrArg (fun x : Oz.OmnificInteger ↦ x.1.length) hmn + rw [finitePowerOz_length, finitePowerOz_length] at hlength + change Order.succ (Ordinal.omega0 ^ (m : Ordinal)) = + Order.succ (Ordinal.omega0 ^ (n : Ordinal)) at hlength + have hpower := Order.succ_injective hlength + have hexponent := + (Ordinal.opow_right_inj Ordinal.one_lt_omega0).mp hpower + exact_mod_cast hexponent + +/-- Subtracting one removes the constant exponent from the `n`-th normal form. -/ +theorem zero_not_mem_finitePowerOz_sub_one_support (n : ℕ) : + 0 ∉ ((finitePowerOz n).1 - 1).support := by + rw [SurrealHahnSeries.mem_support_iff, + SurrealHahnSeries.coeff_sub_apply, finitePowerOz_val, + finitePowerNormalForm_coeff_zero, + Oz.one_eq_single_zero, + SurrealHahnSeries.coeff_single_self] + norm_num + +/-- No member of the family is an ordinary integer. -/ +theorem finitePowerOz_not_isOrdinaryInteger (n : ℕ) : + ¬ Oz.IsOrdinaryInteger (finitePowerOz n) := by + rw [Oz.IsOrdinaryInteger] + rintro ⟨z, hz⟩ + let p := finitePowerZeroIndex n + let e : Surreal := (finitePowerConwayExponent n p : ℝ) + have he0 : e ≠ 0 := by + change ((finitePowerConwayExponent n p : ℝ) : Surreal) ≠ 0 + exact_mod_cast (finitePowerConwayExponent_pos n p).ne' + have hcoeff := congrArg (fun q : SurrealHahnSeries ↦ q.coeff e) hz + have hleft : (finitePowerOz n).1.coeff e = 1 := by + rw [finitePowerOz_val] + exact finitePowerNormalForm_coeff_exponent n p + have hright : (z : SurrealHahnSeries).coeff e = 0 := by + rw [Oz.intCast_eq_single_zero] + exact SurrealHahnSeries.coeff_single_of_ne he0.symm _ + rw [hleft, hright] at hcoeff + norm_num at hcoeff + +/-- Every member of the family is reduced. -/ +theorem finitePowerOz_isReduced (n : ℕ) : + Oz.IsReduced (finitePowerOz n) := by + rw [Oz.IsReduced] + constructor + · intro hzero + apply finitePowerOz_not_isOrdinaryInteger n + refine ⟨0, ?_⟩ + rw [hzero] + rw [Oz.intCast_eq_single_zero] + norm_num + · refine ⟨0, ?_⟩ + intro i hi + have hiSupport := hi.1 + rw [finitePowerOz_val, finitePowerNormalForm_support] at hiSupport + obtain ⟨p, hp⟩ := hiSupport + induction p using WithTop.recTopCoe with + | top => + simp only [finitePowerConwayExponentAtIndex] at hp + have hi0 : i = 0 := hp.symm + subst i + exact (zero_not_mem_finitePowerOz_sub_one_support n hi.2).elim + | coe p => + change ArchimedeanClass.mk i = 0 + rw [← hp] + exact Surreal.mk_realCast (finitePowerConwayExponent_pos n p).ne' + +universe w + +private theorem omega_opow_nat_add_one_lt_omega_opow_omega (n : ℕ) : + (Ordinal.omega0 : Ordinal.{w}) ^ (n : Ordinal.{w}) + 1 < + (Ordinal.omega0 : Ordinal.{w}) ^ (Ordinal.omega0 : Ordinal.{w}) := by + cases n with + | zero => + rw [Nat.cast_zero, Ordinal.opow_zero] + calc + (1 : Ordinal.{w}) + 1 = 2 := by norm_num + _ < Ordinal.omega0 := Ordinal.natCast_lt_omega0 2 + _ = Ordinal.omega0 ^ (1 : Ordinal.{w}) := by rw [Ordinal.opow_one] + _ < Ordinal.omega0 ^ Ordinal.omega0 := + (Ordinal.opow_lt_opow_iff_right Ordinal.one_lt_omega0).2 + Ordinal.one_lt_omega0 + | succ n => + have hw : (1 : Ordinal.{w}) < + Ordinal.omega0 ^ ((n + 1 : ℕ) : Ordinal.{w}) := + (Ordinal.one_lt_opow).2 ⟨Ordinal.one_lt_omega0, by simp⟩ + simpa only [mul_one] using + (Ordinal.opow_mul_add_lt_opow + (b := (Ordinal.omega0 : Ordinal.{w})) + (u := ((n + 1 : ℕ) : Ordinal.{w})) + (v := 1) (w := 1) (x := Ordinal.omega0) + Ordinal.one_lt_omega0 hw (Ordinal.natCast_lt_omega0 (n + 1))) + +private theorem lift_omega0_opow_natCast (n : ℕ) : + Ordinal.lift.{1, 0} ((Ordinal.omega0 : Ordinal.{0}) ^ (n : Ordinal)) = + (Ordinal.omega0 : Ordinal.{1}) ^ (n : Ordinal) := by + rw [Ordinal.opow_natCast, Ordinal.opow_natCast] + induction n with + | zero => simp + | succ n ih => simp [pow_succ, Ordinal.lift_mul, ih] + +/-- Every member of the family has Conway length below `ω ^ ω`. -/ +theorem finitePowerOz_hasFiniteDegree (n : ℕ) : + Oz.HasFiniteDegree (finitePowerOz n) := by + rw [Oz.HasFiniteDegree, finitePowerOz_val, + finitePowerNormalForm_length, Ordinal.lift_add, Ordinal.lift_one, + lift_omega0_opow_natCast] + exact omega_opow_nat_add_one_lt_omega_opow_omega n + +/-- Every coefficient-one omnific integer `finitePowerOz n` is primal. -/ +def PrimalFamily : Prop := + ∀ n : ℕ, IsPrimal (finitePowerOz n) + +/- +## Formal proof + +Proof module: `Support.FinitePowerFamilyProof`. + +* `PrimalFamily` → `PrimalFamily.proof` +-/ + +/-- Twice the `n`-th normal form. -/ +def finitePowerFoil (n : ℕ) : Oz.OmnificInteger := + 2 * finitePowerOz n + +@[simp] +theorem finitePowerFoil_val (n : ℕ) : + (finitePowerFoil n).1 = 2 * finitePowerNormalForm n := by + rfl + +/-- Doubling all nonzero coefficients leaves the exponent support unchanged. -/ +theorem finitePowerFoil_support (n : ℕ) : + (finitePowerFoil n).1.support = (finitePowerOz n).1.support := by + rw [finitePowerFoil_val, finitePowerOz_val, two_mul] + ext i + simp only [SurrealHahnSeries.mem_support_iff, + SurrealHahnSeries.coeff_add_apply] + constructor + · intro h hzero + apply h + rw [hzero, zero_add] + · intro h hsum + apply h + linarith + +/-- The doubled normal form is not reduced: its constant exponent survives subtraction by one. -/ +theorem finitePowerFoil_not_isReduced (n : ℕ) : + ¬ Oz.IsReduced (finitePowerFoil n) := by + rw [Oz.IsReduced] + rintro ⟨_, c, hc⟩ + let p := finitePowerZeroIndex n + let e : Surreal := (finitePowerConwayExponent n p : ℝ) + have he0 : e ≠ 0 := by + change ((finitePowerConwayExponent n p : ℝ) : Surreal) ≠ 0 + exact_mod_cast (finitePowerConwayExponent_pos n p).ne' + have hzeroFoil : 0 ∈ (finitePowerFoil n).1.support := by + rw [finitePowerFoil_support, finitePowerOz_support] + exact ⟨⊤, rfl⟩ + have hzeroSub : 0 ∈ ((finitePowerFoil n).1 - 1).support := by + rw [SurrealHahnSeries.mem_support_iff, + SurrealHahnSeries.coeff_sub_apply, finitePowerFoil_val, two_mul, + SurrealHahnSeries.coeff_add_apply, finitePowerNormalForm_coeff_zero, + Oz.one_eq_single_zero, + SurrealHahnSeries.coeff_single_self] + norm_num + have heFoil : e ∈ (finitePowerFoil n).1.support := by + rw [finitePowerFoil_support, finitePowerOz_support] + exact ⟨(↑p : ConwayIndex n), rfl⟩ + have hone : (1 : SurrealHahnSeries).coeff e = 0 := by + rw [Oz.one_eq_single_zero] + exact SurrealHahnSeries.coeff_single_of_ne he0.symm _ + have heSub : e ∈ ((finitePowerFoil n).1 - 1).support := by + rw [SurrealHahnSeries.mem_support_iff, + SurrealHahnSeries.coeff_sub_apply, finitePowerFoil_val, two_mul, + SurrealHahnSeries.coeff_add_apply, + finitePowerNormalForm_coeff_exponent, hone] + norm_num + have hclassZero := hc ⟨hzeroFoil, hzeroSub⟩ + have hclassE := hc ⟨heFoil, heSub⟩ + change ArchimedeanClass.mk (0 : Surreal) = c at hclassZero + change ArchimedeanClass.mk e = c at hclassE + have hmkE : ArchimedeanClass.mk e = 0 := by + change ArchimedeanClass.mk ((finitePowerConwayExponent n p : ℝ) : Surreal) = 0 + exact Surreal.mk_realCast (finitePowerConwayExponent_pos n p).ne' + have hmkZero : ArchimedeanClass.mk (0 : Surreal) ≠ 0 := by simp + apply hmkZero + calc + ArchimedeanClass.mk (0 : Surreal) = c := hclassZero + _ = ArchimedeanClass.mk e := hclassE.symm + _ = 0 := hmkE + +end ConwayRefinement.Standalone.Oz.FinitePowerFamily diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/Support/FinitePowerFamilyProof.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/Support/FinitePowerFamilyProof.lean new file mode 100644 index 0000000000..51fe1d2bf7 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/Support/FinitePowerFamilyProof.lean @@ -0,0 +1,28 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Support.FinitePowerFamily +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Examples.OmnificFactorizationProof + +/-! +# Primality of the finite-power family + +Every `finitePowerOz n` is nonordinary, reduced, and has Conway length below `ω ^ ω`. +Finite-degree primality for omnific integers therefore applies to every natural number `n`. +-/ + +public noncomputable section + +namespace ConwayRefinement.Standalone.Oz.FinitePowerFamily.PrimalFamily + +/-- Every coefficient-one omnific integer `finitePowerOz n` is primal. -/ +theorem proof : FinitePowerFamily.PrimalFamily := by + rw [FinitePowerFamily.PrimalFamily] + intro n + exact Oz.EveryOmnificIntegerIsPrimal.proof (FinitePowerFamily.finitePowerOz n) + +end ConwayRefinement.Standalone.Oz.FinitePowerFamily.PrimalFamily diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/Support/OmegaOmegaBoundary.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/Support/OmegaOmegaBoundary.lean new file mode 100644 index 0000000000..3022e59e69 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/Support/OmegaOmegaBoundary.lean @@ -0,0 +1,515 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Support.FinitePowerFamily +public import Mathlib.Data.Sigma.Order + +import Mathlib.SetTheory.Ordinal.Family +import Mathlib.Tactic.Linarith +import Mathlib.Tactic.NormNum + +/-! +# An omnific integer at the `ω ^ ω` boundary + +Let `BoundaryIndex` be the lexicographic sum over `n : ℕ` of the natural tuples `FiniteLex n`. +Its order type is + +`∑ n < ω, ω ^ n = ω ^ ω`. + +The `n`-th tuple block is placed in the negative real interval + +`[-(1 / 3) ^ n, -(1 / 3) ^ (n + 1))`. + +These intervals occur consecutively and approach zero. Negating gives a strictly decreasing +sequence of positive Conway exponents. The coefficient-one normal form on this sequence is a +purely infinite omnific integer: its coefficient at exponent zero is zero. + +The resulting omnific integer is nonordinary and reduced, and its Conway length is exactly +`ω ^ ω`. Thus it lies at, rather than below, the strict length bound in the finite-degree +primality theorem. No primality or nonprimality assertion is made about this boundary element. + +## References + +* J. H. Conway, *On Numbers and Games*, 2nd ed., A K Peters, 2001. +* S. L'Innocente, V. Mantova, *A factorisation theory for generalised power series and omnific + integers*, Adv. Math. 442 (2024) 109513, cited as [LM24]. +-/ + +@[expose] public noncomputable section + +namespace ConwayRefinement.Standalone.Oz.OmegaOmegaBoundary + +open Ordinal +open ConwayRefinement.Standalone.Oz.FinitePowerFamily + +/-- The lexicographic sum of the finite-tuple orders of types `ω ^ n`. -/ +abbrev BoundaryIndex := Σₗ n : ℕ, FiniteLex n + +instance : WellFoundedLT BoundaryIndex := by + change WellFounded + (Sigma.Lex (· < ·) fun n => (· < · : FiniteLex n → FiniteLex n → Prop)) + let e := Equiv.psigmaEquivSigma (fun n : ℕ => FiniteLex n) + let f : + (Sigma.Lex (· < ·) fun n => (· < · : FiniteLex n → FiniteLex n → Prop)) ↪r + (PSigma.Lex (· < ·) fun n => (· < · : FiniteLex n → FiniteLex n → Prop)) := { + toFun := e.symm + inj' := e.symm.injective + map_rel_iff' := by + rintro ⟨i, a⟩ ⟨j, b⟩ + simp only [PSigma.lex_iff, Sigma.lex_iff] + rfl } + exact f.wellFounded + (WellFounded.psigma_lex wellFounded_lt fun n => (finiteLexWellFoundedLT n)) + +private theorem fiber_type_le_boundary (n : ℕ) : + (Ordinal.omega0 : Ordinal) ^ (n : Ordinal) ≤ + Ordinal.type ((· < ·) : BoundaryIndex → BoundaryIndex → Prop) := by + rw [← typeLT_finiteLex] + apply Ordinal.type_le_iff'.mpr + refine ⟨{ + toFun := fun p => ⟨n, p⟩ + inj' := by intro p q h; cases h; rfl + map_rel_iff' := by + intro p q + change Sigma.Lex (· < ·) (fun n => (· < ·)) ⟨n, p⟩ ⟨n, q⟩ ↔ p < q + exact ⟨fun h => by cases h with + | left _ _ hn => exact (lt_irrefl n hn).elim + | right _ _ hpq => exact hpq, + fun hpq => Sigma.Lex.right p q hpq⟩ }⟩ + +private theorem omegaPowOmega_le_boundaryType : + (Ordinal.omega0 : Ordinal) ^ Ordinal.omega0 ≤ + Ordinal.type ((· < ·) : BoundaryIndex → BoundaryIndex → Prop) := by + rw [Ordinal.opow_limit Ordinal.omega0_ne_zero Ordinal.isSuccLimit_omega0] + apply Ordinal.iSup_le + intro i + obtain ⟨n, hn⟩ := Ordinal.lt_omega0.mp i.2 + rw [hn] + exact fiber_type_le_boundary n + +private def boundaryRank (x : BoundaryIndex) : Ordinal := + let p := ofLex x + Ordinal.omega0 ^ ((p.1 + 1 : ℕ) : Ordinal) + + Ordinal.typein ((· < ·) : FiniteLex p.1 → FiniteLex p.1 → Prop) p.2 + +@[simp] +private theorem boundaryRank_mk (n : ℕ) (p : FiniteLex n) : + boundaryRank (toLex ⟨n, p⟩) = + Ordinal.omega0 ^ ((n + 1 : ℕ) : Ordinal) + + Ordinal.typein ((· < ·) : FiniteLex n → FiniteLex n → Prop) p := by + rfl + +private theorem typein_finiteLex_lt_opow (n : ℕ) (p : FiniteLex n) : + Ordinal.typein ((· < ·) : FiniteLex n → FiniteLex n → Prop) p < + Ordinal.omega0 ^ (n : Ordinal) := by + rw [← typeLT_finiteLex] + exact Ordinal.typein_lt_type _ p + +private theorem boundaryRank_lt_stage (n : ℕ) (p : FiniteLex n) : + boundaryRank (toLex ⟨n, p⟩) < + Ordinal.omega0 ^ ((n + 2 : ℕ) : Ordinal) := by + rw [boundaryRank_mk] + simpa only [mul_one] using + (Ordinal.opow_mul_add_lt_opow + (b := Ordinal.omega0) + (u := ((n + 1 : ℕ) : Ordinal)) + (v := 1) + (w := Ordinal.typein ((· < ·) : FiniteLex n → FiniteLex n → Prop) p) + (x := ((n + 2 : ℕ) : Ordinal)) + Ordinal.one_lt_omega0 + ((typein_finiteLex_lt_opow n p).trans + ((Ordinal.opow_lt_opow_iff_right Ordinal.one_lt_omega0).mpr (by + exact_mod_cast Nat.lt_succ_self n))) + (by exact_mod_cast (show n + 1 < n + 2 by omega))) + +private theorem boundaryRank_lt_omegaPowOmega (x : BoundaryIndex) : + boundaryRank x < Ordinal.omega0 ^ Ordinal.omega0 := by + induction x using Lex.rec with + | h x => + obtain ⟨n, p⟩ := x + exact (boundaryRank_lt_stage n p).trans + ((Ordinal.opow_lt_opow_iff_right Ordinal.one_lt_omega0).mpr + (Ordinal.natCast_lt_omega0 (n + 2))) + +private theorem boundaryRank_strictMono : StrictMono boundaryRank := by + intro x y hxy + induction x using Lex.rec with + | h x => + induction y using Lex.rec with + | h y => + obtain ⟨n, p⟩ := x + obtain ⟨m, q⟩ := y + change Sigma.Lex (· < ·) (fun n => (· < ·)) ⟨n, p⟩ ⟨m, q⟩ at hxy + cases hxy with + | left _ _ hnm => + apply (boundaryRank_lt_stage n p).trans_le + calc + Ordinal.omega0 ^ ((n + 2 : ℕ) : Ordinal) ≤ + Ordinal.omega0 ^ ((m + 1 : ℕ) : Ordinal) := + Ordinal.opow_le_opow_right Ordinal.omega0_pos (by + exact_mod_cast (show n + 2 ≤ m + 1 by omega)) + _ ≤ boundaryRank (toLex ⟨m, q⟩) := by + rw [boundaryRank_mk] + exact le_add_right (le_refl _) + | right _ _ hpq => + rw [boundaryRank_mk, boundaryRank_mk] + exact add_lt_add_right + ((Ordinal.typein_lt_typein + ((· < ·) : FiniteLex n → FiniteLex n → Prop)).mpr hpq) _ + +private def boundaryRankToType (x : BoundaryIndex) : + (Ordinal.omega0 ^ Ordinal.omega0).ToType := + Ordinal.enum + ((· < ·) : + (Ordinal.omega0 ^ Ordinal.omega0).ToType → + (Ordinal.omega0 ^ Ordinal.omega0).ToType → Prop) + ⟨boundaryRank x, by + rw [Ordinal.type_toType] + exact boundaryRank_lt_omegaPowOmega x⟩ + +private theorem boundaryRankToType_strictMono : StrictMono boundaryRankToType := by + intro x y hxy + unfold boundaryRankToType + apply (Ordinal.enum_lt_enum + (r := ((· < ·) : + (Ordinal.omega0 ^ Ordinal.omega0).ToType → + (Ordinal.omega0 ^ Ordinal.omega0).ToType → Prop))).mpr + exact boundaryRank_strictMono hxy + +private theorem boundaryType_le_omegaPowOmega : + Ordinal.type ((· < ·) : BoundaryIndex → BoundaryIndex → Prop) ≤ + Ordinal.omega0 ^ Ordinal.omega0 := by + rw [← Ordinal.type_toType (Ordinal.omega0 ^ Ordinal.omega0)] + apply Ordinal.type_le_iff'.mpr + exact ⟨(OrderEmbedding.ofStrictMono boundaryRankToType + boundaryRankToType_strictMono).ltEmbedding⟩ + +/-- The lexicographic sum of the finite-tuple orders has order type `ω ^ ω`. -/ +theorem typeLT_boundaryIndex : + Ordinal.type ((· < ·) : BoundaryIndex → BoundaryIndex → Prop) = + Ordinal.omega0 ^ Ordinal.omega0 := by + exact le_antisymm boundaryType_le_omegaPowOmega omegaPowOmega_le_boundaryType + +private theorem boundary_scale_pos : 0 < scale := by + norm_num [scale] + +private theorem boundary_scale_le_one : scale ≤ 1 := by + norm_num [scale] + +/-- The increasing negative real sequence used before reversing the Conway exponents. -/ +def boundarySignedExponent (x : BoundaryIndex) : ℝ := + match ofLex x with + | ⟨n, p⟩ => + -scale ^ (n + 1) + + (4 / 9 : ℝ) * scale ^ n * finitePowerExponent n p + +@[simp] +theorem boundarySignedExponent_mk (n : ℕ) (p : FiniteLex n) : + boundarySignedExponent (toLex ⟨n, p⟩) = + -scale ^ (n + 1) + + (4 / 9 : ℝ) * scale ^ n * finitePowerExponent n p := by + rfl + +private theorem boundarySignedExponent_lt_blockLimit (n : ℕ) (p : FiniteLex n) : + boundarySignedExponent (toLex ⟨n, p⟩) < -scale ^ (n + 1) := by + have hp := finitePowerExponent_neg n p + have hs : 0 < (4 / 9 : ℝ) * scale ^ n := + mul_pos (by norm_num) (pow_pos boundary_scale_pos n) + rw [boundarySignedExponent_mk] + nlinarith + +private theorem boundarySignedExponent_blockLowerBound (n : ℕ) (p : FiniteLex n) : + -scale ^ n ≤ boundarySignedExponent (toLex ⟨n, p⟩) := by + have hp := finitePowerExponent_lowerBound n p + have hs : 0 ≤ (4 / 9 : ℝ) * scale ^ n := + (mul_pos (by norm_num) (pow_pos boundary_scale_pos n)).le + have hmul := mul_le_mul_of_nonneg_left hp hs + rw [boundarySignedExponent_mk, pow_succ] + norm_num [scale] at hmul ⊢ + nlinarith + +/-- The `n`-th block lies in the interval +`[-scale ^ n, -scale ^ (n + 1))`. -/ +theorem boundarySignedExponent_mem_block (n : ℕ) (p : FiniteLex n) : + boundarySignedExponent (toLex ⟨n, p⟩) ∈ + Set.Ico (-scale ^ n) (-scale ^ (n + 1)) := by + exact ⟨boundarySignedExponent_blockLowerBound n p, + boundarySignedExponent_lt_blockLimit n p⟩ + +/-- Every signed exponent is negative. -/ +theorem boundarySignedExponent_neg (x : BoundaryIndex) : + boundarySignedExponent x < 0 := by + induction x using Lex.rec with + | h x => + obtain ⟨n, p⟩ := x + exact (boundarySignedExponent_lt_blockLimit n p).trans + (neg_lt_zero.mpr (pow_pos boundary_scale_pos _)) + +/-- The signed exponent sequence preserves the boundary-index order. -/ +theorem boundarySignedExponent_strictMono : StrictMono boundarySignedExponent := by + intro x y hxy + induction x using Lex.rec with + | h x => + induction y using Lex.rec with + | h y => + obtain ⟨n, p⟩ := x + obtain ⟨m, q⟩ := y + change Sigma.Lex (· < ·) (fun n => (· < ·)) ⟨n, p⟩ ⟨m, q⟩ at hxy + cases hxy with + | left _ _ hnm => + apply (boundarySignedExponent_lt_blockLimit n p).trans_le + calc + -scale ^ (n + 1) ≤ -scale ^ m := by + exact neg_le_neg + (pow_le_pow_of_le_one boundary_scale_pos.le + boundary_scale_le_one (by omega)) + _ ≤ boundarySignedExponent (toLex ⟨m, q⟩) := + boundarySignedExponent_blockLowerBound m q + | right _ _ hpq => + rw [boundarySignedExponent_mk, boundarySignedExponent_mk] + have hs : 0 < (4 / 9 : ℝ) * scale ^ n := + mul_pos (by norm_num) (pow_pos boundary_scale_pos n) + exact add_lt_add_right + (mul_lt_mul_of_pos_left (finitePowerExponent_strictMono n hpq) hs) _ + +/-- The positive real Conway exponent obtained by reversing the signed exponent sequence. -/ +def boundaryConwayExponent (x : BoundaryIndex) : ℝ := + -boundarySignedExponent x + +@[simp] +theorem boundaryConwayExponent_apply (x : BoundaryIndex) : + boundaryConwayExponent x = -boundarySignedExponent x := by + rfl + +/-- Every boundary Conway exponent is positive. -/ +theorem boundaryConwayExponent_pos (x : BoundaryIndex) : + 0 < boundaryConwayExponent x := by + exact neg_pos.mpr (boundarySignedExponent_neg x) + +/-- The boundary Conway exponents strictly decrease along the index order. -/ +theorem boundaryConwayExponent_strictAnti : StrictAnti boundaryConwayExponent := by + intro x y hxy + exact neg_lt_neg (boundarySignedExponent_strictMono hxy) + +/-- The positive Conway exponents in the `n`-th block lie in +`(scale ^ (n + 1), scale ^ n]`. -/ +theorem boundaryConwayExponent_mem_block (n : ℕ) (p : FiniteLex n) : + boundaryConwayExponent (toLex ⟨n, p⟩) ∈ + Set.Ioc (scale ^ (n + 1)) (scale ^ n) := by + rw [Set.mem_Ioc, boundaryConwayExponent_apply] + exact ⟨by + simpa using neg_lt_neg (boundarySignedExponent_lt_blockLimit n p), + by simpa using neg_le_neg (boundarySignedExponent_blockLowerBound n p)⟩ + +/-- The surreal Conway exponent associated to an index. -/ +def boundaryExponentAtIndex (x : BoundaryIndex) : Surreal.{0} := + (boundaryConwayExponent x : ℝ) + +/-- Every surreal boundary exponent is positive. -/ +theorem boundaryExponentAtIndex_pos (x : BoundaryIndex) : + 0 < boundaryExponentAtIndex x := by + simpa only [boundaryExponentAtIndex, Real.toSurreal_pos_iff] using + boundaryConwayExponent_pos x + +/-- The surreal boundary exponents strictly decrease along the index order. -/ +theorem boundaryExponentAtIndex_strictAnti : StrictAnti boundaryExponentAtIndex := by + intro x y hxy + simpa only [boundaryExponentAtIndex, Real.toSurreal_lt_iff] using + boundaryConwayExponent_strictAnti hxy + +/-- The coefficient function equal to one exactly on the boundary exponents. -/ +def boundaryCoefficient (i : Surreal.{0}) : ℝ := + by + classical + exact if i ∈ Set.range boundaryExponentAtIndex then 1 else 0 + +private theorem support_boundaryCoefficient : + Function.support boundaryCoefficient = Set.range boundaryExponentAtIndex := by + classical + ext i + simp [Function.support, boundaryCoefficient] + +/-- The boundary coefficient support is a small set. -/ +theorem small_support_boundaryCoefficient : + Small.{0} (Function.support boundaryCoefficient) := by + rw [support_boundaryCoefficient] + infer_instance + +/-- The boundary coefficient support is reverse well-ordered. -/ +theorem wellFoundedOn_support_boundaryCoefficient : + (Function.support boundaryCoefficient).WellFoundedOn (· > ·) := by + rw [support_boundaryCoefficient, Set.wellFoundedOn_range] + convert wellFounded_lt (α := BoundaryIndex) using 1 + ext x y + exact boundaryExponentAtIndex_strictAnti.lt_iff_gt + +/-- The coefficient-one Conway normal form whose support has order type `ω ^ ω`. -/ +def boundaryNormalForm : SurrealHahnSeries.{0} := + SurrealHahnSeries.mk boundaryCoefficient + small_support_boundaryCoefficient + wellFoundedOn_support_boundaryCoefficient + +@[simp] +theorem boundaryNormalForm_coeff (i : Surreal.{0}) : + boundaryNormalForm.coeff i = boundaryCoefficient i := by + rw [boundaryNormalForm, SurrealHahnSeries.coeff_mk, boundaryCoefficient] + +@[simp] +theorem boundaryNormalForm_support : + boundaryNormalForm.support = Set.range boundaryExponentAtIndex := by + rw [boundaryNormalForm, SurrealHahnSeries.support_mk, support_boundaryCoefficient] + +/-- The boundary normal form has Conway length exactly `ω ^ ω`. -/ +theorem boundaryNormalForm_length : + boundaryNormalForm.length = Ordinal.omega0 ^ Ordinal.omega0 := by + let f : BoundaryIndex → Surrealᵒᵈ := + fun x ↦ OrderDual.toDual (boundaryExponentAtIndex x) + have hf : StrictMono f := by + intro x y hxy + exact boundaryExponentAtIndex_strictAnti hxy + let eRange : BoundaryIndex ≃o Set.range f := hf.orderIso f + let eSupport : boundaryNormalForm.support ≃ Set.range f := { + toFun x := ⟨OrderDual.toDual x.1, by + have hx : x.1 ∈ Set.range boundaryExponentAtIndex := by + rw [← boundaryNormalForm_support] + exact x.2 + obtain ⟨p, hp⟩ := hx + exact ⟨p, congrArg OrderDual.toDual hp⟩⟩ + invFun x := ⟨OrderDual.ofDual x.1, by + rw [boundaryNormalForm_support] + obtain ⟨p, hp⟩ := x.2 + exact ⟨p, congrArg OrderDual.ofDual hp⟩⟩ + left_inv x := Subtype.ext rfl + right_inv x := Subtype.ext rfl } + let eSupportRel : + (· > · : boundaryNormalForm.support → boundaryNormalForm.support → Prop) ≃r + (· < · : Set.range f → Set.range f → Prop) := { + toEquiv := eSupport + map_rel_iff' := by intro x y; rfl } + let e : + (· > · : boundaryNormalForm.support → boundaryNormalForm.support → Prop) ≃r + (· < · : BoundaryIndex → BoundaryIndex → Prop) := + eSupportRel.trans eRange.symm.toRelIsoLT + have htype : + Ordinal.type (α := boundaryNormalForm.support) (· > ·) = + Ordinal.lift.{1, 0} + (Ordinal.type ((· < ·) : BoundaryIndex → BoundaryIndex → Prop)) := by + simpa only [Ordinal.lift_id'] using e.ordinal_lift_type_eq + have hsupport := SurrealHahnSeries.type_support boundaryNormalForm + rw [htype, typeLT_boundaryIndex] at hsupport + exact Ordinal.lift_inj.mp hsupport.symm + +theorem boundaryNormalForm_coeff_exponent (x : BoundaryIndex) : + boundaryNormalForm.coeff (boundaryExponentAtIndex x) = 1 := by + classical + rw [boundaryNormalForm_coeff, boundaryCoefficient, ite_eq_left] + exact ⟨x, rfl⟩ + +theorem boundaryNormalForm_coeff_zero : boundaryNormalForm.coeff 0 = 0 := by + classical + rw [boundaryNormalForm_coeff, boundaryCoefficient, ite_eq_right] + rintro ⟨x, hx⟩ + have hxpos := boundaryExponentAtIndex_pos x + rw [hx] at hxpos + exact (lt_irrefl 0 hxpos).elim + +private theorem boundaryNormalForm_support_nonnegative : + boundaryNormalForm.support ⊆ Set.Ici 0 := by + rw [boundaryNormalForm_support] + rintro i ⟨x, rfl⟩ + exact (boundaryExponentAtIndex_pos x).le + +/-- The purely infinite coefficient-one normal form as an omnific integer. -/ +def boundaryOz : Oz.OmnificInteger.{0} := + ⟨boundaryNormalForm, by + rw [Oz.mem_omnificIntegers] + exact ⟨boundaryNormalForm_support_nonnegative, + ⟨0, by simpa using boundaryNormalForm_coeff_zero.symm⟩⟩⟩ + +@[simp] +theorem boundaryOz_val : boundaryOz.1 = boundaryNormalForm := by + rfl + +theorem boundaryOz_support : + boundaryOz.1.support = Set.range boundaryExponentAtIndex := by + rw [boundaryOz_val, boundaryNormalForm_support] + +theorem boundaryOz_coeff_exponent (x : BoundaryIndex) : + boundaryOz.1.coeff (boundaryExponentAtIndex x) = 1 := by + rw [boundaryOz_val, boundaryNormalForm_coeff_exponent] + +theorem boundaryOz_coeff_zero : boundaryOz.1.coeff 0 = 0 := by + rw [boundaryOz_val, boundaryNormalForm_coeff_zero] + +/-- The boundary omnific integer has Conway length exactly `ω ^ ω`. -/ +theorem boundaryOz_length : + boundaryOz.1.length = Ordinal.omega0 ^ Ordinal.omega0 := by + rw [boundaryOz_val, boundaryNormalForm_length] + +/-- The boundary omnific integer is not an integer constant. -/ +theorem boundaryOz_not_isOrdinaryInteger : + ¬ Oz.IsOrdinaryInteger boundaryOz := by + rw [Oz.IsOrdinaryInteger] + rintro ⟨z, hz⟩ + let x : BoundaryIndex := toLex ⟨0, ()⟩ + let e : Surreal := boundaryExponentAtIndex x + have he0 : e ≠ 0 := (boundaryExponentAtIndex_pos x).ne' + have hcoeff := congrArg (fun q : SurrealHahnSeries ↦ q.coeff e) hz + have hleft : boundaryOz.1.coeff e = 1 := by + rw [boundaryOz_val] + exact boundaryNormalForm_coeff_exponent x + have hright : (z : SurrealHahnSeries).coeff e = 0 := by + rw [Oz.intCast_eq_single_zero] + exact SurrealHahnSeries.coeff_single_of_ne he0.symm _ + rw [hleft, hright] at hcoeff + norm_num at hcoeff + +private theorem boundaryOz_ne_zero : boundaryOz ≠ 0 := by + intro hzero + apply boundaryOz_not_isOrdinaryInteger + refine ⟨0, ?_⟩ + rw [hzero, Oz.intCast_eq_single_zero] + norm_num + +/-- The boundary omnific integer is reduced. -/ +theorem boundaryOz_isReduced : Oz.IsReduced boundaryOz := by + rw [Oz.IsReduced] + refine ⟨boundaryOz_ne_zero, 0, ?_⟩ + intro i hi + change ArchimedeanClass.mk i = 0 + have hiSupport := hi.1 + rw [boundaryOz_support] at hiSupport + obtain ⟨x, hx⟩ := hiSupport + rw [← hx, boundaryExponentAtIndex] + exact Surreal.mk_realCast (boundaryConwayExponent_pos x).ne' + +private theorem lift_omega0_opow_natCast_boundary (n : ℕ) : + Ordinal.lift.{1, 0} ((Ordinal.omega0 : Ordinal.{0}) ^ (n : Ordinal)) = + (Ordinal.omega0 : Ordinal.{1}) ^ (n : Ordinal) := by + rw [Ordinal.opow_natCast, Ordinal.opow_natCast] + induction n with + | zero => simp + | succ n ih => simp [pow_succ, Ordinal.lift_mul, ih] + +private theorem omegaPowOmega_le_lift_boundaryOz_length : + (Ordinal.omega0 : Ordinal.{1}) ^ (Ordinal.omega0 : Ordinal.{1}) ≤ + Ordinal.lift.{1, 0} boundaryOz.1.length := by + rw [Ordinal.opow_limit Ordinal.omega0_ne_zero Ordinal.isSuccLimit_omega0] + apply Ordinal.iSup_le + intro i + obtain ⟨n, hn⟩ := Ordinal.lt_omega0.mp i.2 + rw [hn, ← lift_omega0_opow_natCast_boundary] + rw [Ordinal.lift_le, boundaryOz_length] + exact Ordinal.opow_le_opow_right Ordinal.omega0_pos + (Ordinal.natCast_lt_omega0 n).le + +/-- The boundary omnific integer does not satisfy the strict finite-degree inequality. -/ +theorem boundaryOz_not_hasFiniteDegree : ¬ Oz.HasFiniteDegree boundaryOz := by + rw [Oz.HasFiniteDegree] + exact not_lt_of_ge omegaPowOmega_le_lift_boundaryOz_length + +end ConwayRefinement.Standalone.Oz.OmegaOmegaBoundary diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/Support/OmnificFactorizationProof.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/Support/OmnificFactorizationProof.lean new file mode 100644 index 0000000000..399c057781 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/Support/OmnificFactorizationProof.lean @@ -0,0 +1,67 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Examples.OmnificFactorization +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.ConwayRefinementProof +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Support.ConwayNormalForm + +/-! +# Proofs of factorisation statements for omnific integers + +The normal-form equivalence identifies this presentation of `Oz` with the omnific integer +subring. Primality and factorisation therefore pass across the equivalence. +-/ + +universe u + +public noncomputable section + +namespace ConwayRefinement.Standalone.Oz + +namespace NormalFormIdentifiesOmnificIntegers + +/-- Conway's cut definition and the normal-form definition determine the same subring. -/ +theorem of_normalForm : Oz.NormalFormIdentifiesOmnificIntegers.{u} := by + exact normalFormIdentifiesOmnificIntegers + +end NormalFormIdentifiesOmnificIntegers + +namespace EveryOmnificIntegerIsPrimal + +/-- Conway's refinement conjecture implies that every normal-form omnific integer is primal. -/ +theorem of_refinement : Oz.EveryOmnificIntegerIsPrimal.{u} := by + intro x + have hnative : IsPrimal + (normalFormRingEquiv x) := + (conwayConjecture_iff_forall_isPrimal.mp ConwayConjecture.proof) _ + exact (RingEquiv.isPrimal_iff + normalFormRingEquiv x).mp hnative + +end EveryOmnificIntegerIsPrimal + +namespace IrreducibleIsPrime + +/-- Every irreducible omnific integer is prime. -/ +theorem of_primality : Oz.IrreducibleIsPrime.{u} := by + intro x hx + exact hx.prime_of_isPrimal (EveryOmnificIntegerIsPrimal.of_refinement x) + +end IrreducibleIsPrime + +namespace IrreducibleFactorizationsAreUnique + +/-- Irreducible factorisations in `Oz` are unique up to order and units. -/ +theorem of_primality : Oz.IrreducibleFactorizationsAreUnique.{u} := by + intro f g hf hg hfg + exact prime_factors_unique + (fun x hx ↦ IrreducibleIsPrime.of_primality x (hf x hx)) + (fun x hx ↦ IrreducibleIsPrime.of_primality x (hg x hx)) + hfg + +end IrreducibleFactorizationsAreUnique + +end ConwayRefinement.Standalone.Oz diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/Support/OmnificFiniteDegree.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/Support/OmnificFiniteDegree.lean new file mode 100644 index 0000000000..6ac8a3fa3d --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/Support/OmnificFiniteDegree.lean @@ -0,0 +1,66 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Examples.OmnificFactorization +public import LeanPool.ConwayRefinement.CombinatorialGames.NatOrdinal.Pow + +/-! +# Finite-degree predicates for omnific integers + +These predicates state the finite-degree examples in `Examples/`. +-/ + +universe u + +@[expose] public noncomputable section + +namespace ConwayRefinement.Standalone.Oz + +open Ordinal + +/-- An omnific integer is ordinary when its Conway normal form is an integer constant. -/ +def IsOrdinaryInteger (x : OmnificInteger.{u}) : Prop := + ∃ z : ℤ, x.1 = (z : SurrealHahnSeries) + +/-- LM24 reducedness: `x` is nonzero, and the exponents occurring in both `x` and `x - 1` lie in +one Archimedean class. -/ +def IsReduced (x : OmnificInteger.{u}) : Prop := + x ≠ 0 ∧ ∃ c : ArchimedeanClass Surreal, + x.1.support ∩ (x.1 - 1).support ⊆ {i | ArchimedeanClass.mk i = c} + +/-- Every nonordinary reduced omnific integer is primal. -/ +def ReducedIsPrimal : Prop := + ∀ x : OmnificInteger.{u}, ¬ IsOrdinaryInteger x → IsReduced x → IsPrimal x + +/-- The Conway normal form has finite degree when its support order type is below `ω ^ ω`. -/ +def HasFiniteDegree (x : OmnificInteger.{u}) : Prop := + Ordinal.lift.{u + 1, u} x.1.length < + (ω : Ordinal.{u + 1}) ^ (ω : Ordinal.{u + 1}) + +/-- Every irreducible, nonordinary, reduced omnific integer is prime. -/ +def ReducedIrreducibleIsPrime : Prop := + ∀ x : OmnificInteger.{u}, ¬ IsOrdinaryInteger x → IsReduced x → Irreducible x → Prime x + +/-- Every nonordinary reduced omnific integer of finite degree is primal. -/ +def FiniteDegreeIsPrimal : Prop := + ∀ x : OmnificInteger.{u}, ¬ IsOrdinaryInteger x → + IsReduced x → HasFiniteDegree x → IsPrimal x + +/-- Every irreducible, nonordinary, reduced omnific integer of finite degree is prime. -/ +def FiniteDegreeIrreducibleIsPrime : Prop := + ∀ x : OmnificInteger.{u}, ¬ IsOrdinaryInteger x → + IsReduced x → HasFiniteDegree x → Irreducible x → Prime x + +/-- Every irreducible, nonordinary, reduced omnific integer of support order type `ω ^ 2` is +prime. -/ +def DegreeTwoIrreducibleIsPrime : Prop := + ∀ x : OmnificInteger.{u}, ¬ IsOrdinaryInteger x → + IsReduced x → Ordinal.lift.{u + 1, u} x.1.length = + (ω : Ordinal.{u + 1}) ^ (2 : Ordinal.{u + 1}) → + Irreducible x → Prime x + +end ConwayRefinement.Standalone.Oz diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/Support/OmnificIntegers.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/Support/OmnificIntegers.lean new file mode 100644 index 0000000000..ccdd482b4b --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/Support/OmnificIntegers.lean @@ -0,0 +1,266 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.CombinatorialGames.Surreal.HahnSeries.Basic +public import Mathlib.Algebra.Ring.Subring.Defs + +import all LeanPool.ConwayRefinement.CombinatorialGames.Surreal.HahnSeries.Basic + +/-! +# Omnific integers in Conway normal-form coordinates + +CombinatorialGames supplies `SurrealHahnSeries`, the target of Conway normal form. In these +coordinates, the omnific integers are exactly the series whose exponents are nonnegative and whose +constant coefficient is an integer [LM24, §1.1]. + +This module constructs that subring using only Mathlib and CombinatorialGames. It does not assume a +normal-form map from surreals; the statement module next to it formulates the identification with +Conway's cut definition of `Oz`. + +## References + +* S. L'Innocente, V. Mantova, *A factorisation theory for generalised power series and omnific + integers*, Adv. Math. 442 (2024) 109513, , cited + as [LM24]. +-/ + +universe u + +public noncomputable section + +namespace ConwayRefinement.Standalone.Oz + +open Order Set + +private theorem ofLex_coe_mul (x y : SurrealHahnSeries) : + ofLex (x * y).1 = ofLex x.1 * ofLex y.1 := by + with_unfolding_all rfl + +private theorem ofLex_coe_single (p : Surreal) (r : ℝ) : + ofLex (SurrealHahnSeries.single p r).1 = + HahnSeries.single (OrderDual.toDual p) r := by + apply HahnSeries.ext + funext k + rw [HahnSeries.coeff_single] + unfold SurrealHahnSeries.single SurrealHahnSeries.mk + by_cases hk : k = OrderDual.toDual p + · subst k + simp + · have hk' : k.ofDual ≠ p := fun h ↦ hk (by simpa using congrArg OrderDual.toDual h) + simp [hk, hk'] + +private theorem mem_support_ofLex_coe_iff (x : SurrealHahnSeries) (k : Surreal) : + OrderDual.toDual k ∈ (ofLex x.1).support ↔ k ∈ x.support := by + rfl + +private theorem exists_add_eq_of_mem_support_mul + {x y : SurrealHahnSeries.{u}} {k : Surreal} + (hk : k ∈ (x * y).support) : + ∃ p ∈ x.support, ∃ q ∈ y.support, p + q = k := by + have hk' : OrderDual.toDual k ∈ (ofLex (x * y).1).support := + (mem_support_ofLex_coe_iff (x * y) k).2 hk + rw [ofLex_coe_mul] at hk' + obtain ⟨p, hp, q, hq, hpq⟩ := HahnSeries.support_mul_subset hk' + refine ⟨p.ofDual, (mem_support_ofLex_coe_iff x p.ofDual).1 ?_, + q.ofDual, (mem_support_ofLex_coe_iff y q.ofDual).1 ?_, ?_⟩ + · simpa using hp + · simpa using hq + · simpa using congrArg OrderDual.ofDual hpq + +private theorem support_mul_subset_Ici {x y : SurrealHahnSeries} + (hx : x.support ⊆ Ici 0) (hy : y.support ⊆ Ici 0) : + (x * y).support ⊆ Ici 0 := by + intro k hk + obtain ⟨p, hp, q, hq, rfl⟩ := exists_add_eq_of_mem_support_mul hk + rw [mem_Ici] + exact add_nonneg (show 0 ≤ p by simpa only [mem_Ici] using hx hp) + (show 0 ≤ q by simpa only [mem_Ici] using hy hq) + +private theorem single_mul_single (p q : Surreal.{u}) (r s : ℝ) : + SurrealHahnSeries.single p r * SurrealHahnSeries.single q s = + SurrealHahnSeries.single (p + q) (r * s) := by + apply Subtype.ext + rw [← ofLex_inj, ofLex_coe_mul, ofLex_coe_single, ofLex_coe_single, + HahnSeries.single_mul_single, ofLex_coe_single] + congr 2 + +private theorem coeff_mul_zero_of_support_subsets {x y : SurrealHahnSeries} + (hx : x.support ⊆ Ioi 0) (hy : y.support ⊆ Ici 0) : + (x * y).coeff 0 = 0 := by + rw [← not_ne_iff] + intro hcoeff + have hzero : 0 ∈ (x * y).support := + SurrealHahnSeries.mem_support_iff.mpr hcoeff + obtain ⟨p, hp, q, hq, hpq⟩ := exists_add_eq_of_mem_support_mul hzero + have hpPos : 0 < p := hx hp + have hqNonneg : 0 ≤ q := hy hq + have : 0 < p + q := add_pos_of_pos_of_nonneg hpPos hqNonneg + rw [hpq] at this + exact this.false + +private theorem coeff_zero_mul_of_support_subset_Ici {x y : SurrealHahnSeries} + (hx : x.support ⊆ Ici 0) (hy : y.support ⊆ Ici 0) : + (x * y).coeff 0 = x.coeff 0 * y.coeff 0 := by + have hxSplit : x.trunc 0 + SurrealHahnSeries.single 0 (x.coeff 0) = x := + SurrealHahnSeries.trunc_add_single fun i hi ↦ hx hi + have hySplit : y.trunc 0 + SurrealHahnSeries.single 0 (y.coeff 0) = y := + SurrealHahnSeries.trunc_add_single fun i hi ↦ hy hi + conv_lhs => rw [← hxSplit, ← hySplit] + rw [add_mul, mul_add, mul_add, + SurrealHahnSeries.coeff_add_apply, SurrealHahnSeries.coeff_add_apply, + SurrealHahnSeries.coeff_add_apply] + have hxTrunc : (x.trunc 0).support ⊆ Ioi 0 := by + intro i hi + rw [SurrealHahnSeries.support_trunc] at hi + exact hi.2 + have hyTrunc : (y.trunc 0).support ⊆ Ioi 0 := by + intro i hi + rw [SurrealHahnSeries.support_trunc] at hi + exact hi.2 + have hxTruncNonneg : (x.trunc 0).support ⊆ Ici 0 := by + intro i hi + rw [mem_Ici] + exact (show 0 < i by simpa only [mem_Ioi] using hxTrunc hi).le + have hyTruncNonneg : (y.trunc 0).support ⊆ Ici 0 := by + intro i hi + rw [mem_Ici] + exact (show 0 < i by simpa only [mem_Ioi] using hyTrunc hi).le + have hsingleNonneg (r : ℝ) : + (SurrealHahnSeries.single 0 r).support ⊆ Ici 0 := by + intro i hi + have hi' := SurrealHahnSeries.support_single_subset hi + rw [mem_Ici] + have : i = 0 := by simpa only [mem_singleton_iff] using hi' + simp [this] + rw [coeff_mul_zero_of_support_subsets hxTrunc hyTruncNonneg, + coeff_mul_zero_of_support_subsets hxTrunc (hsingleNonneg _)] + have hsingleTrunc : + (SurrealHahnSeries.single 0 (x.coeff 0) * y.trunc 0).coeff 0 = 0 := by + rw [mul_comm] + exact coeff_mul_zero_of_support_subsets hyTrunc (hsingleNonneg _) + rw [hsingleTrunc, single_mul_single] + simp [SurrealHahnSeries.coeff_single_self] + +/-- The Conway normal form of an integer is concentrated at exponent zero. -/ +theorem intCast_eq_single_zero (z : ℤ) : + (z : SurrealHahnSeries) = SurrealHahnSeries.single 0 (z : ℝ) := by + apply Subtype.ext + rw [← ofLex_inj, ofLex_coe_single] + with_unfolding_all rfl + +/-- The Conway normal form of one has coefficient one at exponent zero. -/ +theorem one_eq_single_zero : + (1 : SurrealHahnSeries) = SurrealHahnSeries.single 0 1 := by + apply Subtype.ext + rw [← ofLex_inj, ofLex_coe_single] + with_unfolding_all rfl + +/-- The omnific integers in Conway normal-form coordinates: surreal Hahn series with nonnegative +exponents and an integer constant coefficient [LM24, §1.1]. -/ +def omnificIntegers : Subring SurrealHahnSeries.{u} where + carrier := {x | x.support ⊆ Ici 0 ∧ x.coeff 0 ∈ range ((↑) : ℤ → ℝ)} + zero_mem' := by + refine ⟨by simp [SurrealHahnSeries.support_zero], ⟨0, by simp⟩⟩ + one_mem' := by + rw [one_eq_single_zero] + refine ⟨?_, ⟨1, by simp⟩⟩ + intro i hi + have hi' := SurrealHahnSeries.support_single_subset hi + rw [mem_Ici] + have : i = 0 := by simpa only [mem_singleton_iff] using hi' + simp [this] + add_mem' := by + rintro x y ⟨hxSupport, ⟨m, hm⟩⟩ ⟨hySupport, ⟨n, hn⟩⟩ + refine ⟨?_, ⟨m + n, ?_⟩⟩ + · exact SurrealHahnSeries.support_add_subset.trans + (union_subset hxSupport hySupport) + · rw [SurrealHahnSeries.coeff_add_apply, ← hm, ← hn] + simp + neg_mem' := by + rintro x ⟨hxSupport, ⟨m, hm⟩⟩ + refine ⟨?_, ⟨-m, ?_⟩⟩ + · intro i hi + apply hxSupport + rw [SurrealHahnSeries.mem_support_iff] at hi ⊢ + simpa only [SurrealHahnSeries.coeff_neg, Pi.neg_apply, neg_ne_zero] using hi + · rw [show (-x).coeff 0 = -x.coeff 0 by + exact congrFun (SurrealHahnSeries.coeff_neg x) 0, ← hm] + simp + mul_mem' := by + rintro x y ⟨hxSupport, ⟨m, hm⟩⟩ ⟨hySupport, ⟨n, hn⟩⟩ + refine ⟨support_mul_subset_Ici hxSupport hySupport, ⟨m * n, ?_⟩⟩ + rw [coeff_zero_mul_of_support_subset_Ici hxSupport hySupport, ← hm, ← hn] + simp + +/-- Membership in the normal-form presentation of the omnific integers. -/ +theorem mem_omnificIntegers {x : SurrealHahnSeries.{u}} : + x ∈ omnificIntegers ↔ + x.support ⊆ Ici 0 ∧ x.coeff 0 ∈ range ((↑) : ℤ → ℝ) := by + rfl + +/-- The omnific integers in Conway normal-form coordinates. -/ +abbrev OmnificInteger := ↥(omnificIntegers : Subring SurrealHahnSeries.{u}) + +/-- The integer coefficient of `ω ^ 0` in an omnific integer's Conway normal form. -/ +def integerConstantCoeff (x : OmnificInteger.{u}) : ℤ := + Classical.choose x.2.2 + +/-- The chosen integer really is the coefficient of `ω ^ 0`. -/ +@[simp] +theorem coe_integerConstantCoeff (x : OmnificInteger.{u}) : + (integerConstantCoeff x : ℝ) = x.1.coeff 0 := by + exact Classical.choose_spec x.2.2 + +/-- Taking the integer constant coefficient is a ring homomorphism `Oz →+* ℤ`. -/ +def integerConstantCoeffRingHom : OmnificInteger.{u} →+* ℤ where + toFun := integerConstantCoeff + map_zero' := by + apply Int.cast_injective (α := ℝ) + rw [coe_integerConstantCoeff] + simp + map_one' := by + apply Int.cast_injective (α := ℝ) + rw [coe_integerConstantCoeff] + rw [show (1 : OmnificInteger).1 = (1 : SurrealHahnSeries) by rfl, + one_eq_single_zero] + simp + map_add' x y := by + apply Int.cast_injective (α := ℝ) + rw [coe_integerConstantCoeff, Int.cast_add, coe_integerConstantCoeff, + coe_integerConstantCoeff] + exact SurrealHahnSeries.coeff_add_apply x.1 y.1 0 + map_mul' x y := by + apply Int.cast_injective (α := ℝ) + rw [coe_integerConstantCoeff, Int.cast_mul, coe_integerConstantCoeff, + coe_integerConstantCoeff] + exact coeff_zero_mul_of_support_subset_Ici x.2.1 y.2.1 + +@[simp] +theorem integerConstantCoeffRingHom_apply (x : OmnificInteger.{u}) : + integerConstantCoeffRingHom x = integerConstantCoeff x := (rfl) + +/-- A monomial with nonnegative exponent and coefficient one is an omnific integer. -/ +theorem single_one_mem_omnificIntegers (p : Surreal.{u}) (hp : 0 ≤ p) : + SurrealHahnSeries.single p 1 ∈ omnificIntegers := by + rw [mem_omnificIntegers] + refine ⟨fun i hi ↦ ?_, ?_⟩ + · have hip := SurrealHahnSeries.support_single_subset hi + have hiEq : i = p := by simpa only [Set.mem_singleton_iff] using hip + simpa only [Set.mem_Ici, hiEq] using hp + · by_cases hp0 : p = 0 + · subst p + exact ⟨1, by simp [SurrealHahnSeries.coeff_single_self]⟩ + · exact ⟨0, by simp [SurrealHahnSeries.coeff_single_of_ne hp0]⟩ + +/-- Powers of coefficient-one monomials multiply their exponent by the power. -/ +theorem single_one_pow (p : Surreal.{u}) (n : ℕ) : + (SurrealHahnSeries.single p 1) ^ n = SurrealHahnSeries.single (n • p) 1 := by + induction n with + | zero => rw [pow_zero, zero_nsmul, one_eq_single_zero] + | succ n ih => rw [pow_succ, ih, single_mul_single, succ_nsmul, one_mul] + +end ConwayRefinement.Standalone.Oz diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/Support/OneRowExample.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/Support/OneRowExample.lean new file mode 100644 index 0000000000..76502bb1a3 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/Support/OneRowExample.lean @@ -0,0 +1,142 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Support.OmnificIntegers + +import all LeanPool.ConwayRefinement.CombinatorialGames.Surreal.HahnSeries.Basic + +/-! +# Conway's one-row omnific integer + +This module writes the normal form + +`1 + Σ n : ℕ, ω ^ (1 / (n + 1))`, + +with every displayed coefficient equal to one. Its positive exponents form one decreasing row +converging to zero, followed by the final constant term. The sibling statement `OneRowPrime` +records its arithmetic properties using only Mathlib and CombinatorialGames. +-/ + +@[expose] public noncomputable section + +namespace ConwayRefinement.Standalone.Oz.OneRowExample + +open Set + +/-- The `n`-th positive exponent in Conway's one-row normal form. -/ +def exponent (n : ℕ) : ℝ := + 1 / (n + 1 : ℝ) + +@[simp] +theorem exponent_apply (n : ℕ) : exponent n = 1 / (n + 1 : ℝ) := by + rfl + +private theorem exponent_strictAnti : StrictAnti exponent := by + refine strictAnti_nat_of_succ_lt fun n ↦ ?_ + rw [exponent_apply, exponent_apply] + apply one_div_lt_one_div_of_lt + · positivity + · norm_num + +/-- The natural-number row followed by the final constant-term index. -/ +abbrev Index := WithTop ℕ + +/-- The exponent at an index of the displayed normal form. -/ +def exponentAtIndex : Index → Surreal + | ⊤ => 0 + | (n : ℕ) => (exponent n : ℝ) + +private theorem exponent_pos (n : ℕ) : 0 < exponent n := by + rw [exponent_apply] + positivity + +private theorem exponentAtIndex_strictAnti : StrictAnti exponentAtIndex := by + intro p q hpq + induction p using WithTop.recTopCoe with + | top => exact (not_lt_of_ge le_top hpq).elim + | coe p => + induction q using WithTop.recTopCoe with + | top => + change (0 : Surreal) < (exponent p : ℝ) + exact_mod_cast exponent_pos p + | coe q => + change ((exponent q : ℝ) : Surreal) < (exponent p : ℝ) + exact_mod_cast exponent_strictAnti (WithTop.coe_lt_coe.mp hpq) + +/-- The coefficient function supported on the displayed exponents. -/ +def coefficient (i : Surreal) : ℝ := + by + classical + exact if i ∈ range exponentAtIndex then 1 else 0 + +private theorem support_coefficient : + Function.support coefficient = range exponentAtIndex := by + classical + ext i + simp [Function.support, coefficient] + +/-- The displayed coefficient support is small enough for a surreal Hahn series. -/ +theorem small_support_coefficient : + Small.{0} (Function.support coefficient) := by + rw [support_coefficient] + infer_instance + +/-- The displayed exponents are reverse well-ordered. -/ +theorem wellFoundedOn_support_coefficient : + (Function.support coefficient).WellFoundedOn (· > ·) := by + rw [support_coefficient, wellFoundedOn_range] + convert wellFounded_lt (α := Index) using 1 + ext p q + exact exponentAtIndex_strictAnti.lt_iff_gt + +/-- Conway's coefficient-one normal form `1 + Σ n, ω ^ (1 / (n + 1))`. -/ +def normalForm : SurrealHahnSeries := + SurrealHahnSeries.mk coefficient small_support_coefficient + wellFoundedOn_support_coefficient + +@[simp] +theorem normalForm_coeff (i : Surreal) : + normalForm.coeff i = coefficient i := by + rw [normalForm, SurrealHahnSeries.coeff_mk, coefficient] + +@[simp] +theorem normalForm_support : normalForm.support = range exponentAtIndex := by + rw [normalForm, SurrealHahnSeries.support_mk, support_coefficient] + +theorem normalForm_coeff_exponent (n : ℕ) : + normalForm.coeff (exponent n : ℝ) = 1 := by + classical + rw [normalForm_coeff, coefficient, ite_eq_left] + exact ⟨(n : Index), rfl⟩ + +theorem normalForm_coeff_zero : normalForm.coeff 0 = 1 := by + classical + rw [normalForm_coeff, coefficient, ite_eq_left] + exact ⟨⊤, rfl⟩ + +private theorem normalForm_support_nonnegative : normalForm.support ⊆ Ici 0 := by + rw [normalForm_support] + rintro i ⟨p, rfl⟩ + induction p using WithTop.recTopCoe with + | top => exact le_rfl + | coe n => + rw [mem_Ici] + change (0 : Surreal) ≤ (exponent n : ℝ) + exact_mod_cast (exponent_pos n).le + +/-- Conway's one-row normal form, regarded as an omnific integer. -/ +def oneRowOz : Oz.OmnificInteger := + ⟨normalForm, by + rw [Oz.mem_omnificIntegers] + exact ⟨normalForm_support_nonnegative, + ⟨1, by simpa using normalForm_coeff_zero.symm⟩⟩⟩ + +@[simp] +theorem oneRowOz_val : oneRowOz.1 = normalForm := by + rfl + +end ConwayRefinement.Standalone.Oz.OneRowExample diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/Support/PrincipalRVAlgebraicIndependenceProof.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/Support/PrincipalRVAlgebraicIndependenceProof.lean new file mode 100644 index 0000000000..59a0fc77cd --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/CombinatorialGames/Support/PrincipalRVAlgebraicIndependenceProof.lean @@ -0,0 +1,376 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.PrincipalRVAlgebraicIndependence +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.Polynomiality + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrdinalValue +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Germ +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrderType +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.SupportSupremum +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.NegativeMonomialIdeal +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.AlgebraicIndependence.TruncationExpansion +import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.GradedRing.Extension + +/-! +# Proof of algebraic independence in `P̂` + +The standalone ring `nonpos K` is `K((ℝ^{≤0}))`, and its `ordinalValue` is Berarducci's ordinal +value. Standalone decomposability agrees with membership in +`(P̂_+)² ∩ P_β = ∑_{i ⊕ j = β, i, j ≠ 0} P_i P_j`. A minimal homogeneous family extends to a +minimal homogeneous generating system of `P̂`; polynomiality of that system gives algebraic +independence of the original family. +-/ + +universe u + +open scoped NatOrdinal HahnSeries +open Berarducci HahnSeries MvPolynomial OrdinalGraded + +public noncomputable section + +namespace ConwayRefinement.Standalone.PrincipalRVAlgebraicIndependence + +variable {K : Type u} [Field K] + +/-! ### The ring -/ + +/-- The standalone and development presentations of `K((ℝ^{≤0}))` are the same `K`-algebra. -/ +@[expose] def seriesAlgEquiv : nonpos K ≃ₐ[K] Series K where + toFun a := ⟨(a : HahnSeries ℝ K), (HahnSeries.mem_nonpositiveSubring ℝ K).mpr a.2⟩ + invFun s := ⟨(s : HahnSeries ℝ K), (HahnSeries.mem_nonpositiveSubring ℝ K).mp s.2⟩ + left_inv _ := rfl + right_inv _ := rfl + map_add' _ _ := rfl + map_mul' _ _ := rfl + commutes' k := by + rw [HahnSeries.Nonpositive.algebraMap_apply] + exact Subtype.ext <| by + rw [Subalgebra.coe_algebraMap, HahnSeries.algebraMap_apply, Algebra.algebraMap_self, + RingHom.id_apply, HahnSeries.Nonpositive.coe_C] + +/-- Regard the standalone presentation as Berarducci's series ring. -/ +abbrev toSeries (a : nonpos K) : Series K := seriesAlgEquiv a + +/-- Regard Berarducci's series ring in the standalone presentation. -/ +abbrev ofSeries (s : Series K) : nonpos K := seriesAlgEquiv.symm s + +@[simp] theorem coe_toSeries (a : nonpos K) : + ((toSeries a : Series K) : HahnSeries ℝ K) = (a : HahnSeries ℝ K) := rfl + +@[simp] theorem toSeries_ofSeries (s : Series K) : toSeries (ofSeries s) = s := rfl + +theorem toSeries_algebraMap (k : K) : + toSeries (algebraMap K (nonpos K) k) = HahnSeries.Nonpositive.C k := by + rw [← HahnSeries.Nonpositive.algebraMap_apply] + exact seriesAlgEquiv.commutes k + +theorem toSeries_sub (a b : nonpos K) : toSeries (a - b) = toSeries a - toSeries b := + map_sub seriesAlgEquiv a b + +theorem toSeries_add (a b : nonpos K) : toSeries (a + b) = toSeries a + toSeries b := + map_add seriesAlgEquiv a b + +theorem toSeries_mul (a b : nonpos K) : toSeries (a * b) = toSeries a * toSeries b := + map_mul seriesAlgEquiv a b + +theorem toSeries_sum {ι : Type*} (s : Finset ι) (f : ι → nonpos K) : + toSeries (∑ i ∈ s, f i) = ∑ i ∈ s, toSeries (f i) := + map_sum seriesAlgEquiv f s + +theorem toSeries_aeval {ι : Type*} (b : ι → nonpos K) (F : MvPolynomial ι K) : + toSeries (aeval b F) = aeval (fun i ↦ toSeries (b i)) F := by + change seriesAlgEquiv.toAlgHom (aeval b F) = aeval (fun i ↦ seriesAlgEquiv (b i)) F + rw [← AlgHom.comp_apply, MvPolynomial.comp_aeval] + rfl + +/-! ### The ordinal value -/ + +theorem ot_eq (x : HahnSeries ℝ K) : ot x = HahnSeries.supportOrderType x := by + have : WellFoundedLT x.support := (supportIsWellOrder x).wf + exact (HahnSeries.supportOrderType_eq_typeLT (OrderIso.refl _)).symm + +theorem memJ_iff (a : nonpos K) : + MemJ a ↔ toSeries a ∈ HahnSeries.Nonpositive.negativeMonomialIdeal K := by + rw [HahnSeries.Nonpositive.mem_negativeMonomialIdeal_iff_supportSup_lt_zero] + rcases eq_or_ne (toSeries a) 0 with h0 | h0 + · rw [h0, HahnSeries.Nonpositive.supportSup_zero] + refine ⟨fun _ ↦ WithBot.bot_lt_coe 0, fun _ ↦ ⟨-1, by norm_num, fun y hy ↦ ?_⟩⟩ + have : (a : HahnSeries ℝ K) = 0 := by + have := congrArg (fun s : Series K ↦ (s : HahnSeries ℝ K)) h0 + simpa using this + rw [this, HahnSeries.support_zero] at hy + exact absurd hy (Set.notMem_empty y) + · have h0' : (a : HahnSeries ℝ K) ≠ 0 := fun h ↦ h0 (Subtype.ext h) + rw [HahnSeries.Nonpositive.supportSup_of_ne h0, ← WithBot.coe_zero, WithBot.coe_lt_coe] + constructor + · rintro ⟨s, hs, hsupp⟩ + exact (csSup_le (HahnSeries.support_nonempty_iff.mpr h0') hsupp).trans_lt hs + · intro h + exact ⟨_, h, fun y hy ↦ le_csSup (HahnSeries.Nonpositive.bddAbove_support (toSeries a)) hy⟩ + +theorem isNearConstant_iff (a : nonpos K) : + IsNearConstant a ↔ toSeries a ∈ Berarducci.nearConstantSubgroup K := by + rw [Berarducci.mem_nearConstantSubgroup_iff] + constructor + · rintro ⟨k, hk⟩ + refine ⟨toSeries (a - algebraMap K (nonpos K) k), (memJ_iff _).mp hk, k, ?_⟩ + rw [toSeries_sub, toSeries_algebraMap, sub_add_cancel] + · rintro ⟨j, hj, k, hjk⟩ + refine ⟨k, (memJ_iff _).mpr ?_⟩ + rw [toSeries_sub, toSeries_algebraMap, ← hjk, add_sub_cancel_right] + exact hj + +/-- The standalone ordinal value is Berarducci's. -/ +theorem ordinalValue_eq (a : nonpos K) : ordinalValue a = Berarducci.ordinalValue (toSeries a) := by + classical + unfold ordinalValue + by_cases hJ : MemJ a + · rw [ite_eq_left hJ, Berarducci.ordinalValue_of_mem_negativeMonomialIdeal ((memJ_iff a).mp hJ)] + rw [ite_eq_right hJ] + by_cases hN : IsNearConstant a + · rw [ite_eq_left hN, + Berarducci.ordinalValue_of_mem_nearConstantSubgroup_of_not_mem_negativeMonomialIdeal + ((isNearConstant_iff a).mp hN) (fun h ↦ hJ ((memJ_iff a).mpr h))] + rw [ite_eq_right hN, + Berarducci.ordinalValue_of_not_mem_nearConstantSubgroup + (fun h ↦ hN ((isNearConstant_iff a).mpr h))] + congr 1 + ext o + simp only [Set.mem_ofPred_eq, Berarducci.mem_representativeOrderTypes_iff] + constructor + · rintro ⟨c, hc, rfl⟩ + refine ⟨toSeries c, ?_, by rw [ot_eq]; rfl⟩ + have := (isNearConstant_iff _).mp hc + rwa [toSeries_sub] at this + · rintro ⟨c, hc, rfl⟩ + refine ⟨ofSeries c, ?_, by rw [ot_eq]; rfl⟩ + rw [isNearConstant_iff, toSeries_sub, toSeries_ofSeries] + exact hc + +/-! ### Decomposables -/ + +/-- A representative of the sum of two classes differs from the sum of representatives by a +series of small value. -/ +theorem ordinalValue_sub_lt_of_represents {a a₁ a₂ : Series K} {β : NatOrdinal} + {y₁ y₂ : PrincipalSubring K} (h : Represents a β (y₁ + y₂)) (h₁ : Represents a₁ β y₁) + (h₂ : Represents a₂ β y₂) : Berarducci.ordinalValue (a - (a₁ + a₂)) < ω^ β := by + have h12 := h₁.add h₂ + obtain ⟨ha, hae⟩ := represents_iff.mp h + obtain ⟨ha12, ha12e⟩ := represents_iff.mp h12 + have := DirectSum.of_injective β (hae.trans ha12e.symm) + exact (principalComponentMk_eq_iff β _ _ ha ha12).mp this + +/-- The standalone decomposables contain every series representing an element of +`(P̂_+)² ∩ P_β` (`decomposableAt`). -/ +theorem isDecomposable_of_mem_decomposableAt {β : NatOrdinal} {y : PrincipalSubring K} + (hy : y ∈ decomposableAt (principalGrading K) β) {a : nonpos K} + (ha : Represents (toSeries a) β y) : IsDecomposable β a := by + classical + -- the submodule of elements of `P_β` all of whose representatives are decomposable + let N : Submodule K (PrincipalSubring K) := + { carrier := {y | y ∈ principalGrading K β ∧ + ∀ a : nonpos K, Represents (toSeries a) β y → IsDecomposable β a} + zero_mem' := by + refine ⟨zero_mem _, fun a ha ↦ ?_⟩ + refine ⟨0, Fin.elim0, Fin.elim0, Fin.elim0, Fin.elim0, fun k ↦ k.elim0, fun k ↦ k.elim0, + fun k ↦ k.elim0, ?_⟩ + rw [Finset.univ_eq_empty, Finset.sum_empty, sub_zero, ordinalValue_eq] + exact ha.ordinalValue_lt_of_eq_zero + add_mem' := by + rintro y₁ y₂ ⟨hy₁, h₁⟩ ⟨hy₂, h₂⟩ + refine ⟨add_mem hy₁ hy₂, fun a ha ↦ ?_⟩ + -- representatives of `y₁`, `y₂` + obtain ⟨z₁, rfl⟩ := (DirectSum.mem_rangeLof_iff K _ _ y₁).mp hy₁ + obtain ⟨z₂, rfl⟩ := (DirectSum.mem_rangeLof_iff K _ _ y₂).mp hy₂ + simp only [DirectSum.lof_eq_of] at h₁ h₂ ha + obtain ⟨s₁, hs₁, hz₁⟩ := exists_principalComponentMk β z₁ + obtain ⟨s₂, hs₂, hz₂⟩ := exists_principalComponentMk β z₂ + have hr₁ : Represents (toSeries (ofSeries s₁)) β + (DirectSum.of (PrincipalComponent K) β z₁) := by + rw [toSeries_ofSeries]; exact represents_iff.mpr ⟨hs₁, congrArg _ hz₁⟩ + have hr₂ : Represents (toSeries (ofSeries s₂)) β + (DirectSum.of (PrincipalComponent K) β z₂) := by + rw [toSeries_ofSeries]; exact represents_iff.mpr ⟨hs₂, congrArg _ hz₂⟩ + obtain ⟨n₁, β₁, β₁', u₁, w₁, hβ₁, hu₁, hw₁, hv₁⟩ := h₁ _ hr₁ + obtain ⟨n₂, β₂, β₂', u₂, w₂, hβ₂, hu₂, hw₂, hv₂⟩ := h₂ _ hr₂ + refine ⟨n₁ + n₂, Fin.append β₁ β₂, Fin.append β₁' β₂', Fin.append u₁ u₂, Fin.append w₁ w₂, + fun k ↦ ?_, fun k ↦ ?_, fun k ↦ ?_, ?_⟩ + · refine Fin.addCases (fun k ↦ ?_) (fun k ↦ ?_) k + · simp only [Fin.append_left]; exact hβ₁ k + · simp only [Fin.append_right]; exact hβ₂ k + · refine Fin.addCases (fun k ↦ ?_) (fun k ↦ ?_) k + · simp only [Fin.append_left]; exact hu₁ k + · simp only [Fin.append_right]; exact hu₂ k + · refine Fin.addCases (fun k ↦ ?_) (fun k ↦ ?_) k + · simp only [Fin.append_left]; exact hw₁ k + · simp only [Fin.append_right]; exact hw₂ k + · rw [Fin.sum_univ_add] + simp only [Fin.append_left, Fin.append_right] + rw [ordinalValue_eq] at hv₁ hv₂ ⊢ + simp only [toSeries_sub, toSeries_add, toSeries_sum, toSeries_ofSeries] at hv₁ hv₂ ⊢ + have hsmall := ordinalValue_sub_lt_of_represents ha hr₁ hr₂ + rw [toSeries_ofSeries, toSeries_ofSeries] at hsmall + have heq : toSeries a - (∑ k, toSeries (u₁ k * w₁ k) + ∑ k, toSeries (u₂ k * w₂ k)) = + (toSeries a - (s₁ + s₂)) + (s₁ - ∑ k, toSeries (u₁ k * w₁ k)) + + (s₂ - ∑ k, toSeries (u₂ k * w₂ k)) := by abel + rw [heq] + refine (ordinalValue_add_le_max _ _).trans_lt (max_lt ?_ hv₂) + exact (ordinalValue_add_le_max _ _).trans_lt (max_lt hsmall hv₁) + smul_mem' := by + rintro k y ⟨hy, h⟩ + refine ⟨Submodule.smul_mem _ k hy, fun a ha ↦ ?_⟩ + obtain ⟨z, rfl⟩ := (DirectSum.mem_rangeLof_iff K _ _ y).mp hy + rw [DirectSum.lof_eq_of] at h ha + obtain ⟨s, hs, hz⟩ := exists_principalComponentMk β z + have hr : Represents (toSeries (ofSeries s)) β + (DirectSum.of (PrincipalComponent K) β z) := by + rw [toSeries_ofSeries]; exact represents_iff.mpr ⟨hs, congrArg _ hz⟩ + obtain ⟨n, β₀, β₀', u, w, hβ₀, hu, hw, hv⟩ := h _ hr + -- `C k · s` represents `k • y` + have hrk : Represents (HahnSeries.Nonpositive.C k * s) β + (k • DirectSum.of (PrincipalComponent K) β z) := by + have hr' : Represents s β (DirectSum.of (PrincipalComponent K) β z) := by + rw [← toSeries_ofSeries s]; exact hr + have := (represents_C (K := K) k).mul hr' + rw [zero_add] at this + rw [Algebra.smul_def] + exact this + refine ⟨n, β₀, β₀', fun i ↦ algebraMap K (nonpos K) k * u i, w, hβ₀, fun i ↦ ?_, hw, ?_⟩ + · rw [ordinalValue_eq, toSeries_mul, toSeries_algebraMap] + have hui := hu i + rw [ordinalValue_eq] at hui + exact Lifts.ordinalValue_C_mul_lt k hui + · rw [ordinalValue_eq, toSeries_sub, toSeries_sum] + rw [ordinalValue_eq, toSeries_sub, toSeries_sum, toSeries_ofSeries] at hv + have hsmall : + Berarducci.ordinalValue (toSeries a - HahnSeries.Nonpositive.C k * s) < ω^ β := by + obtain ⟨h1, h1e⟩ := represents_iff.mp ha + obtain ⟨h2, h2e⟩ := represents_iff.mp hrk + exact (principalComponentMk_eq_iff β _ _ h1 h2).mp + (DirectSum.of_injective β (h1e.trans h2e.symm)) + have heq : toSeries a - ∑ i, toSeries (algebraMap K (nonpos K) k * u i * w i) = + (toSeries a - HahnSeries.Nonpositive.C k * s) + + HahnSeries.Nonpositive.C k * (s - ∑ i, toSeries (u i * w i)) := by + simp only [toSeries_mul, toSeries_algebraMap, mul_sub, Finset.mul_sum, mul_assoc] + abel + rw [heq] + exact (ordinalValue_add_le_max _ _).trans_lt + (max_lt hsmall (Lifts.ordinalValue_C_mul_lt k hv)) } + -- the decomposables lie in `N` + have hle : decomposableAt (principalGrading K) β ≤ N := by + refine decomposableAt_le (principalGrading K) fun i j hi hj hij ↦ + Submodule.mul_le.mpr fun m hm n hn ↦ ?_ + refine ⟨hij ▸ SetLike.mul_mem_graded hm hn, fun a ha ↦ ?_⟩ + obtain ⟨zm, rfl⟩ := (DirectSum.mem_rangeLof_iff K _ _ m).mp hm + obtain ⟨zn, rfl⟩ := (DirectSum.mem_rangeLof_iff K _ _ n).mp hn + simp only [DirectSum.lof_eq_of] at ha + obtain ⟨sm, hsm, hzm⟩ := exists_principalComponentMk i zm + obtain ⟨sn, hsn, hzn⟩ := exists_principalComponentMk j zn + have hrm : Represents sm i (DirectSum.of (PrincipalComponent K) i zm) := + represents_iff.mpr ⟨hsm, congrArg _ hzm⟩ + have hrn : Represents sn j (DirectSum.of (PrincipalComponent K) j zn) := + represents_iff.mpr ⟨hsn, congrArg _ hzn⟩ + have hrmn := (hrm.mul hrn).of_eq hij + refine ⟨1, fun _ ↦ i, fun _ ↦ j, fun _ ↦ ofSeries sm, fun _ ↦ ofSeries sn, + fun _ ↦ ⟨hi, hj, hij⟩, fun _ ↦ ?_, fun _ ↦ ?_, ?_⟩ + · rw [ordinalValue_eq, toSeries_ofSeries]; exact hsm + · rw [ordinalValue_eq, toSeries_ofSeries]; exact hsn + · rw [Fin.sum_univ_one, ordinalValue_eq, toSeries_sub, toSeries_mul, toSeries_ofSeries, + toSeries_ofSeries] + obtain ⟨h1, h1e⟩ := represents_iff.mp ha + obtain ⟨h2, h2e⟩ := represents_iff.mp hrmn + exact (principalComponentMk_eq_iff β _ _ h1 h2).mp + (DirectSum.of_injective β (h1e.trans h2e.symm)) + exact (hle hy).2 a ha + +/-! ### Minimal homogeneous families -/ + +variable {ι : Type} (deg : ι → NatOrdinal) (b : ι → nonpos K) + (hB : IsMinimalHomogeneousFamily deg b) +include hB + +theorem ordinalValue_toSeries_lt (i : ι) : + Berarducci.ordinalValue (toSeries (b i)) < ω^ (deg i + 1) := by + rw [← ordinalValue_eq]; exact hB.mem i + +/-- The classes of the generators. -/ +def classes (i : ι) : PrincipalSubring K := + DirectSum.of (PrincipalComponent K) (deg i) + (principalComponentMk (deg i) (toSeries (b i)) (ordinalValue_toSeries_lt deg b hB i)) + +/-- The lifts of the classes: the series themselves. -/ +def lifts : Lifts deg (classes deg b hB) where + lift i := toSeries (b i) + represents i := represents_iff.mpr ⟨ordinalValue_toSeries_lt deg b hB i, rfl⟩ + +/-- The classes of the given family are independent modulo the decomposables. -/ +theorem independent_classes (β : NatOrdinal) (c : ι →₀ K) (hc : ∀ i ∈ c.support, deg i = β) + (hdec : Finsupp.linearCombination K (classes deg b hB) c ∈ + decomposableAt (principalGrading K) β) : c = 0 := by + classical + refine hB.independent β c hc ?_ + refine isDecomposable_of_mem_decomposableAt hdec ?_ + rw [Finsupp.linearCombination_apply, Finsupp.sum, Finsupp.sum, toSeries_sum] + refine represents_sum _ _ _ _ fun i hi ↦ ?_ + rw [toSeries_mul, toSeries_algebraMap, Algebra.smul_def] + have := (represents_C (K := K) (c i)).mul ((lifts deg b hB).represents i) + rw [zero_add, hc i hi] at this + exact this + +omit hB in +/-- Renaming the variables along a degree-preserving map preserves homogeneity. -/ +theorem isWeightedHomogeneous_rename {ι' : Type*} {e : ι → ι'} {wt' : ι' → NatOrdinal} + (hwt : ∀ i, wt' (e i) = deg i) {F : MvPolynomial ι K} {α : NatOrdinal} + (hF : IsWeightedHomogeneous deg F α) : IsWeightedHomogeneous wt' (rename e F) α := by + intro d hd + obtain ⟨u, rfl, hu⟩ := coeff_rename_ne_zero e F d hd + rw [← hF hu, Finsupp.weight_apply, Finsupp.weight_apply, + Finsupp.sum_mapDomain_index (h := fun i c ↦ c • wt' i) (fun _ ↦ zero_smul ℕ _) + (fun _ _ _ ↦ add_smul _ _ _)] + exact Finsupp.sum_congr fun i _ ↦ by rw [hwt] + +end ConwayRefinement.Standalone.PrincipalRVAlgebraicIndependence + +namespace ConwayRefinement.Standalone.PrincipalRVAlgebraicIndependence + +namespace MinimalFamiliesAlgebraicallyIndependent + +open ConwayRefinement.Standalone.PrincipalRVAlgebraicIndependence + +/-- Every minimal homogeneous family in `P̂` is algebraically independent. -/ +theorem of_algebraicIndependence (K : Type u) [Field K] : + PrincipalRVAlgebraicIndependence.MinimalFamiliesAlgebraicallyIndependent K := by + intro hK + let := hK + intro ι deg b hB α F hF hval + -- Extend the family to a minimal homogeneous generating system of `P̂`. + obtain ⟨ι', wt', x', e, he, hwt', hx', hmin⟩ := + exists_isMinimalSystem_extension (principalGrading K) hB.ne_zero + (fun i ↦ of_mem_principalGrading _ _) (independent_classes deg b hB) + have hinj := Berarducci.injectiveAt_of_isMinimalSystem hmin α + -- `F(classes) = 0` in `P̂` + have hrep := (lifts deg b hB).aeval_represents hF + have h0 : Berarducci.ordinalValue (aeval (lifts deg b hB).lift F) < ω^ α := by + have : aeval (lifts deg b hB).lift F = toSeries (aeval b F) := (toSeries_aeval b F).symm + rw [this, ← ordinalValue_eq] + exact hval + obtain ⟨hu, heq⟩ := represents_iff.mp hrep + have hzero : aeval (classes deg b hB) F = 0 := by + rw [← heq, (principalComponentMk_eq_zero_iff α _ hu).mpr h0, map_zero] + -- hence `F`, read in the extended variables, vanishes, so `F = 0` + have hren : rename e F = 0 := by + refine (injectiveAt_iff α).mp hinj _ (isWeightedHomogeneous_rename deg hwt' hF) ?_ + rw [aeval_rename] + have : x' ∘ e = classes deg b hB := funext hx' + rw [this] + exact hzero + exact rename_injective e he (by rw [hren, map_zero]) + +end MinimalFamiliesAlgebraicallyIndependent + +end ConwayRefinement.Standalone.PrincipalRVAlgebraicIndependence diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib.lean new file mode 100644 index 0000000000..6ea53c4e5b --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib.lean @@ -0,0 +1,24 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.CompleteHahnGerm +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.CompleteHahnGermProof +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.Examples +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.GermPolynomialRing +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.GermPolynomialRingProof +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.HahnIntegerPartRefinement +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.HahnIntegerPartRefinementProof +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.HahnSeriesGCD +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.HahnSeriesGCDProof +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.HahnSeriesPolynomialRing +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.HahnSeriesPolynomialRingProof +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.InlineConwayRefinement +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.InlineConwayRefinementProof +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.Support + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/CompleteHahnGerm.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/CompleteHahnGerm.lean new file mode 100644 index 0000000000..7a6de99115 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/CompleteHahnGerm.lean @@ -0,0 +1,96 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import Mathlib.Algebra.MvPolynomial.Equiv +public import Mathlib.Algebra.Order.Archimedean.Class +public import Mathlib.RingTheory.HahnSeries.Multiplication +public import Mathlib.RingTheory.Ideal.Quotient.Operations +public import Mathlib.Topology.Algebra.IsUniformGroup.Defs +public import Mathlib.Topology.Order.Basic +public import Mathlib.Topology.UniformSpace.Cauchy + +/-! +# Hahn germs over a Cauchy-complete exponent group + +Let `K((G^{≤ 0}))` be the ring of Hahn series supported in the nonpositive cone of `G`, and +identify two series when they agree on some interval immediately below zero. If `G` is Cauchy +complete for an order-compatible uniformity, dense, has no endpoints, and has no smallest nonzero +Archimedean magnitude, then this germ ring is a polynomial algebra over `K`. Consequently it has +four-factor refinement. +-/ + +@[expose] public noncomputable section + +namespace ConwayRefinement.Standalone.CompleteHahnGerm + +universe u v + +variable (G : Type u) (K : Type v) +variable [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] +variable [NoMinOrder G] [Field K] + +/-- The Hahn-series `K`-algebra `K((G^{≤ 0}))`. -/ +def NonpositiveSeries : Subalgebra K (HahnSeries G K) where + carrier := {x | x.support ⊆ Set.Iic 0} + algebraMap_mem' k := by + intro g hg + rw [HahnSeries.algebraMap_apply] at hg + have hg0 : g = 0 := HahnSeries.support_single_subset hg + simp [hg0] + add_mem' := fun hx hy ↦ + (HahnSeries.support_add_subset _ _).trans (Set.union_subset hx hy) + mul_mem' := fun hx hy ↦ HahnSeries.support_mul_subset.trans fun _ ⟨i, hi, j, hj, h⟩ ↦ + h ▸ show i + j ≤ 0 from add_nonpos (hx hi) (hy hj) + +/-- The ideal of series whose support is bounded away from zero. -/ +def BoundedAwayIdeal : Ideal (NonpositiveSeries G K) where + carrier := {x | ∃ r < (0 : G), (x : HahnSeries G K).support ⊆ Set.Iic r} + zero_mem' := by + obtain ⟨r, hr⟩ := exists_lt (0 : G) + exact ⟨r, hr, by simp⟩ + add_mem' := by + rintro x y ⟨r, hr, hxr⟩ ⟨s, hs, hys⟩ + refine ⟨max r s, max_lt hr hs, ?_⟩ + intro q hq + rcases HahnSeries.support_add_subset (x : HahnSeries G K) y hq with hqx | hqy + · exact (hxr hqx).trans (le_max_left r s) + · exact (hys hqy).trans (le_max_right r s) + smul_mem' := by + rintro x y ⟨r, hr, hyr⟩ + refine ⟨r, hr, HahnSeries.support_mul_subset.trans ?_⟩ + rintro _ ⟨i, hi, j, hj, rfl⟩ + simpa only [Set.mem_Iic, zero_add] using add_le_add (x.2 hi) (hyr hj) + +/-- The germ ring `K((G^{≤ 0}))` modulo series supported away from zero. -/ +abbrev Germ := NonpositiveSeries G K ⧸ BoundedAwayIdeal G K + +/-- The germ ring is isomorphic to a polynomial algebra over `K`. -/ +abbrev IsPolynomialRing : Prop := + ∀ [UniformSpace G] [IsUniformAddGroup G] [OrderTopology G] + [Nontrivial G] [CompleteSpace G] [DenselyOrdered G] [NoMaxOrder G] + [NoMaxOrder (FiniteArchimedeanClass G)] [CharZero K], + ∃ ι : Type (max (u + 1) v), Nonempty (MvPolynomial ι K ≃ₐ[K] Germ G K) + +/-- Every equation of four germs admits a four-factor refinement. -/ +abbrev HasRefinement : Prop := + ∀ [UniformSpace G] [IsUniformAddGroup G] [OrderTopology G] + [Nontrivial G] [CompleteSpace G] [DenselyOrdered G] [NoMaxOrder G] + [NoMaxOrder (FiniteArchimedeanClass G)] [CharZero K], + ∀ a b c d : Germ G K, a * b = c * d → + ∃ e f g h : Germ G K, + a = e * f ∧ b = g * h ∧ c = e * g ∧ d = f * h + +end ConwayRefinement.Standalone.CompleteHahnGerm + +/-! +## Formal proof + +Proof module: `CompleteHahnGermProof`. + +* `IsPolynomialRing` → `IsPolynomialRing.proof` +* `HasRefinement` → `HasRefinement.proof` +-/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/CompleteHahnGermProof.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/CompleteHahnGermProof.lean new file mode 100644 index 0000000000..0a9f87f310 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/CompleteHahnGermProof.lean @@ -0,0 +1,39 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.CompleteHahnGerm +import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.Support.CompleteHahnGermProof + +/-! # Complete Hahn Germ Proof -/ + +public noncomputable section + +namespace ConwayRefinement.Standalone.CompleteHahnGerm + +universe u v + +namespace IsPolynomialRing + +/-- The germ ring is a polynomial ring over its coefficient field. -/ +theorem proof (G : Type u) (K : Type v) + [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [NoMinOrder G] [Field K] : + IsPolynomialRing G K := Support.isPolynomialRing G K + +end IsPolynomialRing + +namespace HasRefinement + +/-- Polynomiality gives the four-factor refinement of germs. -/ +theorem proof (G : Type u) (K : Type v) + [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [NoMinOrder G] [Field K] : + HasRefinement G K := Support.hasRefinement G K + +end HasRefinement + +end ConwayRefinement.Standalone.CompleteHahnGerm diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/Examples.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/Examples.lean new file mode 100644 index 0000000000..b38fe46f08 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/Examples.lean @@ -0,0 +1,16 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.Examples.DegreeTwoPrime +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.Examples.DegreeTwoPrimeProof +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.Examples.HahnIntegerPartRefinementCriterion +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.Examples.HahnIntegerPartRefinementCriterionProof +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.Examples.NegativeMonomialRoots +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.Examples.NegativeMonomialRootsProof + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/Examples/DegreeTwoPrime.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/Examples/DegreeTwoPrime.lean new file mode 100644 index 0000000000..485347f22d --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/Examples/DegreeTwoPrime.lean @@ -0,0 +1,62 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import Mathlib.Algebra.Prime.Defs +public import Mathlib.Basic.Real.Basic +public import Mathlib.RingTheory.HahnSeries.Multiplication + +/-! +# An explicit degree-two prime Hahn series + +The coefficient-one series on the displayed two-dimensional support is prime in +`K((ℝ^{≤ 0}))` over every field of characteristic zero. Its rows converge to +`-1 / (m + 1)`, and those row limits converge to zero. +-/ + +@[expose] public noncomputable section + +namespace ConwayRefinement.Standalone.Hahn.DegreeTwoExample + +universe u + +/-- Hahn series over `K` supported in the nonpositive real exponents. -/ +def NonpositiveSeries (K : Type u) [Field K] : Subring (HahnSeries ℝ K) where + carrier := {x | x.support ⊆ Set.Iic 0} + zero_mem' := by simp + one_mem' := fun _ hg ↦ (HahnSeries.support_single_subset hg).le + add_mem' := fun hx hy ↦ + (HahnSeries.support_add_subset _ _).trans (Set.union_subset hx hy) + neg_mem' := fun hx ↦ (HahnSeries.support_neg_subset _).trans hx + mul_mem' := fun hx hy ↦ HahnSeries.support_mul_subset.trans fun _ ⟨i, hi, j, hj, h⟩ ↦ + h ▸ show i + j ≤ 0 from add_nonpos (hx hi) (hy hj) + +/-- The exponent in row `m` and column `n` of the displayed support. -/ +def exponent (m n : ℕ) : ℝ := + -(1 / (m + 1 : ℝ)) - + 1 / ((m + 1 : ℝ) * (m + 2 : ℝ) * (n + 1 : ℝ)) + +/-- The support consists exactly of zero and the displayed row-column exponents. -/ +def IsDisplayedExponent (r : ℝ) : Prop := + r = 0 ∨ ∃ m n : ℕ, r = exponent m n + +/-- Over every characteristic-zero field there is a prime series whose coefficient is one at +exactly the displayed exponents and zero elsewhere. -/ +def ExistsPrime (K : Type u) [Field K] : Prop := + CharZero K → ∃ x : NonpositiveSeries K, + (∀ r : ℝ, IsDisplayedExponent r → (x : HahnSeries ℝ K).coeff r = 1) ∧ + (∀ r : ℝ, ¬ IsDisplayedExponent r → (x : HahnSeries ℝ K).coeff r = 0) ∧ + Prime x + +end ConwayRefinement.Standalone.Hahn.DegreeTwoExample + +/-! +## Formal proof + +Proof module: `DegreeTwoPrimeProof`. + +* `ExistsPrime` → `ExistsPrime.proof` +-/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/Examples/DegreeTwoPrimeProof.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/Examples/DegreeTwoPrimeProof.lean new file mode 100644 index 0000000000..ae2c3d3b3d --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/Examples/DegreeTwoPrimeProof.lean @@ -0,0 +1,76 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.Examples.DegreeTwoPrime +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.DegreeTwo.DegreeTwoExample + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Primality.Primality + +/-! # Degree Two Prime Proof -/ + +public noncomputable section + +namespace ConwayRefinement.Standalone.Hahn.DegreeTwoExample + +open PommersheimShahriari.DegreeTwoExample + +universe u + +variable {K : Type u} [Field K] + +private theorem nonpositiveSeries_eq : + NonpositiveSeries K = HahnSeries.nonpositiveSubring ℝ K := by + ext x + rfl + +private theorem coeff_eq_one_of_isDisplayedExponent {r : ℝ} (hr : IsDisplayedExponent r) : + ((degreeTwoWithConstant (K := K) : Berarducci.Series K) : HahnSeries ℝ K).coeff r = 1 := by + rcases hr with rfl | ⟨m, n, rfl⟩ + · exact degreeTwoWithConstant_coeff_zero + · simpa only [exponent, degreeTwoExponentEmbedding_apply, + degreeTwoExponentPair_apply] using + degreeTwoWithConstant_coeff_embedding (K := K) m n + +private theorem coeff_eq_zero_of_not_isDisplayedExponent {r : ℝ} + (hr : ¬ IsDisplayedExponent r) : + ((degreeTwoWithConstant (K := K) : Berarducci.Series K) : HahnSeries ℝ K).coeff r = 0 := by + apply degreeTwoWithConstant_coeff_eq_zero + · rintro ⟨p, rfl⟩ + rcases p with ⟨m, n⟩ + apply hr + exact Or.inr ⟨m, n, by + change degreeTwoExponentEmbedding (toLex (m, n)) = exponent m n + rw [degreeTwoExponentEmbedding_apply, degreeTwoExponentPair_apply] + rfl⟩ + · intro hzero + exact hr (Or.inl hzero) + +namespace ExistsPrime + +/-- The displayed coefficient-one Hahn series is prime. -/ +theorem proof (K : Type u) [Field K] : ExistsPrime K := by + intro hK + let : CharZero K := hK + let E : NonpositiveSeries K ≃+* HahnSeries.Nonpositive ℝ K := + RingEquiv.subringCongr nonpositiveSeries_eq + let x : NonpositiveSeries K := E.symm (degreeTwoWithConstant (K := K)) + refine ⟨x, ?_, ?_, ?_⟩ + · intro r hr + rw [show (x : HahnSeries ℝ K) = + ((degreeTwoWithConstant (K := K) : Berarducci.Series K) : HahnSeries ℝ K) by rfl] + exact coeff_eq_one_of_isDisplayedExponent hr + · intro r hr + rw [show (x : HahnSeries ℝ K) = + ((degreeTwoWithConstant (K := K) : Berarducci.Series K) : HahnSeries ℝ K) by rfl] + exact coeff_eq_zero_of_not_isDisplayedExponent hr + · apply (MulEquiv.prime_iff E.toMulEquiv).mp + change Prime (degreeTwoWithConstant (K := K)) + exact Berarducci.prime_of_irreducible degreeTwoWithConstant_irreducible + +end ExistsPrime + +end ConwayRefinement.Standalone.Hahn.DegreeTwoExample diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/Examples/HahnIntegerPartRefinementCriterion.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/Examples/HahnIntegerPartRefinementCriterion.lean new file mode 100644 index 0000000000..4ca669474c --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/Examples/HahnIntegerPartRefinementCriterion.lean @@ -0,0 +1,116 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.Support.HahnLimitTailQuotient +public import Mathlib.Algebra.Divisibility.Basic +public import Mathlib.Algebra.Order.Module.HahnEmbedding +public import Mathlib.Basic.Real.Basic +public import Mathlib.RingTheory.HahnSeries.Cardinal +public import Mathlib.SetTheory.Cardinal.Cofinality.Basic +public import Mathlib.SetTheory.Cardinal.Regular + +/-! +# A criterion for refinement in bounded Hahn integer parts + +Conditions `(A1)`--`(A3)` of LM24, together with two conditions on every common tail at a limit of +Archimedean classes, imply four-factor refinement in a cardinal-bounded Hahn integer part. +-/ + +public noncomputable section + +open Cardinal + +namespace ConwayRefinement.Standalone.Hahn + +universe u v + +variable {G : Type u} {R : Type v} +variable [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] +variable [Module ℚ G] [IsOrderedModule ℚ G] +variable [Field R] + +/-- The cardinal-bounded Hahn integer part +`Z + {x : R((G)) | supp(x) ⊆ G^{<0} and #supp(x) < κ}`. -/ +abbrev hahnIntegerPart (Z : Subring R) (κ : Cardinal.{u}) : Set (HahnSeries G R) := + {x | x.cardSupp < κ ∧ x.support ⊆ Set.Iic 0 ∧ x.coeff 0 ∈ Z} + +/-- The bounded Hahn field is the fraction field of its bounded Hahn integer part. -/ +abbrev IsFractionFieldOfHahnIntegerPart (Z : Subring R) (κ : Cardinal.{u}) : Prop := + ∀ x : HahnSeries G R, x.cardSupp < κ → + ∃ a b : HahnSeries G R, + a ∈ hahnIntegerPart Z κ ∧ b ∈ hahnIntegerPart Z κ ∧ b ≠ 0 ∧ x = a / b + +/-- Condition `(A1)`: every nonzero Archimedean stratum is order additively isomorphic to +`ℝ`. -/ +abbrev AssumptionA1 (s : HahnEmbedding.ArchimedeanStrata ℚ G) : Prop := + ∀ c : FiniteArchimedeanClass G, Nonempty (s.stratum c ≃+o ℝ) + +/-- The coefficient field is generated by fractions of elements of `Z`. -/ +abbrev GeneratesFractionField (Z : Subring R) : Prop := + ∀ x : R, ∃ a b : Z, b ≠ 0 ∧ x = (a : R) / (b : R) + +/-- Condition `(A2)` at every nonzero Archimedean class. The second alternative is the +degenerate case in which the strict inner ball is zero. -/ +abbrev AssumptionA2 (Z : Subring R) (κ : Cardinal.{u}) : Prop := + ∀ c : FiniteArchimedeanClass G, + κ ≤ Order.cof ↑(FiniteArchimedeanClass.ball ℚ c) ∨ + (Subsingleton ↑(FiniteArchimedeanClass.ball ℚ c) ∧ GeneratesFractionField Z) + +/-- Condition `(A3)`: every element of the coefficient ring is primal. -/ +abbrev AssumptionA3 (Z : Subring R) : Prop := + ∀ z a b : Z, z ∣ a * b → + ∃ z₁ z₂ : Z, z₁ ∣ a ∧ z₂ ∣ b ∧ z = z₁ * z₂ + +/-- A nonempty family of nonzero Archimedean classes with no least member in the magnitude +order. -/ +abbrev IsLimitFamily (T : Set (FiniteArchimedeanClass G)) : Prop := + T.Nonempty ∧ ∀ c ∈ T, ∃ d ∈ T, c < d + +/-- The exponents lying beyond every Archimedean class in `T`. -/ +abbrev commonTail (T : Set (FiniteArchimedeanClass G)) : Submodule ℚ G := + FiniteArchimedeanClass.tailSubmodule ℚ T + +/-- An exponent belongs to the common tail exactly when its Archimedean magnitude lies beyond +every class in `T`. -/ +theorem mem_commonTail_iff {T : Set (FiniteArchimedeanClass G)} {x : G} : + x ∈ commonTail T ↔ ∀ c : T, c.1.1 ≤ ArchimedeanClass.mk x := by + rw [FiniteArchimedeanClass.mem_tailSubmodule_iff, + FiniteArchimedeanClass.mem_tailKernel_iff] + +/-- Cauchy completeness and fraction-field equality for common tails of limit families. -/ +structure LimitTailConditions (Z : Subring R) (κ : Cardinal.{u}) : Prop where + cauchy_complete_quotient (T : Set (FiniteArchimedeanClass G)) (hT : IsLimitFamily T) + (hTcard : #T < κ) : + Nonempty (CompleteSpace (G ⧸ commonTail T)) + fraction_field_commonTail (T : Set (FiniteArchimedeanClass G)) + (hT : IsLimitFamily T) (hTcard : #T < κ) : + IsFractionFieldOfHahnIntegerPart (G := commonTail T) Z κ + +/-- **Four-factor refinement from `(A1)`--`(A3)` and the common-tail conditions.** Every equality +`a * b = c * d` in `Z + R((G^{<0}))_κ` has a four-factor refinement. -/ +abbrev HahnIntegerPartRefinementCriterion : Prop := + CharZero R → ∀ (κ : Cardinal.{u}), ℵ₀ < κ → κ.IsRegular → + ∀ (Z : Subring R) (s : HahnEmbedding.ArchimedeanStrata ℚ G), + AssumptionA1 s → AssumptionA2 (G := G) Z κ → AssumptionA3 Z → + LimitTailConditions (G := G) Z κ → + ∀ a b c d : HahnSeries G R, + a ∈ hahnIntegerPart Z κ → b ∈ hahnIntegerPart Z κ → + c ∈ hahnIntegerPart Z κ → d ∈ hahnIntegerPart Z κ → a * b = c * d → + ∃ e f g h : HahnSeries G R, + e ∈ hahnIntegerPart Z κ ∧ f ∈ hahnIntegerPart Z κ ∧ + g ∈ hahnIntegerPart Z κ ∧ h ∈ hahnIntegerPart Z κ ∧ + a = e * f ∧ b = g * h ∧ c = e * g ∧ d = f * h + +end ConwayRefinement.Standalone.Hahn + +/-! +## Formal proof + +Proof module: `HahnIntegerPartRefinementCriterionProof`. + +* `HahnIntegerPartRefinementCriterion` → `HahnIntegerPartRefinementCriterion.proof` +-/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/Examples/HahnIntegerPartRefinementCriterionProof.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/Examples/HahnIntegerPartRefinementCriterionProof.lean new file mode 100644 index 0000000000..d58091d3df --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/Examples/HahnIntegerPartRefinementCriterionProof.lean @@ -0,0 +1,28 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.Examples.HahnIntegerPartRefinementCriterion +import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.Support.HahnIntegerPartRefinementProof + +/-! # Hahn Integer Part Refinement Criterion Proof -/ + +public noncomputable section + +namespace ConwayRefinement.Standalone.Hahn.HahnIntegerPartRefinementCriterion + +universe u v + +variable {G : Type u} {R : Type v} +variable [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] +variable [Module ℚ G] [IsOrderedModule ℚ G] +variable [Field R] + +/-- Conditions `(A1)`--`(A3)` and the common-tail conditions imply four-factor refinement. -/ +theorem proof : HahnIntegerPartRefinementCriterion (G := G) (R := R) := + HahnIntegerPartRefinement.of_assumptions + +end ConwayRefinement.Standalone.Hahn.HahnIntegerPartRefinementCriterion diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/Examples/NegativeMonomialRoots.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/Examples/NegativeMonomialRoots.lean new file mode 100644 index 0000000000..b8d470f957 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/Examples/NegativeMonomialRoots.lean @@ -0,0 +1,55 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.HahnSeriesGCD + +/-! +# Arbitrarily long factorisations of a Hahn monomial + +In the ring `ℚ((ℝ^{≤0}))`, the nonunit monomial `t⁻¹` is the `n`-th power of the nonunit +monomial `t⁻¹⁄ⁿ` for every positive integer `n`. This is a useful boundary example: the GCD and +primality theorems impose no bound on factorisation length. This example by itself makes no +atomicity claim. +-/ + +@[expose] public noncomputable section + +namespace ConwayRefinement.Standalone.Hahn.NegativeMonomialExample + +/-- The Hahn-series ring `ℚ((ℝ^{≤0}))`. -/ +abbrev Ring := Hahn.nonpos ℚ + +/-- The elements of `ℚ((ℝ^{≤0}))` are exactly the Hahn series supported in `(-∞, 0]`. -/ +theorem mem_ring_iff (x : HahnSeries ℝ ℚ) : + x ∈ Ring ↔ x.support ⊆ Set.Iic 0 := (Iff.rfl) + +/-- The monomial `tˣ`, for `x ≤ 0`, as an element of `ℚ((ℝ^{≤0}))`. -/ +def monomial (x : ℝ) (hx : x ≤ 0) : Ring := + ⟨HahnSeries.single x 1, fun y hy ↦ by + rw [HahnSeries.eq_of_mem_support_single hy] + exact hx⟩ + +/-- The monomial `t⁻¹⁄ⁿ`. -/ +def nthRoot (n : ℕ) : Ring := + monomial (-(n : ℝ)⁻¹) (neg_nonpos.mpr (inv_nonneg.mpr (Nat.cast_nonneg n))) + +/-- The monomial `t⁻¹`. -/ +def negativeOne : Ring := monomial (-1) (by norm_num) + +/-- For every `n > 0`, `t⁻¹⁄ⁿ` is a nonunit and `(t⁻¹⁄ⁿ)ⁿ = t⁻¹`. -/ +def NegativeMonomialHasAllRoots : Prop := + ∀ (n : ℕ), 0 < n → ¬ IsUnit (nthRoot n) ∧ nthRoot n ^ n = negativeOne + +end ConwayRefinement.Standalone.Hahn.NegativeMonomialExample + +/-! +## Formal proof + +Proof module: `NegativeMonomialRootsProof`. + +* `NegativeMonomialHasAllRoots` → `NegativeMonomialHasAllRoots.proof` +-/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/Examples/NegativeMonomialRootsProof.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/Examples/NegativeMonomialRootsProof.lean new file mode 100644 index 0000000000..3266406c9e --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/Examples/NegativeMonomialRootsProof.lean @@ -0,0 +1,80 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.Examples.NegativeMonomialRoots + +import Mathlib.Tactic.FieldSimp +import Mathlib.Tactic.Linarith + +/-! # Negative Monomial Roots Proof -/ + +public noncomputable section + +namespace ConwayRefinement.Standalone.Hahn.NegativeMonomialExample + +private theorem eq_zero_of_mem_addAntidiagonal_zero {x y : Ring} {ij : ℝ × ℝ} + (hij : ij ∈ Finset.antidiagonal x.1.isPWO_support y.1.isPWO_support 0) : + ij = (0, 0) := by + rcases Finset.mem_antidiagonal.mp hij with ⟨hi, hj, hij⟩ + have hi_zero := eq_zero_of_add_nonneg_left (x.2 hi) (y.2 hj) hij.ge + have hj_zero := eq_zero_of_add_nonneg_right (x.2 hi) (y.2 hj) hij.ge + exact Prod.ext hi_zero hj_zero + +private def constantCoeff : Ring →+* ℚ where + toFun x := x.1.coeff 0 + map_one' := by simp + map_zero' := by simp + map_add' x y := by simp + map_mul' x y := by + change (x.1 * y.1).coeff 0 = x.1.coeff 0 * y.1.coeff 0 + rw [HahnSeries.coeff_mul] + by_cases hx : x.1.coeff 0 = 0 + · rw [hx, zero_mul] + apply Finset.sum_eq_zero + intro ij hij + rw [eq_zero_of_mem_addAntidiagonal_zero hij] + simp [hx] + · by_cases hy : y.1.coeff 0 = 0 + · rw [hy, mul_zero] + apply Finset.sum_eq_zero + intro ij hij + rw [eq_zero_of_mem_addAntidiagonal_zero hij] + simp [hy] + · apply Finset.sum_eq_single (0, 0) + · intro ij hij hne + exact (hne (eq_zero_of_mem_addAntidiagonal_zero hij)).elim + · simp [Finset.mem_antidiagonal, HahnSeries.mem_support, hx, hy] + +private theorem nthRoot_not_unit (n : ℕ) (hn : 0 < n) : ¬ IsUnit (nthRoot n) := by + intro h + have hu := h.map constantCoeff + have hz : constantCoeff (nthRoot n) = 0 := by + change ((HahnSeries.single (-(n : ℝ)⁻¹)) 1).coeff 0 = 0 + rw [HahnSeries.coeff_single_of_ne] + exact fun hzero ↦ by + have : (n : ℝ)⁻¹ = 0 := by linarith + exact inv_ne_zero (Nat.cast_ne_zero.mpr (Nat.ne_of_gt hn)) this + rw [hz] at hu + exact not_isUnit_zero hu + +private theorem nthRoot_pow (n : ℕ) (hn : 0 < n) : + nthRoot n ^ n = negativeOne := by + apply Subtype.ext + simp [nthRoot, negativeOne, monomial, HahnSeries.single_pow] + field_simp + +namespace NegativeMonomialHasAllRoots + +/-- The exponent identity `n(-1/n) = -1` gives the factorisation; the zero coefficient shows +that each factor is a nonunit. -/ +theorem proof : NegativeMonomialExample.NegativeMonomialHasAllRoots := by + intro n hn + exact ⟨nthRoot_not_unit n hn, nthRoot_pow n hn⟩ + +end NegativeMonomialHasAllRoots + +end ConwayRefinement.Standalone.Hahn.NegativeMonomialExample diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/GermPolynomialRing.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/GermPolynomialRing.lean new file mode 100644 index 0000000000..5e51d7c17b --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/GermPolynomialRing.lean @@ -0,0 +1,104 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import Mathlib.Algebra.MvPolynomial.Equiv +public import Mathlib.Basic.Real.Basic +public import Mathlib.RingTheory.HahnSeries.Multiplication +public import Mathlib.RingTheory.Ideal.Quotient.Operations +public import Mathlib.RingTheory.Ideal.Span +public import Mathlib.RingTheory.UniqueFactorizationDomain.Defs + +/-! +# The ring of germs is a polynomial ring + +Let `J` be the ideal of `K((ℝ^{≤0}))` generated by the monomials `t^x`, `x < 0`. +The quotient `K((ℝ^{≤0}))/J` is Berarducci's ring of germs. In characteristic zero it is +isomorphic as a ring to a polynomial ring with coefficient field `K`; in particular it has +unique factorisation. + +The polynomial presentation proves Berarducci's factorisation conjecture as stated in +[LM17, Conjecture 1.5]. + +## References + +* A. Berarducci, *Factorization in generalized power series*, Trans. Amer. Math. Soc. 352 (2000), + 553–577, cited as [Ber00]. +* S. L'Innocente, V. Mantova, *Factorisation of germ-like series*, J. Log. Anal. 9 (2017), cited + as [LM17]. +-/ + +@[expose] public noncomputable section + +namespace ConwayRefinement.Standalone.GermPolynomial + +universe u + +variable {K : Type u} [Field K] + +/-- The Hahn-series ring `K((ℝ^{≤0}))`. -/ +def nonpos (K : Type u) [Field K] : Subring (HahnSeries ℝ K) where + carrier := {x | x.support ⊆ Set.Iic 0} + zero_mem' := by simp + one_mem' := by + intro g hg + have hg0 : g = 0 := HahnSeries.support_single_subset hg + simp [hg0] + add_mem' := fun {x y} hx hy => by + intro g hg + rcases HahnSeries.support_add_subset x y hg with hg | hg + · exact hx hg + · exact hy hg + neg_mem' := fun {x} hx => (HahnSeries.support_neg_subset x).trans hx + mul_mem' := fun {x y} hx hy => by + intro g hg + obtain ⟨i, hi, j, hj, rfl⟩ := HahnSeries.support_mul_subset hg + exact add_nonpos (show i ≤ 0 from hx hi) (show j ≤ 0 from hy hj) + +/-- The elements of `K((ℝ^{≤0}))` are exactly the Hahn series supported in `(-∞, 0]`. -/ +theorem mem_nonpos_iff (x : HahnSeries ℝ K) : + x ∈ nonpos K ↔ x.support ⊆ Set.Iic 0 := (Iff.rfl) + +variable (K) in +/-- Berarducci's ideal `J`: the ideal of `K((ℝ^{≤0}))` generated by the monomials `t^x`, `x < 0`. -/ +def J : Ideal (nonpos K) := + Ideal.span {m : nonpos K | + ∃ x : ℝ, x < 0 ∧ (m : HahnSeries ℝ K) = HahnSeries.single x 1} + +variable (K) in +/-- Berarducci's ring of germs `K((ℝ^{≤0}))/J`. -/ +abbrev Germ := nonpos K ⧸ J K + +variable (K) in +/-- **Polynomial presentation of the ring of germs.** For some set `ι`, the ring +`K((ℝ^{≤0}))/J` is ring-isomorphic to `K[X_i : i ∈ ι]`. -/ +abbrev GermIsPolynomialRing : Prop := + CharZero K → ∃ ι : Type (max u 1), Nonempty (MvPolynomial ι K ≃+* Germ K) + +variable (K) in +/-- **Unique factorisation in the ring of germs** [LM17, Conjecture 1.5]: the ring of germs is a +domain; every nonzero germ is, up to a unit, a product of irreducible germs; and two products of +irreducible germs that agree up to a unit have the same factors up to order and associates. + +The conclusion is asserted in characteristic zero. -/ +abbrev GermHasUniqueFactorization : Prop := + CharZero K → + IsDomain (Germ K) ∧ + (∀ a : Germ K, a ≠ 0 → + ∃ f : Multiset (Germ K), (∀ b ∈ f, Irreducible b) ∧ Associated f.prod a) ∧ + ∀ f g : Multiset (Germ K), (∀ b ∈ f, Irreducible b) → (∀ b ∈ g, Irreducible b) → + Associated f.prod g.prod → Multiset.Rel Associated f g + +end ConwayRefinement.Standalone.GermPolynomial + +/-! +## Formal proof + +Proof module: `GermPolynomialRingProof`. + +* `GermIsPolynomialRing` → `GermIsPolynomialRing.proof` +* `GermHasUniqueFactorization` → `GermHasUniqueFactorization.proof` +-/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/GermPolynomialRingProof.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/GermPolynomialRingProof.lean new file mode 100644 index 0000000000..3dee10d524 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/GermPolynomialRingProof.lean @@ -0,0 +1,35 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.GermPolynomialRing +import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.Support.GermPolynomialRingProof + +/-! # Germ Polynomial Ring Proof -/ + +public noncomputable section + +namespace ConwayRefinement.Standalone.GermPolynomial + +universe u + +namespace GermIsPolynomialRing + +/-- The ring of germs is a polynomial ring over its coefficient field. -/ +theorem proof (K : Type u) [Field K] : GermIsPolynomialRing K := by + exact of_polynomiality K + +end GermIsPolynomialRing + +namespace GermHasUniqueFactorization + +/-- Every nonzero germ factors uniquely into irreducibles, up to order and association. -/ +theorem proof (K : Type u) [Field K] : GermHasUniqueFactorization K := by + exact of_polynomiality K + +end GermHasUniqueFactorization + +end ConwayRefinement.Standalone.GermPolynomial diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/HahnIntegerPartRefinement.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/HahnIntegerPartRefinement.lean new file mode 100644 index 0000000000..bdaef8b556 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/HahnIntegerPartRefinement.lean @@ -0,0 +1,65 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import Mathlib.Algebra.Order.Module.HahnEmbedding +public import Mathlib.RingTheory.HahnSeries.Cardinal +public import Mathlib.SetTheory.Cardinal.Regular + +/-! +# Refinement over saturated exponent groups + +An uncountably saturated ordered rational vector space gives four-factor refinement in the +cardinal-bounded generalised-power-series integer part with integer constant coefficients. +-/ + +public noncomputable section + +open Cardinal + +namespace ConwayRefinement.Standalone.Hahn + +universe u v + +variable {G : Type u} {R : Type v} +variable [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] +variable [Field R] + +/-- The cardinal-bounded integer part +`ℤ + {x : R((G)) | supp(x) ⊆ G^{<0} and #supp(x) < κ}`. -/ +abbrev integerHahnPart (κ : Cardinal.{u}) : Set (HahnSeries G R) := + {x | x.cardSupp < κ ∧ x.support ⊆ Set.Iic 0 ∧ ∃ z : ℤ, (z : R) = x.coeff 0} + +/-- The ordered set `G` is `κ`-saturated. -/ +abbrev IsKappaSaturated (κ : Cardinal.{u}) : Prop := + ∀ L R : Set G, #L < κ → #R < κ → + (∀ l ∈ L, ∀ r ∈ R, l < r) → + ∃ x : G, (∀ l ∈ L, l < x) ∧ ∀ r ∈ R, x < r + +/-- **Four-factor refinement over a saturated exponent group.** Let `κ` be regular and +uncountable, let `G` be a `κ`-saturated ordered rational vector space, and let `R` be a field of +characteristic zero. Every equality `a * b = c * d` in +`ℤ + R((G^{<0}))_κ` has four-factor refinement. -/ +abbrev HahnIntegerPartRefinement + : Prop := + ∀ (κ : Cardinal.{u}), ℵ₀ < κ → κ.IsRegular → IsKappaSaturated (G := G) κ → + ∀ a b c d : HahnSeries G R, + a ∈ integerHahnPart κ → b ∈ integerHahnPart κ → + c ∈ integerHahnPart κ → d ∈ integerHahnPart κ → a * b = c * d → + ∃ e f g h : HahnSeries G R, + e ∈ integerHahnPart κ ∧ f ∈ integerHahnPart κ ∧ + g ∈ integerHahnPart κ ∧ h ∈ integerHahnPart κ ∧ + a = e * f ∧ b = g * h ∧ c = e * g ∧ d = f * h + +end ConwayRefinement.Standalone.Hahn + +/-! +## Formal proof + +Proof module: `HahnIntegerPartRefinementProof`. + +* `HahnIntegerPartRefinement` → `HahnIntegerPartRefinement.proof` +-/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/HahnIntegerPartRefinementProof.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/HahnIntegerPartRefinementProof.lean new file mode 100644 index 0000000000..2fc5afb218 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/HahnIntegerPartRefinementProof.lean @@ -0,0 +1,27 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.HahnIntegerPartRefinement +import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.Support.HahnIntegerPartRefinementProof + +/-! # Hahn Integer Part Refinement Proof -/ +public noncomputable section + +namespace ConwayRefinement.Standalone.Hahn.HahnIntegerPartRefinement + +universe u v + +variable {G : Type u} {R : Type v} +variable [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] +variable [Field R] +variable [Module ℚ G] [IsOrderedModule ℚ G] [CharZero R] + +/-- Refinement for Hahn series with integer constant coefficient. -/ +theorem proof : HahnIntegerPartRefinement (G := G) (R := R) := + of_saturation_integer_coefficients + +end ConwayRefinement.Standalone.Hahn.HahnIntegerPartRefinement diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/HahnSeriesGCD.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/HahnSeriesGCD.lean new file mode 100644 index 0000000000..bca8f063fd --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/HahnSeriesGCD.lean @@ -0,0 +1,78 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import Mathlib.Algebra.Divisibility.Basic +public import Mathlib.Basic.Real.Basic +public import Mathlib.RingTheory.HahnSeries.Multiplication + +/-! +# Greatest common divisors and factorisation in `K((ℝ^{≤0}))` + +`nonpos K` is the Hahn-series ring `K((ℝ^{≤0}))`. In characteristic zero it is a GCD domain and +pre-Schreier. Consequently every irreducible series is prime, and any two irreducible +factorisations are the same up to order and units. LM24, Corollary 6.4.2 proves that these two +ring properties are equivalent to every irreducible series with infinite support being prime; +the theorems below establish the properties themselves. + +## References + +* S. L'Innocente, V. Mantova, *A factorisation theory for generalised power series and omnific + integers*, Adv. Math. 442 (2024) 109513, , cited + as [LM24]. +-/ + +@[expose] public noncomputable section + +namespace ConwayRefinement.Standalone.Hahn + +universe u + +variable (K : Type u) [Field K] + +/-- `K((ℝ^{≤0}))`: Hahn series with real exponents `≤ 0` [LM24, §1.2]. -/ +def nonpos : Subring (HahnSeries ℝ K) where + carrier := {x | x.support ⊆ Set.Iic 0} + zero_mem' := by simp + one_mem' := fun _ hg ↦ (HahnSeries.support_single_subset hg).le + add_mem' := fun hx hy ↦ + (HahnSeries.support_add_subset _ _).trans (Set.union_subset hx hy) + neg_mem' := fun hx ↦ (HahnSeries.support_neg_subset _).trans hx + mul_mem' := fun hx hy ↦ HahnSeries.support_mul_subset.trans fun _ ⟨i, hi, j, hj, h⟩ ↦ + h ▸ show i + j ≤ 0 from add_nonpos (hx hi) (hy hj) + +/-- Every pair of series in `K((ℝ^{≤0}))` has a greatest common divisor. -/ +abbrev SeriesHasGCDs : Prop := + CharZero K → + ∀ a b : nonpos K, ∃ d : nonpos K, ∀ e : nonpos K, e ∣ a ∧ e ∣ b ↔ e ∣ d + +/-- Every series in `K((ℝ^{≤0}))` is primal, in the sense of LM24, §2.5. -/ +abbrev SeriesIsPrimal : Prop := + CharZero K → ∀ a : nonpos K, IsPrimal a + +/-- Every irreducible series in `K((ℝ^{≤0}))` is prime. -/ +abbrev SeriesIrreduciblesArePrime : Prop := + CharZero K → ∀ a : nonpos K, Irreducible a → Prime a + +/-- Two products of irreducibles that agree up to a unit have the same factors up to order and +association. -/ +abbrev SeriesFactorizationsAreUnique : Prop := + CharZero K → + ∀ f g : Multiset (nonpos K), (∀ x ∈ f, Irreducible x) → (∀ x ∈ g, Irreducible x) → + Associated f.prod g.prod → Multiset.Rel Associated f g + +end ConwayRefinement.Standalone.Hahn + +/-! +## Formal proof + +Proof module: `HahnSeriesGCDProof`. + +* `SeriesHasGCDs` → `SeriesHasGCDs.proof` +* `SeriesIsPrimal` → `SeriesIsPrimal.proof` +* `SeriesIrreduciblesArePrime` → `SeriesIrreduciblesArePrime.proof` +* `SeriesFactorizationsAreUnique` → `SeriesFactorizationsAreUnique.proof` +-/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/HahnSeriesGCDProof.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/HahnSeriesGCDProof.lean new file mode 100644 index 0000000000..79d3422525 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/HahnSeriesGCDProof.lean @@ -0,0 +1,51 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.HahnSeriesGCD +import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.Support.HahnSeriesGCDProof + +/-! # Hahn Series GCDProof -/ + +public noncomputable section + +namespace ConwayRefinement.Standalone.Hahn + +universe u + +namespace SeriesHasGCDs + +/-- Every pair of series in `K((ℝ^{≤0}))` has a greatest common divisor. -/ +theorem proof (K : Type u) [Field K] : SeriesHasGCDs K := by + exact of_polynomiality K + +end SeriesHasGCDs + +namespace SeriesIsPrimal + +/-- Every series in `K((ℝ^{≤0}))` is primal. -/ +theorem proof (K : Type u) [Field K] : SeriesIsPrimal K := by + exact of_gcds K + +end SeriesIsPrimal + +namespace SeriesIrreduciblesArePrime + +/-- Every irreducible series is prime. -/ +theorem proof (K : Type u) [Field K] : SeriesIrreduciblesArePrime K := by + exact of_primality K + +end SeriesIrreduciblesArePrime + +namespace SeriesFactorizationsAreUnique + +/-- Irreducible factorisations are unique up to order and units. -/ +theorem proof (K : Type u) [Field K] : SeriesFactorizationsAreUnique K := by + exact of_primality K + +end SeriesFactorizationsAreUnique + +end ConwayRefinement.Standalone.Hahn diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/HahnSeriesPolynomialRing.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/HahnSeriesPolynomialRing.lean new file mode 100644 index 0000000000..36325f4b92 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/HahnSeriesPolynomialRing.lean @@ -0,0 +1,76 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import Mathlib.Algebra.MvPolynomial.Equiv +public import Mathlib.Basic.Real.Basic +public import Mathlib.RingTheory.HahnSeries.Cardinal + +/-! +# The Hahn-series ring is a polynomial ring + +Let `K_fin` be the subring of `K((ℝ^{≤0}))` consisting of the series with finite support. In +characteristic zero there is a set of indeterminates `ι` for which + +`K_fin[X_i : i ∈ ι] ≅ K((ℝ^{≤0}))`. + +Both rings are defined below in ordinary Mathlib language; the statement does not mention the +principal graded ring or a chosen generating system. +-/ + +open Cardinal + +@[expose] public noncomputable section + +namespace ConwayRefinement.Standalone.HahnPolynomial + +universe u + +variable (K : Type u) [Field K] + +/-- The Hahn-series ring `K((ℝ^{≤0}))`. -/ +def Series : Subring (HahnSeries ℝ K) where + carrier := {x | x.support ⊆ Set.Iic 0} + zero_mem' := by simp + one_mem' := fun _ hg ↦ (HahnSeries.support_single_subset hg).le + add_mem' := fun hx hy ↦ + (HahnSeries.support_add_subset _ _).trans (Set.union_subset hx hy) + neg_mem' := fun hx ↦ (HahnSeries.support_neg_subset _).trans hx + mul_mem' := fun hx hy ↦ HahnSeries.support_mul_subset.trans fun _ ⟨i, hi, j, hj, h⟩ ↦ + h ▸ show i + j ≤ 0 from add_nonpos (hx hi) (hy hj) + +/-- The elements of `K((ℝ^{≤0}))` are exactly the Hahn series supported in `(-∞, 0]`. -/ +theorem mem_series_iff (x : HahnSeries ℝ K) : + x ∈ Series K ↔ x.support ⊆ Set.Iic 0 := (Iff.rfl) + +/-- The subring `K_fin` of nonpositive Hahn series with finite support. -/ +def FiniteSupport : Subring (Series K) := + let _ : Fact (aleph0.{0} ≤ aleph0.{0}) := ⟨le_rfl⟩ + (HahnSeries.cardSuppLTSubring ℝ K aleph0).comap (Series K).subtype + +/-- Membership in `K_fin` is exactly finiteness of the Hahn-series support. -/ +theorem mem_finiteSupport_iff (x : Series K) : + x ∈ FiniteSupport K ↔ x.1.support.Finite := by + let : Fact (aleph0.{0} ≤ aleph0.{0}) := ⟨le_rfl⟩ + rw [FiniteSupport, Subring.mem_comap, HahnSeries.mem_cardSuppLTSubring, + HahnSeries.cardSupp] + exact Cardinal.lt_aleph0_iff_set_finite + +/-- **Polynomial presentation of the full series ring.** For some set `ι`, the polynomial algebra +over the finite-support series is isomorphic to the full nonpositive Hahn-series ring. -/ +abbrev IsPolynomialRing : Prop := + CharZero K → ∃ ι : Type (max u 1), + Nonempty (MvPolynomial ι (FiniteSupport K) ≃ₐ[FiniteSupport K] Series K) + +end ConwayRefinement.Standalone.HahnPolynomial + +/-! +## Formal proof + +Proof module: `HahnSeriesPolynomialRingProof`. + +* `IsPolynomialRing` → `IsPolynomialRing.proof` +-/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/HahnSeriesPolynomialRingProof.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/HahnSeriesPolynomialRingProof.lean new file mode 100644 index 0000000000..2e8b978e69 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/HahnSeriesPolynomialRingProof.lean @@ -0,0 +1,24 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.HahnSeriesPolynomialRing +import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.Support.HahnSeriesPolynomialRingProof + +/-! # Hahn Series Polynomial Ring Proof -/ + +public noncomputable section + +namespace ConwayRefinement.Standalone.HahnPolynomial.IsPolynomialRing + +universe u + +/-- The nonpositive Hahn-series ring is a polynomial ring over its finite-support subring. -/ +theorem proof (K : Type u) [Field K] : + ConwayRefinement.Standalone.HahnPolynomial.IsPolynomialRing K := by + exact of_polynomiality K + +end ConwayRefinement.Standalone.HahnPolynomial.IsPolynomialRing diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/InlineConwayRefinement.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/InlineConwayRefinement.lean new file mode 100644 index 0000000000..0c7229a39d --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/InlineConwayRefinement.lean @@ -0,0 +1,275 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Copyright (c) 2025 Aaron Liu. All rights reserved. +Copyright (c) 2025 Violeta Hernández Palacios. All rights reserved. +Copyright (c) 2025 Yuyang Zhao. All rights reserved. +Copyright (c) 2024 Theodore Hwa. All rights reserved. +Copyright (c) 2019 Mario Carneiro. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov, Aaron Liu, Apurva Nakade, Fox Thomson, František Silváši, +Isabel Longbottom, Junyan Xu, Kim Morrison, Mario Carneiro, Reid Barton, Theodore Hwa, +Violeta Hernández Palacios, Yuyang Zhao +-/ +/- +Adapted and modified from the Apache-2.0-licensed CombinatorialGames construction: +https://github.com/vihdzp/combinatorial-games +-/ +module + +public import Mathlib.Order.GameAdd + +/-! +# Conway's refinement conjecture from first principles + +This file gives, in order, the complete definitions needed to read Conway's refinement conjecture: + +1. a well-founded game with small left and right option families; +2. Conway recursion for negation, addition, multiplication, and order; +3. numeric games and equality of games; +4. surreal-number representatives and Conway's omnific-integer cut; +5. Conway's eight-variable refinement statement. + +Surreals are presented by numeric games. `Game.Equivalent` is equality in their quotient, so the +four displayed product equations below are exactly the corresponding quotient equations. +`InlineConwayRefinementProof` proves that the recursive operations preserve numericity and +equivalence and then proves the final proposition. +-/ + +public noncomputable section + +universe u + +namespace ConwayRefinement.Standalone.InlineConwayRefinement + +/-- A well-founded Conway game, built from small left and right option families. -/ +inductive Game : Type (u + 1) where + | mk (Left Right : Type u) (left : Left → Game) (right : Right → Game) + +namespace Game + +/-- A direct move selects either a left or a right option. -/ +inductive Move : Game → Game → Prop + | left {Left Right : Type u} {left : Left → Game} {right : Right → Game} + (i : Left) : Move (left i) (.mk Left Right left right) + | right {Left Right : Type u} {left : Left → Game} {right : Right → Game} + (i : Right) : Move (right i) (.mk Left Right left right) + +/-- Direct descent through options is well founded. -/ +theorem move_wf : WellFounded Move := by + constructor + intro x + induction x with + | mk Left Right left right ihLeft ihRight => + constructor + intro y hy + cases hy with + | left i => exact ihLeft i + | right i => exact ihRight i + +/-- Well-founded recursion on an ordered pair of games. -/ +noncomputable def pairRec {C : Game → Game → Sort*} + (step : ∀ x y, + (∀ x' y', Prod.Lex Move Move (x', y') (x, y) → C x' y') → C x y) + (x y : Game) : C x y := + @WellFounded.fix (Game × Game) (fun p ↦ C p.1 p.2) _ (move_wf.prod_lex move_wf) + (fun p rec ↦ step p.1 p.2 (fun x' y' h ↦ rec (x', y') h)) (x, y) + +/-- The characteristic equation for recursion on a pair of games. -/ +theorem pairRec_eq {C : Game → Game → Sort*} + (step : ∀ x y, + (∀ x' y', Prod.Lex Move Move (x', y') (x, y) → C x' y') → C x y) + (x y : Game) : + pairRec step x y = step x y fun x' y' _ ↦ pairRec step x' y' := + WellFounded.fix_eq .. + +/-- Negation interchanges the players and negates every option. -/ +@[expose] def neg : Game → Game + | .mk Left Right left right => + .mk Right Left (fun i ↦ neg (right i)) (fun i ↦ neg (left i)) + +/-- The defining option equation for negation. -/ +theorem neg_mk (Left Right : Type u) (left : Left → Game) (right : Right → Game) : + neg (.mk Left Right left right) = + .mk Right Left (fun i ↦ neg (right i)) (fun i ↦ neg (left i)) := + (rfl) + +/-- Conway addition: either player moves in exactly one summand. -/ +@[expose] noncomputable def add : Game → Game → Game := + pairRec fun x y rec ↦ + match x, y with + | .mk Lx Rx lx rx, .mk Ly Ry ly ry => + let x := Game.mk Lx Rx lx rx + let y := Game.mk Ly Ry ly ry + .mk (Lx ⊕ Ly) (Rx ⊕ Ry) + (Sum.elim + (fun i ↦ rec (lx i) y (Prod.Lex.left y y (Move.left i))) + (fun j ↦ rec x (ly j) (Prod.Lex.right x (Move.left j)))) + (Sum.elim + (fun i ↦ rec (rx i) y (Prod.Lex.left y y (Move.right i))) + (fun j ↦ rec x (ry j) (Prod.Lex.right x (Move.right j)))) + +/-- The defining option equation for Conway addition. -/ +theorem add_mk (Lx Rx Ly Ry : Type u) (lx : Lx → Game) (rx : Rx → Game) + (ly : Ly → Game) (ry : Ry → Game) : + add (.mk Lx Rx lx rx) (.mk Ly Ry ly ry) = + .mk (Lx ⊕ Ly) (Rx ⊕ Ry) + (Sum.elim (fun i ↦ add (lx i) (.mk Ly Ry ly ry)) + (fun j ↦ add (.mk Lx Rx lx rx) (ly j))) + (Sum.elim (fun i ↦ add (rx i) (.mk Ly Ry ly ry)) + (fun j ↦ add (.mk Lx Rx lx rx) (ry j))) := by + rw [add, pairRec_eq] + +/-- The zero game `{ | }`. -/ +@[expose] def zero : Game.{u} := .mk (ULift.{u} Empty) (ULift.{u} Empty) nofun nofun + +/-- The zero game has no options. -/ +theorem zero_eq : zero = + .mk (ULift.{u} Empty) (ULift.{u} Empty) nofun nofun := (rfl) + +/-- The unit game `{0 | }`. -/ +@[expose] def one : Game.{u} := + .mk PUnit.{u + 1} (ULift.{u} Empty) (fun _ ↦ zero) nofun + +/-- The unit game has zero as its sole left option. -/ +theorem one_eq : one = + .mk PUnit.{u + 1} (ULift.{u} Empty) (fun _ ↦ zero) nofun := (rfl) + +/-- Conway multiplication. Its option from options `a` of `x` and `b` of `y` is +`a * y + x * b - a * b`; equal-side moves are left options and opposite-side moves are right +options. -/ +@[expose] noncomputable def mul : Game → Game → Game := + pairRec fun x y rec ↦ + match x, y with + | .mk Lx Rx lx rx, .mk Ly Ry ly ry => + let x := Game.mk Lx Rx lx rx + let y := Game.mk Ly Ry ly ry + let option (a b : Game) (ha : Move a x) (hb : Move b y) := + add (add (rec a y (Prod.Lex.left y y ha)) + (rec x b (Prod.Lex.right x hb))) + (neg (rec a b (Prod.Lex.left b y ha))) + .mk ((Lx × Ly) ⊕ (Rx × Ry)) ((Lx × Ry) ⊕ (Rx × Ly)) + (Sum.elim + (fun ij ↦ option (lx ij.1) (ly ij.2) (Move.left ij.1) (Move.left ij.2)) + (fun ij ↦ option (rx ij.1) (ry ij.2) (Move.right ij.1) (Move.right ij.2))) + (Sum.elim + (fun ij ↦ option (lx ij.1) (ry ij.2) (Move.left ij.1) (Move.right ij.2)) + (fun ij ↦ option (rx ij.1) (ly ij.2) (Move.right ij.1) (Move.left ij.2))) + +/-- The defining option equation for Conway multiplication. -/ +theorem mul_mk (Lx Rx Ly Ry : Type u) (lx : Lx → Game) (rx : Rx → Game) + (ly : Ly → Game) (ry : Ry → Game) : + mul (.mk Lx Rx lx rx) (.mk Ly Ry ly ry) = + let x := Game.mk Lx Rx lx rx + let y := Game.mk Ly Ry ly ry + let option (a b : Game) := add (add (mul a y) (mul x b)) (neg (mul a b)) + .mk ((Lx × Ly) ⊕ (Rx × Ry)) ((Lx × Ry) ⊕ (Rx × Ly)) + (Sum.elim (fun ij ↦ option (lx ij.1) (ly ij.2)) + (fun ij ↦ option (rx ij.1) (ry ij.2))) + (Sum.elim (fun ij ↦ option (lx ij.1) (ry ij.2)) + (fun ij ↦ option (rx ij.1) (ly ij.2))) := by + rw [mul, pairRec_eq] + +/-- Conway's recursive order: `x ≤ y` when no left option of `x` is at least `y`, and no right +option of `y` is at most `x`. -/ +@[expose] noncomputable def Le : Game → Game → Prop := + Sym2.GameAdd.recursion move_wf fun x y rec ↦ + match x, y with + | .mk Lx Rx lx rx, .mk Ly Ry ly ry => + let x := Game.mk Lx Rx lx rx + let y := Game.mk Ly Ry ly ry + (∀ i : Lx, ¬rec y (lx i) (Sym2.GameAdd.snd_fst (Move.left i))) ∧ + (∀ j : Ry, ¬rec (ry j) x (Sym2.GameAdd.fst_snd (Move.right j))) + +/-- The defining option equation for Conway's order. -/ +theorem le_mk (Lx Rx Ly Ry : Type u) (lx : Lx → Game) (rx : Rx → Game) + (ly : Ly → Game) (ry : Ry → Game) : + Le (.mk Lx Rx lx rx) (.mk Ly Ry ly ry) ↔ + (∀ i, ¬Le (.mk Ly Ry ly ry) (lx i)) ∧ + (∀ j, ¬Le (ry j) (.mk Lx Rx lx rx)) := by + exact propext_iff.1 <| Sym2.GameAdd.recursion_eq .. + +/-- Conway equivalence, the equality relation on games. -/ +def Equivalent (x y : Game) : Prop := Le x y ∧ Le y x + +/-- Conway equivalence unfolds to the two order inequalities. -/ +theorem equivalent_iff (x y : Game) : Equivalent x y ↔ Le x y ∧ Le y x := (Iff.rfl) + +/-- Conway's strict order on numeric games. -/ +def Less (x y : Game) : Prop := Le x y ∧ ¬Le y x + +/-- Conway's strict order unfolds to an inequality and failure of its reverse. -/ +theorem less_iff (x y : Game) : Less x y ↔ Le x y ∧ ¬Le y x := (Iff.rfl) + +/-- A game is numeric when all its options are numeric and every left option is strictly below +every right option. -/ +inductive Numeric : Game → Prop where + | mk {Left Right : Type u} {left : Left → Game} {right : Right → Game} : + (∀ i j, Less (left i) (right j)) → + (∀ i, Numeric (left i)) → + (∀ j, Numeric (right j)) → + Numeric (.mk Left Right left right) + +end Game + +/-- A surreal-number representative is a numeric well-founded Conway game. Two representatives +denote the same surreal number precisely when their games are `Game.Equivalent`. -/ +structure Surreal : Type (u + 1) where + /-- The numeric Conway game representing this surreal number. -/ + game : Game.{u} + numeric : Game.Numeric game + +namespace Surreal + +/-- The singleton Conway cut `{x - 1 | x + 1}` at game level. -/ +noncomputable def singletonIntegerCut (x : Game.{u}) : Game.{u} := + .mk PUnit PUnit (fun _ ↦ Game.add x (Game.neg Game.one)) + (fun _ ↦ Game.add x Game.one) + +/-- The singleton-cut construction unfolds to its two displayed options. -/ +theorem singletonIntegerCut_eq (x : Game.{u}) : + singletonIntegerCut x = + .mk PUnit PUnit (fun _ ↦ Game.add x (Game.neg Game.one)) + (fun _ ↦ Game.add x Game.one) := (rfl) + +/-- Conway's cut equation defining an omnific integer. -/ +def IsConwayOmnificInteger (x : Surreal.{u}) : Prop := + Game.Equivalent x.game (singletonIntegerCut x.game) + +/-- Membership unfolds to Conway's defining cut equation. -/ +theorem isConwayOmnificInteger_iff (x : Surreal.{u}) : + IsConwayOmnificInteger x ↔ Game.Equivalent x.game (singletonIntegerCut x.game) := + (Iff.rfl) + +/-- Conway's four-factor statement. Every equation `a * b = c * d` of omnific integers has +omnific integers `e`, `f`, `g`, `h` with +`a = e * f`, `b = g * h`, `c = e * g`, and `d = f * h`. All equations are equality in the +quotient of numeric games, written directly as `Game.Equivalent`. -/ +abbrev ConwayConjecture : Prop := + ∀ a b c d : Surreal.{u}, + IsConwayOmnificInteger a → IsConwayOmnificInteger b → + IsConwayOmnificInteger c → IsConwayOmnificInteger d → + Game.Equivalent (Game.mul a.game b.game) (Game.mul c.game d.game) → + ∃ e f g h : Surreal.{u}, + IsConwayOmnificInteger e ∧ IsConwayOmnificInteger f ∧ + IsConwayOmnificInteger g ∧ IsConwayOmnificInteger h ∧ + Game.Equivalent a.game (Game.mul e.game f.game) ∧ + Game.Equivalent b.game (Game.mul g.game h.game) ∧ + Game.Equivalent c.game (Game.mul e.game g.game) ∧ + Game.Equivalent d.game (Game.mul f.game h.game) + +end Surreal + +end ConwayRefinement.Standalone.InlineConwayRefinement + +/-! +## Formal proof + +Proof module: `InlineConwayRefinementProof`. + +* `ConwayConjecture` → `ConwayConjecture.proof` +-/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/InlineConwayRefinementProof.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/InlineConwayRefinementProof.lean new file mode 100644 index 0000000000..67d568d98c --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/InlineConwayRefinementProof.lean @@ -0,0 +1,22 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.InlineConwayRefinement +import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.Support.InlineConwayRefinementProof + +/-! # Inline Conway Refinement Proof -/ +public noncomputable section + +universe u + +namespace ConwayRefinement.Standalone.InlineConwayRefinement.Surreal.ConwayConjecture + +/-- Conway's refinement theorem for the fully displayed Mathlib construction of surreal numbers. -/ +theorem proof : ConwayConjecture.{u} := + ConwayRefinement.Standalone.InlineConwayRefinement.Surreal.conwayRefinementProof + +end ConwayRefinement.Standalone.InlineConwayRefinement.Surreal.ConwayConjecture diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/Support.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/Support.lean new file mode 100644 index 0000000000..1768f4544a --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/Support.lean @@ -0,0 +1,25 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.Support.ArchimedeanQuotient +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.Support.CompleteHahnGermProof +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.Support.ConvexQuotient +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.Support.ConvexQuotientSplitting +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.Support.ConwayRefinement +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.Support.ConwayRefinementProof +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.Support.GermPolynomialRingProof +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.Support.HahnIntegerPartRefinementProof +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.Support.HahnLimitTailQuotient +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.Support.HahnSeriesGCDProof +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.Support.HahnSeriesPolynomialRingProof +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.Support.InlineConwayRefinementProof +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.Support.InlineSurreal +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.Support.OrderedAddGroup +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.Support.SeriesConsequences + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/Support/ArchimedeanQuotient.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/Support/ArchimedeanQuotient.lean new file mode 100644 index 0000000000..c159451165 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/Support/ArchimedeanQuotient.lean @@ -0,0 +1,267 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.Support.ConvexQuotient +public import Mathlib.Algebra.Group.Subgroup.Lattice +public import Mathlib.Algebra.Order.Archimedean.Class + +/-! +# Archimedean classes in subgroups and limit quotients + +A positively coinitial subgroup of an ordered abelian group inherits the absence of a largest +finite Archimedean class from the ambient group. The ambient hypothesis is essential: positive +coinitiality alone does not create new Archimedean classes. + +There is a separate construction suited to a limit family of classes. For a set `T` of finite +Archimedean classes, `FiniteArchimedeanClass.tailKernel T` is the intersection of their closed +Archimedean balls. If every member of `T` has a strictly later member, the quotient by this convex +subgroup has no largest finite Archimedean class. This is the quotient used at a limit of support +support classes. +-/ + +open Set + +universe u + +public noncomputable section + +namespace ConwayRefinement.Standalone.Hahn + +namespace AddSubgroup + +variable {C : Type u} [AddCommGroup C] [LinearOrder C] [IsOrderedAddMonoid C] + +/-- An additive subgroup of an ordered abelian group inherits the ordered-additive structure. -/ +instance instIsOrderedAddMonoid (S : AddSubgroup C) : IsOrderedAddMonoid S where + add_le_add_left a b h z := + show (a : C) + (z : C) ≤ (b : C) + (z : C) from by + simpa [add_comm] using + add_le_add_left (show (a : C) ≤ (b : C) from h) (z : C) + +/-- A positively coinitial subgroup inherits the absence of a largest finite Archimedean class +from its ambient ordered group. -/ +theorem finiteArchimedeanClass_noMax_of_pos_coinitial + [NoMaxOrder (FiniteArchimedeanClass C)] (S : AddSubgroup C) + (hS : ∀ y : C, 0 < y → ∃ x : S, 0 < (x : C) ∧ (x : C) ≤ y) : + NoMaxOrder (FiniteArchimedeanClass S) := by + constructor + intro c + induction c using FiniteArchimedeanClass.ind with + | mk x hx => + obtain ⟨d, hxd⟩ := exists_gt + (FiniteArchimedeanClass.mk (x : C) (Subtype.coe_ne_coe.mpr hx)) + induction d using FiniteArchimedeanClass.ind with + | mk y hy => + obtain ⟨z, hzpos, hzy⟩ := hS |y| (abs_pos.mpr hy) + have hz0 : z ≠ 0 := fun hz ↦ hzpos.ne' (Subtype.ext_iff.mp hz) + refine ⟨FiniteArchimedeanClass.mk z hz0, ?_⟩ + let e : S →+o C := + { toFun := fun z ↦ (z : C) + map_zero' := rfl + map_add' := fun _ _ ↦ rfl + monotone' := fun _ _ h ↦ h } + change ArchimedeanClass.mk (e x) < ArchimedeanClass.mk (e z) + rw [← ArchimedeanClass.orderHom_mk e x, ← ArchimedeanClass.orderHom_mk e z] + apply ((ArchimedeanClass.orderHom e).monotone.strictMono_of_injective + (ArchimedeanClass.orderHom_injective Subtype.val_injective)).lt_iff_lt.mpr + change ArchimedeanClass.mk (x : C) < ArchimedeanClass.mk (z : C) + change ArchimedeanClass.mk (x : C) < ArchimedeanClass.mk y at hxd + refine hxd.trans_le ?_ + apply ArchimedeanClass.mk_le_mk_of_abs + simpa [abs_of_pos hzpos] using hzy + +end AddSubgroup + +namespace FiniteArchimedeanClass + +variable {G : Type u} [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + +/-- The elements lying in the closed ball of every class in `T`. -/ +def tailKernel (T : Set (FiniteArchimedeanClass G)) : AddSubgroup G := + ⨅ c : T, ArchimedeanClass.closedBallAddSubgroup c.1.1 + +/-- Membership in the tail kernel means having class at least every class in `T`. -/ +theorem mem_tailKernel_iff {T : Set (FiniteArchimedeanClass G)} {x : G} : + x ∈ tailKernel T ↔ ∀ c : T, c.1.1 ≤ ArchimedeanClass.mk x := by + rw [tailKernel, AddSubgroup.mem_iInf] + exact forall_congr' fun c ↦ ArchimedeanClass.mem_closedBallAddSubgroup_iff + +/-- The common tail kernel of a family of Archimedean classes is convex. -/ +instance tailKernel_isConvex (T : Set (FiniteArchimedeanClass G)) : + ConvexQuotient.IsConvex (tailKernel T) where + ordConnected := by + constructor + intro a ha b hb x hx + apply mem_tailKernel_iff.mpr + intro c + exact (le_min (mem_tailKernel_iff.mp ha c) (mem_tailKernel_iff.mp hb c)).trans + (ArchimedeanClass.min_le_mk_of_le_of_le hx.1 hx.2) + +/-- Absolute value commutes with projection to a convex tail quotient. -/ +theorem quotient_abs (T : Set (FiniteArchimedeanClass G)) (x : G) : + |(x : G ⧸ tailKernel T)| = ((|x| : G) : G ⧸ tailKernel T) := by + rcases le_total 0 x with hx | hx + · have hxq : (0 : G ⧸ tailKernel T) ≤ (x : G ⧸ tailKernel T) := by + rw [← QuotientAddGroup.mk_zero] + exact ConvexQuotient.mk_le_mk hx + rw [abs_of_nonneg hx, abs_of_nonneg hxq] + · have hxq : (x : G ⧸ tailKernel T) ≤ (0 : G ⧸ tailKernel T) := by + rw [← QuotientAddGroup.mk_zero] + exact ConvexQuotient.mk_le_mk hx + rw [abs_of_nonpos hx, abs_of_nonpos hxq, ← QuotientAddGroup.mk_neg] + +/-- A strict comparison of Archimedean classes in a common-tail quotient reflects to any chosen +representatives. -/ +theorem archimedeanClass_mk_lt_of_quotient_mk_lt + (T : Set (FiniteArchimedeanClass G)) {x y : G} + (h : ArchimedeanClass.mk (x : G ⧸ tailKernel T) < + ArchimedeanClass.mk (y : G ⧸ tailKernel T)) : + ArchimedeanClass.mk x < ArchimedeanClass.mk y := by + rw [ArchimedeanClass.mk_lt_mk] at h ⊢ + intro n + have hn := h n + have hn' : ((n • |y| : G) : G ⧸ tailKernel T) < + ((|x| : G) : G ⧸ tailKernel T) := by + simpa only [quotient_abs, QuotientAddGroup.mk_nsmul] using hn + exact ConvexQuotient.lt_of_mk_lt_mk hn' + +/-- A nonzero natural multiple of an absolute value stays in the same Archimedean class. -/ +theorem mk_nsmul_abs {x : G} {n : ℕ} (hn : n ≠ 0) : + ArchimedeanClass.mk (n • |x|) = ArchimedeanClass.mk x := by + apply ArchimedeanClass.mk_eq_mk.mpr + constructor + · refine ⟨1, ?_⟩ + rw [one_nsmul, abs_nsmul, abs_abs] + obtain ⟨k, rfl⟩ := Nat.exists_eq_succ_of_ne_zero hn + simpa [succ_nsmul] using + (le_add_of_nonneg_left (nsmul_nonneg (abs_nonneg x) k) : + |x| ≤ k • |x| + |x|) + · refine ⟨n, ?_⟩ + rw [abs_nsmul, abs_abs] + +/-- If `T` has no least member in the magnitude order, its common tail quotient has no least +nonzero Archimedean class in the magnitude order. -/ +theorem quotient_noMax_of_forall_exists_gt (T : Set (FiniteArchimedeanClass G)) + (hT : ∀ c ∈ T, ∃ d ∈ T, c < d) : + NoMaxOrder (FiniteArchimedeanClass (G ⧸ tailKernel T)) := by + constructor + intro c + induction c using FiniteArchimedeanClass.ind with + | mk x hx => + induction x using QuotientAddGroup.induction_on with + | H x => + have hxH : x ∉ tailKernel T := by + simpa using (show (x : G ⧸ tailKernel T) ≠ 0 from hx) + rw [mem_tailKernel_iff] at hxH + push Not at hxH + obtain ⟨d, hxd⟩ := hxH + obtain ⟨e, heT, hde⟩ := hT d.1 d.2 + obtain ⟨f, hfT, hef⟩ := hT e heT + let y : G := e.1.out + have hyclass : ArchimedeanClass.mk y = e.1 := ArchimedeanClass.mk_out e.1 + have hy0 : y ≠ 0 := ArchimedeanClass.mk_eq_top_iff.not.mp + (hyclass.trans_ne e.2) + have hyH : y ∉ tailKernel T := by + intro hy + have hf_le_y : f.1 ≤ ArchimedeanClass.mk y := + mem_tailKernel_iff.mp hy ⟨f, hfT⟩ + rw [hyclass] at hf_le_y + exact (not_le_of_gt hef) hf_le_y + refine ⟨FiniteArchimedeanClass.mk (y : G ⧸ tailKernel T) (by simpa using hyH), ?_⟩ + change ArchimedeanClass.mk (x : G ⧸ tailKernel T) < + ArchimedeanClass.mk (y : G ⧸ tailKernel T) + rw [ArchimedeanClass.mk_lt_mk] + intro n + have hclass : ArchimedeanClass.mk x < ArchimedeanClass.mk y := by + rw [hyclass] + exact hxd.trans hde + have hxy : n • |y| < |x| := ArchimedeanClass.mk_lt_mk.mp hclass n + have hquot : ((n • |y| : G) : G ⧸ tailKernel T) < + ((|x| : G) : G ⧸ tailKernel T) := by + apply ConvexQuotient.mk_lt_mk_iff.mpr + refine ⟨hxy, ?_⟩ + intro hmem + have hdiff : d.1 ≤ ArchimedeanClass.mk (|x| - n • |y|) := + mem_tailKernel_iff.mp hmem d + have hdiffclass : ArchimedeanClass.mk (|x| - n • |y|) = + ArchimedeanClass.mk x := by + by_cases hn : n = 0 + · simp [hn] + rw [ArchimedeanClass.mk_sub_eq_mk_left] + · exact ArchimedeanClass.mk_abs x + · simpa only [ArchimedeanClass.mk_abs, mk_nsmul_abs hn] using hclass + rw [hdiffclass] at hdiff + exact (not_le_of_gt hxd) hdiff + simpa only [quotient_abs, QuotientAddGroup.mk_nsmul] using hquot + +/-- The no-largest-class theorem for a quotient by any additive subgroup whose carrier is the +tail kernel. -/ +theorem quotient_noMax_of_eq_tailKernel (T : Set (FiniteArchimedeanClass G)) + (H : AddSubgroup G) [ConvexQuotient.IsConvex H] (hH : H = tailKernel T) + (hT : ∀ c ∈ T, ∃ d ∈ T, c < d) : + NoMaxOrder (FiniteArchimedeanClass (G ⧸ H)) := by + subst H + exact quotient_noMax_of_forall_exists_gt T hT + +/-- A canonical positive representative of a finite Archimedean class. -/ +def positiveRepresentative (c : FiniteArchimedeanClass G) : G := + |c.1.out| + +/-- The canonical representative of a finite class is positive. -/ +theorem positiveRepresentative_pos (c : FiniteArchimedeanClass G) : + 0 < positiveRepresentative c := by + rw [positiveRepresentative, abs_pos] + intro h + have := congrArg ArchimedeanClass.mk h + rw [ArchimedeanClass.mk_out, ArchimedeanClass.mk_zero] at this + exact c.2 this + +/-- The canonical positive representative represents the requested class. -/ +theorem mk_positiveRepresentative (c : FiniteArchimedeanClass G) : + ArchimedeanClass.mk (positiveRepresentative c) = c.1 := by + rw [positiveRepresentative, ArchimedeanClass.mk_abs, ArchimedeanClass.mk_out] + +/-- At a limit family, each canonical representative survives the common tail quotient. -/ +theorem positiveRepresentative_not_mem_tailKernel {T : Set (FiniteArchimedeanClass G)} + (hT : ∀ c ∈ T, ∃ d ∈ T, c < d) (c : T) : + positiveRepresentative c.1 ∉ tailKernel T := by + obtain ⟨d, hdT, hcd⟩ := hT c.1 c.2 + intro hmem + have := mem_tailKernel_iff.mp hmem ⟨d, hdT⟩ + rw [mk_positiveRepresentative] at this + exact (not_le_of_gt hcd) this + +/-- The image of a canonical representative in its limit quotient is positive. -/ +theorem quotient_positiveRepresentative_pos {T : Set (FiniteArchimedeanClass G)} + (hT : ∀ c ∈ T, ∃ d ∈ T, c < d) (c : T) : + 0 < ((positiveRepresentative c.1 : G) : G ⧸ tailKernel T) := by + rw [← QuotientAddGroup.mk_zero] + exact ConvexQuotient.mk_lt_mk_iff.mpr ⟨positiveRepresentative_pos c.1, + by simpa using positiveRepresentative_not_mem_tailKernel hT c⟩ + +/-- The canonical representatives of a limit family are coinitial among the positive elements of +the common tail quotient. -/ +theorem exists_quotient_positiveRepresentative_le {T : Set (FiniteArchimedeanClass G)} + {x : G ⧸ tailKernel T} (hx : 0 < x) : + ∃ c : T, ((positiveRepresentative c.1 : G) : G ⧸ tailKernel T) ≤ x := by + induction x using QuotientAddGroup.induction_on with + | H x => + have hxq : ((0 : G) : G ⧸ tailKernel T) < (x : G ⧸ tailKernel T) := by + simpa using hx + have hx0 : 0 < x := ConvexQuotient.lt_of_mk_lt_mk hxq + have hxH : x ∉ tailKernel T := by + simpa using (ConvexQuotient.mk_lt_mk_iff.mp hxq).2 + rw [mem_tailKernel_iff] at hxH + push Not at hxH + obtain ⟨c, hxc⟩ := hxH + refine ⟨c, ConvexQuotient.mk_le_mk ?_⟩ + apply (ArchimedeanClass.lt_of_mk_lt_mk_of_nonneg ?_ hx0.le).le + rwa [mk_positiveRepresentative] + +end FiniteArchimedeanClass + +end ConwayRefinement.Standalone.Hahn diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/Support/CompleteHahnGermProof.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/Support/CompleteHahnGermProof.lean new file mode 100644 index 0000000000..82786c35fc --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/Support/CompleteHahnGermProof.lean @@ -0,0 +1,95 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.CompleteHahnGerm +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Refinement.CompleteGermRefinement + +import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Divisibility.Refinement +import Mathlib.Algebra.Ring.Hom.InjSurj + +/-! # Complete Hahn Germ Proof -/ + +public noncomputable section + +namespace ConwayRefinement.Standalone.CompleteHahnGerm.Support + +universe u v + +variable {G : Type u} {K : Type v} +variable [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] +variable [Field K] + +private def seriesRingEquiv : + NonpositiveSeries G K ≃+* HahnSeries.Nonpositive G K where + toFun x := ⟨x, x.2⟩ + invFun x := ⟨x, x.2⟩ + left_inv _ := rfl + right_inv _ := rfl + map_add' _ _ := rfl + map_mul' _ _ := rfl + +private def seriesAlgEquiv : + NonpositiveSeries G K ≃ₐ[K] HahnSeries.Nonpositive G K := + AlgEquiv.ofRingEquiv (f := seriesRingEquiv) fun k ↦ by + apply Subtype.ext + change (algebraMap K (HahnSeries G K)) k = + ((HahnSeries.Nonpositive.C (Γ := G) k : HahnSeries.Nonpositive G K) : HahnSeries G K) + rw [HahnSeries.Nonpositive.coe_C, HahnSeries.algebraMap_apply, Algebra.algebraMap_self, + RingHom.id_apply] + +@[simp] private theorem coe_seriesEquiv (x : NonpositiveSeries G K) : + ((seriesAlgEquiv x : HahnSeries.Nonpositive G K) : HahnSeries G K) = x := rfl + +variable [NoMinOrder G] +variable [UniformSpace G] [IsUniformAddGroup G] [OrderTopology G] +variable [Nontrivial G] [CompleteSpace G] [CharZero K] + +private theorem boundedAwayIdeal_map_eq : + (HahnSeries.Nonpositive.cantorBendixsonValuation (G := G) (R := K)).supp = + (BoundedAwayIdeal G K).map seriesAlgEquiv := by + ext y + rw [HahnSeries.Nonpositive.mem_cantorBendixsonValuation_supp, + Ideal.mem_map_iff_of_surjective seriesAlgEquiv seriesAlgEquiv.surjective] + constructor + · rintro ⟨r, hr, hyr⟩ + refine ⟨seriesAlgEquiv.symm y, ⟨r, hr, ?_⟩, seriesAlgEquiv.apply_symm_apply y⟩ + change (y : HahnSeries G K).support ⊆ Set.Iic r + exact hyr + · rintro ⟨x, ⟨r, hr, hxr⟩, rfl⟩ + exact ⟨r, hr, by simpa only [coe_seriesEquiv] using hxr⟩ + +/-- The internal Cantor–Bendixson construction gives the standalone polynomial presentation. -/ +theorem isPolynomialRing (G : Type u) (K : Type v) + [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [NoMinOrder G] [Field K] : + IsPolynomialRing G K := by + intro _ _ _ _ _ _ _ _ _ + obtain ⟨ι, ⟨equiv⟩⟩ := + HahnSeries.Nonpositive.exists_mvPolynomial_algEquiv_germ (G := G) (K := K) + let quotientEquiv : Germ G K ≃ₐ[K] + HahnSeries.Nonpositive G K ⧸ + (HahnSeries.Nonpositive.cantorBendixsonValuation (G := G) (R := K)).supp := + Ideal.quotientEquivAlg (BoundedAwayIdeal G K) + (HahnSeries.Nonpositive.cantorBendixsonValuation (G := G) (R := K)).supp + seriesAlgEquiv boundedAwayIdeal_map_eq + exact ⟨ι, ⟨equiv.trans quotientEquiv.symm⟩⟩ + +/-- A polynomial presentation gives four-factor refinement. -/ +theorem hasRefinement (G : Type u) (K : Type v) + [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [NoMinOrder G] [Field K] : + HasRefinement G K := by + intro _ _ _ _ _ _ _ _ _ + obtain ⟨ι, ⟨equiv⟩⟩ := isPolynomialRing G K + let : IsDomain (Germ G K) := + Function.Injective.isDomain equiv.symm.toRingHom equiv.symm.injective + let : DecompositionMonoid (Germ G K) := + MulEquiv.decompositionMonoid equiv.symm.toMulEquiv + intro a b c d habcd + exact (hasFourFactorRefinement_of_decompositionMonoid (R := Germ G K)).refine habcd + +end ConwayRefinement.Standalone.CompleteHahnGerm.Support diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/Support/ConvexQuotient.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/Support/ConvexQuotient.lean new file mode 100644 index 0000000000..336d488992 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/Support/ConvexQuotient.lean @@ -0,0 +1,185 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import Mathlib.Algebra.Order.Group.Defs +public import Mathlib.GroupTheory.QuotientGroup.Defs +public import Mathlib.Order.Interval.Set.OrdConnected +import Mathlib.Tactic.Abel + +/-! +# The quotient of an ordered group by a convex subgroup + +A subgroup of a linearly ordered abelian group that is order-connected as a set is *convex*, and +the quotient by it inherits a linear order: one coset lies below another when some representative +of the first lies below some representative of the second. Convexity is exactly what makes that +relation antisymmetric, because an element trapped between zero and a subgroup element belongs to +the subgroup. + +The projection is monotone and reflects the strict order (`mk_le_mk`, `lt_of_mk_lt_mk`). Those +two facts are what let order-theoretic hypotheses be transported to the quotient — filling cuts, +in the intended application, where the quotient is taken to gain a small coinitial family of +positive elements that the group itself lacks. +-/ + +universe u + +open Set + +public section + +namespace ConwayRefinement.Standalone.Hahn + +namespace ConvexQuotient + +variable {G : Type u} [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + +/-- A subgroup of an ordered group is convex when it is order-connected. -/ +class IsConvex (H : AddSubgroup G) : Prop where + /-- The carrier of a convex subgroup is order-connected. -/ + ordConnected : (H : Set G).OrdConnected + +omit [IsOrderedAddMonoid G] in +/-- A nonnegative element below an element of a convex subgroup lies in the subgroup. -/ +theorem mem_of_nonneg_of_le (H : AddSubgroup G) [IsConvex H] {x y : G} (hx : 0 ≤ x) + (hxy : x ≤ y) (hy : y ∈ H) : x ∈ H := + IsConvex.ordConnected.out H.zero_mem hy ⟨hx, hxy⟩ + +variable {G : Type u} [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + {H : AddSubgroup G} [IsConvex H] + +/-- One coset lies below another when some representative of the first lies below some +representative of the second. -/ +instance instLE : LE (G ⧸ H) where + le x y := ∃ a b : G, (a : G ⧸ H) = x ∧ (b : G ⧸ H) = y ∧ a ≤ b + +/-- **Comparing cosets.** One coset lies below another exactly when the chosen representatives are +already comparable or differ by a subgroup element. Convexity supplies the forward direction: were +the representatives reversed, their difference would be trapped between zero and the subgroup +element relating the two choices. -/ +theorem mk_le_mk_iff {a b : G} : + ((a : G ⧸ H) ≤ (b : G ⧸ H)) ↔ a ≤ b ∨ b - a ∈ H := by + constructor + · rintro ⟨a', b', ha', hb', hab⟩ + rw [QuotientAddGroup.eq_iff_sub_mem] at ha' hb' + rcases le_or_gt a b with h | h + · exact Or.inl h + refine Or.inr ?_ + have hsub : a - b ≤ (b' - b) - (a' - a) := by + rw [← sub_nonneg] + have heq : (b' - b) - (a' - a) - (a - b) = b' - a' := by abel + rw [heq] + exact sub_nonneg.mpr hab + have hmem := mem_of_nonneg_of_le H (sub_nonneg.mpr h.le) hsub + (H.sub_mem hb' ha') + simpa using H.neg_mem hmem + · rintro (h | h) + · exact ⟨a, b, rfl, rfl, h⟩ + · exact ⟨a, a, rfl, + QuotientAddGroup.eq_iff_sub_mem.mpr (by simpa using H.neg_mem h), le_rfl⟩ + +/-- The projection is monotone. -/ +theorem mk_le_mk {a b : G} (h : a ≤ b) : (a : G ⧸ H) ≤ (b : G ⧸ H) := + mk_le_mk_iff.mpr (Or.inl h) + +open Classical in +noncomputable instance instLinearOrder : LinearOrder (G ⧸ H) where + le := (· ≤ ·) + le_refl := by + refine fun x ↦ QuotientAddGroup.induction_on x fun a ↦ ?_ + exact mk_le_mk le_rfl + le_trans := by + refine fun x y z ↦ QuotientAddGroup.induction_on x fun a ↦ QuotientAddGroup.induction_on y + fun b ↦ QuotientAddGroup.induction_on z fun c hab hbc ↦ ?_ + rw [mk_le_mk_iff] at hab hbc ⊢ + rcases hab with hab | hab + · rcases hbc with hbc | hbc + · exact Or.inl (hab.trans hbc) + -- `c` and `b` differ in the subgroup, so `a ≤ c` unless `a - c` is trapped below `b - c`. + · rcases le_or_gt a c with h | h + · exact Or.inl h + refine Or.inr ?_ + have hbc' : b - c ∈ H := by simpa using H.neg_mem hbc + have hmem := mem_of_nonneg_of_le H (sub_nonneg.mpr h.le) + (sub_le_sub_right hab c) hbc' + simpa using H.neg_mem hmem + · rcases hbc with hbc | hbc + · rcases le_or_gt a c with h | h + · exact Or.inl h + refine Or.inr ?_ + have hab' : a - b ∈ H := by simpa using H.neg_mem hab + have hmem := mem_of_nonneg_of_le H (sub_nonneg.mpr h.le) + (sub_le_sub_left hbc a) hab' + simpa using H.neg_mem hmem + · exact Or.inr (by simpa using H.add_mem hbc hab) + le_antisymm := by + refine fun x y ↦ QuotientAddGroup.induction_on x fun a ↦ QuotientAddGroup.induction_on y + fun b hab hba ↦ ?_ + rw [mk_le_mk_iff] at hab hba + rw [QuotientAddGroup.eq_iff_sub_mem] + rcases hab with hab | hab + · rcases hba with hba | hba + · rw [le_antisymm hab hba, sub_self] + exact H.zero_mem + · exact hba + · simpa using H.neg_mem hab + le_total := by + refine fun x y ↦ QuotientAddGroup.induction_on x fun a ↦ QuotientAddGroup.induction_on y + fun b ↦ ?_ + rcases le_total a b with h | h + · exact Or.inl (mk_le_mk h) + · exact Or.inr (mk_le_mk h) + toDecidableLE := Classical.decRel _ + +instance instIsOrderedAddMonoid : IsOrderedAddMonoid (G ⧸ H) where + add_le_add_left := by + refine fun x y ↦ QuotientAddGroup.induction_on x fun a ↦ QuotientAddGroup.induction_on y + fun b hab z ↦ QuotientAddGroup.induction_on z fun c ↦ ?_ + rw [mk_le_mk_iff] at hab + have hc : ((a + c : G) : G ⧸ H) ≤ ((b + c : G) : G ⧸ H) := by + rw [mk_le_mk_iff] + rcases hab with hab | hab + · exact Or.inl (add_le_add hab le_rfl) + · exact Or.inr (by simpa using hab) + simpa using hc + +/-- **The projection reflects the strict order.** Two representatives whose cosets are strictly +comparable are themselves strictly comparable. -/ +theorem lt_of_mk_lt_mk {a b : G} (h : (a : G ⧸ H) < (b : G ⧸ H)) : a < b := by + rcases mk_le_mk_iff.mp h.le with hab | hab + · refine hab.lt_of_ne fun hEq ↦ ?_ + exact absurd (le_of_eq (congrArg _ hEq.symm)) (not_le.mpr h) + · exact absurd (mk_le_mk_iff.mpr (Or.inr (by simpa using H.neg_mem hab))) (not_le.mpr h) + +/-- One coset lies strictly below another exactly when the representatives do and their difference +escapes the subgroup. -/ +theorem mk_lt_mk_iff {a b : G} : + ((a : G ⧸ H) < (b : G ⧸ H)) ↔ a < b ∧ b - a ∉ H := by + refine ⟨fun h ↦ ⟨lt_of_mk_lt_mk h, fun hmem ↦ ?_⟩, fun ⟨hab, hmem⟩ ↦ ?_⟩ + · exact absurd (mk_le_mk_iff.mpr (Or.inr (by simpa using H.neg_mem hmem))) (not_le.mpr h) + · refine lt_of_le_of_ne (mk_le_mk hab.le) fun hEq ↦ hmem ?_ + simpa using H.neg_mem (QuotientAddGroup.eq_iff_sub_mem.mp hEq) + +/-- **Halving descends to the quotient.** If every positive element of `G` is twice a positive +element, the same holds in the quotient: a representative's half stays outside the subgroup, +since otherwise the representative itself would lie inside it. -/ +theorem exists_half_of_pos (hG : ∀ x : G, 0 < x → ∃ y, 0 < y ∧ y + y = x) {c : G ⧸ H} + (hc : 0 < c) : ∃ d : G ⧸ H, 0 < d ∧ d + d ≤ c := by + induction c using QuotientAddGroup.induction_on with + | H x => + have hpos : ((0 : G) : G ⧸ H) < (x : G ⧸ H) := by + rw [QuotientAddGroup.mk_zero] + exact hc + have hxH : x ∉ H := by simpa using (mk_lt_mk_iff.mp hpos).2 + obtain ⟨y, hy, hyx⟩ := hG x (lt_of_mk_lt_mk hpos) + have hyH : y ∉ H := fun hmem ↦ hxH (hyx ▸ H.add_mem hmem hmem) + refine ⟨(y : G ⧸ H), ?_, ?_⟩ + · exact mk_lt_mk_iff.mpr ⟨hy, by simpa using hyH⟩ + · rw [← QuotientAddGroup.mk_add, hyx] + +end ConvexQuotient + +end ConwayRefinement.Standalone.Hahn diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/Support/ConvexQuotientSplitting.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/Support/ConvexQuotientSplitting.lean new file mode 100644 index 0000000000..2a80b12d09 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/Support/ConvexQuotientSplitting.lean @@ -0,0 +1,178 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.Support.ArchimedeanQuotient +public import Mathlib.Algebra.Order.Module.Archimedean +public import Mathlib.Algebra.Order.Monoid.Prod +public import Mathlib.LinearAlgebra.Basis.VectorSpace +public import Mathlib.LinearAlgebra.Projection + +/-! +# Ordered splitting by a convex subspace + +A subspace of a vector space over a field has an algebraic complement. If the ambient additive +group is linearly ordered and the subspace is convex, this complement presents the ambient group +as the lexicographic product of the ordered quotient and the subspace. The quotient coordinate is +dominant. This additive splitting is what permits Hahn series to be regrouped by quotient cosets +without introducing a cocycle. + +For a family of finite Archimedean classes, `FiniteArchimedeanClass.tailSubmodule` equips their +common tail kernel with its natural subspace structure. Thus the generic splitting applies to the +limit-tail quotients used in the Cantor–Bendixson argument. +-/ + +open Set + +universe u v + +public noncomputable section + +namespace ConwayRefinement.Standalone.Hahn + +namespace FiniteArchimedeanClass + +variable (K : Type v) {G : Type u} +variable [Field K] [LinearOrder K] [IsOrderedRing K] [Archimedean K] +variable [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] +variable [Module K G] [PosSMulMono K G] + +/-- The common tail kernel of `T`, equipped with its natural `K`-subspace structure. -/ +def tailSubmodule (T : Set (FiniteArchimedeanClass G)) : Submodule K G where + __ := tailKernel T + smul_mem' k x hx := by + apply mem_tailKernel_iff.mpr + intro c + exact (mem_tailKernel_iff.mp hx c).trans (ArchimedeanClass.mk_le_mk_smul x k) + +/-- Membership in the common-tail subspace is membership in the underlying common-tail +kernel. -/ +@[simp] +theorem mem_tailSubmodule_iff {T : Set (FiniteArchimedeanClass G)} {x : G} : + x ∈ tailSubmodule K T ↔ x ∈ tailKernel T := + (Iff.rfl) + +@[simp] +theorem tailSubmodule_toAddSubgroup (T : Set (FiniteArchimedeanClass G)) : + (tailSubmodule K T).toAddSubgroup = tailKernel T := + (rfl) + +/-- The subspace form of the common tail kernel is convex. -/ +instance tailSubmodule_isConvex (T : Set (FiniteArchimedeanClass G)) : + ConvexQuotient.IsConvex (tailSubmodule K T).toAddSubgroup := by + rw [tailSubmodule_toAddSubgroup K T] + infer_instance + +end FiniteArchimedeanClass + +namespace Submodule + +variable {K : Type v} {G : Type u} +variable [Field K] [AddCommGroup G] [Module K G] +variable [LinearOrder G] [IsOrderedAddMonoid G] + +variable (P : Submodule K G) + +/-- A chosen linear complement of `P`. -/ +noncomputable def linearComplement : Submodule K G := + Classical.choose P.exists_isCompl + +omit [LinearOrder G] [IsOrderedAddMonoid G] in +/-- The chosen complement is complementary to `P`. -/ +theorem isCompl_linearComplement : IsCompl P (linearComplement P) := + Classical.choose_spec P.exists_isCompl + +/-- The quotient by `P`, identified linearly with the chosen complement. -/ +noncomputable def quotientLinearEquivComplement : (G ⧸ P) ≃ₗ[K] linearComplement P := + P.quotientEquivOfIsCompl (linearComplement P) (isCompl_linearComplement P) + +/-- Reassemble a quotient coordinate and a `P`-coordinate in the ambient vector space. -/ +noncomputable def quotientProdLinearEquiv : ((G ⧸ P) × P) ≃ₗ[K] G := + ((quotientLinearEquivComplement P).prodCongr (LinearEquiv.refl K P)).trans + ((linearComplement P).prodEquivOfIsCompl P (isCompl_linearComplement P).symm) + +omit [LinearOrder G] [IsOrderedAddMonoid G] in +/-- Reassembly has the prescribed quotient coordinate. -/ +@[simp] +theorem mk_quotientProdLinearEquiv (x : (G ⧸ P) × P) : + _root_.Submodule.Quotient.mk (quotientProdLinearEquiv P x) = x.1 := by + rw [quotientProdLinearEquiv, LinearEquiv.trans_apply, LinearEquiv.prodCongr_apply, + Submodule.coe_prodEquivOfIsCompl'] + change QuotientAddGroup.mk' P.toAddSubgroup + ((quotientLinearEquivComplement P x.1 : G) + (x.2 : G)) = x.1 + rw [map_add, show QuotientAddGroup.mk' P.toAddSubgroup (x.2 : G) = 0 by + exact (Submodule.Quotient.mk_eq_zero P).mpr x.2.property, add_zero] + exact P.mk_quotientEquivOfIsCompl_apply (isCompl_linearComplement P) x.1 + +omit [LinearOrder G] [IsOrderedAddMonoid G] in +/-- Reassembling a zero quotient coordinate returns the subspace coordinate. -/ +@[simp] +theorem quotientProdLinearEquiv_zero_left (p : P) : + quotientProdLinearEquiv P (0, p) = (p : G) := by + rw [quotientProdLinearEquiv, LinearEquiv.trans_apply, LinearEquiv.prodCongr_apply, + Submodule.coe_prodEquivOfIsCompl'] + simp [quotientLinearEquivComplement] + +/-- The linear order on the quotient by the convex exponent submodule. -/ +noncomputable local instance quotientLinearOrder [ConvexQuotient.IsConvex P.toAddSubgroup] : + LinearOrder (G ⧸ P) := + ConvexQuotient.instLinearOrder (H := P.toAddSubgroup) + +local instance submoduleIsOrderedAddMonoid : IsOrderedAddMonoid P := + AddSubgroup.instIsOrderedAddMonoid P.toAddSubgroup + +/-- A linearly ordered vector space is the lexicographic product of the quotient by a convex +subspace and that subspace. The quotient is the dominant coordinate. -/ +noncomputable def quotientLexEquiv [ConvexQuotient.IsConvex P.toAddSubgroup] : + ((G ⧸ P) ×ₗ P) ≃+o G := + { (quotientProdLinearEquiv P).toAddEquiv with + map_le_map_iff' := by + intro x y + apply (show StrictMono + (fun x : ((G ⧸ P) ×ₗ P) ↦ quotientProdLinearEquiv P (ofLex x)) by + intro x y hxy + rcases Prod.Lex.lt_iff.mp hxy with houter | ⟨houter, hinner⟩ + · have hq : + ((quotientProdLinearEquiv P (ofLex x) : G) : G ⧸ P.toAddSubgroup) < + ((quotientProdLinearEquiv P (ofLex y) : G) : G ⧸ P.toAddSubgroup) := by + change (_root_.Submodule.Quotient.mk (quotientProdLinearEquiv P (ofLex x)) : + G ⧸ P) < + _root_.Submodule.Quotient.mk (quotientProdLinearEquiv P (ofLex y)) + rw [mk_quotientProdLinearEquiv, mk_quotientProdLinearEquiv] + exact houter + exact ConvexQuotient.lt_of_mk_lt_mk hq + · change quotientProdLinearEquiv P (ofLex x) < quotientProdLinearEquiv P (ofLex y) + simp only [quotientProdLinearEquiv, LinearEquiv.trans_apply, + LinearEquiv.prodCongr_apply, Submodule.coe_prodEquivOfIsCompl'] + rw [show (ofLex x).1 = (ofLex y).1 from houter] + simpa only [LinearEquiv.refl_apply, add_comm] using + add_lt_add_left (show ((ofLex x).2 : G) < ((ofLex y).2 : G) from hinner) + (quotientLinearEquivComplement P (ofLex y).1 : G)).le_iff_le } + +@[simp] +theorem quotientLexEquiv_apply [ConvexQuotient.IsConvex P.toAddSubgroup] + (x : (G ⧸ P) ×ₗ P) : + quotientLexEquiv P x = quotientProdLinearEquiv P (ofLex x) := + (rfl) + +end Submodule + +namespace FiniteArchimedeanClass + +variable (K : Type v) {G : Type u} +variable [Field K] [LinearOrder K] [IsOrderedRing K] [Archimedean K] +variable [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] +variable [Module K G] [PosSMulMono K G] + +/-- The ambient group split lexicographically into the quotient by its tail subspace and that +subspace. Its additive subgroup is propositionally equal to `tailKernel T`. -/ +noncomputable def tailQuotientLexEquiv (T : Set (FiniteArchimedeanClass G)) : + ((G ⧸ (tailSubmodule K T).toAddSubgroup) ×ₗ tailSubmodule K T) ≃+o G := + Submodule.quotientLexEquiv (tailSubmodule K T) + +end FiniteArchimedeanClass + +end ConwayRefinement.Standalone.Hahn diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/Support/ConwayRefinement.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/Support/ConwayRefinement.lean new file mode 100644 index 0000000000..8b31d5d227 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/Support/ConwayRefinement.lean @@ -0,0 +1,55 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import Mathlib.Algebra.Group.Defs + +/-! +# Conway's four-factor refinement statement + +This file records the logical form of Conway's statement without choosing a construction of the +surreal numbers or the omnific integers. Given a predicate `P` on a type with multiplication, the +statement says that every equation `a * b = c * d` among `P`-elements admits Conway's +four-factor refinement. + +Concrete developments may instantiate `P` by Conway's cut definition of the omnific integers or +by membership in a Hahn integer part. This module imports only Mathlib. +-/ + +public section + +namespace ConwayRefinement.Standalone + +universe u + +variable {R : Type u} [Mul R] + +/-- Conway's four-factor refinement schema for a predicate `P`: from `a * b = c * d`, produce +`a = e * f`, `b = g * h`, `c = e * g`, and `d = f * h`, with all eight entries satisfying `P`. -/ +def HasRefinement (P : R → Prop) : Prop := + ∀ a b c d : R, + P a → P b → P c → P d → a * b = c * d → + ∃ e f g h : R, + P e ∧ P f ∧ P g ∧ P h ∧ + a = e * f ∧ b = g * h ∧ c = e * g ∧ d = f * h + +/-- The standalone proposition unfolds to the four equations in Conway's refinement conjecture. -/ +theorem conwayRefinement_iff (P : R → Prop) : HasRefinement P ↔ + ∀ a b c d : R, + P a → P b → P c → P d → a * b = c * d → + ∃ e f g h : R, + P e ∧ P f ∧ P g ∧ P h ∧ + a = e * f ∧ b = g * h ∧ c = e * g ∧ d = f * h := (Iff.rfl) + +end ConwayRefinement.Standalone + +/-! +## Formal proof + +Proof module: `ConwayRefinementProof`. + +* `HasRefinement` → `HasRefinement.refine` +-/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/Support/ConwayRefinementProof.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/Support/ConwayRefinementProof.lean new file mode 100644 index 0000000000..1c793300f1 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/Support/ConwayRefinementProof.lean @@ -0,0 +1,33 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.Support.ConwayRefinement + +/-! +# Public interface for four-factor refinement + +This proof sibling supplies the module-safe eliminator for the standalone proposition. +-/ + +public section + +namespace ConwayRefinement.Standalone.HasRefinement + +universe u + +variable {R : Type u} [Mul R] {P : R → Prop} + +/-- Apply four-factor refinement to one product equation. -/ +theorem refine (hc : HasRefinement P) + {a b c d : R} (ha : P a) (hb : P b) (hc' : P c) (hd : P d) + (heq : a * b = c * d) : + ∃ e f g h : R, + P e ∧ P f ∧ P g ∧ P h ∧ + a = e * f ∧ b = g * h ∧ c = e * g ∧ d = f * h := by + exact conwayRefinement_iff P |>.mp hc a b c d ha hb hc' hd heq + +end ConwayRefinement.Standalone.HasRefinement diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/Support/GermPolynomialRingProof.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/Support/GermPolynomialRingProof.lean new file mode 100644 index 0000000000..8d7f5cb153 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/Support/GermPolynomialRingProof.lean @@ -0,0 +1,86 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.GermPolynomialRing +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Nonpositive +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.NegativeMonomialIdeal +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Germ + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Primality.OrdinalValueQuotient +import Mathlib.Algebra.Ring.Hom.InjSurj +import Mathlib.RingTheory.Ideal.Quotient.Operations +import Mathlib.RingTheory.UniqueFactorizationDomain.Basic + +/-! +# Proof that the ring of germs is a polynomial ring + +The standalone ideal `J` is `negativeMonomialIdeal`, so its quotient is Berarducci's `Germ K`. +A minimal homogeneous generating system gives a polynomial presentation and hence unique +factorisation. +-/ + +public noncomputable section + +namespace ConwayRefinement.Standalone.GermPolynomial + +universe u + +variable {K : Type u} [Field K] + +/-- The ideal `J` is the span of the monomials `t^x` with `x < 0`. -/ +theorem J_eq : J K = HahnSeries.Nonpositive.negativeMonomialIdeal K := by + rw [HahnSeries.Nonpositive.negativeMonomialIdeal_def] + unfold J + congr 1 + ext m + constructor + · rintro ⟨x, hx, hm⟩ + exact HahnSeries.Nonpositive.mem_negativeMonomials_iff.mpr + ⟨⟨x, hx⟩, Subtype.ext (by rw [HahnSeries.Nonpositive.coe_single]; exact hm.symm)⟩ + · intro h + obtain ⟨⟨x, hx⟩, rfl⟩ := HahnSeries.Nonpositive.mem_negativeMonomials_iff.mp h + exact ⟨x, hx, HahnSeries.Nonpositive.coe_single _ _ _⟩ + +variable (K) in +/-- The standalone ring of germs is ring-equivalent to Berarducci's germ ring. -/ +def germRingEquiv : Germ K ≃+* Berarducci.Germ K := by + exact @Ideal.quotEquivOfEq (nonpos K) inferInstance (J K) + (HahnSeries.Nonpositive.negativeMonomialIdeal K) inferInstance + ⟨fun b ha ↦ mul_comm b _ ▸ Ideal.mul_mem_left _ b ha⟩ J_eq + +namespace GermIsPolynomialRing + +/-- The germ ring is a polynomial ring over its coefficient field. -/ +theorem of_polynomiality (K : Type u) [Field K] : GermIsPolynomialRing K := by + intro hK + let := hK + obtain ⟨ι, wt, x, hx⟩ := + OrdinalGraded.exists_isMinimalSystem (Berarducci.principalGrading K) + obtain ⟨σ⟩ := Berarducci.exists_lifts hx.mem + exact ⟨ι, ⟨(σ.ordinalValueQuotientAlgEquiv hx).symm.toRingEquiv.trans (germRingEquiv K).symm⟩⟩ + +end GermIsPolynomialRing + +namespace GermHasUniqueFactorization + +/-- Every nonzero germ factors uniquely into irreducibles, up to order and association. -/ +theorem of_polynomiality (K : Type u) [Field K] : + GermHasUniqueFactorization K := by + intro hK + let := hK + obtain ⟨ι, ⟨equiv⟩⟩ := GermIsPolynomialRing.of_polynomiality K hK + have hdom : IsDomain (Germ K) := + Function.Injective.isDomain equiv.symm.toRingHom equiv.symm.injective + have : UniqueFactorizationMonoid (Germ K) := + equiv.toMulEquiv.uniqueFactorizationMonoid inferInstance + refine ⟨hdom, fun a ha ↦ ?_, fun f g hf hg h ↦ UniqueFactorizationMonoid.factors_unique hf hg h⟩ + obtain ⟨f, hf, hfa⟩ := UniqueFactorizationMonoid.exists_prime_factors a ha + exact ⟨f, fun b hb ↦ (hf b hb).irreducible, hfa⟩ + +end GermHasUniqueFactorization + +end ConwayRefinement.Standalone.GermPolynomial diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/Support/HahnIntegerPartRefinementProof.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/Support/HahnIntegerPartRefinementProof.lean new file mode 100644 index 0000000000..5b9a110f68 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/Support/HahnIntegerPartRefinementProof.lean @@ -0,0 +1,943 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.HahnIntegerPartRefinement +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.Examples.HahnIntegerPartRefinementCriterion + +import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Divisibility.Refinement +import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Divisibility.PrimalPreimage +import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Order.Module.ArchimedeanBallSplitting +import LeanPool.ConwayRefinement.ConwayRefinement.Topology.Order.CoinitialComplete +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.LimitTailPrimality +import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Order.ArchimedeanBall +import Mathlib.Algebra.Module.Rat +import Mathlib.Algebra.GCDMonoid.Nat +import Mathlib.Basic.Real.Embedding +import Mathlib.SetTheory.Cardinal.Rat + +/-! +# Proof of refinement in cardinal-bounded Hahn integer parts + +The finite-class argument uses conditions `(A1)`--`(A3)` from LM24. The common-tail hypotheses +extend primality to every bounded generalised-power-series integer part, and primality gives the +four-factor refinement property. +-/ + +public noncomputable section + +open Cardinal +open HahnSeries.CardSuppLTTruncationIntegerPart + +namespace ConwayRefinement.Standalone.Hahn.HahnIntegerPartRefinement + +universe u v + +variable {G : Type u} {R : Type v} +variable [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] +variable [Module ℚ G] [IsOrderedModule ℚ G] +variable [Field R] + +local instance : PosSMulStrictMono ℚ G := PosSMulMono.toPosSMulStrictMono + +omit [IsOrderedAddMonoid G] [Module ℚ G] [IsOrderedModule ℚ G] in +theorem mem_hahnIntegerPart_iff {Z : Subring R} {κ : Cardinal.{u}} {x : HahnSeries G R} : + x ∈ hahnIntegerPart Z κ ↔ + x.cardSupp < κ ∧ x.support ⊆ Set.Iic 0 ∧ x.coeff 0 ∈ Z := + Iff.rfl + +omit [Module ℚ G] [IsOrderedModule ℚ G] in +theorem isFractionFieldOfHahnIntegerPart_iff {Z : Subring R} {κ : Cardinal.{u}} : + IsFractionFieldOfHahnIntegerPart (G := G) Z κ ↔ + ∀ x : HahnSeries G R, x.cardSupp < κ → + ∃ a b : HahnSeries G R, + a ∈ hahnIntegerPart Z κ ∧ b ∈ hahnIntegerPart Z κ ∧ b ≠ 0 ∧ x = a / b := + Iff.rfl + +omit [IsOrderedAddMonoid G] [Module ℚ G] [IsOrderedModule ℚ G] in +theorem mem_integerHahnPart_iff {κ : Cardinal.{u}} {x : HahnSeries G R} : + x ∈ integerHahnPart κ ↔ + x.cardSupp < κ ∧ x.support ⊆ Set.Iic 0 ∧ ∃ z : ℤ, (z : R) = x.coeff 0 := + Iff.rfl + +theorem assumptionA1_iff {s : HahnEmbedding.ArchimedeanStrata ℚ G} : + AssumptionA1 s ↔ + ∀ c : FiniteArchimedeanClass G, Nonempty (s.stratum c ≃+o ℝ) := + Iff.rfl + +theorem generatesFractionField_iff {Z : Subring R} : + GeneratesFractionField Z ↔ + ∀ x : R, ∃ a b : Z, b ≠ 0 ∧ x = (a : R) / (b : R) := + Iff.rfl + +theorem assumptionA2_iff {Z : Subring R} {κ : Cardinal.{u}} : + AssumptionA2 (G := G) Z κ ↔ + ∀ c : FiniteArchimedeanClass G, + κ ≤ Order.cof ↑(FiniteArchimedeanClass.ball ℚ c) ∨ + (Subsingleton ↑(FiniteArchimedeanClass.ball ℚ c) ∧ GeneratesFractionField Z) := + Iff.rfl + +theorem assumptionA3_iff {Z : Subring R} : + AssumptionA3 Z ↔ + ∀ z a b : Z, z ∣ a * b → + ∃ z₁ z₂ : Z, z₁ ∣ a ∧ z₂ ∣ b ∧ z = z₁ * z₂ := + Iff.rfl + +omit [Module ℚ G] [IsOrderedModule ℚ G] in +theorem isLimitFamily_iff {T : Set (FiniteArchimedeanClass G)} : + IsLimitFamily T ↔ T.Nonempty ∧ ∀ c ∈ T, ∃ d ∈ T, c < d := + Iff.rfl + +omit [AddCommGroup G] [IsOrderedAddMonoid G] [Module ℚ G] [IsOrderedModule ℚ G] in +theorem isKappaSaturated_iff {κ : Cardinal.{u}} : + IsKappaSaturated (G := G) κ ↔ + ∀ L R : Set G, #L < κ → #R < κ → + (∀ l ∈ L, ∀ r ∈ R, l < r) → + ∃ x : G, (∀ l ∈ L, l < x) ∧ ∀ r ∈ R, x < r := + Iff.rfl + +/-- The standalone common-tail definition agrees with the canonical common-tail subspace used by +the proof. -/ +theorem commonTail_eq_tailSubmodule + (T : Set (FiniteArchimedeanClass G)) : + commonTail T = _root_.FiniteArchimedeanClass.tailSubmodule ℚ T := by + ext x + rw [mem_commonTail_iff, + _root_.FiniteArchimedeanClass.mem_tailSubmodule_iff, + _root_.FiniteArchimedeanClass.mem_tailKernel_iff] + +/-- The standalone and canonical common-tail subspaces are order-isomorphic. -/ +def commonTailSubtypeOrderIso (T : Set (FiniteArchimedeanClass G)) : + commonTail T ≃o _root_.FiniteArchimedeanClass.tailSubmodule ℚ T where + toFun x := ⟨x, by + rw [← commonTail_eq_tailSubmodule (G := G) T] + exact x.2⟩ + invFun x := ⟨x, by + rw [commonTail_eq_tailSubmodule (G := G) T] + exact x.2⟩ + left_inv _ := rfl + right_inv _ := rfl + map_rel_iff' := Iff.rfl + +/-- The two independently stated common-tail quotients are the same ordered additive group. -/ +noncomputable def commonTailOrderAddMonoidIso + (T : Set (FiniteArchimedeanClass G)) : + (G ⧸ commonTail T) ≃+o + (G ⧸ _root_.FiniteArchimedeanClass.tailSubmodule ℚ T) := by + let h := commonTail_eq_tailSubmodule (G := G) T + refine { (Submodule.quotEquivOfEq (commonTail T) + (_root_.FiniteArchimedeanClass.tailSubmodule ℚ T) h).toAddEquiv with + map_le_map_iff' := ?_ } + intro a b + refine Submodule.Quotient.induction_on (commonTail T) a fun a ↦ ?_ + refine Submodule.Quotient.induction_on (commonTail T) b fun b ↦ ?_ + change + ((Submodule.Quotient.mk a : + G ⧸ _root_.FiniteArchimedeanClass.tailSubmodule ℚ T) ≤ + Submodule.Quotient.mk b) ↔ + ((Submodule.Quotient.mk a : G ⧸ commonTail T) ≤ + Submodule.Quotient.mk b) + have htarget : + ((Submodule.Quotient.mk a : + G ⧸ _root_.FiniteArchimedeanClass.tailSubmodule ℚ T) ≤ + Submodule.Quotient.mk b) ↔ + a ≤ b ∨ b - a ∈ _root_.FiniteArchimedeanClass.tailSubmodule ℚ T := by + exact _root_.ConvexQuotient.mk_le_mk_iff + have hsource : + ((Submodule.Quotient.mk a : G ⧸ commonTail T) ≤ + Submodule.Quotient.mk b) ↔ a ≤ b ∨ b - a ∈ commonTail T := by + exact ConvexQuotient.mk_le_mk_iff + exact htarget.trans ((or_congr Iff.rfl (by rw [h])).trans hsource.symm) + +/-- The independent common-tail quotient presentations have the same additive uniformity. -/ +noncomputable def commonTailUniformEquiv + (T : Set (FiniteArchimedeanClass G)) : + (G ⧸ commonTail T) ≃ᵤ + (G ⧸ _root_.FiniteArchimedeanClass.tailSubmodule ℚ T) := by + let e := commonTailOrderAddMonoidIso (G := G) T + exact + { e.toEquiv with + uniformContinuous_toFun := + uniformContinuous_of_continuousAt_zero e.toAddEquiv + e.toOrderIso.continuous.continuousAt + uniformContinuous_invFun := + uniformContinuous_of_continuousAt_zero e.symm.toAddEquiv + e.symm.toOrderIso.continuous.continuousAt } + +omit [AddCommGroup G] [IsOrderedAddMonoid G] [Module ℚ G] [IsOrderedModule ℚ G] in +private theorem fillsCuts_of_isKappaSaturated {κ : Cardinal.{u}} + (hG : IsKappaSaturated (G := G) κ) {ι : Type u} (hι : #ι < κ) : + FillsCuts ι G := by + rw [isKappaSaturated_iff] at hG + rw [fillsCuts_iff] + intro L R hLR + have hL : #(Set.range L) < κ := Cardinal.mk_range_le.trans_lt hι + have hR : #(Set.range R) < κ := Cardinal.mk_range_le.trans_lt hι + obtain ⟨x, hxL, hxR⟩ := hG (Set.range L) (Set.range R) hL hR + (by rintro _ ⟨i, rfl⟩ _ ⟨j, rfl⟩; exact hLR i j) + exact ⟨x, fun i ↦ (hxL _ ⟨i, rfl⟩).le, fun j ↦ (hxR _ ⟨j, rfl⟩).le⟩ + +@[blueprint "lem:saturated-archimedean-strata-real" + (phase := "Bounded generalised-power-series integer parts") + (title := "Archimedean strata of saturated ordered groups") + (statement := /-- + Let $\kappa>\aleph_0$ and let $G$ be a $\kappa$-saturated ordered rational + vector space. Every Archimedean stratum in any Hahn splitting of $G$ is + order additively isomorphic to $\mathbb R$. + -/) + (proof := /-- + Embed a stratum order additively into $\mathbb R$ and fix a positive + element whose image is $\rho>0$. For $y\in\mathbb R$, the rational + multiples $q\rhoy$ define two countable subsets of $G$. + Saturation supplies an element between them. It lies in the corresponding + closed Archimedean ball; project it to the stratum using the lexicographic + splitting of that ball. Comparison with every rational multiple forces + the projected element to map to $y$. Thus the embedding is surjective. + -/)] +private theorem stratum_orderAddEquiv_real_of_isKappaSaturated + {κ : Cardinal.{u}} (hκ : ℵ₀ < κ) (hG : IsKappaSaturated (G := G) κ) + (s : HahnEmbedding.ArchimedeanStrata ℚ G) (c : FiniteArchimedeanClass G) : + Nonempty (s.stratum c ≃+o ℝ) := by + rw [isKappaSaturated_iff] at hG + let S := s.stratum c + obtain ⟨f, hf⟩ := Archimedean.exists_orderAddMonoidHom_real_injective S + have hfmono : StrictMono f := + (OrderHomClass.monotone f).strictMono_of_injective hf + obtain ⟨a₀, ha₀⟩ := exists_ne (0 : S) + let a : S := |a₀| + have ha : 0 < a := abs_pos.mpr ha₀ + let ρ : ℝ := f a + have hρ : 0 < ρ := by + change 0 < f a + simpa using hfmono ha + have hsurj : Function.Surjective f := by + intro y + let L : Set G := {x | ∃ q : ℚ, (q : ℝ) * ρ < y ∧ x = (q • a : S)} + let R : Set G := {x | ∃ q : ℚ, y < (q : ℝ) * ρ ∧ x = (q • a : S)} + have hLcard : #L < κ := by + refine (Cardinal.mk_le_mk_of_subset (s := L) + (t := Set.range (fun q : ULift.{u} ℚ ↦ ((q.down • a : S) : G))) ?_).trans_lt ?_ + · rintro x ⟨q, -, rfl⟩ + exact ⟨ULift.up q, rfl⟩ + · refine Cardinal.mk_range_le.trans_lt ?_ + rw [Cardinal.mk_uLift, Cardinal.mkRat, Cardinal.lift_aleph0] + exact hκ + have hRcard : #R < κ := by + refine (Cardinal.mk_le_mk_of_subset (s := R) + (t := Set.range (fun q : ULift.{u} ℚ ↦ ((q.down • a : S) : G))) ?_).trans_lt ?_ + · rintro x ⟨q, -, rfl⟩ + exact ⟨ULift.up q, rfl⟩ + · refine Cardinal.mk_range_le.trans_lt ?_ + rw [Cardinal.mk_uLift, Cardinal.mkRat, Cardinal.lift_aleph0] + exact hκ + have hLR : ∀ l ∈ L, ∀ r ∈ R, l < r := by + rintro l ⟨q, hqy, rfl⟩ r ⟨q', hyq', rfl⟩ + apply Subtype.coe_lt_coe.mp + apply hfmono.lt_iff_lt.mp + rw [map_rat_smul, map_rat_smul] + change (q : ℝ) * ρ < (q' : ℝ) * ρ + exact hqy.trans hyq' + obtain ⟨x, hxL, hxR⟩ := hG L R hLcard hRcard hLR + obtain ⟨qₗ, hqₗ⟩ := exists_rat_lt (y / ρ) + obtain ⟨qᵣ, hqᵣ⟩ := exists_rat_gt (y / ρ) + have hqₗ' : (qₗ : ℝ) * ρ < y := by rwa [lt_div_iff₀ hρ] at hqₗ + have hqᵣ' : y < (qᵣ : ℝ) * ρ := by rwa [div_lt_iff₀ hρ] at hqᵣ + have hqₗL : ((qₗ • a : S) : G) ∈ L := ⟨qₗ, hqₗ', rfl⟩ + have hqᵣR : ((qᵣ • a : S) : G) ∈ R := ⟨qᵣ, hqᵣ', rfl⟩ + have hstratumClosed (z : S) : (z : G) ∈ FiniteArchimedeanClass.closedBall ℚ c := by + rw [← s.ball_sup_stratum_eq c] + exact Submodule.mem_sup_right z.2 + have hxclosed : x ∈ FiniteArchimedeanClass.closedBall ℚ c := by + have hl := hstratumClosed (qₗ • a) + have hr := hstratumClosed (qᵣ • a) + exact FiniteArchimedeanClass.closedBall_ordConnected c |>.out hl hr + ⟨(hxL _ hqₗL).le, (hxR _ hqᵣR).le⟩ + let xClosed : FiniteArchimedeanClass.closedBall ℚ c := ⟨x, hxclosed⟩ + let p := s.closedBallEquivStratumLexBall c xClosed + let z : S := (ofLex p).1 + have hfirst_le_of_mem_L (q : ℚ) (hq : (q : ℝ) * ρ < y) : q • a ≤ z := by + have hqL : ((q • a : S) : G) ∈ L := ⟨q, hq, rfl⟩ + let qClosed : FiniteArchimedeanClass.closedBall ℚ c := + ⟨((q • a : S) : G), hstratumClosed (q • a)⟩ + have hqClosed : s.stratumLexBallEquivClosedBall c + (toLex (q • a, (0 : FiniteArchimedeanClass.ball ℚ c))) = qClosed := by + apply Subtype.ext + rw [s.stratumLexBallEquivClosedBall_apply] + simp [qClosed] + have hlt : s.closedBallEquivStratumLexBall c qClosed < p := by + change s.closedBallEquivStratumLexBall c qClosed < + s.closedBallEquivStratumLexBall c xClosed + apply (s.closedBallEquivStratumLexBall c).toOrderIso.lt_iff_lt.mpr + exact hxL _ hqL + rw [← hqClosed, + s.closedBallEquivStratumLexBall_stratumLexBallEquivClosedBall] at hlt + exact (Prod.Lex.lt_iff.mp hlt).elim (fun h ↦ h.le) (fun h ↦ h.1.le) + have hfirst_ge_of_mem_R (q : ℚ) (hq : y < (q : ℝ) * ρ) : z ≤ q • a := by + have hqR : ((q • a : S) : G) ∈ R := ⟨q, hq, rfl⟩ + let qClosed : FiniteArchimedeanClass.closedBall ℚ c := + ⟨((q • a : S) : G), hstratumClosed (q • a)⟩ + have hqClosed : s.stratumLexBallEquivClosedBall c + (toLex (q • a, (0 : FiniteArchimedeanClass.ball ℚ c))) = qClosed := by + apply Subtype.ext + rw [s.stratumLexBallEquivClosedBall_apply] + simp [qClosed] + have hlt : p < s.closedBallEquivStratumLexBall c qClosed := by + change s.closedBallEquivStratumLexBall c xClosed < + s.closedBallEquivStratumLexBall c qClosed + apply (s.closedBallEquivStratumLexBall c).toOrderIso.lt_iff_lt.mpr + exact hxR _ hqR + rw [← hqClosed, + s.closedBallEquivStratumLexBall_stratumLexBallEquivClosedBall] at hlt + exact (Prod.Lex.lt_iff.mp hlt).elim (fun h ↦ h.le) (fun h ↦ h.1.le) + refine ⟨z, le_antisymm ?_ ?_⟩ + · by_contra hnot + have hyfz : y < f z := lt_of_not_ge hnot + obtain ⟨q, hq₁, hq₂⟩ := + exists_rat_btwn ((div_lt_div_iff_of_pos_right hρ).mpr hyfz) + have hyq : y < (q : ℝ) * ρ := (div_lt_iff₀ hρ).mp hq₁ + have hqfz : (q : ℝ) * ρ < f z := (lt_div_iff₀ hρ).mp hq₂ + have hzq := hfirst_ge_of_mem_R q hyq + have := hfmono.monotone hzq + rw [map_rat_smul] at this + exact (not_le_of_gt hqfz) this + · by_contra hnot + have hfzy : f z < y := lt_of_not_ge hnot + obtain ⟨q, hq₁, hq₂⟩ := + exists_rat_btwn ((div_lt_div_iff_of_pos_right hρ).mpr hfzy) + have hfzq : f z < (q : ℝ) * ρ := (div_lt_iff₀ hρ).mp hq₁ + have hqy : (q : ℝ) * ρ < y := (lt_div_iff₀ hρ).mp hq₂ + have hqz := hfirst_le_of_mem_L q hqy + have := hfmono.monotone hqz + rw [map_rat_smul] at this + exact (not_le_of_gt hfzq) this + exact ⟨{ AddEquiv.ofBijective f ⟨hf, hsurj⟩ with + map_le_map_iff' := hfmono.le_iff_le }⟩ + +@[blueprint "lem:saturated-common-tail-quotient-complete" + (phase := "Bounded generalised-power-series integer parts") + (title := "Cauchy completeness of common-tail quotients") + (statement := /-- + Let $G$ be a $\kappa$-saturated ordered rational vector space. Let $T$ be + a nonempty set of fewer than $\kappa$ nonzero Archimedean classes with no + least member in the magnitude order, and let $H_T$ consist of the + exponents beyond every class in $T$. Then $G/H_T$ is Cauchy complete for + its additive uniformity. + -/) + (proof := /-- + Positive representatives of the classes in $T$ descend to a coinitial + family in $G/H_T$, and rational halving gives arbitrarily small doubled + scales. Every cut between two $T$-indexed families in $G$ is filled by + $\kappa$-saturation; by + \ref{lem:cut-filling-order-reflecting-surjection}, the monotone quotient + map, which reflects strict inequalities, transfers this cut-filling + property to $G/H_T$. Apply + \ref{lem:complete-of-coinitial-scales-and-cut-filling}. + -/)] +private theorem completeSpace_tailQuotient_of_isKappaSaturated + {κ : Cardinal.{u}} (hG : IsKappaSaturated (G := G) κ) + (T : Set (FiniteArchimedeanClass G)) (hT : IsLimitFamily T) (hTcard : #T < κ) : + Nonempty (CompleteSpace (G ⧸ commonTail T)) := by + rw [isLimitFamily_iff] at hT + let : Nonempty T := Set.nonempty_coe_sort.mpr hT.1 + let Q := G ⧸ commonTail T + let ε : T → Q := fun c ↦ + Submodule.Quotient.mk (FiniteArchimedeanClass.positiveRepresentative c.1) + have hε : ∀ c, 0 < ε c := by + intro c + apply ConvexQuotient.mk_lt_mk_iff.mpr + refine ⟨FiniteArchimedeanClass.positiveRepresentative_pos c.1, ?_⟩ + intro hmem + have hmem' : FiniteArchimedeanClass.positiveRepresentative c.1 ∈ + (commonTail T).toAddSubgroup := by + simpa only [sub_zero] using hmem + have hmem'' : FiniteArchimedeanClass.positiveRepresentative c.1 ∈ commonTail T := hmem' + obtain ⟨d, hdT, hcd⟩ := hT.2 c.1 c.2 + have hdle := mem_commonTail_iff.mp hmem'' ⟨d, hdT⟩ + rw [FiniteArchimedeanClass.mk_positiveRepresentative] at hdle + exact (not_le_of_gt hcd) hdle + have hcoinitial : ∀ x : Q, 0 < x → ∃ c, ε c ≤ x := by + intro x hx + exact FiniteArchimedeanClass.exists_tailQuotient_positiveRepresentative_le hx + have hhalf : ∀ x : Q, 0 < x → ∃ y : Q, 0 < y ∧ y + y ≤ x := by + intro x hx + refine ⟨(2 : ℚ)⁻¹ • x, smul_pos (by norm_num) hx, ?_⟩ + rw [← add_smul] + norm_num + have hfillG : FillsCuts T G := fillsCuts_of_isKappaSaturated hG hTcard + have hfillQ : FillsCuts T Q := FillsCuts.of_surjective + (Submodule.Quotient.mk_surjective (commonTail T)) + (fun _ _ h ↦ ConvexQuotient.mk_le_mk h) + (fun _ _ h ↦ ConvexQuotient.lt_of_mk_lt_mk h) hfillG + exact ⟨completeSpace_of_coinitial_of_exists_half ε hε hcoinitial hhalf hfillQ⟩ + +@[blueprint "lem:saturated-common-tail-cofinality" + (phase := "Bounded generalised-power-series integer parts") + (title := "Cofinality of common tails in saturated ordered groups") + (statement := /-- + Let $\kappa>\aleph_0$, let $G$ be a $\kappa$-saturated ordered rational + vector space, and let $T$ be a nonempty set of fewer than $\kappa$ + nonzero Archimedean classes with no least member in the magnitude order. + Then the common tail $H_T$ has cofinality at least $\kappa$. + -/) + (proof := /-- + If a set $S\subseteq H_T$ of cardinality less than $\kappa$ were cofinal, + use $S\cup\{0\}$ as the left side of a cut. On the right put all rational + fractions of positive representatives of classes in $T$. Saturation + fills the cut by a positive element of $H_T$ lying strictly above every + member of $S$, a contradiction. + -/)] +private theorem cofinal_commonTail_of_isKappaSaturated + {κ : Cardinal.{u}} (hκ : ℵ₀ < κ) (hG : IsKappaSaturated (G := G) κ) + (T : Set (FiniteArchimedeanClass G)) (hT : IsLimitFamily T) (hTcard : #T < κ) : + κ ≤ Order.cof ↑(commonTail T) := by + rw [isKappaSaturated_iff] at hG + rw [isLimitFamily_iff] at hT + rw [Order.le_cof_iff] + intro s hs + by_contra hcard + have hscard : #s < κ := lt_of_not_ge hcard + let L : Set G := {0} ∪ ((↑) : commonTail T → G) '' s + let R : Set G := Set.range fun p : T × ℕ ↦ + ((p.2 + 1 : ℚ)⁻¹) • FiniteArchimedeanClass.positiveRepresentative p.1.1 + have hLcard : #L < κ := by + refine (Cardinal.mk_union_le _ _).trans_lt ?_ + apply Cardinal.add_lt_of_lt hκ.le + · simpa using Cardinal.one_lt_aleph0.trans hκ + · exact Cardinal.mk_image_le.trans_lt hscard + have hprod : #(T × ℕ) < κ := by + simpa using Cardinal.mul_lt_of_lt hκ.le hTcard hκ + have hRcard : #R < κ := Cardinal.mk_range_le.trans_lt hprod + have hLR : ∀ x ∈ L, ∀ y ∈ R, x < y := by + intro x hx y hy + obtain rfl | ⟨z, hz, rfl⟩ := hx + · obtain ⟨⟨c, n⟩, rfl⟩ := hy + exact smul_pos (inv_pos.mpr (by positivity)) + (FiniteArchimedeanClass.positiveRepresentative_pos c.1) + · obtain ⟨⟨c, n⟩, rfl⟩ := hy + by_cases hz0 : (z : G) = 0 + · rw [hz0] + exact smul_pos (inv_pos.mpr (by positivity)) + (FiniteArchimedeanClass.positiveRepresentative_pos c.1) + obtain ⟨d, hdT, hcd⟩ := hT.2 c.1 c.2 + have hzTail : (z : G) ∈ FiniteArchimedeanClass.tailKernel T := + (FiniteArchimedeanClass.mem_tailSubmodule_iff (K := ℚ)).mp z.2 + have hdz : d.1 ≤ ArchimedeanClass.mk (z : G) := + FiniteArchimedeanClass.mem_tailKernel_iff.mp hzTail ⟨d, hdT⟩ + have hcd' : c.1.1 < d.1 := hcd + have hcz : c.1.1 < ArchimedeanClass.mk (z : G) := hcd'.trans_le hdz + rcases le_total (z : G) 0 with hzneg | hznonneg + · exact hzneg.trans_lt (smul_pos (inv_pos.mpr (by positivity)) + (FiniteArchimedeanClass.positiveRepresentative_pos c.1)) + · apply ArchimedeanClass.lt_of_mk_lt_mk_of_nonneg + · rw [ArchimedeanClass.mk_smul _ (inv_ne_zero (by positivity)), + FiniteArchimedeanClass.mk_positiveRepresentative] + exact hcz + · exact smul_nonneg (inv_nonneg.mpr (by positivity)) + (FiniteArchimedeanClass.positiveRepresentative_pos c.1).le + obtain ⟨y, hyL, hyR⟩ := hG L R hLcard hRcard hLR + have hypos : 0 < y := hyL 0 (Set.mem_union_left _ (Set.mem_singleton 0)) + have hyright (c : T) (n : ℕ) : + y < ((n + 1 : ℚ)⁻¹) • FiniteArchimedeanClass.positiveRepresentative c.1 := + hyR _ (Set.mem_range_self (c, n)) + have hyTail : y ∈ commonTail T := by + rw [FiniteArchimedeanClass.mem_tailSubmodule_iff, + FiniteArchimedeanClass.mem_tailKernel_iff] + intro c + obtain ⟨d, hdT, hcd⟩ := hT.2 c.1 c.2 + have hcd' : c.1.1 < d.1 := hcd + apply hcd'.le.trans + rw [← FiniteArchimedeanClass.mk_positiveRepresentative d, + ArchimedeanClass.mk_le_mk] + refine ⟨1, ?_⟩ + rw [abs_of_pos (FiniteArchimedeanClass.positiveRepresentative_pos d), abs_of_pos hypos] + simpa using (hyright ⟨d, hdT⟩ 0).le + have hnot : ¬ IsCofinal s := by + rw [not_isCofinal_iff] + exact ⟨⟨y, hyTail⟩, fun z hz ↦ + hyL (z : G) (Set.mem_union_right _ (Set.mem_image_of_mem _ hz))⟩ + exact hnot hs + +@[blueprint "lem:saturated-inner-ball-cofinality" + (phase := "Bounded generalised-power-series integer parts") + (title := "Cofinality of Archimedean inner balls in saturated ordered groups") + (statement := /-- + Let $\kappa>\aleph_0$ and let $G$ be a $\kappa$-saturated ordered rational + vector space. At every nonzero Archimedean class, the strict inner ball + has cofinality at least $\kappa$. + -/) + (proof := /-- + If a set $S$ of cardinality less than $\kappa$ were cofinal in the strict + inner ball below the class of $a\ne0$, place $S\cup\{0\}$ on the left of a + cut and the elements $|a|/(n+1)$ on the right. Saturation gives a positive + element still in the strict inner ball and strictly above $S$, a + contradiction. + -/)] +private theorem le_cof_ball_of_isKappaSaturated + {κ : Cardinal.{u}} (hκ : ℵ₀ < κ) (hG : IsKappaSaturated (G := G) κ) + (c : FiniteArchimedeanClass G) : + κ ≤ Order.cof ↑(FiniteArchimedeanClass.ball ℚ c) := by + rw [isKappaSaturated_iff] at hG + induction c using FiniteArchimedeanClass.ind with + | mk a ha => + rw [Order.le_cof_iff] + intro s hs + by_contra hcard + have hscard : #s < κ := lt_of_not_ge hcard + let L : Set G := {0} ∪ + (fun z : FiniteArchimedeanClass.ball ℚ (FiniteArchimedeanClass.mk a ha) ↦ + (z : G)) '' s + let R : Set G := Set.range fun n : ℕ ↦ ((n + 1 : ℚ)⁻¹) • |a| + have hLcard : #L < κ := by + refine (Cardinal.mk_union_le _ _).trans_lt ?_ + apply Cardinal.add_lt_of_lt hκ.le + · simpa using Cardinal.one_lt_aleph0.trans hκ + · exact Cardinal.mk_image_le.trans_lt hscard + have hRle : #R ≤ Cardinal.lift.{u} #ℕ := by + simpa only [R, Cardinal.lift_uzero] using + Cardinal.lift_mk_le_lift_mk_of_surjective + (Set.rangeFactorization_surjective + (f := fun n : ℕ ↦ ((n + 1 : ℚ)⁻¹) • |a|)) + have hRcard : #R < κ := hRle.trans_lt (by + rw [Cardinal.mk_nat, Cardinal.lift_aleph0] + exact hκ) + have hLR : ∀ x ∈ L, ∀ y ∈ R, x < y := by + intro x hx y hy + obtain rfl | ⟨z, hz, rfl⟩ := hx + · obtain ⟨n, rfl⟩ := hy + exact smul_pos (inv_pos.mpr (by positivity)) (abs_pos.mpr ha) + · obtain ⟨n, rfl⟩ := hy + by_cases hz0 : (z : G) = 0 + · change (z : G) < ((n + 1 : ℚ)⁻¹) • |a| + rw [hz0] + exact smul_pos (inv_pos.mpr (by positivity)) (abs_pos.mpr ha) + have hzclass : ArchimedeanClass.mk a < ArchimedeanClass.mk (z : G) := by + have hzclass' := (FiniteArchimedeanClass.mem_ball_iff ℚ).mp z.property hz0 + exact hzclass' + apply ArchimedeanClass.lt_of_mk_lt_mk_of_nonneg + · rw [ArchimedeanClass.mk_smul _ (inv_ne_zero (by positivity)), + ArchimedeanClass.mk_abs] + exact hzclass + · exact smul_nonneg (inv_nonneg.mpr (by positivity)) (abs_nonneg a) + obtain ⟨y, hyL, hyR⟩ := hG L R hLcard hRcard hLR + have hypos : 0 < y := hyL 0 (Set.mem_union_left _ (Set.mem_singleton 0)) + have hyright (n : ℕ) : y < ((n + 1 : ℚ)⁻¹) • |a| := + hyR _ (Set.mem_range_self n) + have hyball : y ∈ FiniteArchimedeanClass.ball ℚ + (FiniteArchimedeanClass.mk a ha) := by + rw [FiniteArchimedeanClass.mem_ball_iff] + intro hy0 + rw [FiniteArchimedeanClass.mk_lt_mk ha hy0, ArchimedeanClass.mk_lt_mk] + intro n + rw [abs_of_pos hypos] + obtain rfl | hn := n.eq_zero_or_pos + · simpa using abs_pos.mpr ha + · have hbound := hyright (n - 1) + have hcast : (((n - 1 : ℕ) : ℚ) + 1) = n := by + exact_mod_cast Nat.sub_add_cancel hn + rw [hcast] at hbound + have hnQ : (0 : ℚ) < n := by exact_mod_cast hn + have hnQ0 : (n : ℚ) ≠ 0 := by exact_mod_cast hn.ne' + have hmul := smul_lt_smul_of_pos_left hbound hnQ + simpa only [smul_smul, mul_inv_cancel₀ hnQ0, one_smul, + Nat.cast_smul_eq_nsmul] using hmul + have hnot : ¬ IsCofinal s := by + rw [not_isCofinal_iff] + exact ⟨⟨y, hyball⟩, fun z hz ↦ + hyL (z : G) (Set.mem_union_right _ (Set.mem_image_of_mem _ hz))⟩ + exact hnot hs + +/-- The standalone form of `(A1)` is exactly LM24's condition at every nonzero class. -/ +theorem assumptionA1_iff_lm24 (s : HahnEmbedding.ArchimedeanStrata ℚ G) : + AssumptionA1 s ↔ ∀ c, LM24.AssumptionA1AtFiniteClass s c := by + rw [assumptionA1_iff] + exact forall_congr' fun c ↦ (LM24.assumptionA1AtFiniteClass_iff s c).symm + +/-- Generating `R` by fractions is equivalent to the fraction subring being all of `R`. -/ +theorem generatesFractionField_iff_fracSubring_eq_top (Z : Subring R) : + GeneratesFractionField Z ↔ Subring.fracSubring Z = ⊤ := by + rw [generatesFractionField_iff] + constructor + · intro h + apply top_unique + intro x _ + obtain ⟨a, b, _hb, rfl⟩ := h x + rw [div_eq_mul_inv] + exact (Subring.fracSubring Z).mul_mem (Subring.le_fracSubring a.2) + (Subring.inv_mem_fracSubring (Subring.le_fracSubring b.2)) + · intro h x + have hx : x ∈ Subring.fracSubring Z := by rw [h]; trivial + obtain ⟨b, hb, hb0, hbx⟩ := Subring.exists_den hx + have hbZ0 : (⟨b, hb⟩ : Z) ≠ 0 := fun hzero ↦ hb0 (congrArg Subtype.val hzero) + refine ⟨⟨b * x, hbx⟩, ⟨b, hb⟩, hbZ0, ?_⟩ + change x = (b * x) / b + exact (mul_div_cancel_left₀ x hb0).symm + +omit [Module ℚ G] [IsOrderedModule ℚ G] in +/-- The standalone fraction-field condition is the corresponding fraction-subring equality. -/ +theorem isFractionFieldOfHahnIntegerPart_iff_fracSubring_eq_top + {κ : Cardinal} [Fact (ℵ₀ < κ)] (Z : Subring R) : + IsFractionFieldOfHahnIntegerPart (G := G) Z κ ↔ + Subring.fracSubring (HahnSeries.cardSuppLTTruncationIntegerPart + (G := G) (R := R) (κ := κ) Z) = ⊤ := by + rw [isFractionFieldOfHahnIntegerPart_iff] + let S := HahnSeries.cardSuppLTTruncationIntegerPart + (G := G) (R := R) (κ := κ) Z + constructor + · intro h + apply top_unique + intro x _ + obtain ⟨a₀, b₀, ha₀, hb₀, hb₀ne, hx⟩ := h (x : HahnSeries G R) x.2 + have ha₀' := (mem_hahnIntegerPart_iff.mp ha₀) + have hb₀' := (mem_hahnIntegerPart_iff.mp hb₀) + let a : HahnSeries.CardSuppLTField (G := G) (R := R) (κ := κ) := ⟨a₀, ha₀'.1⟩ + let b : HahnSeries.CardSuppLTField (G := G) (R := R) (κ := κ) := ⟨b₀, hb₀'.1⟩ + have haS : a ∈ S := by + rw [HahnSeries.mem_cardSuppLTTruncationIntegerPart] + exact ⟨ha₀'.2.1, ha₀'.2.2⟩ + have hbS : b ∈ S := by + rw [HahnSeries.mem_cardSuppLTTruncationIntegerPart] + exact ⟨hb₀'.2.1, hb₀'.2.2⟩ + have hxb : x = a / b := by + apply Subtype.ext + exact hx + rw [hxb, div_eq_mul_inv] + exact (Subring.fracSubring S).mul_mem (Subring.le_fracSubring haS) + (Subring.inv_mem_fracSubring (Subring.le_fracSubring hbS)) + · intro h x hx + let X : HahnSeries.CardSuppLTField (G := G) (R := R) (κ := κ) := ⟨x, hx⟩ + have hXF : X ∈ Subring.fracSubring S := by + rw [h] + trivial + obtain ⟨b, hbS, hb0, hbX⟩ := Subring.exists_den hXF + have hb0' : (b : HahnSeries G R) ≠ 0 := by + intro hzero + apply hb0 + exact Subtype.ext hzero + refine ⟨((b * X : HahnSeries.CardSuppLTField (G := G) (R := R) (κ := κ)) : + HahnSeries G R), (b : HahnSeries G R), ?_, ?_, hb0', ?_⟩ + · rw [mem_hahnIntegerPart_iff] + exact ⟨(b * X).2, + (HahnSeries.mem_cardSuppLTTruncationIntegerPart.mp hbX).1, + (HahnSeries.mem_cardSuppLTTruncationIntegerPart.mp hbX).2⟩ + · rw [mem_hahnIntegerPart_iff] + exact ⟨b.2, + (HahnSeries.mem_cardSuppLTTruncationIntegerPart.mp hbS).1, + (HahnSeries.mem_cardSuppLTTruncationIntegerPart.mp hbS).2⟩ + · change x = ((b : HahnSeries G R) * x) / (b : HahnSeries G R) + exact (mul_div_cancel_left₀ x hb0').symm + +/-- Saturation supplies the two common-tail hypotheses of the bounded Hahn theorem. -/ +@[blueprint "lem:saturated-common-tail-conditions" + (phase := "Bounded generalised-power-series integer parts") + (title := "Common-tail conditions in saturated ordered groups") + (statement := /-- + Let $\kappa>\aleph_0$, let $G$ be a $\kappa$-saturated ordered rational + vector space, and let $Z$ be a subring of a field $R$. For every nonempty + set $T$ of fewer than $\kappa$ nonzero Archimedean classes with no least + member in the magnitude order, the quotient $G/H_T$ is Cauchy complete in + its additive uniformity, and the bounded Hahn field $R((H_T))_\kappa$ is + the fraction field of $Z+R((H_T^{<0}))_\kappa$. + -/) + (proof := /-- + Quotient completeness follows from + \ref{lem:saturated-common-tail-quotient-complete}. By + \ref{lem:saturated-common-tail-cofinality}, + $\kappa\le\operatorname{cof}(H_T)$; hence + \ref{thm:bounded-hahn-integer-part-fraction-field} gives the asserted + fraction-field equality. + -/)] +private theorem limitTailConditions_of_isKappaSaturated + {κ : Cardinal.{u}} [Fact (ℵ₀ < κ)] (Z : Subring R) + (hG : IsKappaSaturated (G := G) κ) : LimitTailConditions (G := G) Z κ := by + constructor + · intro T hT hTcard + exact completeSpace_tailQuotient_of_isKappaSaturated hG T hT hTcard + · intro T hT hTcard + apply (isFractionFieldOfHahnIntegerPart_iff_fracSubring_eq_top + (G := commonTail T) Z).mpr + exact HahnSeries.fracSubring_cardSuppLTTruncationIntegerPart_eq_top_of_le_cof Z + (cofinal_commonTail_of_isKappaSaturated Fact.out hG T hT hTcard) + +/-- The standalone disjunction `(A2)` is exactly LM24's condition at every nonzero class. -/ +theorem assumptionA2_iff_lm24 (Z : Subring R) (κ : Cardinal) : + AssumptionA2 (G := G) Z κ ↔ + ∀ c : FiniteArchimedeanClass G, + LM24.AssumptionA2AtFiniteClass (K := ℚ) κ Z c := by + rw [assumptionA2_iff] + apply forall_congr' + intro c + rw [LM24.assumptionA2AtFiniteClass_iff] + constructor + · rintro (hcof | ⟨hzero, hfrac⟩) + · exact Or.inl hcof + · exact Or.inr ⟨hzero, (generatesFractionField_iff_fracSubring_eq_top Z).mp hfrac⟩ + · rintro (hcof | ⟨hzero, hfrac⟩) + · exact Or.inl hcof + · exact Or.inr ⟨hzero, (generatesFractionField_iff_fracSubring_eq_top Z).mpr hfrac⟩ + +/-- The standalone form of `(A3)` says exactly that `Z` is pre-Schreier. -/ +theorem assumptionA3_iff_decompositionMonoid (Z : Subring R) : + AssumptionA3 Z ↔ DecompositionMonoid Z := by + rw [assumptionA3_iff] + constructor + · intro h + rw [decompositionMonoid_iff] + intro z a b hab + exact h z a b hab + · intro h + rw [decompositionMonoid_iff] at h + intro z a b hab + exact h z hab + +/-- Conditions `(A1)`--`(A3)` and the common-tail conditions make the bounded Hahn integer part +pre-Schreier. -/ +@[blueprint "thm:hahn-integer-part-pre-schreier" + (phase := "Bounded generalised-power-series integer parts") + (title := "Pre-Schreier property of bounded Hahn integer parts") + (statement := /-- + Let $G$ be an ordered rational vector space, $R$ a field of characteristic + zero, $\kappa>\aleph_0$ a regular cardinal, and $Z\subseteq R$ a + pre-Schreier subring. Choose an additive complement to the strict inner + ball at every nonzero Archimedean class. Assume every complement is order + additively isomorphic to $\mathbb R$, and that at each such class either + the strict inner ball has cofinality at least $\kappa$, or it is zero and + every element of $R$ is a fraction of elements of $Z$. + + For every nonempty set $T$ of fewer than $\kappa$ nonzero Archimedean + classes having no least member in the magnitude order, let $H_T$ be the + rational subspace of exponents lying beyond every class in $T$. Assume + that $G/H_T$ is Cauchy complete for its additive uniformity and that the + bounded Hahn field on $H_T$ is the fraction field of its bounded Hahn + integer part. Then $Z+R((G^{<0}))_\kappa$ is pre-Schreier. + -/) + (proof := /-- + The real-complement and inner-ball hypotheses are LM24 conditions $(A1)$ + and $(A2)$, while the pre-Schreier hypothesis on $Z$ is condition $(A3)$. + By \ref{thm:hahn-integer-part-primality}, every element of the bounded Hahn + integer part is primal. This is exactly the pre-Schreier property. + -/)] +theorem decompositionMonoid_of_assumptions [CharZero R] + {κ : Cardinal} [Fact (ℵ₀ < κ)] [Fact κ.IsRegular] + (Z : Subring R) (s : HahnEmbedding.ArchimedeanStrata ℚ G) + (hA1 : AssumptionA1 s) (hA2 : AssumptionA2 (G := G) Z κ) + (hA3 : AssumptionA3 Z) (hlimit : LimitTailConditions (G := G) Z κ) : + DecompositionMonoid (HahnSeries.cardSuppLTTruncationIntegerPart + (G := G) (R := R) (κ := κ) Z) := by + let : DecompositionMonoid Z := (assumptionA3_iff_decompositionMonoid Z).mp hA3 + rw [decompositionMonoid_iff] + intro x + apply isPrimal_of_finite_class_assumptions_and_limit_tail_conditions Z s + ((assumptionA1_iff_lm24 s).mp hA1) ((assumptionA2_iff_lm24 Z κ).mp hA2) + · intro T hTne hTgt hTcard + obtain ⟨hcomplete⟩ := + hlimit.cauchy_complete_quotient T (isLimitFamily_iff.mpr ⟨hTne, hTgt⟩) hTcard + let := hcomplete + exact ⟨(commonTailUniformEquiv (G := G) T).completeSpace_iff.mp inferInstance⟩ + · intro T hTne hTgt hTcard + have hfraction := hlimit.fraction_field_commonTail T + (isLimitFamily_iff.mpr ⟨hTne, hTgt⟩) hTcard + rw [commonTail_eq_tailSubmodule] at hfraction + exact (isFractionFieldOfHahnIntegerPart_iff_fracSubring_eq_top + (G := _root_.FiniteArchimedeanClass.tailSubmodule ℚ T) Z).mp hfraction + +/-- Saturation makes the bounded Hahn integer part pre-Schreier. -/ +@[blueprint "cor:hahn-integer-part-pre-schreier-of-saturation" + (phase := "Bounded generalised-power-series integer parts") + (title := "Pre-Schreier Hahn integer parts over saturated exponent groups") + (statement := /-- + Let $\kappa>\aleph_0$ be regular, let $G$ be a $\kappa$-saturated ordered + rational vector space, let $R$ be a field of characteristic zero, and let + $Z\subseteq R$ be pre-Schreier. Then + $Z+R((G^{<0}))_\kappa$ is pre-Schreier. + -/) + (proof := /-- + Saturation gives real Archimedean strata by + \ref{lem:saturated-archimedean-strata-real}, the cofinal alternative in + condition $(A2)$ by \ref{lem:saturated-inner-ball-cofinality}, and the + completeness and fraction-field conditions at common tails by + \ref{lem:saturated-common-tail-conditions}. These are the hypotheses of + \ref{thm:hahn-integer-part-pre-schreier}. + -/)] +theorem decompositionMonoid_of_saturation [CharZero R] + {κ : Cardinal} [Fact (ℵ₀ < κ)] [Fact κ.IsRegular] + (Z : Subring R) (hA3 : AssumptionA3 Z) (hG : IsKappaSaturated (G := G) κ) : + DecompositionMonoid (HahnSeries.cardSuppLTTruncationIntegerPart + (G := G) (R := R) (κ := κ) Z) := by + let s : HahnEmbedding.ArchimedeanStrata ℚ G := Classical.choice inferInstance + have hA1 : AssumptionA1 s := by + rw [assumptionA1_iff] + exact stratum_orderAddEquiv_real_of_isKappaSaturated Fact.out hG s + have hA2 : AssumptionA2 (G := G) Z κ := by + rw [assumptionA2_iff] + intro c + exact Or.inl (le_cof_ball_of_isKappaSaturated Fact.out hG c) + have hlimit := limitTailConditions_of_isKappaSaturated Z hG + exact decompositionMonoid_of_assumptions Z s hA1 hA2 hA3 hlimit + +/-- Conditions `(A1)`--`(A3)` and the common-tail conditions imply four-factor refinement. -/ +@[blueprint "thm:hahn-integer-part-refinement" + (phase := "Bounded generalised-power-series integer parts") + (title := "Refinement of bounded generalised-power-series integer parts") + (statement := /-- + Under the hypotheses of \ref{thm:hahn-integer-part-pre-schreier}, every + equality $ab=cd$ in $Z+R((G^{<0}))_\kappa$ admits elements + $e,f,g,h$ in the same ring such that + \[ + a=ef,\qquad b=gh,\qquad c=eg,\qquad d=fh. + \] + -/) + (proof := /-- + By \ref{thm:hahn-integer-part-pre-schreier}, the bounded + generalised-power-series integer part is pre-Schreier. The standard + equivalence between primality of every element and four-factor refinement + gives the displayed factors, which are then viewed as elements of the + ambient generalised-power-series field. + -/) + (highlight)] +theorem of_assumptions : HahnIntegerPartRefinementCriterion (G := G) (R := R) := by + intro hR + let : CharZero R := hR + intro κ hκcountable hκregular Z s hA1 hA2 hA3 hlimit + let : Fact (ℵ₀ < κ) := ⟨hκcountable⟩ + let : Fact κ.IsRegular := ⟨hκregular⟩ + let S := HahnSeries.cardSuppLTTruncationIntegerPart + (G := G) (R := R) (κ := κ) Z + let : DecompositionMonoid S := + decompositionMonoid_of_assumptions Z s hA1 hA2 hA3 hlimit + let inclusion : HahnSeries.CardSuppLTField (G := G) (R := R) (κ := κ) →+* + HahnSeries G R := (HahnSeries.cardSuppLTSubfield G R κ).subtype + let E := Subring.equivMapOfInjective S inclusion Subtype.val_injective + let : DecompositionMonoid (S.map inclusion) := + MulEquiv.decompositionMonoid E.symm.toMulEquiv + have hmem (x : HahnSeries G R) : x ∈ S.map inclusion ↔ x ∈ hahnIntegerPart Z κ := by + rw [Subring.mem_map, mem_hahnIntegerPart_iff] + constructor + · rintro ⟨y, hy, rfl⟩ + have hy' := (HahnSeries.mem_cardSuppLTTruncationIntegerPart (Z := Z)).mp hy + exact ⟨y.2, hy'.1, hy'.2⟩ + · rintro ⟨hxcard, hxsupp, hxzero⟩ + refine ⟨⟨x, hxcard⟩, ?_, rfl⟩ + exact (HahnSeries.mem_cardSuppLTTruncationIntegerPart (Z := Z)).mpr ⟨hxsupp, hxzero⟩ + intro a b c d ha hb hc hd habcd + simpa only [hmem] using + Subring.exists_fourFactorRefinement_of_decompositionMonoid (S.map inclusion) + (hmem a |>.mpr ha) (hmem b |>.mpr hb) (hmem c |>.mpr hc) (hmem d |>.mpr hd) habcd + +/-- Saturation supplies `(A1)`, `(A2)`, quotient completeness, and the common-tail +fraction-field condition. -/ +@[blueprint "cor:hahn-integer-part-refinement-of-saturation" + (phase := "Bounded generalised-power-series integer parts") + (title := "Refinement over saturated exponent groups") + (statement := /-- + Let $\kappa>\aleph_0$ be regular, let $G$ be a $\kappa$-saturated ordered + rational vector space, let $R$ be a field of characteristic zero, and let + $Z\subseteq R$ be pre-Schreier. Then every equality + $ab=cd$ in $Z+R((G^{<0}))_\kappa$ has a refinement + \[ + a=ef,\qquad b=gh,\qquad c=eg,\qquad d=fh + \] + in the same ring. + -/) + (proof := /-- + By \ref{lem:saturated-archimedean-strata-real}, saturation supplies + condition $(A1)$. By \ref{lem:saturated-inner-ball-cofinality}, it also + supplies the cofinal alternative in condition $(A2)$ at every nonzero + Archimedean class. For each limit family, + \ref{lem:saturated-common-tail-conditions} supplies quotient completeness + and says that every bounded common-tail series is a fraction of two + elements of the bounded common-tail Hahn integer part. These are all the + hypotheses of + \ref{thm:hahn-integer-part-refinement}. + -/)] +theorem of_saturation [CharZero R] + {κ : Cardinal.{u}} (hκcount : ℵ₀ < κ) (hκregular : κ.IsRegular) + (Z : Subring R) (hA3 : AssumptionA3 Z) (hG : IsKappaSaturated (G := G) κ) : + ∀ a b c d : HahnSeries G R, + a ∈ hahnIntegerPart Z κ → b ∈ hahnIntegerPart Z κ → + c ∈ hahnIntegerPart Z κ → d ∈ hahnIntegerPart Z κ → a * b = c * d → + ∃ e f g h : HahnSeries G R, + e ∈ hahnIntegerPart Z κ ∧ f ∈ hahnIntegerPart Z κ ∧ + g ∈ hahnIntegerPart Z κ ∧ h ∈ hahnIntegerPart Z κ ∧ + a = e * f ∧ b = g * h ∧ c = e * g ∧ d = f * h := by + let : Fact (ℵ₀ < κ) := ⟨hκcount⟩ + let : Fact κ.IsRegular := ⟨hκregular⟩ + let s : HahnEmbedding.ArchimedeanStrata ℚ G := Classical.choice inferInstance + have hA1 : AssumptionA1 s := by + rw [assumptionA1_iff] + exact stratum_orderAddEquiv_real_of_isKappaSaturated hκcount hG s + have hA2 : AssumptionA2 (G := G) Z κ := by + rw [assumptionA2_iff] + intro c + exact Or.inl (le_cof_ball_of_isKappaSaturated hκcount hG c) + have hlimit := limitTailConditions_of_isKappaSaturated Z hG + exact of_assumptions (inferInstance : CharZero R) κ hκcount hκregular + Z s hA1 hA2 hA3 hlimit + +private def integerCoefficientSubring : Subring R := + (Int.castRingHom R).range + +private noncomputable def integerCoefficientSubringEquiv [CharZero R] : + ℤ ≃+* integerCoefficientSubring (R := R) := + RingEquiv.ofBijective (Int.castRingHom R).rangeRestrict + ⟨Int.cast_injective, RingHom.rangeRestrict_surjective _⟩ + +private theorem integerCoefficientSubring_preSchreier [CharZero R] : + AssumptionA3 (integerCoefficientSubring (R := R)) := by + apply assumptionA3_iff.mpr + intro z + let e := integerCoefficientSubringEquiv (R := R) + change IsPrimal z + rw [← e.apply_symm_apply z] + exact (RingEquiv.isPrimal_iff e (e.symm z)).mpr + (DecompositionMonoid.primal (e.symm z)) + +omit [IsOrderedAddMonoid G] [Module ℚ G] [IsOrderedModule ℚ G] in +private theorem mem_hahnIntegerPart_integerCoefficientSubring_iff + {κ : Cardinal.{u}} {x : HahnSeries G R} : + x ∈ hahnIntegerPart (integerCoefficientSubring (R := R)) κ ↔ + x ∈ integerHahnPart κ := by + rw [mem_hahnIntegerPart_iff, mem_integerHahnPart_iff] + constructor + · rintro ⟨hcard, hsupp, ⟨z, hz⟩⟩ + exact ⟨hcard, hsupp, z, hz⟩ + · rintro ⟨hcard, hsupp, z, hz⟩ + exact ⟨hcard, hsupp, ⟨z, hz⟩⟩ + +/-- Uncountable regular saturation implies refinement with integer constant coefficients. -/ +@[blueprint "cor:integer-hahn-refinement-of-saturation" + (phase := "Bounded generalised-power-series integer parts") + (title := "Refinement of saturated Hahn integer parts with integer constants") + (statement := /-- + Let $\kappa>\aleph_0$ be regular, let $G$ be a $\kappa$-saturated ordered + rational vector space, and let $R$ be a field of characteristic zero. + Then every equality $ab=cd$ in + $\mathbb Z+R((G^{<0}))_\kappa$ has a refinement + \[ + a=ef,\qquad b=gh,\qquad c=eg,\qquad d=fh + \] + in the same ring. + -/) + (proof := /-- + The image of $\mathbb Z$ in $R$ is pre-Schreier. Apply + \ref{cor:hahn-integer-part-refinement-of-saturation} with + this coefficient ring and rewrite membership as the requirement that the + constant coefficient be an integer. + -/)] +theorem of_saturation_integer_coefficients [CharZero R] : + HahnIntegerPartRefinement (G := G) (R := R) := by + intro κ hκcount hκregular hG a b c d ha hb hc hd habcd + have hrefine := of_saturation (G := G) (R := R) hκcount hκregular + (integerCoefficientSubring (R := R)) + (integerCoefficientSubring_preSchreier (R := R)) hG + simpa only [mem_hahnIntegerPart_integerCoefficientSubring_iff] using + hrefine a b c d + (mem_hahnIntegerPart_integerCoefficientSubring_iff.mpr ha) + (mem_hahnIntegerPart_integerCoefficientSubring_iff.mpr hb) + (mem_hahnIntegerPart_integerCoefficientSubring_iff.mpr hc) + (mem_hahnIntegerPart_integerCoefficientSubring_iff.mpr hd) habcd + +end ConwayRefinement.Standalone.Hahn.HahnIntegerPartRefinement diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/Support/HahnLimitTailQuotient.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/Support/HahnLimitTailQuotient.lean new file mode 100644 index 0000000000..3f194eaf85 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/Support/HahnLimitTailQuotient.lean @@ -0,0 +1,150 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import Mathlib.Algebra.Order.Archimedean.Basic +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.Support.ConvexQuotientSplitting +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.Support.OrderedAddGroup +public import Mathlib.Algebra.Algebra.Rat +public import Mathlib.Algebra.Order.Module.Rat +public import Mathlib.Topology.Algebra.IsUniformGroup.Basic + +/-! +# Ordered common-tail quotients + +A family of finite Archimedean classes determines a common convex rational subspace. Its quotient +is ordered by representatives and carries its order topology and right uniformity. These are the +explicit Hahn exponent quotients used in the limit hypothesis of the standalone Conway theorem. +-/ + +open Set + +universe u + +public noncomputable section + +namespace ConwayRefinement.Standalone.Hahn + +namespace FiniteArchimedeanClass + +variable {G : Type u} [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [Module ℚ G] [PosSMulMono ℚ G] + +/-- The ordered rational quotient by the common tail of a family of finite Archimedean +classes. -/ +abbrev TailQuotient (T : Set (FiniteArchimedeanClass G)) := G ⧸ tailSubmodule ℚ T + +noncomputable instance tailQuotientLinearOrder (T : Set (FiniteArchimedeanClass G)) : + LinearOrder (TailQuotient T) := + ConvexQuotient.instLinearOrder (H := (tailSubmodule ℚ T).toAddSubgroup) + +instance tailQuotientIsOrderedAddMonoid (T : Set (FiniteArchimedeanClass G)) : + IsOrderedAddMonoid (TailQuotient T) := + ConvexQuotient.instIsOrderedAddMonoid (H := (tailSubmodule ℚ T).toAddSubgroup) + +instance tailQuotientPosSMulMono (T : Set (FiniteArchimedeanClass G)) : + PosSMulMono ℚ (TailQuotient T) where + smul_le_smul_of_nonneg_left q hq x y hxy := by + change ∃ a b : G, Submodule.Quotient.mk a = x ∧ + Submodule.Quotient.mk b = y ∧ a ≤ b at hxy + obtain ⟨a, b, ha, hb, hab⟩ := hxy + change ∃ a b : G, Submodule.Quotient.mk a = q • x ∧ + Submodule.Quotient.mk b = q • y ∧ a ≤ b + refine ⟨q • a, q • b, ?_, ?_, smul_le_smul_of_nonneg_left hab hq⟩ + · simpa only [Submodule.Quotient.mk_smul] using congrArg (q • ·) ha + · simpa only [Submodule.Quotient.mk_smul] using congrArg (q • ·) hb + +instance tailQuotientPosSMulStrictMono (T : Set (FiniteArchimedeanClass G)) : + PosSMulStrictMono ℚ (TailQuotient T) := PosSMulMono.toPosSMulStrictMono + +noncomputable instance tailQuotientTopologicalSpace (T : Set (FiniteArchimedeanClass G)) : + TopologicalSpace (TailQuotient T) := Preorder.topology (TailQuotient T) + +instance tailQuotientOrderTopology (T : Set (FiniteArchimedeanClass G)) : + OrderTopology (TailQuotient T) := ⟨rfl⟩ + +instance tailQuotientDenselyOrdered (T : Set (FiniteArchimedeanClass G)) : + DenselyOrdered (TailQuotient T) := by + constructor + intro a b hab + refine ⟨(2 : ℚ)⁻¹ • (a + b), ?_, ?_⟩ + · calc + a = (2 : ℚ)⁻¹ • (a + a) := by rw [smul_add, ← add_smul]; norm_num + _ < (2 : ℚ)⁻¹ • (a + b) := smul_lt_smul_of_pos_left + (add_lt_add_left hab a |>.trans_eq (add_comm _ _)) (by norm_num) + · calc + (2 : ℚ)⁻¹ • (a + b) < (2 : ℚ)⁻¹ • (b + b) := + smul_lt_smul_of_pos_left + (by simpa [add_comm] using add_lt_add_left hab b) (by norm_num) + _ = b := by rw [smul_add, ← add_smul]; norm_num + +instance tailQuotientIsTopologicalAddGroup (T : Set (FiniteArchimedeanClass G)) : + IsTopologicalAddGroup (TailQuotient T) where + toContinuousAdd := continuousAdd_of_orderTopology (TailQuotient T) + toContinuousNeg := continuousNeg_of_orderTopology (TailQuotient T) + +noncomputable instance tailQuotientUniformSpace (T : Set (FiniteArchimedeanClass G)) : + UniformSpace (TailQuotient T) := + IsTopologicalAddGroup.rightUniformSpace (TailQuotient T) + +instance tailQuotientIsUniformAddGroup (T : Set (FiniteArchimedeanClass G)) : + IsUniformAddGroup (TailQuotient T) := isUniformAddGroup_of_addCommGroup + +/-- Absolute value commutes with projection to a rational tail quotient. -/ +theorem tailQuotient_abs (T : Set (FiniteArchimedeanClass G)) (x : G) : + |(Submodule.Quotient.mk x : TailQuotient T)| = Submodule.Quotient.mk |x| := by + rcases le_total 0 x with hx | hx + · have hxq : (0 : TailQuotient T) ≤ Submodule.Quotient.mk x := by + rw [← Submodule.Quotient.mk_zero] + exact ConvexQuotient.mk_le_mk hx + rw [abs_of_nonneg hx, abs_of_nonneg hxq] + · have hxq : (Submodule.Quotient.mk x : TailQuotient T) ≤ 0 := by + rw [← Submodule.Quotient.mk_zero] + exact ConvexQuotient.mk_le_mk hx + rw [abs_of_nonpos hx, abs_of_nonpos hxq, ← Submodule.Quotient.mk_neg] + +/-- A strict class comparison in a rational tail quotient reflects to representatives. -/ +theorem archimedeanClass_mk_lt_of_tailQuotient_mk_lt + (T : Set (FiniteArchimedeanClass G)) {x y : G} + (h : ArchimedeanClass.mk (Submodule.Quotient.mk x : TailQuotient T) < + ArchimedeanClass.mk (Submodule.Quotient.mk y : TailQuotient T)) : + ArchimedeanClass.mk x < ArchimedeanClass.mk y := by + rw [ArchimedeanClass.mk_lt_mk] at h ⊢ + intro n + have hn := h n + have hn' : (Submodule.Quotient.mk (n • |y|) : TailQuotient T) < + Submodule.Quotient.mk |x| := by + have heq : (Submodule.Quotient.mk (n • |y|) : TailQuotient T) = + n • Submodule.Quotient.mk |y| := by + change QuotientAddGroup.mk' _ (n • |y|) = n • QuotientAddGroup.mk' _ |y| + exact map_nsmul (QuotientAddGroup.mk' _) n |y| + rw [heq] + simpa only [tailQuotient_abs] using hn + exact ConvexQuotient.lt_of_mk_lt_mk hn' + +/-- Canonical representatives of a limit family are coinitial in its rational tail quotient. -/ +theorem exists_tailQuotient_positiveRepresentative_le + {T : Set (FiniteArchimedeanClass G)} + {x : TailQuotient T} (hx : 0 < x) : + ∃ c : T, (Submodule.Quotient.mk (positiveRepresentative c.1) : TailQuotient T) ≤ x := by + induction x using Submodule.Quotient.induction_on with + | H x => + have hxq : (Submodule.Quotient.mk (0 : G) : TailQuotient T) < + Submodule.Quotient.mk x := by + simpa using hx + have hx0 : 0 < x := ConvexQuotient.lt_of_mk_lt_mk hxq + have hxP : x ∉ tailSubmodule ℚ T := by + simpa using (ConvexQuotient.mk_lt_mk_iff.mp hxq).2 + rw [mem_tailSubmodule_iff, mem_tailKernel_iff] at hxP + push Not at hxP + obtain ⟨c, hxc⟩ := hxP + refine ⟨c, ConvexQuotient.mk_le_mk ?_⟩ + apply (ArchimedeanClass.lt_of_mk_lt_mk_of_nonneg ?_ hx0.le).le + rwa [mk_positiveRepresentative] + +end FiniteArchimedeanClass + +end ConwayRefinement.Standalone.Hahn diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/Support/HahnSeriesGCDProof.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/Support/HahnSeriesGCDProof.lean new file mode 100644 index 0000000000..4651b9a0df --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/Support/HahnSeriesGCDProof.lean @@ -0,0 +1,89 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.HahnSeriesGCD +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.Support.SeriesConsequences +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Nonpositive + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Primality.Primality + +/-! +# Proofs of the Mathlib-only gcd and primality statements + +The standalone ring `nonpos K` is `K((ℝ^{≤0}))`, the type `Berarducci.Series K` used by the proof +modules. The polynomial presentation supplies its GCD structure. The gcd operation proves +`SeriesHasGCDs`; Mathlib then turns the existence of gcds into a +`DecompositionMonoid`, proving `SeriesIsPrimal`. +-/ + +public noncomputable section + +namespace ConwayRefinement.Standalone.Hahn + +universe u + +namespace SeriesHasGCDs + +/-- Every pair of series in `K((ℝ^{≤0}))` has a greatest common divisor. -/ +theorem of_polynomiality (K : Type u) [Field K] : SeriesHasGCDs K := by + intro hK + let := hK + obtain ⟨hGCD⟩ := Berarducci.nonemptyGCDMonoid (K := K) + let : GCDMonoid (nonpos K) := hGCD + intro a b + refine ⟨gcd a b, fun e ↦ ?_⟩ + constructor + · rintro ⟨hea, heb⟩ + exact dvd_gcd hea heb + · intro hed + exact ⟨hed.trans (gcd_dvd_left a b), hed.trans (gcd_dvd_right a b)⟩ + +end SeriesHasGCDs + +namespace SeriesIsPrimal + +/-- Every series in `K((ℝ^{≤0}))` is primal, as a consequence of the existence of gcds. -/ +theorem of_gcds (K : Type u) [Field K] : SeriesIsPrimal K := by + intro hK + let := hK + let : DecidableEq (nonpos K) := Classical.decEq _ + let : GCDMonoid (nonpos K) := + gcdMonoidOfExistsGCD (SeriesHasGCDs.of_polynomiality K inferInstance) + intro a + exact DecompositionMonoid.primal a + +end SeriesIsPrimal + +namespace SeriesIrreduciblesArePrime + +/-- Every irreducible series is prime. -/ +theorem of_primality (K : Type u) [Field K] : + SeriesIrreduciblesArePrime K := by + intro hK + let := hK + intro a ha + exact prime_of_irreducible_of (SeriesIsPrimal.of_gcds K) ha + +end SeriesIrreduciblesArePrime + +namespace SeriesFactorizationsAreUnique + +/-- Irreducible factorisations are unique up to order and units. -/ +theorem of_primality (K : Type u) [Field K] : + SeriesFactorizationsAreUnique K := by + intro hK + let := hK + intro f g hf hg hfg + exact factorization_unique_of (SeriesIsPrimal.of_gcds K) hf hg hfg + +end SeriesFactorizationsAreUnique + +/-- The pre-Schreier, or `DecompositionMonoid`, structure on `K((ℝ^{≤0}))`. -/ +instance (K : Type u) [Field K] [CharZero K] : DecompositionMonoid (nonpos K) := + decompositionMonoid_of (SeriesIsPrimal.of_gcds K) + +end ConwayRefinement.Standalone.Hahn diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/Support/HahnSeriesPolynomialRingProof.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/Support/HahnSeriesPolynomialRingProof.lean new file mode 100644 index 0000000000..a2724ce75b --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/Support/HahnSeriesPolynomialRingProof.lean @@ -0,0 +1,67 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.HahnSeriesPolynomialRing +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.PolynomialAlgebra.PolynomialRing + +/-! # Hahn Series Polynomial Ring Proof -/ + +public noncomputable section + +namespace ConwayRefinement.Standalone.HahnPolynomial + +universe u + +private def seriesEquiv (K : Type u) [Field K] : + Series K ≃+* Berarducci.Series K := by + have h : Series K = HahnSeries.nonpositiveSubring ℝ K := by + ext x + rfl + rw [h] + +private def finiteSupportEquiv (K : Type u) [Field K] : + FiniteSupport K ≃+* + HahnSeries.Nonpositive.FiniteSupportRing (G := ℝ) (K := K) where + toFun x := ⟨seriesEquiv K x.1, by + rw [HahnSeries.Nonpositive.mem_finiteSupportSubring_iff] + exact (mem_finiteSupport_iff K x.1).mp x.2⟩ + invFun x := ⟨(seriesEquiv K).symm x.1, by + rw [mem_finiteSupport_iff] + exact (HahnSeries.Nonpositive.mem_finiteSupportSubring_iff x.1).mp x.2⟩ + left_inv _ := rfl + right_inv _ := rfl + map_add' _ _ := rfl + map_mul' _ _ := rfl + +namespace IsPolynomialRing + +/-- A minimal homogeneous system and lifts of its generators supply the polynomial variables. -/ +theorem of_polynomiality (K : Type u) [Field K] : + HahnPolynomial.IsPolynomialRing K := by + intro hK + let := hK + obtain ⟨ι, weight, generators, hminimal, ⟨lifts⟩⟩ := + Berarducci.exists_isMinimalSystem_and_generatorLifts K + let ringEquiv : MvPolynomial ι (FiniteSupport K) ≃+* Series K := + (MvPolynomial.mapEquiv ι (finiteSupportEquiv K)).trans + ((Berarducci.polynomialRingEquiv hminimal lifts).toRingEquiv.trans + (seriesEquiv K).symm) + let algEquiv : MvPolynomial ι (FiniteSupport K) ≃ₐ[FiniteSupport K] Series K := + AlgEquiv.ofRingEquiv (f := ringEquiv) fun x ↦ by + change ringEquiv (MvPolynomial.C x) = (x : Series K) + simp only [ringEquiv, RingEquiv.trans_apply, MvPolynomial.mapEquiv_apply, + MvPolynomial.map_C] + change (seriesEquiv K).symm + (Berarducci.polynomialRingEquiv hminimal lifts + (MvPolynomial.C (finiteSupportEquiv K x))) = (x : Series K) + rw [Berarducci.polynomialRingEquiv_apply, Berarducci.evalAtLifts_C] + rfl + exact ⟨ι, ⟨algEquiv⟩⟩ + +end IsPolynomialRing + +end ConwayRefinement.Standalone.HahnPolynomial diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/Support/InlineConwayRefinementProof.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/Support/InlineConwayRefinementProof.lean new file mode 100644 index 0000000000..f1639a613a --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/Support/InlineConwayRefinementProof.lean @@ -0,0 +1,669 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.InlineConwayRefinement +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.Support.InlineSurreal +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.ConwayRefinement +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Support.ConwayRefinementConsequences +public import LeanPool.ConwayRefinement.CombinatorialGames.Game.Functor +import Mathlib.Tactic.Linarith +import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.ConwayRefinementProof + +/-! # Inline Conway Refinement Proof -/ + +public noncomputable section + +namespace ConwayRefinement.Standalone.InlineConwayRefinement + +universe u + +/-- The shared CombinatorialGames representation used by the proof bridge. -/ +abbrev SupportGame := _root_.IGame + +/-- Recursively convert an indexed Conway game to the auxiliary representation by its option +sets. -/ +noncomputable def Game.toSupport : Game.{u} → SupportGame.{u} + | .mk Left Right left right => + _root_.OfSets.ofSets + (_root_.Player.cases + (Set.range fun i : Left ↦ Game.toSupport (left i)) + (Set.range fun i : Right ↦ Game.toSupport (right i))) trivial + +/-- Convert an auxiliary game to an indexed Conway game by shrinking its left and right option +sets. -/ +@[expose] noncomputable def Game.fromSupport (x : SupportGame.{u}) : Game.{u} := + _root_.IGame.ofSetsRecOn x fun s t _ _ hs ht ↦ + .mk (Shrink s) (Shrink t) + (fun i ↦ + let z := (equivShrink s).symm i + hs z.1 z.2) + (fun i ↦ + let z := (equivShrink t).symm i + ht z.1 z.2) + +theorem Game.fromSupport_ofSets (s t : Set SupportGame.{u}) [Small.{u} s] [Small.{u} t] : + Game.fromSupport + (_root_.OfSets.ofSets + (_root_.Player.cases s t) trivial) = + .mk (Shrink s) (Shrink t) + (fun i ↦ Game.fromSupport ((equivShrink s).symm i).1) + (fun i ↦ Game.fromSupport ((equivShrink t).symm i).1) := by + rw [Game.fromSupport, + _root_.IGame.ofSetsRecOn_ofSets] + simp only [Game.fromSupport] + +theorem Game.toSupport_fromSupport (x : SupportGame.{u}) : + Game.toSupport (Game.fromSupport x) = x := by + induction x using _root_.IGame.ofSetsRecOn with + | ofSets s t ihs iht => + simp only [Game.fromSupport, + _root_.IGame.ofSetsRecOn_ofSets, Game.toSupport] + apply _root_.IGame.ext + intro p + simp only [_root_.IGame.moves_ofSets] + cases p + · ext z + constructor + · rintro ⟨i, rfl⟩ + let y := (equivShrink s).symm i + change Game.toSupport (Game.fromSupport y.1) ∈ s + simpa only [ihs y.1 y.2] using y.2 + · intro hz + let i := equivShrink s ⟨z, hz⟩ + refine ⟨i, ?_⟩ + simpa only [i, Equiv.symm_apply_apply, Game.fromSupport] using ihs z hz + · ext z + constructor + · rintro ⟨i, rfl⟩ + let y := (equivShrink t).symm i + change Game.toSupport (Game.fromSupport y.1) ∈ t + simpa only [iht y.1 y.2] using y.2 + · intro hz + let i := equivShrink t ⟨z, hz⟩ + refine ⟨i, ?_⟩ + simpa only [i, Equiv.symm_apply_apply, Game.fromSupport] using iht z hz + +theorem Game.toSupport_neg (x : Game.{u}) : + Game.toSupport (Game.neg x) = -Game.toSupport x := by + induction x with + | mk Left Right left right ihLeft ihRight => + rw [Game.neg_mk] + simp only [Game.toSupport] + rw [_root_.IGame.neg_ofSets] + apply _root_.IGame.ext + intro p + simp only [_root_.IGame.moves_ofSets] + cases p + · calc + Set.range (fun i ↦ Game.toSupport (Game.neg (right i))) = + Set.range (fun i ↦ -Game.toSupport (right i)) := by + congr 1 + funext i + exact ihRight i + _ = -Set.range (fun i ↦ Game.toSupport (right i)) := by + rw [← Set.image_neg_eq_neg] + exact Set.range_comp' _ _ + · calc + Set.range (fun i ↦ Game.toSupport (Game.neg (left i))) = + Set.range (fun i ↦ -Game.toSupport (left i)) := by + congr 1 + funext i + exact ihLeft i + _ = -Set.range (fun i ↦ Game.toSupport (left i)) := by + rw [← Set.image_neg_eq_neg] + exact Set.range_comp' _ _ + +theorem Game.toSupport_le (x y : Game.{u}) : + Game.Le x y ↔ Game.toSupport x ≤ Game.toSupport y := by + induction x, y using Sym2.GameAdd.recursion Game.move_wf with + | _ x y ih => + cases x with + | mk Lx Rx lx rx => + cases y with + | mk Ly Ry ly ry => + rw [Game.le_mk] + rw [_root_.IGame.le_iff_forall_lf] + simp only [Game.toSupport, + _root_.IGame.moves_ofSets, Set.forall_mem_range] + constructor + · rintro ⟨hLeft, hRight⟩ + constructor + · intro i h + exact hLeft i ((ih _ _ (Sym2.GameAdd.snd_fst (Game.Move.left i))).mpr h) + · intro j h + exact hRight j ((ih _ _ (Sym2.GameAdd.fst_snd (Game.Move.right j))).mpr h) + · rintro ⟨hLeft, hRight⟩ + constructor + · intro i h + exact hLeft i ((ih _ _ (Sym2.GameAdd.snd_fst (Game.Move.left i))).mp h) + · intro j h + exact hRight j ((ih _ _ (Sym2.GameAdd.fst_snd (Game.Move.right j))).mp h) + +theorem Game.Numeric.toSupport {x : Game.{u}} (h : Game.Numeric x) : + _root_.IGame.Numeric (Game.toSupport x) := by + induction h with + | mk hOrder hLeft hRight ihLeft ihRight => + rw [_root_.IGame.numeric_def] + simp only [Game.toSupport, + _root_.IGame.moves_ofSets, Set.forall_mem_range] + constructor + · intro i j + obtain ⟨hij, hji⟩ := Game.less_iff _ _ |>.mp (hOrder i j) + rw [lt_iff_le_not_ge] + exact ⟨Game.toSupport_le _ _ |>.mp hij, + fun h ↦ hji (Game.toSupport_le _ _ |>.mpr h)⟩ + · intro p + cases p + · intro y hy + obtain ⟨i, rfl⟩ := hy + exact ihLeft i + · intro y hy + obtain ⟨j, rfl⟩ := hy + exact ihRight j + +theorem Game.Numeric.fromSupport {x : SupportGame.{u}} + (h : _root_.IGame.Numeric x) : + Game.Numeric (Game.fromSupport x) := by + revert h + induction x using _root_.IGame.ofSetsRecOn with + | ofSets s t ihLeft ihRight => + intro h + have hdef := _root_.IGame.numeric_def.mp h + simp only [_root_.IGame.moves_ofSets] at hdef + rw [Game.fromSupport_ofSets] + apply Game.Numeric.mk + · intro i j + let a := (equivShrink s).symm i + let b := (equivShrink t).symm j + have hab : a.1 < b.1 := hdef.1 a.1 a.2 b.1 b.2 + obtain ⟨hab, hba⟩ := lt_iff_le_not_ge.mp hab + apply Game.less_iff _ _ |>.mpr + constructor + · apply Game.toSupport_le _ _ |>.mpr + simpa only [Game.toSupport_fromSupport] using hab + · intro hrev + apply hba + have := Game.toSupport_le _ _ |>.mp hrev + simpa only [Game.toSupport_fromSupport] using this + · intro i + let a := (equivShrink s).symm i + exact ihLeft a.1 a.2 + (hdef.2 _root_.Player.left a.1 a.2) + · intro j + let b := (equivShrink t).symm j + exact ihRight b.1 b.2 + (hdef.2 _root_.Player.right b.1 b.2) + +theorem Game.toSupport_add (x y : Game.{u}) : + Game.toSupport (Game.add x y) = Game.toSupport x + Game.toSupport y := by + induction x, y using Game.pairRec with + | _ x y ih => + cases x with + | mk Lx Rx lx rx => + cases y with + | mk Ly Ry ly ry => + rw [Game.add_mk] + simp only [Game.toSupport] + rw [_root_.IGame.ofSets_add_ofSets] + apply _root_.IGame.ext + intro p + simp only [_root_.IGame.moves_ofSets] + cases p + · ext z + simp only [Set.mem_range, Set.mem_union, Set.mem_image] + constructor + · rintro ⟨i | j, rfl⟩ + · left + refine ⟨Game.toSupport (lx i), ⟨i, rfl⟩, ?_⟩ + exact (ih (lx i) (.mk Ly Ry ly ry) + (Prod.Lex.left _ _ (Game.Move.left i))).symm + · right + refine ⟨Game.toSupport (ly j), ⟨j, rfl⟩, ?_⟩ + exact (ih (.mk Lx Rx lx rx) (ly j) + (Prod.Lex.right _ (Game.Move.left j))).symm + · rintro (⟨_, ⟨i, rfl⟩, rfl⟩ | ⟨_, ⟨j, rfl⟩, rfl⟩) + · exact ⟨Sum.inl i, ih _ _ (Prod.Lex.left _ _ (Game.Move.left i))⟩ + · exact ⟨Sum.inr j, ih _ _ (Prod.Lex.right _ (Game.Move.left j))⟩ + · ext z + simp only [Set.mem_range, Set.mem_union, Set.mem_image] + constructor + · rintro ⟨i | j, rfl⟩ + · left + refine ⟨Game.toSupport (rx i), ⟨i, rfl⟩, ?_⟩ + exact (ih (rx i) (.mk Ly Ry ly ry) + (Prod.Lex.left _ _ (Game.Move.right i))).symm + · right + refine ⟨Game.toSupport (ry j), ⟨j, rfl⟩, ?_⟩ + exact (ih (.mk Lx Rx lx rx) (ry j) + (Prod.Lex.right _ (Game.Move.right j))).symm + · rintro (⟨_, ⟨i, rfl⟩, rfl⟩ | ⟨_, ⟨j, rfl⟩, rfl⟩) + · exact ⟨Sum.inl i, ih _ _ (Prod.Lex.left _ _ (Game.Move.right i))⟩ + · exact ⟨Sum.inr j, ih _ _ (Prod.Lex.right _ (Game.Move.right j))⟩ + +theorem Game.toSupport_mul (x y : Game.{u}) : + Game.toSupport (Game.mul x y) = Game.toSupport x * Game.toSupport y := by + induction x, y using Game.pairRec with + | _ x y ih => + cases x with + | mk Lx Rx lx rx => + cases y with + | mk Ly Ry ly ry => + let x := Game.mk Lx Rx lx rx + let y := Game.mk Ly Ry ly ry + have option_eq (a b : Game) (ha : Game.Move a x) (hb : Game.Move b y) : + Game.toSupport + (Game.add (Game.add (Game.mul a y) (Game.mul x b)) + (Game.neg (Game.mul a b))) = + _root_.IGame.mulOption + (Game.toSupport x) (Game.toSupport y) + (Game.toSupport a) (Game.toSupport b) := by + rw [Game.toSupport_add, Game.toSupport_add, Game.toSupport_neg, + ih a y (Prod.Lex.left y y ha), ih x b (Prod.Lex.right x hb), + ih a b (Prod.Lex.left b y ha)] + rfl + rw [Game.mul_mk] + simp only [Game.toSupport] + rw [_root_.IGame.mul_eq] + apply _root_.IGame.ext + intro p + simp only [_root_.IGame.moves_ofSets] + cases p + · ext z + simp only [Set.mem_range, Set.mem_image, Set.mem_union, Set.mem_prod] + constructor + · rintro ⟨ij | ij, rfl⟩ + · refine ⟨(Game.toSupport (lx ij.1), Game.toSupport (ly ij.2)), ?_, ?_⟩ + · left + exact ⟨⟨ij.1, rfl⟩, ⟨ij.2, rfl⟩⟩ + · exact (option_eq _ _ (Game.Move.left ij.1) (Game.Move.left ij.2)).symm + · refine ⟨(Game.toSupport (rx ij.1), Game.toSupport (ry ij.2)), ?_, ?_⟩ + · right + exact ⟨⟨ij.1, rfl⟩, ⟨ij.2, rfl⟩⟩ + · exact (option_eq _ _ (Game.Move.right ij.1) (Game.Move.right ij.2)).symm + · rintro ⟨⟨a, b⟩, (⟨⟨i, rfl⟩, ⟨j, rfl⟩⟩ | ⟨⟨i, rfl⟩, ⟨j, rfl⟩⟩), rfl⟩ + · exact ⟨Sum.inl (i, j), + option_eq _ _ (Game.Move.left i) (Game.Move.left j)⟩ + · exact ⟨Sum.inr (i, j), + option_eq _ _ (Game.Move.right i) (Game.Move.right j)⟩ + · ext z + simp only [Set.mem_range, Set.mem_image, Set.mem_union, Set.mem_prod] + constructor + · rintro ⟨ij | ij, rfl⟩ + · refine ⟨(Game.toSupport (lx ij.1), Game.toSupport (ry ij.2)), ?_, ?_⟩ + · left + exact ⟨⟨ij.1, rfl⟩, ⟨ij.2, rfl⟩⟩ + · exact (option_eq _ _ (Game.Move.left ij.1) (Game.Move.right ij.2)).symm + · refine ⟨(Game.toSupport (rx ij.1), Game.toSupport (ly ij.2)), ?_, ?_⟩ + · right + exact ⟨⟨ij.1, rfl⟩, ⟨ij.2, rfl⟩⟩ + · exact (option_eq _ _ (Game.Move.right ij.1) (Game.Move.left ij.2)).symm + · rintro ⟨⟨a, b⟩, (⟨⟨i, rfl⟩, ⟨j, rfl⟩⟩ | ⟨⟨i, rfl⟩, ⟨j, rfl⟩⟩), rfl⟩ + · exact ⟨Sum.inl (i, j), + option_eq _ _ (Game.Move.left i) (Game.Move.right j)⟩ + · exact ⟨Sum.inr (i, j), + option_eq _ _ (Game.Move.right i) (Game.Move.left j)⟩ + +/-- Map a numeric indexed-game representative to its surreal value in the auxiliary model. -/ +noncomputable def Surreal.toSupport (x : Surreal.{u}) : + _root_.Surreal.{u} := + @_root_.Surreal.mk _ x.numeric.toSupport + +theorem Surreal.toSupport_eq (x : Surreal.{u}) : + x.toSupport = @_root_.Surreal.mk _ x.numeric.toSupport := + (rfl) + +/-- Choose a numeric indexed-game representative of a surreal number in the auxiliary model. -/ +noncomputable def Surreal.fromSupport + (x : _root_.Surreal.{u}) : Surreal.{u} := + ⟨Game.fromSupport x.out, Game.Numeric.fromSupport inferInstance⟩ + +theorem Surreal.fromSupport_game + (x : _root_.Surreal.{u}) : + (Surreal.fromSupport x).game = Game.fromSupport x.out := (rfl) + +theorem Surreal.toSupport_fromSupport + (x : _root_.Surreal.{u}) : + (Surreal.fromSupport x).toSupport = x := by + let : _root_.IGame.Numeric + (Game.toSupport (Surreal.fromSupport x).game) := + (Surreal.fromSupport x).numeric.toSupport + rw [Surreal.toSupport_eq] + calc + _root_.Surreal.mk + (Game.toSupport (Surreal.fromSupport x).game) = + _root_.Surreal.mk x.out := by + apply _root_.Surreal.mk_eq + have heq : Game.toSupport (Surreal.fromSupport x).game = x.out := + congrArg Game.toSupport (Surreal.fromSupport_game x) |>.trans + (Game.toSupport_fromSupport x.out) + rw [heq] + _ = x := _root_.Surreal.out_eq x + +theorem Surreal.gameEquivalent_iff_toSupport_eq (x y : Surreal.{u}) : + Game.Equivalent x.game y.game ↔ x.toSupport = y.toSupport := by + let : _root_.IGame.Numeric (Game.toSupport x.game) := + x.numeric.toSupport + let : _root_.IGame.Numeric (Game.toSupport y.game) := + y.numeric.toSupport + rw [Surreal.toSupport_eq, Surreal.toSupport_eq, + _root_.Surreal.mk_eq_mk, Game.equivalent_iff] + change (Game.Le x.game y.game ∧ Game.Le y.game x.game) ↔ + (Game.toSupport x.game ≤ Game.toSupport y.game ∧ + Game.toSupport y.game ≤ Game.toSupport x.game) + rw [Game.toSupport_le, Game.toSupport_le] + +/-- The actual quotient of the numeric representatives displayed in the headline file. -/ +def Surreal.QuotientModel : Type (u + 1) := + Quotient + { r := fun x y : Surreal.{u} ↦ Game.Equivalent x.game y.game + iseqv := ⟨ + fun x ↦ Surreal.gameEquivalent_iff_toSupport_eq x x |>.mpr rfl, + fun h ↦ Surreal.gameEquivalent_iff_toSupport_eq _ _ |>.mpr + (Surreal.gameEquivalent_iff_toSupport_eq _ _ |>.mp h).symm, + fun hxy hyz ↦ Surreal.gameEquivalent_iff_toSupport_eq _ _ |>.mpr + ((Surreal.gameEquivalent_iff_toSupport_eq _ _ |>.mp hxy).trans + (Surreal.gameEquivalent_iff_toSupport_eq _ _ |>.mp hyz))⟩ } + +/-- The map from indexed games modulo numeric equivalence to the auxiliary surreal model. -/ +noncomputable def Surreal.QuotientModel.toSupport : Surreal.QuotientModel.{u} → + _root_.Surreal.{u} := + Quotient.lift Surreal.toSupport fun _ _ h ↦ + Surreal.gameEquivalent_iff_toSupport_eq _ _ |>.mp h + +universe v + +theorem Surreal.QuotientModel.toSupport_bijective : + Function.Bijective Surreal.QuotientModel.toSupport.{v} := by + constructor + · intro x y hxy + refine Quotient.inductionOn₂ x y ?_ hxy + intro x y h + apply Quotient.sound + exact Surreal.gameEquivalent_iff_toSupport_eq x y |>.mpr h + · intro (x : _root_.Surreal.{v}) + exact ⟨Quotient.mk _ (Surreal.fromSupport x), Surreal.toSupport_fromSupport x⟩ + +/-- The quotient of the headline's numeric games is equivalent to the fully developed inlined +surreal numbers. -/ +noncomputable def Surreal.quotientEquivSupport : Surreal.QuotientModel.{v} ≃ + _root_.Surreal.{v} := + Equiv.ofBijective Surreal.QuotientModel.toSupport.{v} + Surreal.QuotientModel.toSupport_bijective + +/-- The quotient of the completely visible inline representatives is exactly the surreal-number +type supplied by CombinatorialGames. -/ +noncomputable def Surreal.quotientEquivCombinatorialGames : + Surreal.QuotientModel.{u} ≃ _root_.Surreal.{u} := + Surreal.quotientEquivSupport + +end ConwayRefinement.Standalone.InlineConwayRefinement +namespace ConwayRefinement.Standalone.InlineConwayRefinement.SupportBridge + +universe u + +theorem supportConway : + ConwayRefinement.Standalone.InlineSurreal.Surreal.ConwayConjecture.{u} := + ConwayRefinement.Standalone.Oz.ConwayConjecture.proof + +end ConwayRefinement.Standalone.InlineConwayRefinement.SupportBridge + +namespace ConwayRefinement.Standalone.InlineConwayRefinement + +universe u + +theorem Game.equivalent_iff_toSupport (x y : Game.{u}) : + Game.Equivalent x y ↔ + (Game.toSupport x ≤ Game.toSupport y ∧ Game.toSupport y ≤ Game.toSupport x) := by + rw [Game.equivalent_iff] + rw [Game.toSupport_le, Game.toSupport_le] + +theorem Surreal.productsEqual_iff_toSupport (a b c d : Surreal.{u}) : + Game.Equivalent (Game.mul a.game b.game) (Game.mul c.game d.game) ↔ + a.toSupport * b.toSupport = c.toSupport * d.toSupport := by + let := a.numeric.toSupport + let := b.numeric.toSupport + let := c.numeric.toSupport + let := d.numeric.toSupport + rw [Game.equivalent_iff_toSupport, Game.toSupport_mul, Game.toSupport_mul] + simp only [Surreal.toSupport_eq] + rw [← _root_.Surreal.mk_mul, + ← _root_.Surreal.mk_mul] + rw [_root_.Surreal.mk_eq_mk] + rfl + +theorem Surreal.equalsProduct_iff_toSupport (a e f : Surreal.{u}) : + Game.Equivalent a.game (Game.mul e.game f.game) ↔ + a.toSupport = e.toSupport * f.toSupport := by + let := a.numeric.toSupport + let := e.numeric.toSupport + let := f.numeric.toSupport + rw [Game.equivalent_iff_toSupport, Game.toSupport_mul] + simp only [Surreal.toSupport_eq] + rw [← _root_.Surreal.mk_mul] + rw [_root_.Surreal.mk_eq_mk] + rfl + +theorem Game.toSupport_mk {Left Right : Type u} + (left : Left → Game.{u}) (right : Right → Game.{u}) : + Game.toSupport (.mk Left Right left right) = + _root_.OfSets.ofSets + (_root_.Player.cases + (Set.range fun i : Left ↦ Game.toSupport (left i)) + (Set.range fun i : Right ↦ Game.toSupport (right i))) trivial := (rfl) + +theorem Game.toSupport_zero : Game.toSupport (Game.zero : Game.{u}) = + (0 : _root_.IGame.{u}) := by + rw [Game.zero_eq, Game.toSupport_mk] + apply _root_.IGame.ext + intro p + cases p + · rw [_root_.IGame.moves_ofSets, + _root_.IGame.moves_zero] + ext z + constructor + · rintro ⟨i, _⟩ + exact nomatch i.down + · simp + · rw [_root_.IGame.moves_ofSets, + _root_.IGame.moves_zero] + ext z + constructor + · rintro ⟨i, _⟩ + exact nomatch i.down + · simp + +theorem Game.toSupport_one : Game.toSupport (Game.one : Game.{u}) = + (1 : _root_.IGame.{u}) := by + rw [Game.one_eq, Game.toSupport_mk] + apply _root_.IGame.ext + intro p + cases p + · rw [_root_.IGame.moves_ofSets] + rw [_root_.IGame.one_def, + _root_.IGame.moves_ofSets] + ext z + constructor + · rintro ⟨_, rfl⟩ + exact Game.toSupport_zero + · intro hz + have hz' : z = 0 := by simpa using hz + subst z + exact ⟨PUnit.unit, Game.toSupport_zero⟩ + · rw [_root_.IGame.moves_ofSets, + _root_.IGame.one_def, + _root_.IGame.moves_ofSets] + ext z + constructor + · rintro ⟨i, _⟩ + exact nomatch i.down + · simp + +theorem Game.toSupport_singletonIntegerCut_numeric (x : Surreal.{u}) : + _root_.IGame.Numeric + (Game.toSupport (Surreal.singletonIntegerCut x.game)) := by + let := x.numeric.toSupport + rw [Surreal.singletonIntegerCut_eq] + rw [Game.toSupport_mk] + rw [_root_.IGame.numeric_def] + simp only [_root_.IGame.moves_ofSets, + Set.forall_mem_range] + constructor + · intro _ _ + change ConwayRefinement.Standalone.InlineConwayRefinement.Game.toSupport + (ConwayRefinement.Standalone.InlineConwayRefinement.Game.add x.game + (ConwayRefinement.Standalone.InlineConwayRefinement.Game.neg + ConwayRefinement.Standalone.InlineConwayRefinement.Game.one)) < + ConwayRefinement.Standalone.InlineConwayRefinement.Game.toSupport + (ConwayRefinement.Standalone.InlineConwayRefinement.Game.add x.game + ConwayRefinement.Standalone.InlineConwayRefinement.Game.one) + rw [ConwayRefinement.Standalone.InlineConwayRefinement.Game.toSupport_add x.game + (ConwayRefinement.Standalone.InlineConwayRefinement.Game.neg + (show Game.{u} from ConwayRefinement.Standalone.InlineConwayRefinement.Game.one)), + ConwayRefinement.Standalone.InlineConwayRefinement.Game.toSupport_add x.game + (show Game.{u} from ConwayRefinement.Standalone.InlineConwayRefinement.Game.one), + ConwayRefinement.Standalone.InlineConwayRefinement.Game.toSupport_neg + (show Game.{u} from ConwayRefinement.Standalone.InlineConwayRefinement.Game.one)] + rw [Game.toSupport_one] + apply _root_.Surreal.mk_lt_mk.mp + simp only [_root_.Surreal.mk_add, + _root_.Surreal.mk_neg, + _root_.Surreal.mk_one] + linarith + · intro p y hy + cases p + · obtain ⟨_, rfl⟩ := hy + change _root_.IGame.Numeric + (ConwayRefinement.Standalone.InlineConwayRefinement.Game.toSupport + (ConwayRefinement.Standalone.InlineConwayRefinement.Game.add x.game + (ConwayRefinement.Standalone.InlineConwayRefinement.Game.neg + ConwayRefinement.Standalone.InlineConwayRefinement.Game.one))) + rw [ConwayRefinement.Standalone.InlineConwayRefinement.Game.toSupport_add x.game + (ConwayRefinement.Standalone.InlineConwayRefinement.Game.neg + (show Game.{u} from ConwayRefinement.Standalone.InlineConwayRefinement.Game.one)), + ConwayRefinement.Standalone.InlineConwayRefinement.Game.toSupport_neg + (show Game.{u} from ConwayRefinement.Standalone.InlineConwayRefinement.Game.one)] + rw [Game.toSupport_one] + infer_instance + · obtain ⟨_, rfl⟩ := hy + change _root_.IGame.Numeric + (ConwayRefinement.Standalone.InlineConwayRefinement.Game.toSupport + (ConwayRefinement.Standalone.InlineConwayRefinement.Game.add x.game + ConwayRefinement.Standalone.InlineConwayRefinement.Game.one)) + rw [ConwayRefinement.Standalone.InlineConwayRefinement.Game.toSupport_add x.game + (show Game.{u} from ConwayRefinement.Standalone.InlineConwayRefinement.Game.one)] + rw [Game.toSupport_one] + infer_instance + +theorem Surreal.toSupport_sub_one (x : Surreal.{u}) : + @_root_.Surreal.mk + (Game.toSupport (Game.add x.game (Game.neg Game.one))) (by + let := x.numeric.toSupport + rw [Game.toSupport_add, Game.toSupport_neg, Game.toSupport_one] + infer_instance) = x.toSupport - 1 := by + let := x.numeric.toSupport + simp only [Game.toSupport_add, Game.toSupport_neg, Game.toSupport_one] + simpa only [_root_.Surreal.mk_neg, + _root_.Surreal.mk_one, Surreal.toSupport_eq, + sub_eq_add_neg] using + (_root_.Surreal.mk_add + (Game.toSupport x.game) (-1 : _root_.IGame.{u})) + +theorem Surreal.toSupport_add_one (x : Surreal.{u}) : + @_root_.Surreal.mk + (Game.toSupport (Game.add x.game Game.one)) (by + let := x.numeric.toSupport + rw [Game.toSupport_add, Game.toSupport_one] + infer_instance) = x.toSupport + 1 := by + let := x.numeric.toSupport + simp only [Game.toSupport_add, Game.toSupport_one] + simpa only [_root_.Surreal.mk_one, + Surreal.toSupport_eq] using + (_root_.Surreal.mk_add + (Game.toSupport x.game) (1 : _root_.IGame.{u})) + +theorem Surreal.toSupport_singletonIntegerCut (x : Surreal.{u}) : + @_root_.Surreal.mk + (Game.toSupport (Surreal.singletonIntegerCut x.game)) + (Game.toSupport_singletonIntegerCut_numeric x) = + ConwayRefinement.Standalone.InlineSurreal.Surreal.singletonIntegerCut x.toSupport := by + simp only [Surreal.singletonIntegerCut_eq, Game.toSupport_mk] + rw [ConwayRefinement.Standalone.InlineSurreal.Surreal.singletonIntegerCut] + rw [_root_.Surreal.mk_ofSets] + congr 2 + · ext z + simp only [Set.mem_range, Set.mem_singleton_iff] + constructor + · rintro ⟨⟨_, ⟨_, rfl⟩⟩, rfl⟩ + exact Surreal.toSupport_sub_one x + · rintro rfl + refine ⟨⟨Game.toSupport (Game.add x.game (Game.neg Game.one)), + ⟨PUnit.unit, rfl⟩⟩, ?_⟩ + exact Surreal.toSupport_sub_one x + · ext z + simp only [Set.mem_range, Set.mem_singleton_iff] + constructor + · rintro ⟨⟨_, ⟨_, rfl⟩⟩, rfl⟩ + exact Surreal.toSupport_add_one x + · rintro rfl + refine ⟨⟨Game.toSupport (Game.add x.game Game.one), + ⟨PUnit.unit, rfl⟩⟩, ?_⟩ + exact Surreal.toSupport_add_one x + +theorem Surreal.isConwayOmnificInteger_iff_toSupport (x : Surreal.{u}) : + IsConwayOmnificInteger x ↔ + ConwayRefinement.Standalone.InlineSurreal.Surreal.IsConwayOmnificInteger x.toSupport := by + let := x.numeric.toSupport + let := Game.toSupport_singletonIntegerCut_numeric x + rw [Surreal.isConwayOmnificInteger_iff, + ConwayRefinement.Standalone.InlineSurreal.Surreal.IsConwayOmnificInteger] + constructor + · intro hx + have hraw := Game.equivalent_iff_toSupport _ _ |>.mp hx + have hmk : x.toSupport = + @_root_.Surreal.mk + (Game.toSupport (Surreal.singletonIntegerCut x.game)) inferInstance := by + rw [Surreal.toSupport_eq, + _root_.Surreal.mk_eq_mk] + exact hraw + exact hmk.trans (Surreal.toSupport_singletonIntegerCut x) + · intro hx + apply Game.equivalent_iff_toSupport _ _ |>.mpr + apply _root_.Surreal.mk_eq_mk.mp + rw [← Surreal.toSupport_eq] + exact hx.trans (Surreal.toSupport_singletonIntegerCut x).symm + +theorem Surreal.conwayRefinementProof : Surreal.ConwayConjecture.{u} := by + intro a b c d ha hb hc hd habcd + have ha' := (Surreal.isConwayOmnificInteger_iff_toSupport a).mp ha + have hb' := (Surreal.isConwayOmnificInteger_iff_toSupport b).mp hb + have hc' := (Surreal.isConwayOmnificInteger_iff_toSupport c).mp hc + have hd' := (Surreal.isConwayOmnificInteger_iff_toSupport d).mp hd + have habcd' := (Surreal.productsEqual_iff_toSupport a b c d).mp habcd + obtain ⟨e, f, g, h, he, hf, hg, hh, hae, hbg, hce, hdf⟩ := + SupportBridge.supportConway a.toSupport b.toSupport c.toSupport d.toSupport + ha' hb' hc' hd' habcd' + refine ⟨Surreal.fromSupport e, Surreal.fromSupport f, + Surreal.fromSupport g, Surreal.fromSupport h, + ?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_⟩ + · apply (Surreal.isConwayOmnificInteger_iff_toSupport _).mpr + simpa only [Surreal.toSupport_fromSupport] using he + · apply (Surreal.isConwayOmnificInteger_iff_toSupport _).mpr + simpa only [Surreal.toSupport_fromSupport] using hf + · apply (Surreal.isConwayOmnificInteger_iff_toSupport _).mpr + simpa only [Surreal.toSupport_fromSupport] using hg + · apply (Surreal.isConwayOmnificInteger_iff_toSupport _).mpr + simpa only [Surreal.toSupport_fromSupport] using hh + · apply (Surreal.equalsProduct_iff_toSupport _ _ _).mpr + simpa only [Surreal.toSupport_fromSupport] using hae + · apply (Surreal.equalsProduct_iff_toSupport _ _ _).mpr + simpa only [Surreal.toSupport_fromSupport] using hbg + · apply (Surreal.equalsProduct_iff_toSupport _ _ _).mpr + simpa only [Surreal.toSupport_fromSupport] using hce + · apply (Surreal.equalsProduct_iff_toSupport _ _ _).mpr + simpa only [Surreal.toSupport_fromSupport] using hdf + +end ConwayRefinement.Standalone.InlineConwayRefinement diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/Support/InlineSurreal.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/Support/InlineSurreal.lean new file mode 100644 index 0000000000..5b8b4fd88f --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/Support/InlineSurreal.lean @@ -0,0 +1,53 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Copyright (c) 2025 Aaron Liu. All rights reserved. +Copyright (c) 2025 Violeta Hernández Palacios. All rights reserved. +Copyright (c) 2025 Yuyang Zhao. All rights reserved. +Copyright (c) 2024 Theodore Hwa. All rights reserved. +Copyright (c) 2019 Mario Carneiro. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov, Aaron Liu, Apurva Nakade, Fox Thomson, František Silváši, +Isabel Longbottom, Junyan Xu, Kim Morrison, Mario Carneiro, Reid Barton, Theodore Hwa, +Violeta Hernández Palacios, Yuyang Zhao +-/ +module + +public import LeanPool.ConwayRefinement.CombinatorialGames.Surreal.Multiplication + +/-! # Cut-defined omnific integers in the shared surreal-number model + +The first-principles indexed-game statement remains in `InlineConwayRefinement`. +Its proof bridges directly to the imported CombinatorialGames implementation. +-/ + +@[expose] public noncomputable section +universe u +namespace ConwayRefinement.Standalone.InlineSurreal.Surreal + +/-- The singleton Conway cut `{x - 1 | x + 1}`. -/ +def singletonIntegerCut (x : _root_.Surreal.{u}) : _root_.Surreal.{u} := + !{{x - 1} | {x + 1}}' (by + simp only [Set.mem_singleton_iff] + rintro _ rfl _ rfl + simp [sub_eq_add_neg]) + +/-- Conway's cut equation defining an omnific integer. -/ +def IsConwayOmnificInteger (x : _root_.Surreal.{u}) : Prop := + x = singletonIntegerCut x + +/-- Conway's refinement conjecture for the concretely defined surreal numbers. -/ +def ConwayConjecture : Prop := + ∀ a b c d : _root_.Surreal.{u}, + IsConwayOmnificInteger a → IsConwayOmnificInteger b → + IsConwayOmnificInteger c → IsConwayOmnificInteger d → a * b = c * d → + ∃ e f g h : _root_.Surreal.{u}, + IsConwayOmnificInteger e ∧ IsConwayOmnificInteger f ∧ + IsConwayOmnificInteger g ∧ IsConwayOmnificInteger h ∧ + a = e * f ∧ b = g * h ∧ c = e * g ∧ d = f * h + +end ConwayRefinement.Standalone.InlineSurreal.Surreal diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/Support/OrderedAddGroup.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/Support/OrderedAddGroup.lean new file mode 100644 index 0000000000..d7ff6ead3d --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/Support/OrderedAddGroup.lean @@ -0,0 +1,67 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import Mathlib.Topology.Algebra.Group.Defs +public import Mathlib.Topology.Order.MonotoneContinuity +import Mathlib.Tactic.Abel + +/-! +# The order topology on a densely ordered additive group + +Addition and negation are continuous for the order topology of a densely ordered abelian group. +The addition proof uses rectangles cut out by an intermediate point, so it does not assume the +continuity that it is constructing. +-/ + +open Set + +universe u + +public section + +namespace ConwayRefinement.Standalone.Hahn + +variable (G : Type u) [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [TopologicalSpace G] [OrderTopology G] [DenselyOrdered G] + +/-- Addition is continuous in the order topology of a densely ordered abelian group. -/ +theorem continuousAdd_of_orderTopology : ContinuousAdd G := by + constructor + apply OrderTopology.continuous_iff.mpr + intro a + constructor + · rw [isOpen_prod_iff] + intro x y hxy + have hxy' : a - y < x := sub_lt_iff_lt_add.mpr hxy + obtain ⟨d, had, hdx⟩ := exists_between hxy' + refine ⟨Ioi d, Ioi (a - d), isOpen_Ioi, isOpen_Ioi, hdx, ?_, ?_⟩ + · change a - d < y + rw [sub_lt_iff_lt_add, add_comm] + exact sub_lt_iff_lt_add.mp had + · rintro ⟨x', y'⟩ ⟨hx', hy'⟩ + calc + a = d + (a - d) := by abel + _ < x' + y' := add_lt_add hx' hy' + · rw [isOpen_prod_iff] + intro x y hxy + have hxy' : x < a - y := lt_sub_iff_add_lt.mpr hxy + obtain ⟨d, hxd, hda⟩ := exists_between hxy' + refine ⟨Iio d, Iio (a - d), isOpen_Iio, isOpen_Iio, hxd, ?_, ?_⟩ + · change y < a - d + rw [lt_sub_iff_add_lt, add_comm] + exact lt_sub_iff_add_lt.mp hda + · rintro ⟨x', y'⟩ ⟨hx', hy'⟩ + calc + x' + y' < d + (a - d) := add_lt_add hx' hy' + _ = a := by abel + +omit [DenselyOrdered G] in +/-- Negation is continuous in the order topology of an ordered abelian group. -/ +theorem continuousNeg_of_orderTopology : ContinuousNeg G := + ⟨(OrderIso.neg G).continuous⟩ + +end ConwayRefinement.Standalone.Hahn diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/Support/SeriesConsequences.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/Support/SeriesConsequences.lean new file mode 100644 index 0000000000..98a0796fa6 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Standalone/Mathlib/Support/SeriesConsequences.lean @@ -0,0 +1,50 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.HahnSeriesGCD +public import Mathlib.RingTheory.UniqueFactorizationDomain.Basic + +/-! +# What follows from the primality of every series, in Mathlib's vocabulary + +Every theorem below follows from the proposition `SeriesIsPrimal K` using Mathlib alone. + +The consequences are the forms in which the theorem is used or quoted: `K((ℝ^{≤0}))` is +pre-Schreier (Mathlib's `DecompositionMonoid`); every irreducible series is prime; and any two +factorisations of a series into irreducibles agree up to order and units, the two multisets of +factors being related by association. +-/ + +public section + +namespace ConwayRefinement.Standalone.Hahn + +universe u + +variable {K : Type u} [Field K] [CharZero K] + +/-- `K((ℝ^{≤0}))` is pre-Schreier: every element is primal, Mathlib's `DecompositionMonoid`. -/ +theorem decompositionMonoid_of (h : SeriesIsPrimal K) : DecompositionMonoid (nonpos K) := by + exact ⟨h inferInstance⟩ + +/-- Every irreducible series is prime. -/ +theorem prime_of_irreducible_of (h : SeriesIsPrimal K) {a : nonpos K} (hirr : Irreducible a) : + Prime a := by + exact hirr.prime_of_isPrimal (h inferInstance a) + +/-- Unique factorisation: two products of irreducibles that agree up to a unit have the same +factors up to order and association. -/ +theorem factorization_unique_of (h : SeriesIsPrimal K) {f g : Multiset (nonpos K)} + (hf : ∀ x ∈ f, Irreducible x) (hg : ∀ x ∈ g, Irreducible x) + (hfg : Associated f.prod g.prod) : + Multiset.Rel Associated f g := by + exact prime_factors_unique (fun x hx ↦ prime_of_irreducible_of h (hf x hx)) + (fun x hx ↦ prime_of_irreducible_of h (hg x hx)) hfg + +end ConwayRefinement.Standalone.Hahn + +end diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Surreal.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal.lean new file mode 100644 index 0000000000..e3efd165d4 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal.lean @@ -0,0 +1,22 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.ArchimedeanAssumptions +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.Cardinal +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.CutFilling +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.HahnSeries +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.OmnificInteger +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.RationalTailQuotient +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.RealArchimedeanStratum +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.RealModule +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.Round +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.SmallDiscrete +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.Tests +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.ZFC + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/ArchimedeanAssumptions.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/ArchimedeanAssumptions.lean new file mode 100644 index 0000000000..aede407ffd --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/ArchimedeanAssumptions.lean @@ -0,0 +1,430 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.RealModule +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.SmallDiscrete +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Order.Module.ConvexQuotientSplitting +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Assumptions +public import LeanPool.ConwayRefinement.CombinatorialGames.Surreal.Leading +public import Mathlib.Algebra.Order.Module.Rat +public import Mathlib.SetTheory.Cardinal.Regular + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint + +/-! +# LM24 assumptions `(A1)_σ` and `(A2)_σ` for surreal Archimedean strata + +Every real-linear complement of one open Archimedean ball in the corresponding closed surreal +ball is order-additively isomorphic to `ℝ`. To construct the isomorphism, choose a positive +element `a` of the stratum and send `x` to the standard part of `x / a`. Elements of the stratum +have the same Archimedean class as `a`, so the quotient is finite; disjointness from the open ball +makes the map injective, while real scalar multiples of `a` make it surjective. + +This proves LM24, Proposition 2.4.3 in the exact form needed for assumption `(A1)_σ` in Theorem +9.0.1. The zero class remains a separate disjunct, following Mathlib's convention that it is `⊤`. + +For `(A2)_σ`, every small family in the open ball has a strict upper bound still in the ball. +The bound is the surreal cut above the family and below every `a / n`, where `a` is a positive +representative of `σ`. Consequently the ball has cofinality at least the universe cardinal that +bounds surreal Hahn supports. This is the universe-bounded form of LM24, Proposition 2.4.4. +-/ + +public noncomputable section + +open ArchimedeanClass FiniteArchimedeanClass + +namespace Surreal + +variable (u : HahnEmbedding.ArchimedeanStrata ℝ Surreal) +variable (c : FiniteArchimedeanClass Surreal) + +private noncomputable def stratumNonzeroElement : u.stratum c := + Classical.choose (exists_ne (0 : u.stratum c)) + +private theorem stratumNonzeroElement_ne_zero : stratumNonzeroElement u c ≠ 0 := + Classical.choose_spec (exists_ne (0 : u.stratum c)) + +private noncomputable def stratumPositiveElement : u.stratum c := + |stratumNonzeroElement u c| + +private theorem stratumPositiveElement_pos : 0 < stratumPositiveElement u c := by + rw [stratumPositiveElement, abs_pos] + exact stratumNonzeroElement_ne_zero u c + +private theorem stratumPositiveElement_ne_zero : stratumPositiveElement u c ≠ 0 := + (stratumPositiveElement_pos u c).ne' + +private theorem stratum_mk_div_positiveElement_eq_zero + (x : u.stratum c) (hx : x ≠ 0) : + ArchimedeanClass.mk ((x : Surreal) / stratumPositiveElement u c) = 0 := by + rw [ArchimedeanClass.mk_div, + u.archimedeanClassMk_of_mem_stratum x.property (by simpa using hx), + u.archimedeanClassMk_of_mem_stratum (stratumPositiveElement u c).property + (by simpa using stratumPositiveElement_ne_zero u c)] + exact LinearOrderedAddCommGroupWithTop.sub_self_eq_zero_of_ne_top c.property + +private theorem stratum_mk_div_positiveElement_nonneg (x : u.stratum c) : + 0 ≤ ArchimedeanClass.mk ((x : Surreal) / stratumPositiveElement u c) := by + by_cases hx : x = 0 + · simp [hx] + · rw [stratum_mk_div_positiveElement_eq_zero u c x hx] + +private noncomputable def stratumStdPartHom : u.stratum c →+ ℝ where + toFun x := ArchimedeanClass.stdPart ((x : Surreal) / stratumPositiveElement u c) + map_zero' := by simp + map_add' x y := by + change ArchimedeanClass.stdPart + (((x : Surreal) + (y : Surreal)) / stratumPositiveElement u c) = _ + rw [add_div, ArchimedeanClass.stdPart_add + (stratum_mk_div_positiveElement_nonneg u c x) + (stratum_mk_div_positiveElement_nonneg u c y)] + +private theorem stratumStdPartHom_pos {x : u.stratum c} (hx : 0 < x) : + 0 < stratumStdPartHom u c x := by + have hquotient : 0 < (x : Surreal) / stratumPositiveElement u c := + div_pos (by exact hx) (by exact stratumPositiveElement_pos u c) + have hnonneg : 0 ≤ stratumStdPartHom u c x := + ArchimedeanClass.stdPart_nonneg hquotient.le + refine lt_of_le_of_ne hnonneg ?_ + intro heq + have hzero : stratumStdPartHom u c x = 0 := heq.symm + have hmkne := ArchimedeanClass.stdPart_eq_zero.mp hzero + exact hmkne (stratum_mk_div_positiveElement_eq_zero u c x hx.ne') + +private theorem stratumStdPartHom_strictMono : StrictMono (stratumStdPartHom u c) := by + intro x y hxy + rw [← sub_pos, ← map_sub] + exact stratumStdPartHom_pos u c (sub_pos.mpr hxy) + +private theorem stratumStdPartHom_surjective : + Function.Surjective (stratumStdPartHom u c) := by + intro r + refine ⟨r • stratumPositiveElement u c, ?_⟩ + change ArchimedeanClass.stdPart + (((r : ℝ) : Surreal) * (stratumPositiveElement u c : Surreal) / + (stratumPositiveElement u c : Surreal)) = r + rw [mul_div_cancel_right₀ _ (by simpa using stratumPositiveElement_ne_zero u c)] + exact ArchimedeanClass.stdPart_map_real Real.toSurrealRingHom r + +/-- A nonzero surreal Archimedean stratum is noncanonically isomorphic to `ℝ` as an ordered +additive group. This is LM24, Proposition 2.4.3. -/ +@[blueprint "fact:surreal-archimedean-strata" + (phase := "Surreal numbers and omnific integers") + (title := "Real structure of surreal Archimedean strata") + (statement := /-- + Every nonzero Archimedean stratum of the surreal numbers is noncanonically + isomorphic to $(\mathbb R,+,<)$ as an ordered additive group + \cite[Proposition~2.4.3]{LM24}. + -/) + (proof := /-- + Choose a positive element $a$ of the stratum and send $x$ to the standard + part of $x/a$. Division by $a$ makes the quotient finite; the chosen + complement to the lower Archimedean ball makes the map injective, and the + real multiples of $a$ make it surjective. + -/)] +noncomputable def stratumOrderAddMonoidIsoReal : u.stratum c ≃+o ℝ := + { AddEquiv.ofBijective (stratumStdPartHom u c) + ⟨(stratumStdPartHom_strictMono u c).injective, + stratumStdPartHom_surjective u c⟩ with + map_le_map_iff' := (stratumStdPartHom_strictMono u c).le_iff_le } + +/-- Every nonzero surreal Archimedean class satisfies LM24 assumption `(A1)_σ`. -/ +theorem assumptionA1AtFiniteClass : LM24.AssumptionA1AtFiniteClass u c := by + rw [LM24.assumptionA1AtFiniteClass_iff] + exact ⟨stratumOrderAddMonoidIsoReal u c⟩ + +/-- Every surreal Archimedean class, including the zero class, satisfies LM24 assumption +`(A1)_σ`. -/ +theorem assumptionA1 (σ : ArchimedeanClass Surreal) : LM24.AssumptionA1 u σ := by + rw [LM24.assumptionA1_iff] + by_cases hσ : σ = ⊤ + · exact Or.inl hσ + · exact Or.inr ⟨⟨σ, hσ⟩, by simp, ⟨stratumOrderAddMonoidIsoReal u ⟨σ, hσ⟩⟩⟩ + +/-- A fixed noncanonical family of real-linear complements to the surreal Archimedean balls. -/ +noncomputable def archimedeanStrata : HahnEmbedding.ArchimedeanStrata ℝ Surreal := + Classical.choice inferInstance + +/-- The fixed surreal strata satisfy LM24 assumption `(A1)_σ` at every class. -/ +theorem archimedeanStrata_assumptionA1 (σ : ArchimedeanClass Surreal) : + LM24.AssumptionA1 archimedeanStrata σ := + assumptionA1 archimedeanStrata σ + +/-! ### Assumption `(A2)_σ` -/ + +universe u v + +/-- The inaccessible universe cardinal that bounds supports of `SurrealHahnSeries.{u}`. -/ +def smallSupportCardinal : Cardinal.{u + 1} := + Cardinal.univ.{u, u + 1} + +/-- The surreal small-support cardinal is the universe cardinal. -/ +theorem smallSupportCardinal_eq_univ : + smallSupportCardinal.{u} = Cardinal.univ.{u, u + 1} := + (rfl) + +/-- The surreal small-support cardinal is uncountable. -/ +theorem aleph0_lt_smallSupportCardinal : + Cardinal.aleph0 < smallSupportCardinal.{u} := + Cardinal.aleph0_lt_univ + +/-- The small-support cardinal carries the uncountability instance used by bounded Hahn fields. -/ +instance smallSupportCardinal_aleph0Fact : + Fact (Cardinal.aleph0 < smallSupportCardinal.{u}) := + ⟨aleph0_lt_smallSupportCardinal⟩ + +/-- The surreal small-support cardinal is regular. -/ +theorem smallSupportCardinal_isRegular : + smallSupportCardinal.{u}.IsRegular := + Cardinal.IsInaccessible.univ.isRegular + +/-- The small-support cardinal carries the regularity instance used by bounded splitting. -/ +instance smallSupportCardinal_isRegularFact : + Fact smallSupportCardinal.{u}.IsRegular := + ⟨smallSupportCardinal_isRegular⟩ + +private theorem ball_not_isCofinal_of_small + {a : Surreal.{u}} (ha : 0 < a) + (s : Set ↥(ball ℝ (FiniteArchimedeanClass.mk a ha.ne'))) + [Small.{u} s] : ¬ IsCofinal s := by + let L : Set Surreal.{u} := + {0} ∪ (fun z : ↥(ball ℝ (FiniteArchimedeanClass.mk a ha.ne')) ↦ (z : Surreal)) '' s + let R : Set Surreal.{u} := Set.range fun n : ℕ ↦ ((n + 1 : ℝ)⁻¹) • a + have hLR : ∀ x ∈ L, ∀ y ∈ R, x < y := by + intro x hx y hy + obtain rfl | ⟨z, hz, rfl⟩ := hx + · obtain ⟨n, rfl⟩ := hy + change 0 < ((n + 1 : ℝ)⁻¹) • a + rw [real_smul_def] + exact mul_pos (Real.toSurreal_pos_iff.mpr (inv_pos.mpr (by positivity))) ha + · obtain ⟨n, rfl⟩ := hy + change (z : Surreal) < ((n + 1 : ℝ)⁻¹) • a + by_cases hz0 : (z : Surreal) = 0 + · rw [hz0, real_smul_def] + exact mul_pos (Real.toSurreal_pos_iff.mpr (inv_pos.mpr (by positivity))) ha + have hzclass : + (FiniteArchimedeanClass.mk a ha.ne').val < ArchimedeanClass.mk (z : Surreal) := + (FiniteArchimedeanClass.mem_ball_iff ℝ).mp z.property hz0 + apply ArchimedeanClass.lt_of_mk_lt_mk_of_nonneg + · rw [ArchimedeanClass.mk_smul _ (inv_ne_zero (by positivity))] + exact hzclass + · exact smul_nonneg (inv_nonneg.mpr (by positivity)) ha.le + let y : Surreal.{u} := !{L | R}' hLR + have hypos : 0 < y := + Surreal.lt_ofSets_of_mem_left (show 0 ∈ L by simp [L]) + have hyright (n : ℕ) : y < ((n + 1 : ℝ)⁻¹) • a := + Surreal.ofSets_lt_of_mem_right + (show ((n + 1 : ℝ)⁻¹) • a ∈ R by exact Set.mem_range_self n) + have hyball : y ∈ ball ℝ (FiniteArchimedeanClass.mk a ha.ne') := by + rw [FiniteArchimedeanClass.mem_ball_iff] + intro hy0 + rw [FiniteArchimedeanClass.mk_lt_mk ha.ne' hy0, ArchimedeanClass.mk_lt_mk] + intro n + rw [abs_of_pos hypos, abs_of_pos ha] + obtain rfl | hn := n.eq_zero_or_pos + · simpa using ha + · have hbound := hyright (n - 1) + have hcast : (((n - 1 : ℕ) : ℝ) + 1) = n := by + exact_mod_cast Nat.sub_add_cancel hn + rw [hcast, real_smul_def] at hbound + have hnSurreal : (0 : Surreal) < n := by exact_mod_cast hn + have hmul := mul_lt_mul_of_pos_left hbound hnSurreal + simpa [mul_assoc, hn.ne'] using hmul + rw [not_isCofinal_iff] + exact ⟨⟨y, hyball⟩, fun z hz ↦ by + apply Surreal.lt_ofSets_of_mem_left + exact Set.mem_union_right _ (Set.mem_image_of_mem _ hz)⟩ + +/-- Every nonzero surreal Archimedean ball has cofinality at least the small-support cardinal. +This is the universe-bounded form of LM24, Proposition 2.4.4. -/ +@[blueprint "fact:surreal-archimedean-ball-cofinality" + (phase := "Surreal numbers and omnific integers") + (title := "Cofinality of surreal Archimedean balls") + (statement := /-- + Fix a universe $u$, let $\kappa_u$ be its universe cardinal, and let $c$ be + a nonzero Archimedean class of $\mathbf{No}_u$. The strict Archimedean ball + below $c$ has cofinality at least $\kappa_u$ + \cite[Proposition~2.4.4]{LM24}. + -/) + (proof := /-- + A cofinal subset of cardinality below $\kappa_u$ is $u$-small. Conway's + cut construction gives a surreal number above that subset but still below + every positive rational multiple of a representative of $c$, contradicting + cofinality. + -/)] +theorem smallSupportCardinal_le_ball_cof (c : FiniteArchimedeanClass Surreal.{u}) : + smallSupportCardinal.{u} ≤ Order.cof ↥(ball ℝ c) := by + induction c using FiniteArchimedeanClass.ind with + | mk a ha => + have hc : FiniteArchimedeanClass.mk |a| (abs_ne_zero.mpr ha) = + FiniteArchimedeanClass.mk a ha := by + apply Subtype.ext + exact ArchimedeanClass.mk_abs a + rw [← hc, Order.le_cof_iff] + intro s hs + by_contra hcard + have hsSmall : Small.{u} s := by + rw [Cardinal.small_iff_lift_mk_lt_univ] + simpa [smallSupportCardinal] using (not_le.mp hcard) + let : Small.{u} s := hsSmall + exact ball_not_isCofinal_of_small (a := |a|) (abs_pos.mpr ha) s hs + +/-- The common tail of a small limit family of surreal Archimedean classes has cofinality at +least the surreal support cardinal. -/ +@[blueprint "lem:surreal-common-tail-cofinality" + (phase := "Surreal numbers and omnific integers") + (title := "Cofinality of common surreal Archimedean tails") + (statement := /-- + Fix a universe $u$, let $\kappa_u$ be its universe cardinal, and let $T$ be + a $u$-small family of nonzero Archimedean classes with no least member in + the magnitude order. The common tail below $T$ has cofinality at least + $\kappa_u$. + -/) + (proof := /-- + If a $u$-small subset were cofinal in the common tail, form a Conway cut + above it and below the positive rational fractions of representatives of + the classes in $T$. The resulting surreal belongs to the common tail but + is above the proposed cofinal subset. + -/)] +theorem smallSupportCardinal_le_tailSubmodule_cof + (T : Set (FiniteArchimedeanClass Surreal.{u})) [Small.{u} T] + (hT : ∀ c ∈ T, ∃ d ∈ T, c < d) : + smallSupportCardinal.{u} ≤ Order.cof ↥(FiniteArchimedeanClass.tailSubmodule ℚ T) := by + rw [Order.le_cof_iff] + intro s hs + by_contra hcard + have hsSmall : Small.{u} s := by + rw [Cardinal.small_iff_lift_mk_lt_univ] + simpa [smallSupportCardinal] using (not_le.mp hcard) + let : Small.{u} s := hsSmall + let L : Set Surreal.{u} := {0} ∪ + ((↑) : ↥(FiniteArchimedeanClass.tailSubmodule ℚ T) → Surreal.{u}) '' s + let R : Set Surreal.{u} := Set.range fun p : T × ℕ ↦ + ((p.2 + 1 : ℝ)⁻¹) • FiniteArchimedeanClass.positiveRepresentative p.1.1 + have hLR : ∀ x ∈ L, ∀ y ∈ R, x < y := by + intro x hx y hy + obtain rfl | ⟨z, hz, rfl⟩ := hx + · obtain ⟨⟨c, n⟩, rfl⟩ := hy + dsimp only + rw [real_smul_def] + exact mul_pos (Real.toSurreal_pos_iff.mpr (inv_pos.mpr (by positivity))) + (FiniteArchimedeanClass.positiveRepresentative_pos c.1) + · obtain ⟨⟨c, n⟩, rfl⟩ := hy + by_cases hz0 : (z : Surreal) = 0 + · rw [hz0] + dsimp only + rw [real_smul_def] + exact mul_pos (Real.toSurreal_pos_iff.mpr (inv_pos.mpr (by positivity))) + (FiniteArchimedeanClass.positiveRepresentative_pos c.1) + obtain ⟨d, hdT, hcd⟩ := hT c.1 c.2 + have hzTail : (z : Surreal) ∈ FiniteArchimedeanClass.tailKernel T := by + exact (FiniteArchimedeanClass.mem_tailSubmodule_iff (K := ℚ)).mp z.2 + have hdz : d.1 ≤ ArchimedeanClass.mk (z : Surreal) := + FiniteArchimedeanClass.mem_tailKernel_iff.mp hzTail ⟨d, hdT⟩ + have hcz : c.1.1 < ArchimedeanClass.mk (z : Surreal) := + (show c.1.1 < d.1 from hcd).trans_le hdz + rcases le_total (z : Surreal) 0 with hzneg | hznonneg + · dsimp only + rw [real_smul_def] + exact hzneg.trans_lt (mul_pos + (Real.toSurreal_pos_iff.mpr (inv_pos.mpr (by positivity))) + (FiniteArchimedeanClass.positiveRepresentative_pos c.1)) + · apply ArchimedeanClass.lt_of_mk_lt_mk_of_nonneg + · dsimp only + rw [ArchimedeanClass.mk_smul _ (inv_ne_zero (by positivity)), + FiniteArchimedeanClass.mk_positiveRepresentative] + exact hcz + · exact smul_nonneg (inv_nonneg.mpr (by positivity)) + (FiniteArchimedeanClass.positiveRepresentative_pos c.1).le + let y : Surreal.{u} := !{L | R}' hLR + have hypos : 0 < y := Surreal.lt_ofSets_of_mem_left (show 0 ∈ L by simp [L]) + have hyright (c : T) (n : ℕ) : + y < ((n + 1 : ℝ)⁻¹) • FiniteArchimedeanClass.positiveRepresentative c.1 := + Surreal.ofSets_lt_of_mem_right + (show ((n + 1 : ℝ)⁻¹) • FiniteArchimedeanClass.positiveRepresentative c.1 ∈ R by + exact Set.mem_range_self (c, n)) + have hyTail : y ∈ FiniteArchimedeanClass.tailSubmodule ℚ T := by + rw [FiniteArchimedeanClass.mem_tailSubmodule_iff, + FiniteArchimedeanClass.mem_tailKernel_iff] + intro c + obtain ⟨d, hdT, hcd⟩ := hT c.1 c.2 + apply (show c.1.1 < d.1 from hcd).le.trans + rw [← FiniteArchimedeanClass.mk_positiveRepresentative d] + rw [ArchimedeanClass.mk_le_mk] + refine ⟨1, ?_⟩ + rw [abs_of_pos (FiniteArchimedeanClass.positiveRepresentative_pos d), abs_of_pos hypos] + simpa using (hyright ⟨d, hdT⟩ 0).le + exact (not_isCofinal_iff.mpr ⟨⟨y, hyTail⟩, fun z hz ↦ by + apply Surreal.lt_ofSets_of_mem_left + exact Set.mem_union_right _ (Set.mem_image_of_mem _ hz)⟩) hs + +/-- The bounded integer part on a surreal common tail generates its whole bounded Hahn field. -/ +@[blueprint "thm:surreal-common-tail-integer-part-fraction-field" + (phase := "Surreal numbers and omnific integers") + (title := "Fraction fields of surreal common-tail integer parts") + (statement := /-- + Let $T$ be a $u$-small family of nonzero Archimedean classes of + $\mathbf{No}_u$ with no least member in the magnitude order, and let $H_T$ + be the common tail below $T$. For every field $R$ and subring + $Z\subseteq R$, the bounded Hahn field $R((H_T))_{\kappa_u}$ is the + fraction field of $Z+R((H_T^{<0}))_{\kappa_u}$. + -/) + (proof := /-- + By \ref{lem:surreal-common-tail-cofinality}, + $\kappa_u\leq\operatorname{cof}(H_T)$. Therefore + \ref{thm:bounded-hahn-integer-part-fraction-field} applies to $H_T$. + -/)] +theorem fracSubring_cardSuppLTTruncationIntegerPart_tailSubmodule_eq_top + {R : Type v} [Field R] (Z : Subring R) + (T : Set (FiniteArchimedeanClass Surreal.{u})) [Small.{u} T] + (hT : ∀ c ∈ T, ∃ d ∈ T, c < d) : + Subring.fracSubring (HahnSeries.cardSuppLTTruncationIntegerPart + (G := FiniteArchimedeanClass.tailSubmodule ℚ T) (R := R) + (κ := smallSupportCardinal.{u}) Z) = ⊤ := + HahnSeries.fracSubring_cardSuppLTTruncationIntegerPart_eq_top_of_le_cof Z + (smallSupportCardinal_le_tailSubmodule_cof T hT) + +/-- Every nonzero surreal Archimedean class satisfies LM24 assumption `(A2)_σ` at the cardinal +that bounds surreal Hahn supports. -/ +theorem assumptionA2AtFiniteClass + {R : Type v} [Field R] (Z : Subring R) + (c : FiniteArchimedeanClass Surreal.{u}) : + LM24.AssumptionA2AtFiniteClass (K := ℝ) smallSupportCardinal.{u} Z c := by + rw [LM24.assumptionA2AtFiniteClass_iff] + exact Or.inl (smallSupportCardinal_le_ball_cof c) + +/-- Every surreal Archimedean class, including the zero class, satisfies LM24 assumption +`(A2)_σ` at the cardinal that bounds surreal Hahn supports. -/ +theorem assumptionA2 + {R : Type v} [Field R] (Z : Subring R) (σ : ArchimedeanClass Surreal.{u}) : + LM24.AssumptionA2 smallSupportCardinal.{u} Z σ := by + rw [LM24.assumptionA2_iff] + by_cases hσ : σ = ⊤ + · exact Or.inr (Or.inr hσ) + · let c : FiniteArchimedeanClass Surreal := ⟨σ, hσ⟩ + have hball : (ball ℝ c : Set Surreal) = σ.ballAddSubgroup := by + change ((ball ℝ c).toAddSubgroup : Set Surreal) = σ.ballAddSubgroup + rw [FiniteArchimedeanClass.toAddSubgroup_ball] + ext x + rw [SetLike.mem_coe, SetLike.mem_coe, + FiniteArchimedeanClass.mem_ballAddSubgroup_iff, + ArchimedeanClass.mem_ballAddSubgroup_iff hσ] + by_cases hx : x = 0 + · subst x + constructor + · intro _ + exact lt_top_iff_ne_top.mpr hσ + · intro _ hzero + exact (hzero rfl).elim + · exact ⟨fun h ↦ h hx, fun h _ ↦ h⟩ + let e : ↥(ball ℝ c) ≃o ↥σ.ballAddSubgroup := + Set.orderIsoOfEq _ _ hball + exact Or.inl (by + rw [← e.cof_congr] + exact smallSupportCardinal_le_ball_cof c) + +end Surreal diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/Cardinal.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/Cardinal.lean new file mode 100644 index 0000000000..a530867245 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/Cardinal.lean @@ -0,0 +1,37 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.CombinatorialGames.Surreal.Basic +public import LeanPool.ConwayRefinement.CombinatorialGames.Surreal.Ordinal +public import Mathlib.SetTheory.Ordinal.Family +public import Mathlib.Logic.Small.Defs + +/-! +# The size of surreal numbers + +The surreal numbers with option sets in universe `u` do not admit an equivalent type in universe +`u`. They contain an injective image of all ordinals in that universe. This certifies the size of +the values, not merely the size of their representations. + +This result is relative to the option-set universe. It does not construct a set-theoretic class +model or identify models across universe levels. +-/ + +universe u + +public section + +namespace Surreal + +/-- Surreal numbers with option sets in universe `u` are not `u`-small. -/ +theorem not_small : ¬Small.{u} Surreal.{u} := by + intro h + let : Small.{u} Surreal.{u} := h + exact not_injective_of_ordinal (fun o : Ordinal.{u} ↦ (NatOrdinal.of o).toSurreal) + (NatOrdinal.toSurreal.injective.comp NatOrdinal.of.injective) + +end Surreal diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/CutFilling.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/CutFilling.lean new file mode 100644 index 0000000000..70d713e985 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/CutFilling.lean @@ -0,0 +1,125 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.CombinatorialGames.Surreal.Basic +public import LeanPool.ConwayRefinement.CombinatorialGames.Surreal.Division +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Order.ConvexQuotient +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Order.ArchimedeanQuotient +public import LeanPool.ConwayRefinement.ConwayRefinement.Topology.Order.CoinitialComplete + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint + +/-! +# The surreals fill cuts between small families + +Between any two small families of surreals separated by the order there is a surreal, namely the +one born from those families as its option sets. This is the simplicity theorem in the form the +completeness criterion of `ConwayRefinement.Topology.Order.CoinitialComplete` +consumes, and it is restricted to *small* families for the reason that makes the restriction +essential rather than +technical: a surreal has a set of options, so no construction reaches across a family the size of +the ordinals. + +That restriction is exactly why the surreals themselves are not Cauchy complete — the positive +surreals have no small coinitial family, so a Cauchy filter can outrun every small cut — and why +the route to a complete group runs through a quotient. `FillsCuts.of_surjective` carries the +conclusion below to such a quotient; supplying the small coinitial family there is separate work. +-/ + +universe u + +public section + +namespace Surreal + +/-- **The simplicity theorem for small cuts.** Two small sets of surreals with every member of the +first below every member of the second are strictly separated by a surreal. -/ +@[blueprint "thm:surreal-simplicity-small-cuts" + (phase := "Surreal numbers and omnific integers") + (title := "The simplicity theorem for small cuts") + (statement := /-- + Let $L,R\subseteq\mathbf{No}_u$ be small sets. If $l`, because its exponent is the exponent of +`ω`, rather than the exponent of LM24's variable `t = ω⁻¹`. Its upstream `length` is therefore +the ordinary order type relevant to LM24 after this sign reversal. It also uses `Shrink` to place +the order type in `Ordinal.{u}`; `SurrealHahnSeries.type_support` identifies its lift with the +unrestricted order type of the support in `Ordinal.{u+1}`. + +This file defines degree from that already validated order type. The explicit finite-support +theorem below checks that the universe lowering preserves the source's zero-degree convention. +-/ + +universe u + +public noncomputable section + +namespace SurrealHahnSeries + +open Ordinal + +/-- `deg(ot(b))`, the Cantor degree of `ot(b)`, the order type of the support of a surreal Hahn +series `b` (the upstream `length`); the value at zero is `⊥`. -/ +def supportDegree (x : SurrealHahnSeries.{u}) : WithBot NatOrdinal.{u} := + Ordinal.cantorDegree x.length + +/-- Degree is the leading Cantor exponent of the small support order type. -/ +theorem supportDegree_eq_cantorDegree (x : SurrealHahnSeries.{u}) : + supportDegree x = Ordinal.cantorDegree x.length := + (rfl) + +@[simp] +theorem supportDegree_eq_bot {x : SurrealHahnSeries.{u}} : supportDegree x = ⊥ ↔ x = 0 := by + rw [supportDegree, Ordinal.cantorDegree_eq_bot, length_eq_zero] + +@[simp] +theorem supportDegree_zero : supportDegree (0 : SurrealHahnSeries.{u}) = ⊥ := + supportDegree_eq_bot.mpr rfl + +/-- A surreal Hahn series has finite support exactly when its small order type is below `ω`. -/ +theorem support_finite_iff_length_lt_omega {x : SurrealHahnSeries.{u}} : + x.support.Finite ↔ x.length < (Ordinal.omega0 : Ordinal.{u}) := by + rw [Set.Finite, ← Cardinal.mk_lt_aleph0_iff] + rw [← Ordinal.card_type (· > ·), type_support, Ordinal.card_lt_aleph0] + rw [← (Ordinal.lift_omega0 : + Ordinal.lift.{u + 1, u} (Ordinal.omega0 : Ordinal.{u}) = Ordinal.omega0), + Ordinal.lift_lt] + +/-- Degree zero is equivalent to nonzero finite support. -/ +@[simp] +theorem supportDegree_eq_zero {x : SurrealHahnSeries.{u}} : + supportDegree x = (0 : WithBot NatOrdinal) ↔ x ≠ 0 ∧ x.support.Finite := by + rw [supportDegree, Ordinal.cantorDegree_eq_zero] + constructor + · rintro ⟨hlength, hlt⟩ + exact ⟨length_eq_zero.not.mp hlength, support_finite_iff_length_lt_omega.mpr hlt⟩ + · rintro ⟨hx, hfinite⟩ + exact ⟨length_eq_zero.not.mpr hx, support_finite_iff_length_lt_omega.mp hfinite⟩ + +/-- This is LM24's maximum characterization of degree in the small support universe. -/ +theorem coe_le_supportDegree_iff {x : SurrealHahnSeries.{u}} {a : Ordinal.{u}} (hx : x ≠ 0) : + (NatOrdinal.of a : WithBot NatOrdinal) ≤ supportDegree x ↔ ω ^ a ≤ x.length := by + exact Ordinal.coe_le_cantorDegree_iff (length_eq_zero.not.mpr hx) + +end SurrealHahnSeries diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/HahnSeries/DegreeTransfer.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/HahnSeries/DegreeTransfer.lean new file mode 100644 index 0000000000..d8b12ac916 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/HahnSeries/DegreeTransfer.lean @@ -0,0 +1,99 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrderType +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.HahnSeries.Full +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.HahnSeries.Degree + +import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.Degree + +/-! +# Degree of Conway normal forms in the full Hahn field + +This module identifies the support order type used by LM24 with `ot(b)`, the order type of the +support of a Conway normal form `b` (the upstream `length`). The full Hahn exponent is +`Surrealᵒᵈ`, so its increasing support order is exactly the decreasing Conway-exponent order. The +only universe adjustment is the lift already recorded by `SurrealHahnSeries.type_support`. + +Consequently, the surreal degree is the Cantor degree of the support order type of the full Hahn +image — the finite-degree paper's extension of LM24's degree to Conway's series, not a notion of +LM24 (Remark 3.4.4). It lies below `ω` exactly when the support order type of the normal form lies +below `ω ^ ω`, which is how the omnific-integer theorem states its hypothesis. +-/ + +universe u + +public noncomputable section + +namespace Surreal + +private def fullSupportRelIso (x : Surreal.{u}) : + Subrel (fun a b : Surrealᵒᵈ ↦ a < b) (· ∈ x.toFullHahnSeries.support) ≃r + (fun a b : x.toHahnSeries.support ↦ a > b) where + toFun i := ⟨i.1.ofDual, by + simpa only [support_toHahnSeries] using + mem_support_toFullHahnSeries.mp i.2⟩ + invFun i := ⟨OrderDual.toDual i.1, by + apply mem_support_toFullHahnSeries.mpr + simpa only [OrderDual.ofDual_toDual, support_toHahnSeries] using i.2⟩ + left_inv i := by + apply Subtype.ext + simp + right_inv i := by + apply Subtype.ext + simp + map_rel_iff' := by + intro i j + rfl + +/-- The full Hahn support order type is the lift of `ot(b)`, the order type of the support of the +Conway normal form. -/ +theorem supportOrderType_toFullHahnSeries (x : Surreal.{u}) : + x.toFullHahnSeries.supportOrderType = + Ordinal.lift.{u + 1, u} x.length := by + rw [HahnSeries.supportOrderType_eq_type_of_relIso (fullSupportRelIso x)] + rw [← length_toHahnSeries] + exact SurrealHahnSeries.type_support x.toHahnSeries + +/-- `deg(ot(b))`, the Cantor degree of `ot(b)`, the order type of the support of the Conway normal +form of a surreal `b`, lifted one universe. -/ +def supportDegree (x : Surreal.{u}) : WithBot NatOrdinal.{u + 1} := + Ordinal.cantorDegree (Ordinal.lift.{u + 1, u} x.length) + +/-- Surreal degree is the Cantor degree of the lifted `ot(b)`. -/ +theorem supportDegree_eq_cantorDegree_lift_length (x : Surreal.{u}) : + x.supportDegree = Ordinal.cantorDegree (Ordinal.lift.{u + 1, u} x.length) := + (rfl) + +/-- Passing to the full Conway Hahn series preserves degree exactly. -/ +@[simp] +theorem supportDegree_toFullHahnSeries (x : Surreal.{u}) : + x.toFullHahnSeries.degree = x.supportDegree := by + rw [HahnSeries.degree_eq_cantorDegree, + supportOrderType_toFullHahnSeries, supportDegree_eq_cantorDegree_lift_length] + +/-- A surreal has bottom degree exactly when it is zero. -/ +@[simp] +theorem supportDegree_eq_bot {x : Surreal.{u}} : x.supportDegree = ⊥ ↔ x = 0 := by + rw [← supportDegree_toFullHahnSeries, HahnSeries.degree_eq_bot] + constructor + · intro hx + apply toFullHahnSeries_injective + rw [hx, toFullHahnSeries_zero] + · rintro rfl + exact toFullHahnSeries_zero + +/-- A Conway normal form `b` has degree below `ω` exactly when `ot(b)`, the order type of its +support, lies below `ω ^ ω`. -/ +theorem supportDegree_lt_omega_iff_length_lt_omega0_opow_omega0 (x : Surreal.{u}) : + x.supportDegree < (NatOrdinal.of Ordinal.omega0 : WithBot NatOrdinal) ↔ + x.length < Ordinal.omega0 ^ Ordinal.omega0 := by + rw [← supportDegree_toFullHahnSeries, HahnSeries.degree_lt_coe_iff_supportOrderType_lt_wpow, + supportOrderType_toFullHahnSeries, NatOrdinal.val_wpow, NatOrdinal.val_of, + ← Ordinal.lift_omega0_opow_omega0.{u + 1, u}, Ordinal.lift_lt] + +end Surreal diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/HahnSeries/Full.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/HahnSeries/Full.lean new file mode 100644 index 0000000000..efc81e2939 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/HahnSeries/Full.lean @@ -0,0 +1,245 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import Mathlib.RingTheory.HahnSeries.Multiplication +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.HahnSeries.NormalFormMul + +import all LeanPool.ConwayRefinement.CombinatorialGames.Surreal.HahnSeries.Basic + +/-! +# Conway normal forms in the full Hahn field + +The Conway coefficients of a surreal number determine a Hahn series in +`ℝ⟦Surrealᵒᵈ⟧`. The order dual implements LM24's change from Conway's monomial `ω` to +`t = ω⁻¹`: nonnegative Conway exponents become nonpositive Hahn exponents. + +This map preserves the full ring structure. +-/ + +universe u + +public noncomputable section + +namespace Surreal + +/-- The full Hahn series with the Conway coefficients of a surreal number. -/ +def toFullHahnSeries (x : Surreal.{u}) : HahnSeries Surrealᵒᵈ ℝ where + coeff i := x.coeff i.ofDual + isPWO_support' := by + rw [Set.isPWO_iff_isWF] + apply Set.WellFoundedOn.mapsTo (fun i : Surrealᵒᵈ ↦ i.ofDual) _ + x.wellFoundedOn_support + intro i hi + rw [mem_support_iff] + exact hi + +/-- Evaluation of the full Conway Hahn series. -/ +@[simp] +theorem coeff_toFullHahnSeries (x : Surreal.{u}) (i : Surrealᵒᵈ) : + x.toFullHahnSeries.coeff i = x.coeff i.ofDual := + (rfl) + +/-- The support of the full Conway Hahn series is the order dual of the Conway support. -/ +theorem mem_support_toFullHahnSeries {x : Surreal.{u}} {i : Surrealᵒᵈ} : + i ∈ x.toFullHahnSeries.support ↔ i.ofDual ∈ x.support := by + rw [HahnSeries.mem_support x.toFullHahnSeries i, coeff_toFullHahnSeries, + mem_support_iff] + +/-- The full Conway Hahn-series map sends zero to zero. -/ +@[simp] +theorem toFullHahnSeries_zero : (0 : Surreal.{u}).toFullHahnSeries = 0 := by + ext i + rw [coeff_toFullHahnSeries, HahnSeries.coeff_zero] + exact congrFun coeff_zero i.ofDual + +/-- The full Conway Hahn-series map preserves addition. -/ +@[simp] +theorem toFullHahnSeries_add (x y : Surreal.{u}) : + (x + y).toFullHahnSeries = x.toFullHahnSeries + y.toFullHahnSeries := by + ext i + rw [coeff_toFullHahnSeries, HahnSeries.coeff_add, coeff_toFullHahnSeries, + coeff_toFullHahnSeries] + exact congrFun (coeff_add x y) i.ofDual + +/-- The full Conway Hahn-series map preserves negation. -/ +@[simp] +theorem toFullHahnSeries_neg (x : Surreal.{u}) : + (-x).toFullHahnSeries = -x.toFullHahnSeries := by + ext i + rw [coeff_toFullHahnSeries, HahnSeries.coeff_neg, coeff_toFullHahnSeries] + exact congrFun (coeff_neg x) i.ofDual + +/-- The full Conway Hahn-series map as an additive homomorphism. -/ +def toFullHahnSeriesAddMonoidHom : + Surreal.{u} →+ HahnSeries Surrealᵒᵈ ℝ where + toFun := toFullHahnSeries + map_zero' := toFullHahnSeries_zero + map_add' := toFullHahnSeries_add + +/-- Evaluation of the additive full Conway Hahn-series homomorphism. -/ +@[simp] +theorem toFullHahnSeriesAddMonoidHom_apply (x : Surreal.{u}) : + toFullHahnSeriesAddMonoidHom x = x.toFullHahnSeries := + (rfl) + +/-- The additive full Conway Hahn-series map is injective. -/ +theorem toFullHahnSeries_injective : + Function.Injective (toFullHahnSeries : Surreal.{u} → HahnSeries Surrealᵒᵈ ℝ) := by + intro x y hxy + rw [← toHahnSeries_inj] + apply SurrealHahnSeries.ext + funext i + have hcoeff := congrArg (fun q : HahnSeries Surrealᵒᵈ ℝ ↦ + q.coeff (OrderDual.toDual i)) hxy + simpa only [coeff_toFullHahnSeries, OrderDual.ofDual_toDual, + coeff_toHahnSeries] using hcoeff + +private theorem toFullHahnSeries_eq_ofLex_toHahnSeries (x : Surreal.{u}) : + x.toFullHahnSeries = ofLex x.toHahnSeries.1 := by + ext i + rw [coeff_toFullHahnSeries, ← coeff_toHahnSeries] + rfl + +private theorem ofLex_coe_mul (x y : SurrealHahnSeries.{u}) : + ofLex (x * y).1 = ofLex x.1 * ofLex y.1 := by + with_unfolding_all rfl + +/-- The full Conway Hahn-series map preserves arbitrary surreal products. -/ +@[simp] +theorem toFullHahnSeries_mul (x y : Surreal.{u}) : + (x * y).toFullHahnSeries = x.toFullHahnSeries * y.toFullHahnSeries := by + calc + (x * y).toFullHahnSeries = ofLex (x * y).toHahnSeries.1 := + toFullHahnSeries_eq_ofLex_toHahnSeries (x * y) + _ = ofLex (x.toHahnSeries * y.toHahnSeries).1 := by + rw [toHahnSeries_mul] + _ = ofLex x.toHahnSeries.1 * ofLex y.toHahnSeries.1 := + ofLex_coe_mul x.toHahnSeries y.toHahnSeries + _ = x.toFullHahnSeries * y.toFullHahnSeries := by + rw [← toFullHahnSeries_eq_ofLex_toHahnSeries, + ← toFullHahnSeries_eq_ofLex_toHahnSeries] + +/-- The full Conway Hahn series of a real is concentrated at exponent zero. -/ +@[simp] +theorem toFullHahnSeries_realCast (r : ℝ) : + toFullHahnSeries (r : Surreal.{u}) = HahnSeries.single 0 r := by + ext i + rw [coeff_toFullHahnSeries, HahnSeries.coeff_single] + have hcoeff : (r : Surreal.{u}).coeff = Pi.single 0 r := by + rw [← coeff_toHahnSeries, toHahnSeries_realCast, + SurrealHahnSeries.coeff_single] + rw [hcoeff] + by_cases hi : i = 0 + · subst i + simp + · have hi' : i.ofDual ≠ 0 := by + exact fun h ↦ hi (by simpa using congrArg OrderDual.toDual h) + simp [hi, hi'] + +/-- The full Conway Hahn series of `ω ^ x` is its corresponding monomial. -/ +@[simp] +theorem toFullHahnSeries_wpow (x : Surreal.{u}) : + toFullHahnSeries (ω^ x) = HahnSeries.single (OrderDual.toDual x) 1 := by + ext i + rw [coeff_toFullHahnSeries, coeff_wpow, HahnSeries.coeff_single] + by_cases hi : i = OrderDual.toDual x + · subst i + simp + · have hi' : i.ofDual ≠ x := by + exact fun h ↦ hi (by simpa using congrArg OrderDual.toDual h) + simp [hi, hi'] + +/-- A real scalar times a Conway monomial becomes the corresponding full Hahn monomial. -/ +theorem toFullHahnSeries_realCast_mul_wpow (r : ℝ) (i : Surreal.{u}) : + toFullHahnSeries ((r : Surreal) * ω^ i) = + HahnSeries.single (OrderDual.toDual i) r := by + have hcoeff : ((r : Surreal) * ω^ i).coeff = Pi.single i r := by + rw [← coeff_toHahnSeries] + have hnormal : + toHahnSeries ((r : Surreal) * ω^ i) = SurrealHahnSeries.single i r := by + rw [← SurrealHahnSeries.toSurreal_single i r, + SurrealHahnSeries.toHahnSeries_toSurreal] + rw [hnormal, SurrealHahnSeries.coeff_single] + ext j + rw [coeff_toFullHahnSeries, hcoeff, HahnSeries.coeff_single] + by_cases hj : j = OrderDual.toDual i + · subst j + simp + · have hj' : j.ofDual ≠ i := by + exact fun h ↦ hj (by simpa using congrArg OrderDual.toDual h) + simp [hj, hj'] + +/-- A surreal number with finite Conway support is the finite sum of its nonzero Conway +monomials. -/ +theorem eq_sum_coeff_mul_wpow_of_support_finite {x : Surreal.{u}} + (hx : x.support.Finite) : + x = ∑ i ∈ hx.toFinset, (x.coeff i : Surreal) * ω^ i := by + apply toFullHahnSeries_injective + rw [← toFullHahnSeriesAddMonoidHom_apply x, + ← toFullHahnSeriesAddMonoidHom_apply (∑ i ∈ hx.toFinset, + (x.coeff i : Surreal) * ω^ i)] + rw [map_sum] + simp_rw [toFullHahnSeriesAddMonoidHom_apply, + toFullHahnSeries_realCast_mul_wpow] + ext j + rw [coeff_toFullHahnSeries, HahnSeries.coeff_sum] + by_cases hj : j.ofDual ∈ x.support + · rw [Finset.sum_eq_single j.ofDual] + · simp + · intro b hb hne + rw [HahnSeries.coeff_single_of_ne] + exact fun h ↦ hne (by simpa using (congrArg OrderDual.ofDual h).symm) + · exact fun hnot ↦ (hnot (hx.mem_toFinset.mpr hj)).elim + · rw [Finset.sum_eq_zero] + · exact notMem_support_iff.mp hj + · intro b hb + rw [HahnSeries.coeff_single_of_ne] + exact fun h ↦ hj (by + have hb' : b ∈ x.support := hx.mem_toFinset.mp hb + simpa [h] using hb') + +/-- The full Conway Hahn-series map preserves the product of two real scalar monomials. -/ +theorem toFullHahnSeries_mul_monomials (r s : ℝ) (i j : Surreal.{u}) : + toFullHahnSeries + (((r : Surreal) * ω^ i) * ((s : Surreal) * ω^ j)) = + toFullHahnSeries ((r : Surreal) * ω^ i) * + toFullHahnSeries ((s : Surreal) * ω^ j) := by + have hprod : + ((r : Surreal) * ω^ i) * ((s : Surreal) * ω^ j) = + ((r * s : ℝ) : Surreal) * ω^ (i + j) := by + rw [wpow_add, Real.toSurreal_mul] + ring + rw [hprod, toFullHahnSeries_realCast_mul_wpow, + toFullHahnSeries_realCast_mul_wpow, + toFullHahnSeries_realCast_mul_wpow, HahnSeries.single_mul_single] + rfl + +/-- The full Conway Hahn-series map preserves multiplication when both Conway supports are +finite. -/ +theorem toFullHahnSeries_mul_of_support_finite {x y : Surreal.{u}} + (hx : x.support.Finite) (hy : y.support.Finite) : + toFullHahnSeries (x * y) = toFullHahnSeries x * toFullHahnSeries y := by + rw [eq_sum_coeff_mul_wpow_of_support_finite hx, + eq_sum_coeff_mul_wpow_of_support_finite hy] + let f (i : Surreal.{u}) := (x.coeff i : Surreal) * ω^ i + let g (j : Surreal.{u}) := (y.coeff j : Surreal) * ω^ j + change toFullHahnSeries ((∑ i ∈ hx.toFinset, f i) * + (∑ j ∈ hy.toFinset, g j)) = + toFullHahnSeries (∑ i ∈ hx.toFinset, f i) * + toFullHahnSeries (∑ j ∈ hy.toFinset, g j) + rw [Finset.sum_mul] + simp_rw [Finset.mul_sum] + rw [← toFullHahnSeriesAddMonoidHom_apply, map_sum] + simp_rw [toFullHahnSeriesAddMonoidHom_apply] + simp_rw [← toFullHahnSeriesAddMonoidHom_apply, + map_sum, toFullHahnSeriesAddMonoidHom_apply] + dsimp only [f, g] + simp_rw [toFullHahnSeries_mul_monomials] + rw [Finset.sum_mul] + simp_rw [Finset.mul_sum] + +end Surreal diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/HahnSeries/IntegerPart.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/HahnSeries/IntegerPart.lean new file mode 100644 index 0000000000..2cc66bf8fa --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/HahnSeries/IntegerPart.lean @@ -0,0 +1,159 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Nonpositive +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.HahnSeries.Full +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.OmnificInteger.NormalForm + +/-! +# Omnific integers in the nonpositive Hahn integer part + +This module packages Conway's normal-form characterization into LM24's Hahn-series orientation. +The order dual implements `t = ω⁻¹`, so a nonnegative Conway exponent becomes a nonpositive +Hahn exponent. The coefficient at exponent zero lands in the image of `ℤ → ℝ`. + +The resulting map is an injective ring map. +-/ + +universe u + +public noncomputable section + +namespace Surreal + +/-- The copy of the integers inside the real coefficient field. -/ +def realIntegerSubring : Subring ℝ := + (Int.castRingHom ℝ).range + +/-- The integer coefficient subring of the reals is isomorphic to `ℤ`. -/ +noncomputable def realIntegerSubringEquiv : ℤ ≃+* realIntegerSubring := + RingEquiv.ofBijective (Int.castRingHom ℝ).rangeRestrict + ⟨Int.cast_injective, RingHom.rangeRestrict_surjective _⟩ + +/-- The integer coefficient subring of the reals is pre-Schreier. -/ +noncomputable instance instDecompositionMonoidRealIntegerSubring : + DecompositionMonoid realIntegerSubring := + MulEquiv.decompositionMonoid realIntegerSubringEquiv.symm.toMulEquiv + +/-- Membership in the real integer coefficient subring. -/ +@[simp] +theorem mem_realIntegerSubring {r : ℝ} : + r ∈ realIntegerSubring ↔ r ∈ Set.range ((↑) : ℤ → ℝ) := + Iff.rfl + +namespace OmnificInteger + +/-- The nonpositive full Hahn series underlying an omnific integer. -/ +def toNonpositiveHahn (x : OmnificInteger.{u}) : + HahnSeries.Nonpositive Surrealᵒᵈ ℝ := + ⟨toFullHahnSeries x.1, fun i hi ↦ by + have hsupport := (isOmnificInteger_iff_normalForm.mp + (mem_omnificIntegers.mp x.2)).1 + exact hsupport (mem_support_toFullHahnSeries.mp hi)⟩ + +/-- Coercing the nonpositive Hahn image recovers the full Conway Hahn series. -/ +@[simp] +theorem coe_toNonpositiveHahn (x : OmnificInteger.{u}) : + (x.toNonpositiveHahn : HahnSeries Surrealᵒᵈ ℝ) = toFullHahnSeries x.1 := + (rfl) + +/-- The nonpositive Hahn image of omnific integers as an additive homomorphism. -/ +def toNonpositiveHahnAddMonoidHom : + OmnificInteger.{u} →+ HahnSeries.Nonpositive Surrealᵒᵈ ℝ where + toFun := toNonpositiveHahn + map_zero' := by + apply Subtype.ext + exact toFullHahnSeries_zero + map_add' x y := by + apply Subtype.ext + exact toFullHahnSeries_add x.1 y.1 + +/-- Evaluation of the additive nonpositive Hahn map. -/ +@[simp] +theorem toNonpositiveHahnAddMonoidHom_apply (x : OmnificInteger.{u}) : + toNonpositiveHahnAddMonoidHom x = x.toNonpositiveHahn := + (rfl) + +/-- The additive nonpositive Hahn map is injective. -/ +theorem toNonpositiveHahn_injective : + Function.Injective (toNonpositiveHahn : + OmnificInteger.{u} → HahnSeries.Nonpositive Surrealᵒᵈ ℝ) := by + intro x y hxy + apply Subtype.ext + apply toFullHahnSeries_injective + have hraw := congrArg (fun q : HahnSeries.Nonpositive Surrealᵒᵈ ℝ ↦ + (q : HahnSeries Surrealᵒᵈ ℝ)) hxy + simpa only [coe_toNonpositiveHahn] using hraw + +/-- The nonpositive Hahn image preserves arbitrary omnific-integer products. -/ +@[simp] +theorem toNonpositiveHahn_mul (x y : OmnificInteger.{u}) : + toNonpositiveHahn (x * y) = toNonpositiveHahn x * toNonpositiveHahn y := by + apply Subtype.ext + exact toFullHahnSeries_mul x.1 y.1 + +/-- The Hahn truncation-integer-part element represented by an omnific integer. -/ +def toTruncationIntegerPart (x : OmnificInteger.{u}) : + HahnSeries.truncationIntegerPart Surrealᵒᵈ realIntegerSubring := + ⟨x.toNonpositiveHahn, by + rw [HahnSeries.mem_truncationIntegerPart] + change (toFullHahnSeries x.1).coeff 0 ∈ realIntegerSubring + rw [coeff_toFullHahnSeries, mem_realIntegerSubring] + change x.1.coeff 0 ∈ Set.range ((↑) : ℤ → ℝ) + exact (isOmnificInteger_iff_normalForm.mp (mem_omnificIntegers.mp x.2)).2⟩ + +/-- Coercing the truncation-integer-part image recovers the nonpositive Hahn image. -/ +@[simp] +theorem coe_toTruncationIntegerPart (x : OmnificInteger.{u}) : + (x.toTruncationIntegerPart : HahnSeries.Nonpositive Surrealᵒᵈ ℝ) = + x.toNonpositiveHahn := + by + apply Subtype.ext + rfl + +/-- The truncation-integer-part image of omnific integers as an additive homomorphism. -/ +def toTruncationIntegerPartAddMonoidHom : + OmnificInteger.{u} →+ + HahnSeries.truncationIntegerPart Surrealᵒᵈ realIntegerSubring where + toFun := toTruncationIntegerPart + map_zero' := by + apply Subtype.ext + change toNonpositiveHahn (0 : OmnificInteger.{u}) = 0 + exact toNonpositiveHahnAddMonoidHom.map_zero + map_add' x y := by + apply Subtype.ext + change toNonpositiveHahn (x + y) = toNonpositiveHahn x + toNonpositiveHahn y + exact toNonpositiveHahnAddMonoidHom.map_add x y + +/-- Evaluation of the additive truncation-integer-part map. -/ +@[simp] +theorem toTruncationIntegerPartAddMonoidHom_apply (x : OmnificInteger.{u}) : + toTruncationIntegerPartAddMonoidHom x = x.toTruncationIntegerPart := + (rfl) + +/-- The additive truncation-integer-part map is injective. -/ +theorem toTruncationIntegerPart_injective : + Function.Injective (toTruncationIntegerPart : OmnificInteger.{u} → + HahnSeries.truncationIntegerPart Surrealᵒᵈ realIntegerSubring) := by + intro x y hxy + apply toNonpositiveHahn_injective + have h := congrArg (fun q : HahnSeries.truncationIntegerPart + Surrealᵒᵈ realIntegerSubring ↦ + (q : HahnSeries.Nonpositive Surrealᵒᵈ ℝ)) hxy + simpa only [coe_toTruncationIntegerPart] using h + +/-- The truncation-integer-part image preserves arbitrary omnific-integer products. -/ +@[simp] +theorem toTruncationIntegerPart_mul (x y : OmnificInteger.{u}) : + toTruncationIntegerPart (x * y) = + toTruncationIntegerPart x * toTruncationIntegerPart y := by + apply Subtype.ext + exact toNonpositiveHahn_mul x y + +end OmnificInteger + +end Surreal diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/HahnSeries/Multiplication.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/HahnSeries/Multiplication.lean new file mode 100644 index 0000000000..3274536ea4 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/HahnSeries/Multiplication.lean @@ -0,0 +1,123 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.HahnSeries.NormalFormMul +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.OmnificInteger.NormalForm + +/-! +# Hahn multiplication of omnific-integer normal forms + +This module records the multiplicative Conway-normal-form bridge needed for the omnific-integer +application in LM24. It proves that the formal Hahn product of two omnific-integer normal forms +again satisfies Conway's support-and-constant characterization of an omnific integer. + +The resulting `normalFormProduct` is the transported multiplication, and multiplicativity of the +Conway normal form identifies it with the ordinary surreal product. +-/ + +universe u + +open Set + +public noncomputable section + +namespace Surreal + +/-- The surreal represented by the Hahn product of two omnific-integer normal forms is an omnific +integer. -/ +theorem IsOmnificInteger.toHahnSeries_mul_toSurreal {x y : Surreal.{u}} + (hx : IsOmnificInteger x) (hy : IsOmnificInteger y) : + IsOmnificInteger ((x.toHahnSeries * y.toHahnSeries).toSurreal) := by + obtain ⟨hxSupport, m, hm⟩ := isOmnificInteger_iff_normalForm.mp hx + obtain ⟨hySupport, n, hn⟩ := isOmnificInteger_iff_normalForm.mp hy + have hxSeriesSupport : x.toHahnSeries.support ⊆ Ici 0 := by + simpa only [support_toHahnSeries] using hxSupport + have hySeriesSupport : y.toHahnSeries.support ⊆ Ici 0 := by + simpa only [support_toHahnSeries] using hySupport + rw [isOmnificInteger_iff_normalForm] + constructor + · simpa only [SurrealHahnSeries.support_toSurreal] using + SurrealHahnSeries.support_mul_subset_Ici hxSeriesSupport hySeriesSupport + · rw [SurrealHahnSeries.coeff_toSurreal, + SurrealHahnSeries.coeff_zero_mul_of_support_subset_Ici hxSeriesSupport hySeriesSupport] + rw [congrFun (coeff_toHahnSeries x) 0, congrFun (coeff_toHahnSeries y) 0, + ← hm, ← hn] + exact ⟨m * n, by simp⟩ + +/-- For omnific integers, Conway/Hahn multiplication compatibility reduces to the product of the +two strictly positive truncations. Integer constant terms and both cross terms are already +handled by additive compatibility. -/ +theorem IsOmnificInteger.toHahnSeries_mul_of_trunc_zero {x y : Surreal.{u}} + (hx : IsOmnificInteger x) (hy : IsOmnificInteger y) + (hpositive : (x.trunc 0 * y.trunc 0).toHahnSeries = + x.toHahnSeries.trunc 0 * y.toHahnSeries.trunc 0) : + (x * y).toHahnSeries = x.toHahnSeries * y.toHahnSeries := by + obtain ⟨hxSupport, m, hm⟩ := isOmnificInteger_iff_normalForm.mp hx + obtain ⟨hySupport, n, hn⟩ := isOmnificInteger_iff_normalForm.mp hy + have hmSurreal : (m : Surreal) = (x.coeff 0 : Surreal) := by + exact_mod_cast hm + have hnSurreal : (n : Surreal) = (y.coeff 0 : Surreal) := by + exact_mod_cast hn + have hxSplit : x.trunc 0 + (m : Surreal) = x := by + rw [hmSurreal, ← sub_trunc_zero_eq_realCast_of_support_subset_Ici hxSupport] + abel + have hySplit : y.trunc 0 + (n : Surreal) = y := by + rw [hnSurreal, ← sub_trunc_zero_eq_realCast_of_support_subset_Ici hySupport] + abel + have hxSeriesSplit : x.toHahnSeries.trunc 0 + + SurrealHahnSeries.single 0 (m : ℝ) = x.toHahnSeries := by + rw [← toHahnSeries_trunc, ← toHahnSeries_intCast, + ← toHahnSeries_add, hxSplit] + have hySeriesSplit : y.toHahnSeries.trunc 0 + + SurrealHahnSeries.single 0 (n : ℝ) = y.toHahnSeries := by + rw [← toHahnSeries_trunc, ← toHahnSeries_intCast, + ← toHahnSeries_add, hySplit] + conv_lhs => rw [← hxSplit, ← hySplit] + rw [add_mul, mul_add, mul_add, toHahnSeries_add, toHahnSeries_add, + toHahnSeries_add, hpositive, toHahnSeries_mul_intCast, + toHahnSeries_intCast_mul, toHahnSeries_mul_intCast, + toHahnSeries_trunc x 0, toHahnSeries_trunc y 0, + toHahnSeries_intCast] + calc + _ = (x.toHahnSeries.trunc 0 + SurrealHahnSeries.single 0 (m : ℝ)) * + (y.toHahnSeries.trunc 0 + SurrealHahnSeries.single 0 (n : ℝ)) := by ring + _ = x.toHahnSeries * y.toHahnSeries := by rw [hxSeriesSplit, hySeriesSplit] + +namespace OmnificInteger + +/-- Multiplication transported from formal Hahn multiplication through Conway normal forms. -/ +def normalFormProduct (x y : OmnificInteger.{u}) : OmnificInteger.{u} := + ⟨(x.1.toHahnSeries * y.1.toHahnSeries).toSurreal, + (mem_omnificIntegers.mpr + ((mem_omnificIntegers.mp x.2).toHahnSeries_mul_toSurreal + (mem_omnificIntegers.mp y.2)))⟩ + +/-- The surreal underlying the transported normal-form product. -/ +theorem coe_normalFormProduct (x y : OmnificInteger.{u}) : + (normalFormProduct x y : Surreal) = + (x.1.toHahnSeries * y.1.toHahnSeries).toSurreal := + (rfl) + +/-- The Conway normal form of the transported product is the formal Hahn product. -/ +theorem toHahnSeries_normalFormProduct (x y : OmnificInteger.{u}) : + (normalFormProduct x y : Surreal).toHahnSeries = + x.1.toHahnSeries * y.1.toHahnSeries := by + rw [coe_normalFormProduct, SurrealHahnSeries.toHahnSeries_toSurreal] + +/-- Multiplication transported through Conway normal forms is ordinary omnific-integer +multiplication. -/ +@[simp] +theorem normalFormProduct_eq_mul (x y : OmnificInteger.{u}) : + normalFormProduct x y = x * y := by + apply Subtype.ext + change (x.1.toHahnSeries * y.1.toHahnSeries).toSurreal = x.1 * y.1 + rw [SurrealHahnSeries.toSurreal_mul, Surreal.toSurreal_toHahnSeries, + Surreal.toSurreal_toHahnSeries] + +end OmnificInteger + +end Surreal diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/HahnSeries/NormalForm.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/HahnSeries/NormalForm.lean new file mode 100644 index 0000000000..84d708fb0c --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/HahnSeries/NormalForm.lean @@ -0,0 +1,1192 @@ +/- +Copyright (c) 2026 Violeta Hernández Palacios. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Violeta Hernández Palacios +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.HahnSeries.NormalFormRecursion +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.HahnSeries.NormalFormSupport +public import LeanPool.ConwayRefinement.CombinatorialGames.Surreal.Birthday.Basic + +/-! +# Converting between surreal Hahn series and surreals + +This map defines the two-way conversion between `SurrealHahnSeries` and `Surreal`, and proves it an +order isomorphism (`Surreal.toHahnSeriesOrderIso`). This downstream port follows the axiom-free +construction in CombinatorialGames PR #263. Both sides of this conversion are quite +technical constructions which require auxiliary definitions. + +## Hahn series to surreals + +For a given surreal Hahn series `x`, we define two sets `truncLT x` and `truncGT x` of surreal Hahn +series. The set `truncLT x` is generated by truncating `x` at some element `e` of its support, and +adding `single r e` for `r < x.coeff e`. The set `truncGT x` is defined analogously, replacing the +last inequality with `r > x.coeff e`. Both are small sets. + +We first define a map `SurrealHahnSeries → IGame` via limit recursion on the length of the Hahn +series. For a Hahn series of successor length, we define +`toIGame (x + single r e)` = `toIGame x + r * ω^ e`. For a Hahn series of limit (or zero) length, +we define `toIGame x = !{truncLT x | truncGT x}`. This definition is well-founded, as all elements +in `truncLT x` and `truncGT x` have a smaller length than `x`, whenever `x` has a limit length. + +We use mutual induction to show that `toIGame x` is always numeric, and that `toIGame` is strictly +monotone. As a corollary, the equivalence `toIGame x ≈ !{truncLT x | truncGT x}` holds +unconditionally. + +## Surreals to Hahn series + +For a given surreal `x`, we define the type `PartialSum x` of partial sums of `x`. These are surreal +Hahn series `y` characterized by the equation `y.term i = (x - y).leadingTerm` for every +`i < y.length`. The idea is that terms of `PartialSum x` represent successive approximations to the +Hahn series which corresponds to `x`, which will be the longest one. + +We define a `Preorder` instance on `PartialSum x` via the lift of the `length` function. We first +show that `length` is injective on `PartialSum x`, meaning we can lift this to a linear order. We +then show that `PartialSum x` is `Small` via a birthday argument. We build a `CompleteLinearOrder` +instance, by setting the supremum to the directed union of series. Finally, we show that +`⊤ : PartialSum x` must be a Hahn series with `toSurreal ⊤ = x`; if it wasn't, we'd be able to +extend it by at least one entry. +-/ + +universe u + +open IGame Order Set + +public noncomputable section + +/-! ### Hahn series as games -/ + +namespace SurrealHahnSeries + +/-- A common base for both `truncLT` and `truncGT`. -/ +private def truncAux (x : SurrealHahnSeries) (R : ℝ → ℝ → Prop) : Set SurrealHahnSeries := + range fun i : (j : x.support) × {r // R r (x.coeff j)} ↦ x.trunc i.1 + single i.1 i.2 + +/-- We write `x ≺ y` whenever `x = y.trunc i + single i r` for some `i ∈ y.support` and +`r < y.coeff i`. + +When `y.length` is a limit ordinal, the series with `x ≺ y` describe the left options of +`toIGame y`. -/ +def truncLT (x : SurrealHahnSeries) : Set SurrealHahnSeries := + truncAux x (· < ·) + +/-- A series lies below another in the truncation order when it belongs to the latter’s lower +truncations. -/ +notation:50 x:50 " ≺ " y:50 => x ∈ truncLT y +recommended_spelling "truncLT" for "≺" in [«term_≺_»] + +/-- We write `x ≻ y` whenever `x = y.trunc i + single i r` for some `i ∈ y.support` and +`r > y.coeff i`. + +When `y.length` is a limit ordinal, the series with `x ≻ y` describe the right options of +`toIGame y`. -/ +def truncGT (x : SurrealHahnSeries) : Set SurrealHahnSeries := + truncAux x (· > ·) + +local notation:50 x:50 " ≻ " y:50 => x ∈ truncGT y +recommended_spelling "truncGT" for "≻" in [«term_≺_»] + +private theorem truncAux_def {x y : SurrealHahnSeries} {R : ℝ → ℝ → Prop} : + x ∈ truncAux y R ↔ ∃ i ∈ y.support, ∃ r : ℝ, R r (y.coeff i) ∧ y.trunc i + single i r = x := by + simp [truncAux] + +theorem truncLT_def {x y : SurrealHahnSeries} : + x ≺ y ↔ ∃ i ∈ y.support, ∃ r : ℝ, r < y.coeff i ∧ y.trunc i + single i r = x := + truncAux_def + +theorem truncGT_def {x y : SurrealHahnSeries} : + x ≻ y ↔ ∃ i ∈ y.support, ∃ r : ℝ, y.coeff i < r ∧ y.trunc i + single i r = x := + truncAux_def + +private theorem forall_mem_truncAux {y : SurrealHahnSeries} + {P : SurrealHahnSeries → Prop} {R : ℝ → ℝ → Prop} : + (∀ x ∈ truncAux y R, P x) ↔ + ∀ i ∈ y.support, ∀ r : ℝ, R r (y.coeff i) → P (y.trunc i + single i r) := by + aesop (add simp [truncAux]) + +theorem forall_mem_truncLT {y : SurrealHahnSeries} {P : SurrealHahnSeries → Prop} : + (∀ x ∈ truncLT y, P x) ↔ + ∀ i ∈ y.support, ∀ r : ℝ, r < y.coeff i → P (y.trunc i + single i r) := + forall_mem_truncAux + +theorem forall_mem_truncGT {y : SurrealHahnSeries} {P : SurrealHahnSeries → Prop} : + (∀ x ∈ truncGT y, P x) ↔ + ∀ i ∈ y.support, ∀ r : ℝ, y.coeff i < r → P (y.trunc i + single i r) := + forall_mem_truncAux + +private theorem exists_mem_truncAux {y : SurrealHahnSeries} + {P : SurrealHahnSeries → Prop} {R : ℝ → ℝ → Prop} : + (∃ x ∈ truncAux y R, P x) ↔ + ∃ i ∈ y.support, ∃ r : ℝ, R r (y.coeff i) ∧ P (y.trunc i + single i r) := by + aesop (add simp [truncAux]) + +theorem exists_mem_truncLT {y : SurrealHahnSeries} {P : SurrealHahnSeries → Prop} : + (∃ x ∈ truncLT y, P x) ↔ + ∃ i ∈ y.support, ∃ r : ℝ, r < y.coeff i ∧ P (y.trunc i + single i r) := + exists_mem_truncAux + +theorem exists_mem_truncGT {y : SurrealHahnSeries} {P : SurrealHahnSeries → Prop} : + (∃ x ∈ truncGT y, P x) ↔ + ∃ i ∈ y.support, ∃ r : ℝ, y.coeff i < r ∧ P (y.trunc i + single i r) := + exists_mem_truncAux + +private theorem truncAux_zero (R : ℝ → ℝ → Prop) : truncAux 0 R = ∅ := by + unfold truncAux; simp + +@[simp] theorem truncLT_zero : truncLT 0 = ∅ := truncAux_zero _ +@[simp] theorem truncGT_zero : truncGT 0 = ∅ := truncAux_zero _ + +private theorem trunc_add_single_truncAux {x : SurrealHahnSeries} {i : Surreal} {r : ℝ} + {R : ℝ → ℝ → Prop} (hi : i ∈ x.support) (hr : R r (x.coeff i)) : + x.trunc i + single i r ∈ truncAux x R := by + unfold truncAux + aesop + +theorem trunc_add_single_truncLT {x : SurrealHahnSeries} {i : Surreal} {r : ℝ} + (hi : i ∈ x.support) (hr : r < x.coeff i) : x.trunc i + single i r ≺ x := + trunc_add_single_truncAux hi hr + +theorem trunc_add_single_truncGT {x : SurrealHahnSeries} {i : Surreal} {r : ℝ} + (hi : i ∈ x.support) (hr : x.coeff i < r) : x.trunc i + single i r ≻ x := + trunc_add_single_truncAux hi hr + +private instance small_truncAux (x : SurrealHahnSeries.{u}) (R : ℝ → ℝ → Prop) : + Small.{u} (truncAux x R) := + by unfold truncAux; infer_instance + +instance small_truncLT (x : SurrealHahnSeries.{u}) : Small.{u} (truncLT x) := small_truncAux .. +instance small_truncGT (x : SurrealHahnSeries.{u}) : Small.{u} (truncGT x) := small_truncAux .. + +private theorem length_le_of_truncAux {x y : SurrealHahnSeries} {R : ℝ → ℝ → Prop} + (h : x ∈ truncAux y R) : x.length ≤ y.length := by + obtain ⟨⟨i, hi⟩, rfl⟩ := h + apply (length_add_single_le ..).trans + · rw [add_one_le_iff] + exact length_trunc_lt i.2 + · simp + +private theorem length_lt_of_truncAux {x y : SurrealHahnSeries} (hy : IsSuccPrelimit y.length) + {R : ℝ → ℝ → Prop} (h : x ∈ truncAux y R) : x.length < y.length := by + obtain ⟨⟨i, hi⟩, rfl⟩ := h + apply (length_add_single_le ..).trans_lt + · exact hy.add_one_lt <| length_trunc_lt i.2 + · simp + +theorem length_le_of_truncLT {x y : SurrealHahnSeries} (h : x ≺ y) : x.length ≤ y.length := + length_le_of_truncAux h + +theorem length_le_of_truncGT {x y : SurrealHahnSeries} (h : x ≻ y) : x.length ≤ y.length := + length_le_of_truncAux h + +theorem length_lt_of_truncLT {x y : SurrealHahnSeries} (hy : IsSuccPrelimit y.length) (h : x ≺ y) : + x.length < y.length := + length_lt_of_truncAux hy h + +theorem length_lt_of_truncGT {x y : SurrealHahnSeries} (hy : IsSuccPrelimit y.length) (h : x ≻ y) : + x.length < y.length := + length_lt_of_truncAux hy h + +theorem lt_of_truncLT {x y : SurrealHahnSeries} (h : x ≺ y) : x < y := by + obtain ⟨⟨⟨i, hi⟩, s, hs⟩, rfl⟩ := h + rw [lt_def] + use i + aesop + +theorem gt_of_truncGT {x y : SurrealHahnSeries} (h : x ≻ y) : y < x := by + obtain ⟨⟨⟨i, hi⟩, s, hs⟩, rfl⟩ := h + rw [lt_def] + use i + aesop + +private theorem truncAux_truncIdx_ssubset {x : SurrealHahnSeries} {R : ℝ → ℝ → Prop} {i : Ordinal} + (h : i < x.length) (hR : ∀ r, ∃ s ≠ 0, R s r) : truncAux (truncIdx x i) R ⊂ truncAux x R := by + constructor + · intro y hy + rw [truncAux_def] at hy ⊢ + obtain ⟨a, ha, r, hr, rfl⟩ := hy + refine ⟨a, support_truncIdx_subset _ _ ha, r, ?_, ?_⟩ + · rwa [coeff_truncIdx_of_mem le_rfl ha] at hr + · rw [trunc_truncIdx_of_mem le_rfl ha] + · rw [not_subset, exists_mem_truncAux] + obtain ⟨s, hs, hs'⟩ := hR (x.coeff ↑(x.exp ⟨i, h⟩)) + refine ⟨x.exp ⟨i, h⟩, Subtype.coe_prop _, s, hs', fun H ↦ (length_le_of_truncAux H).not_gt ?_⟩ + rw [trunc_exp, length_truncIdx_add_single _ hs, length_truncIdx, Order.lt_add_one_iff] + exact min_le_left .. + +private theorem truncAux_truncIdx_subset {x : SurrealHahnSeries} {R : ℝ → ℝ → Prop} {i : Ordinal} + (hR : ∀ r, ∃ s ≠ 0, R s r) : truncAux (truncIdx x i) R ⊆ truncAux x R := by + obtain hi | hi := lt_or_ge i x.length + · exact (truncAux_truncIdx_ssubset hi hR).le + · rw [truncIdx_of_le hi] + +private theorem truncAux_truncIdx_strictMonoOn {x : SurrealHahnSeries} {R : ℝ → ℝ → Prop} + (hR : ∀ r, ∃ s ≠ 0, R s r) : + StrictMonoOn (fun i ↦ truncAux (truncIdx x i) R) (Iio x.length) := by + intro i hi j hj h + dsimp + rw [← min_eq_right h.le, ← truncIdx_truncIdx] + apply truncAux_truncIdx_ssubset _ hR + simp_all + +private theorem truncAux_truncIdx_mono {x : SurrealHahnSeries} {R : ℝ → ℝ → Prop} + (hR : ∀ r, ∃ s ≠ 0, R s r) : + Monotone fun i ↦ truncAux (truncIdx x i) R := by + intro i j h + dsimp + rw [← min_eq_right h, ← truncIdx_truncIdx] + exact truncAux_truncIdx_subset hR + +private theorem truncLT_aux (r : ℝ) : ∃ s ≠ 0, s < r := ⟨min (r - 1) (-1), by grind⟩ +private theorem truncGT_aux (r : ℝ) : ∃ s ≠ 0, r < s := ⟨max (r + 1) 1, by grind⟩ + +theorem truncLT_truncIdx_ssubset {x : SurrealHahnSeries} {i : Ordinal} (h : i < x.length) : + truncLT (truncIdx x i) ⊂ truncLT x := + truncAux_truncIdx_ssubset h truncLT_aux + +theorem truncGT_truncIdx_ssubset {x : SurrealHahnSeries} {i : Ordinal} (h : i < x.length) : + truncGT (truncIdx x i) ⊂ truncGT x := + truncAux_truncIdx_ssubset h truncGT_aux + +theorem truncLT_truncIdx_subset {x : SurrealHahnSeries} {i : Ordinal} : + truncLT (truncIdx x i) ⊆ truncLT x := + truncAux_truncIdx_subset truncLT_aux + +theorem truncGT_truncIdx_subset {x : SurrealHahnSeries} {i : Ordinal} : + truncGT (truncIdx x i) ⊆ truncGT x := + truncAux_truncIdx_subset truncGT_aux + +theorem truncLT_truncIdx_strictMonoOn {x : SurrealHahnSeries} : + StrictMonoOn (fun i ↦ truncLT (truncIdx x i)) (Iio x.length) := + truncAux_truncIdx_strictMonoOn truncLT_aux + +theorem truncGT_truncIdx_strictMonoOn {x : SurrealHahnSeries} : + StrictMonoOn (fun i ↦ truncGT (truncIdx x i)) (Iio x.length) := + truncAux_truncIdx_strictMonoOn truncGT_aux + +theorem truncLT_truncIdx_mono {x : SurrealHahnSeries} : + Monotone fun i ↦ truncLT (truncIdx x i) := + truncAux_truncIdx_mono truncLT_aux + +theorem truncGT_truncIdx_mono {x : SurrealHahnSeries} : + Monotone fun i ↦ truncGT (truncIdx x i) := + truncAux_truncIdx_mono truncGT_aux + +/-- An `IGame` representative of the surreal number encoded by a surreal Hahn series. -/ +@[coe] +def toIGame (x : SurrealHahnSeries.{u}) : IGame.{u} := + lengthRecOn x (fun _ i r _ _ IH ↦ IH + r * ω^ i.out) fun y hy IH ↦ + !{range fun i : truncLT y ↦ IH i <| length_lt_of_truncLT hy i.2 | + range fun i : truncGT y ↦ IH i <| length_lt_of_truncGT hy i.2} + +instance instCoeIGame : Coe SurrealHahnSeries IGame where + coe := toIGame + +theorem toIGame_succ {x : SurrealHahnSeries} + {i : Surreal} {r : ℝ} (hi : ∀ j ∈ x.support, i < j) (hr : r ≠ 0) : + toIGame (x + single i r) = toIGame x + r * ω^ i.out := + lengthRecOn_succ hi hr + +theorem toIGame_succ_equiv {x : SurrealHahnSeries} + {i : Surreal} {r : ℝ} (hi : ∀ j ∈ x.support, i < j) : + toIGame (x + single i r) ≈ toIGame x + r * ω^ i.out := by + obtain rfl | hr := eq_or_ne r 0 + · rw [single_zero, add_zero] + have hz : ((0 : ℝ) : IGame) * ω^ i.out ≈ 0 := by + rw [Numeric.mul_equiv_zero] + exact Or.inl Real.toIGame_zero_equiv + simpa using (IGame.add_congr_right hz).symm + · rw [toIGame_succ hi hr] + +theorem toIGame_limit {x : SurrealHahnSeries.{u}} (hx : IsSuccPrelimit x.length) : + toIGame x = !{toIGame '' truncLT x | toIGame '' truncGT x} := by + simp_rw [image_eq_range] + exact lengthRecOn_limit hx + +@[simp] +theorem toIGame_zero : toIGame 0 = 0 := by + rw [toIGame_limit] <;> aesop + +theorem leftMoves_toIGame_limit {x : SurrealHahnSeries} (hx : IsSuccPrelimit x.length) : + (toIGame x)ᴸ = toIGame '' truncLT x := by + rw [toIGame_limit hx, leftMoves_ofSets] + +theorem rightMoves_toIGame_limit {x : SurrealHahnSeries} (hx : IsSuccPrelimit x.length) : + (toIGame x)ᴿ = toIGame '' truncGT x := by + rw [toIGame_limit hx, rightMoves_ofSets] + +private theorem toIGame_lt_toIGame_of_truncLT {x y : SurrealHahnSeries} (h : x ≺ y) + [hy' : Numeric y] (IH : ∀ z, length z < y.length → Numeric z) : + toIGame x < toIGame y := by + induction y using lengthRecOn generalizing hy' x with + | succ y i r hi hr IH' => + obtain ⟨⟨⟨j, hj⟩, s, hs⟩, rfl⟩ := h + rw [coeff_add_apply] at hs + replace hj := union_subset_union_right y.support support_single_subset (support_add_subset hj) + have hij : i ≤ j := by rw [le_iff_lt_or_eq]; aesop + dsimp + rw [trunc_add, trunc_single_of_le hij, add_zero, toIGame_succ hi hr] + grw [toIGame_succ_equiv (by simp)] + obtain hj | rfl := hj + · replace hij := hi _ hj + rw [coeff_single_of_ne hij.ne, add_zero] at hs + obtain ⟨t, ht, ht'⟩ := exists_between hs + have hst : s * ω^ j.out ≈ t * ω^ j.out + ↑(s - t) * ω^ j.out := by + rw [← Surreal.mk_eq_mk] + simp [← add_mul] + grw [hst, ← add_assoc] + apply add_lt_add _ (Numeric.mul_wpow_lt_mul_wpow_of_neg ..) + · grw [← toIGame_succ_equiv (by simp)] + simp_rw [length_add_single hi hr, lt_add_one_iff] at IH + have := IH _ le_rfl + apply IH' + · rw [truncLT_def] + exact ⟨j, hj, t, ht', rfl⟩ + · exact fun z hz ↦ IH z hz.le + · rwa [sub_neg] + · rw [← Surreal.mk_lt_mk] + simpa + · rw [trunc_eq_self hi] + have : y.coeff j = 0 := by + by_contra h + exact (hi _ h).false + simpa [this] using hs + | limit y hy IH' => + apply Numeric.left_lt + rw [leftMoves_toIGame_limit hy] + exact mem_image_of_mem _ h + +private theorem toIGame_lt_toIGame_of_truncGT {x y : SurrealHahnSeries} (h : x ≻ y) + [hy' : Numeric y] (IH : ∀ z, length z < y.length → Numeric z) : + toIGame y < toIGame x := by + induction y using lengthRecOn generalizing hy' x with + | succ y i r hi hr IH' => + obtain ⟨⟨⟨j, hj⟩, s, hs⟩, rfl⟩ := h + rw [coeff_add_apply] at hs + replace hj := union_subset_union_right y.support support_single_subset (support_add_subset hj) + have hij : i ≤ j := by rw [le_iff_lt_or_eq]; aesop + dsimp + rw [trunc_add, trunc_single_of_le hij, add_zero, toIGame_succ hi hr] + grw [toIGame_succ_equiv (by simp)] + obtain hj | rfl := hj + · replace hij := hi _ hj + rw [coeff_single_of_ne hij.ne, add_zero] at hs + obtain ⟨t, ht', ht⟩ := exists_between hs + have hst : s * ω^ j.out ≈ t * ω^ j.out + ↑(s - t) * ω^ j.out := by + rw [← Surreal.mk_eq_mk] + simp [← add_mul] + grw [hst, ← add_assoc] + apply add_lt_add _ (Numeric.mul_wpow_lt_mul_wpow_of_pos ..) + · grw [← toIGame_succ_equiv (by simp)] + simp_rw [length_add_single hi hr, lt_add_one_iff] at IH + have := IH _ le_rfl + apply IH' + · rw [truncGT_def] + exact ⟨j, hj, t, ht', rfl⟩ + · exact fun z hz ↦ IH z hz.le + · rwa [sub_pos] + · rw [← Surreal.mk_lt_mk] + simpa + · rw [trunc_eq_self hi] + have : y.coeff j = 0 := by + by_contra h + exact (hi _ h).false + simpa [this] using hs + | limit y hy IH' => + apply Numeric.lt_right + rw [rightMoves_toIGame_limit hy] + exact mem_image_of_mem _ h + +private theorem numeric_toIGame' (x : SurrealHahnSeries) + (IH : ∀ {y z}, length y < x.length → length z < x.length → + Numeric y ∧ Numeric z ∧ (y < z → toIGame y < toIGame z)) : Numeric x := by + have IH' {y : SurrealHahnSeries} (hy : y.length < _) := (IH hy hy).1 + cases x using lengthRecOn with + | succ x i r hi hr => + rw [toIGame_succ hi hr] + have hx : x.length < (x + single i r).length := by + rw [length_add_single hi hr, lt_add_one_iff] + have := IH' hx + infer_instance + | limit _ hx => + rw [toIGame_limit hx, numeric_def] + aesop (add apply forward safe [length_lt_of_truncLT, length_lt_of_truncGT, + lt_of_truncLT, gt_of_truncGT, lt_trans]) + +private theorem toIGame_aux {o : Ordinal} {x y : SurrealHahnSeries} + (_ : x.length < o) (_ : y.length < o) : Numeric x ∧ Numeric y ∧ + (x < y → toIGame x < toIGame y) := by + have hx' := numeric_toIGame' x toIGame_aux + have hy' := numeric_toIGame' y toIGame_aux + have IHx (z) (hz : length z < x.length) : Numeric z := (toIGame_aux hz hz).1 + have IHy (z) (hz : length z < y.length) : Numeric z := (toIGame_aux hz hz).1 + refine ⟨hx', hy', fun h ↦ ?_⟩ + obtain ⟨i, hi, hi'⟩ := lt_def.1 h + dsimp at * + obtain hx | hx := eq_or_ne (x.coeff i) 0 <;> obtain hy | hy := eq_or_ne (y.coeff i) 0 + · simp_all + · by_cases! H : ∀ j : x.support, i < j + · apply toIGame_lt_toIGame_of_truncLT _ IHy + rw [truncLT_def] + use i, hy, x.coeff i, hi' + ext j + have (hj : j < i) : x.coeff j = 0 := by + by_contra hj' + exact (H ⟨_, hj'⟩).not_gt hj + have := lt_trichotomy i j + aesop + · obtain ⟨⟨j, hj⟩, (hj' : j ≤ i), hij⟩ := wellFounded_gt.has_min {j : x.support | j ≤ i} H + obtain rfl | hj' := hj'.eq_or_lt + · cases hj hx + · obtain ⟨r, hr⟩ := exists_gt (x.coeff j) + trans ↑(x.trunc j + single j r) + · apply toIGame_lt_toIGame_of_truncGT _ IHx + rw [truncGT_def] + use j, hj, r + · rw [hx] at hi' + obtain ⟨s, hs, hs'⟩ := exists_between hi' + trans ↑(y.trunc i + single i s) + · grw [toIGame_succ_equiv (by simp), toIGame_succ (by simp) hs.ne'] + apply add_lt_add_of_le_of_lt (le_of_eq _) + · apply Numeric.mul_wpow_lt_mul_wpow_of_pos _ hs + simpa [← Surreal.mk_lt_mk] + · congr 1 + trans x.trunc i + · refine trunc_eq_trunc hj'.le fun k hj hi ↦ ?_ + by_contra h + exact hij ⟨_, h⟩ hi hj + · aesop + · apply toIGame_lt_toIGame_of_truncLT _ IHy + rw [truncLT_def] + use i, hy, s + · by_cases! H : ∀ j : y.support, i < j + · apply toIGame_lt_toIGame_of_truncGT _ IHx + rw [truncGT_def] + use i, hx, y.coeff i, hi' + ext j + have (hj : j < i) : y.coeff j = 0 := by + by_contra hj' + exact (H ⟨_, hj'⟩).not_gt hj + have := lt_trichotomy i j + aesop (add safe tactic (by order)) + · obtain ⟨⟨j, hj⟩, (hj' : j ≤ i), hij⟩ := wellFounded_gt.has_min {j : y.support | j ≤ i} H + obtain rfl | hj' := hj'.eq_or_lt + · cases hj hy + · obtain ⟨r, hr⟩ := exists_lt (y.coeff j) + trans ↑(y.trunc j + single j r) + · rw [hy] at hi' + obtain ⟨s, hs', hs⟩ := exists_between hi' + trans ↑(x.trunc i + single i s) + · apply toIGame_lt_toIGame_of_truncGT _ IHx + rw [truncGT_def] + use i, hx, s + · grw [toIGame_succ (by simp) hs.ne, toIGame_succ_equiv (by simp)] + apply add_lt_add_of_le_of_lt (le_of_eq _) + · apply Numeric.mul_wpow_lt_mul_wpow_of_neg _ hs + simpa [← Surreal.mk_lt_mk] + · congr 1 + trans y.trunc i + · aesop + · symm + refine trunc_eq_trunc hj'.le fun k hj hi ↦ ?_ + by_contra h + exact hij ⟨_, h⟩ hi hj + · apply toIGame_lt_toIGame_of_truncLT _ IHy + rw [truncLT_def] + use j, hj, r + · obtain ⟨r, hr, hr'⟩ := exists_between hi' + trans ↑(x.trunc i + single i r) + · apply toIGame_lt_toIGame_of_truncGT _ IHx + rw [truncGT_def] + use i, hx, r + · apply toIGame_lt_toIGame_of_truncLT _ IHy + rw [truncLT_def] + use i, hy, r, hr' + aesop +termination_by o + +instance numeric_toIGame (x : SurrealHahnSeries) : Numeric (toIGame x) := + (toIGame_aux (lt_add_one _) (lt_add_one _)).1 + +theorem toIGame_strictMono : StrictMono toIGame := by + refine fun x y h ↦ (toIGame_aux (o := max (x.length + 1) (y.length + 1)) ?_ ?_).2.2 h <;> simp + +@[simp, norm_cast] +theorem toIGame_lt_toIGame_iff {x y : SurrealHahnSeries} : toIGame x < toIGame y ↔ x < y := + toIGame_strictMono.lt_iff_lt + +@[simp, norm_cast] +theorem toIGame_le_toIGame_iff {x y : SurrealHahnSeries} : toIGame x ≤ toIGame y ↔ x ≤ y := + toIGame_strictMono.le_iff_le + +@[simp, norm_cast] +theorem toIGame_equiv_toIGame_iff {x y : SurrealHahnSeries} : toIGame x ≈ toIGame y ↔ x = y := by + simp [AntisymmRel, le_antisymm_iff] + +@[simp, norm_cast] +theorem toIGame_inj {x y : SurrealHahnSeries} : toIGame x = toIGame y ↔ x = y := + toIGame_strictMono.injective.eq_iff + +theorem toIGame_equiv (x : SurrealHahnSeries) : + toIGame x ≈ !{toIGame '' truncLT x | toIGame '' truncGT x} := by + induction x using lengthRecOn with + | succ x i r hi hr IH => + have hi' : i ∉ x.support := fun hi' ↦ (hi i hi').false + apply Fits.equiv_of_forall_moves_of_equiv ( + !{toIGame '' truncLT x | toIGame '' truncGT x} + + !{(fun s : ℝ ↦ s * ω^ i.out) '' Iio r | (fun s : ℝ ↦ s * ω^ i.out) '' Ioi r}) + · rw [toIGame_succ hi hr] + exact IGame.add_congr IH (Numeric.realCast_mul_wpow_equiv r i.out) + · constructor + all_goals + rw [moves_ofSets, forall_mem_image] + intro y hy + · simpa using lt_of_truncLT hy + · simpa using gt_of_truncGT hy + · simp_rw [forall_moves_add, moves_ofSets, Player.cases, + forall_mem_image, exists_mem_image, forall_mem_truncLT, exists_mem_truncLT, trunc_add] + constructor + · intro j hj s hs + obtain ⟨t, ht⟩ := exists_lt ((x + single i r).coeff i) + refine ⟨i, ?_, t, ht, ?_⟩ + · simp_all + · grw [← Numeric.realCast_mul_wpow_equiv, trunc_single_of_le le_rfl, + ← toIGame_succ_equiv (by aesop), toIGame_le_toIGame_iff] + refine (lt_def.2 ⟨j, fun k hk ↦ ?_, ?_⟩).le + · change + (x.trunc j + single j s + single i r).coeff k = + (x.trunc i + 0 + single i t).coeff k + simp only [coeff_add_apply] + rw [coeff_trunc_of_lt hk, coeff_trunc_of_lt ((hi _ hj).trans hk)] + rw [coeff_single_of_ne hk.ne, + coeff_single_of_ne ((hi _ hj).trans hk).ne] + simpa using coeff_single_of_ne (r := t) ((hi _ hj).trans hk).ne + · aesop + · intro s hs + obtain ⟨t, ht, ht'⟩ := exists_between (α := ℝ) hs + refine ⟨i, ?_, t, ?_, ?_⟩ + · simp_all + · simp_all + · grw [trunc_single_of_le le_rfl, ← IH, toIGame_succ_equiv (by simp), trunc_eq_self hi] + simpa using ht.le + · simp_rw [forall_moves_add, moves_ofSets, Player.cases, + forall_mem_image, exists_mem_image, forall_mem_truncGT, exists_mem_truncGT, trunc_add] + constructor + · intro j hj s hs + obtain ⟨t, ht⟩ := exists_gt ((x + single i r).coeff i) + refine ⟨i, ?_, t, ht, ?_⟩ + · simp_all + · grw [← Numeric.realCast_mul_wpow_equiv, trunc_single_of_le le_rfl, + ← toIGame_succ_equiv (by aesop), toIGame_le_toIGame_iff] + refine (lt_def.2 ⟨j, fun k hk ↦ ?_, ?_⟩).le + · change + (x.trunc i + 0 + single i t).coeff k = + (x.trunc j + single j s + single i r).coeff k + simp only [coeff_add_apply] + rw [coeff_trunc_of_lt hk, coeff_trunc_of_lt ((hi _ hj).trans hk)] + rw [coeff_single_of_ne hk.ne, + coeff_single_of_ne ((hi _ hj).trans hk).ne] + simpa using coeff_single_of_ne (r := r) ((hi _ hj).trans hk).ne + · aesop + · intro s hs + obtain ⟨t, ht, ht'⟩ := exists_between (α := ℝ) hs + refine ⟨i, ?_, t, ?_, ?_⟩ + · simp_all + · simp_all + · grw [trunc_single_of_le le_rfl, ← IH, toIGame_succ_equiv (by simp), trunc_eq_self hi] + simpa using ht'.le + | limit x hx IH => rw [toIGame_limit hx] + +instance numeric_ofSets_truncLT_truncGT (x : SurrealHahnSeries) : + Numeric !{toIGame '' truncLT x | toIGame '' truncGT x} := by + rw [numeric_def] + constructor + · simp_rw [moves_ofSets, Player.cases, forall_mem_image] + intro i hi j hj + exact_mod_cast (lt_of_truncLT hi).trans (gt_of_truncGT hj) + · simp [numeric_toIGame] + +theorem fits_ofSets_truncLT_truncGT (x : SurrealHahnSeries) (i : Ordinal) : + (toIGame x).Fits + !{toIGame '' (x.truncIdx i).truncLT | toIGame '' (x.truncIdx i).truncGT} := by + constructor + all_goals + intro k hk + rw [moves_ofSets] at hk + obtain ⟨k, hk, rfl⟩ := hk + rw [toIGame_le_toIGame_iff, not_le] + exacts [lt_of_truncLT (truncLT_truncIdx_subset hk), gt_of_truncGT (truncGT_truncIdx_subset hk)] + +/-- The surreal that corresponds to a given surreal Hahn series. -/ +@[coe] +def toSurreal (x : SurrealHahnSeries) : Surreal := + .mk x + +@[simp] +theorem mk_toIGame (x : SurrealHahnSeries) : Surreal.mk x.toIGame = toSurreal x := + (rfl) + +instance instCoeSurreal : Coe SurrealHahnSeries Surreal where + coe := toSurreal + +theorem toSurreal_strictMono : StrictMono toSurreal := + toIGame_strictMono + +@[simp, norm_cast] +theorem toSurreal_lt_toSurreal_iff {x y : SurrealHahnSeries} : toSurreal x < toSurreal y ↔ x < y := + toIGame_lt_toIGame_iff + +@[simp, norm_cast] +theorem toSurreal_le_toSurreal_iff {x y : SurrealHahnSeries} : toSurreal x ≤ toSurreal y ↔ x ≤ y := + toIGame_le_toIGame_iff + +@[simp, norm_cast] +theorem toSurreal_inj {x y : SurrealHahnSeries} : toSurreal x = toSurreal y ↔ x = y := + toSurreal_strictMono.injective.eq_iff + +@[simp] +theorem toSurreal_zero : toSurreal 0 = 0 := by simp [toSurreal] + +/-- This is just a special case of `toSurreal_add`. -/ +theorem toSurreal_succ {x : SurrealHahnSeries} + {i : Surreal} {r : ℝ} (hi : ∀ j ∈ x.support, i < j) : + toSurreal (x + single i r) = toSurreal x + r * ω^ i := by + simpa using Surreal.mk_eq (toIGame_succ_equiv hi) + +@[simp] +theorem toSurreal_single (i : Surreal) (r : ℝ) : toSurreal (single i r) = r * ω^ i := by + rw [← zero_add (single i r), toSurreal_succ] <;> simp + +theorem toSurreal_of_length_le_add_one {x : SurrealHahnSeries} {i : Ordinal} + (hi : x.length ≤ i + 1) : toSurreal x = toSurreal (x.truncIdx i) + x.term i := by + obtain hi | hi := hi.eq_or_lt + · conv_lhs => rw [eq_of_length_eq_add_one hi] + rw [toSurreal_succ] + · rw [term_of_lt (by simp [hi])] + · aesop + · rw [Order.lt_add_one_iff] at hi + rw [truncIdx_of_le hi, term_of_le hi, add_zero] + +theorem toSurreal_eq' (x : SurrealHahnSeries) : + toSurreal x = .mk !{toIGame '' truncLT x | toIGame '' truncGT x} := + Surreal.mk_eq <| toIGame_equiv x + +theorem toSurreal_eq (x : SurrealHahnSeries) : + toSurreal x = !{toSurreal '' truncLT x | toSurreal '' truncGT x}'(by + rintro _ ⟨i, hi, rfl⟩ _ ⟨j, hj, rfl⟩ + exact_mod_cast (lt_of_truncLT hi).trans (gt_of_truncGT hj) + ) := by + rw [toSurreal_eq', Surreal.mk_ofSets] + congr <;> aesop + +theorem leadingTerm_sub_truncIdx {x : SurrealHahnSeries} {i : Ordinal} : + Surreal.leadingTerm (x - x.truncIdx i) = x.term i := by + obtain hi | hi := le_or_gt x.length i + · rw [term_of_le hi, truncIdx_of_le hi, sub_self, Surreal.leadingTerm_zero] + · rw [term_of_lt hi] + apply Surreal.leadingTerm_eq (by simpa) <;> refine fun s hs ↦ le_of_lt ?_ + on_goal 1 => rw [lt_sub_iff_add_lt'] + on_goal 2 => rw [sub_lt_iff_lt_add'] + all_goals + rw [← toSurreal_succ (by aesop), toSurreal_lt_toSurreal_iff, lt_def, truncIdx_of_lt hi] + use x.exp ⟨i, hi⟩ + dsimp + refine ⟨fun j hj ↦ ?_, ?_⟩ + · simp only [coeff_add_apply] + rw [coeff_trunc_of_lt hj, coeff_single_of_ne hj.ne] + simp + · rw [coeff_add_apply, coeff_trunc_of_le le_rfl, coeff_single_self, + zero_add, coeff_exp] + exact hs + +theorem birthday_truncIdx_le (x : SurrealHahnSeries) (i : Ordinal) : + Surreal.birthday (x.truncIdx i) ≤ Surreal.birthday x := by + conv_lhs => rw [toSurreal_eq'] + exact (fits_ofSets_truncLT_truncGT ..).birthday_le + +theorem birthday_truncIdx_lt {x : SurrealHahnSeries} {i : Ordinal} (h : i < x.length) : + Surreal.birthday (x.truncIdx i) < Surreal.birthday x := by + conv_lhs => rw [toSurreal_eq'] + apply (fits_ofSets_truncLT_truncGT ..).birthday_lt + grw [← toIGame_equiv, toIGame_equiv_toIGame_iff] + exact (truncIdx_ne h).symm + +theorem birthday_truncIdx_mono (x : SurrealHahnSeries) : + Monotone fun i ↦ Surreal.birthday (truncIdx x i) := by + intro i j h + convert birthday_truncIdx_le (x.truncIdx j) i using 3 + rw [truncIdx_truncIdx, min_eq_right h] + +theorem birthday_truncIdx_strictMonoOn (x : SurrealHahnSeries) : + StrictMonoOn (fun i ↦ Surreal.birthday (truncIdx x i)) (Iio x.length) := by + intro i hi j hj h + convert birthday_truncIdx_lt (x := x.truncIdx j) (i := i) _ using 3 + · rw [truncIdx_truncIdx, min_eq_right h.le] + · simp_all + +theorem birthday_trunc_le (x : SurrealHahnSeries) (i : Surreal) : + Surreal.birthday (x.trunc i) ≤ Surreal.birthday x := by + obtain ⟨j, hj⟩ := trunc_mem_range_truncIdx x i + rw [← hj] + exact birthday_truncIdx_le .. + +theorem birthday_trunc_anti (x : SurrealHahnSeries) : + Antitone fun i ↦ Surreal.birthday (trunc x i) := by + intro i j h + dsimp + convert birthday_trunc_le (x.trunc i) j using 2 + rw [trunc_trunc, max_eq_right h] + +end SurrealHahnSeries + +/-! ### Surreals as Hahn series -/ + +namespace Surreal + +/-- Partial Hahn-series expansions of `x`, ordered by their lengths. -/ +@[ext] +structure PartialSum (x : Surreal) : Type _ where + /-- The underlying `SurrealHahnSeries`. -/ + carrier : SurrealHahnSeries + /-- Every term matches that of `x.toHahnSeries`. -/ + term_eq_leadingTerm_sub {i} (hi : i < carrier.length) : + carrier.term i = (x - carrier.truncIdx i).leadingTerm + +namespace PartialSum +variable {x : Surreal.{u}} + +open SurrealHahnSeries + +instance : Bot (PartialSum x) where + bot := ⟨0, by simp⟩ + +theorem carrier_injective : Function.Injective (carrier (x := x)) := by + intro i j h + ext + rw [h] + +@[simp] +theorem carrier_inj {y z : PartialSum x} : y.carrier = z.carrier ↔ y = z := + carrier_injective.eq_iff + +@[simp] +theorem carrier_bot : carrier (⊥ : PartialSum x) = 0 := + rfl + +/-- The length of the carrier. -/ +def length (y : PartialSum x) : Ordinal := + y.carrier.length + +/-- The length of a partial sum is the length of its Hahn-series carrier. -/ +@[simp] +theorem length_eq_carrier_length (y : PartialSum x) : y.length = y.carrier.length := + (rfl) + +theorem length_bot : length (⊥ : PartialSum x) = 0 := by + simp [length] + +instance : Preorder (PartialSum x) := + .lift length + +instance : WellFoundedLT (PartialSum x) := InvImage.wf length wellFounded_lt + +instance : WellFoundedRelation (PartialSum x) := + ⟨_, wellFounded_lt⟩ + +theorem length_strictMono : StrictMono (length (x := x)) := + fun _ _ ↦ id + +theorem length_lt_length {y z : PartialSum x} : length y < length z ↔ y < z := .rfl +theorem length_le_length {y z : PartialSum x} : length y ≤ length z ↔ y ≤ z := .rfl + +/-- Truncating the series preserves that it is a partial sum. -/ +def truncIdx (y : PartialSum x) (i : Ordinal) : PartialSum x where + carrier := y.carrier.truncIdx i + term_eq_leadingTerm_sub {j} hj := by + have hj' : j < i := hj.trans_le (by simp) + rw [term_truncIdx_of_lt hj', truncIdx_truncIdx, min_eq_right hj'.le] + apply y.term_eq_leadingTerm_sub (hj.trans_le _) + simp + +@[simp] +theorem carrier_truncIdx (y : PartialSum x) (i : Ordinal) : + (y.truncIdx i).carrier = y.carrier.truncIdx i := + (rfl) + +@[grind =] +theorem length_truncIdx (y : PartialSum x) (i : Ordinal) : (y.truncIdx i).length = min i y.length := + y.carrier.length_truncIdx i + +theorem truncIdx_le (y : PartialSum x) (i : Ordinal) : y.truncIdx i ≤ y := + (length_truncIdx ..).trans_le (min_le_right ..) + +@[simp] +theorem truncIdx_truncIdx (y : PartialSum x) (i j : Ordinal) : + (y.truncIdx i).truncIdx j = y.truncIdx (min i j) := + carrier_injective <| SurrealHahnSeries.truncIdx_truncIdx .. + +theorem truncIdx_length (y : PartialSum x) : y.truncIdx y.length = y := by + apply carrier_injective + rw [carrier_truncIdx, truncIdx_of_le] + rfl + +@[simp] +theorem truncIdx_lt_iff {y : PartialSum x} {i : Ordinal} : y.truncIdx i < y ↔ i < y.length := by + simp [← length_lt_length] + +theorem truncIdx_length_of_le {y z : PartialSum x} (h : y ≤ z) : z.truncIdx y.length = y := by + have hlen : y.length ≤ z.length := h + have IH {i} (hi : i < y.length) : (z.truncIdx y.length).truncIdx i = y.truncIdx i := by + have : y.truncIdx i < y := by simpa + convert truncIdx_length_of_le (y := y.truncIdx i) (z := z) _ using 1 + · simp [min_comm] + · exact (truncIdx_le y i).trans h + refine carrier_injective (term_injective <| funext fun i ↦ ?_) + obtain hi | hi := lt_or_ge i y.length + · rw [term_eq_leadingTerm_sub, term_eq_leadingTerm_sub _ hi] + · congr 3 + rw [← carrier_truncIdx, ← carrier_truncIdx, carrier_inj, IH hi] + · rw [← length_eq_carrier_length, length_truncIdx, min_eq_left hlen] + exact hi + · rw [term_of_le, term_of_le hi] + rw [← length_eq_carrier_length, length_truncIdx, min_eq_left hlen] + exact hi +termination_by y + +theorem length_injective : Function.Injective (length (x := x)) := by + intro y z h + rw [← truncIdx_length_of_le h.le, h, truncIdx_length] + +theorem length_inj {y z : PartialSum x} : length y = length z ↔ y = z := + length_injective.eq_iff + +instance : LinearOrder (PartialSum x) where + le_antisymm y z h₁ h₂ := by + rw [← length_inj] + exact h₁.antisymm h₂ + le_total y z := le_total y.length z.length + toDecidableLE := Classical.decRel _ + +theorem exp_lt_exp {y z : PartialSum x} {i : Iio y.carrier.length} {j : Iio z.carrier.length} + (h : i.1 < j.1) : (z.carrier.exp j).1 < (y.carrier.exp i).1 := by + obtain hyz | hyz := le_total y z + all_goals + rw [exp_congr (carrier_inj.2 (truncIdx_length_of_le hyz).symm), + exp_congr (carrier_truncIdx ..), exp_truncIdx] + simpa + +theorem term_congr {y z : PartialSum x} {i : Ordinal} (hy : i < y.length) (hz : i < z.length) : + term y.carrier i = term z.carrier i := by + obtain hyz | hyz := le_total y z <;> + rwa [← truncIdx_length_of_le hyz, carrier_truncIdx, term_truncIdx_of_lt] + +theorem exp_congr {y z : PartialSum x} {i : Ordinal} (hy : i < y.length) (hz : i < z.length) : + (exp y.carrier ⟨i, by rwa [← length_eq_carrier_length]⟩).1 = + exp z.carrier ⟨i, by rwa [← length_eq_carrier_length]⟩ := by + simp_rw [← wlog_term, term_congr hy hz] + +theorem birthday_strictMono : StrictMono fun y : PartialSum x ↦ birthday y.carrier := by + intro y z h + dsimp + rw [← truncIdx_length_of_le h.le] + exact birthday_truncIdx_lt h + +theorem birthday_le (y : PartialSum x) : birthday y.carrier ≤ birthday x := by + cases x with | mk z + rw [toSurreal_eq'] + apply Fits.birthday_le + unfold truncLT truncGT + constructor + all_goals + rw [moves_ofSets, forall_mem_image, forall_mem_truncAux] + intro i hi r hr + grw [Numeric.not_le, toIGame_succ_equiv (by simp), add_comm] + first | rw [← IGame.lt_sub_iff_add_lt] | rw [← IGame.sub_lt_iff_lt_add] + rw [← Surreal.mk_lt_mk] + apply leadingTerm_mono.reflect_lt + obtain ⟨⟨i, hi'⟩, rfl⟩ := eq_exp_of_mem_support hi + rw [mk_sub, mk_toIGame, trunc_exp, ← term_eq_leadingTerm_sub _ hi', term_of_lt hi'] + simpa using hr + +instance : Small.{u} (PartialSum x) := by + refine small_of_injective (β := Iic x.birthday) (f := fun y ↦ ⟨_, birthday_le y⟩) fun y z h ↦ + birthday_strictMono.injective ?_ + exact congrArg Subtype.val h + +/-- The term sequence obtained as the supremum of a set of partial Hahn-series expansions. -/ +@[expose] +def sSupAux (s : Set (PartialSum x)) : TermSeq where + length := ⨆ x : s, x.1.length + exp i := + haveI H := (lt_ciSup_iff' Ordinal.bddAbove_of_small).1 i.2 + exp (Classical.choose H).1.1 ⟨_, by + rw [← length_eq_carrier_length] + exact Classical.choose_spec H⟩ + coeff i := + haveI H := (lt_ciSup_iff' Ordinal.bddAbove_of_small).1 i.2 + coeffIdx (Classical.choose H).1.1 i + exp_strictAnti _ _ h := exp_lt_exp h + coeff_ne_zero i := by + generalize_proofs H + rw [ne_eq, coeffIdx_eq_zero_iff, not_le, ← length_eq_carrier_length] + exact Classical.choose_spec H + +@[simp] +theorem length_sSupAux (s : Set (PartialSum x)) : + (sSupAux s).length = ⨆ x : s, x.1.length := + (rfl) + +private theorem term_sSupAux {s : Set (PartialSum x)} {y : PartialSum x} + {i : Ordinal} (hs : i < (sSupAux s).length) (hi : i < y.length) : + term (sSupAux s) i = term y.carrier i := by + have hs' : i < ⨆ x : s, x.1.length := by + rw [← length_sSupAux] + exact hs + unfold sSupAux + generalize_proofs _ H _ + rw [TermSeq.term_coe_of_lt hs', ← term_of_lt (H ⟨i, hs'⟩), + term_congr (by + rw [length_eq_carrier_length] + exact H ⟨i, hs'⟩) hi] + +private theorem truncIdx_sSupAux {s : Set (PartialSum x)} {y : PartialSum x} + {i : Ordinal} (hs : i < (sSupAux s).length) (hy : i < y.length) : + .truncIdx (sSupAux s) i = y.carrier.truncIdx i := by + refine term_injective <| funext fun j ↦ ?_ + obtain hj | hj := lt_or_ge j i + · rw [term_truncIdx_of_lt hj, term_truncIdx_of_lt hj, term_sSupAux (hj.trans hs) (hj.trans hy)] + · rw [term_truncIdx_of_le hj, term_truncIdx_of_le hj] + +/-- Directed union of partial sums. -/ +instance : SupSet (PartialSum x) where + sSup s := ⟨sSupAux s, fun hi ↦ by + have hi' := TermSeq.length_coe (sSupAux s) ▸ hi + obtain ⟨⟨y, hy⟩, hy'⟩ := (lt_ciSup_iff' Ordinal.bddAbove_of_small).1 hi' + rw [truncIdx_sSupAux hi' hy', term_sSupAux hi' hy', term_eq_leadingTerm_sub _ hy'] + ⟩ + +theorem length_sSup (s : Set (PartialSum x)) : (sSup s).length = ⨆ x : s, x.1.length := + TermSeq.length_coe (sSupAux s) + +instance : CompleteSemilatticeSup (PartialSum x) where + __ := instLinearOrder + __ := instSupSet + isLUB_sSup s := ⟨ + fun y hy ↦ by + rw [← length_le_length, length_sSup] + exact le_ciSup Ordinal.bddAbove_of_small (⟨y, hy⟩ : s), + fun y hy ↦ by + rw [← length_le_length, length_sSup, ciSup_le_iff' Ordinal.bddAbove_of_small] + intro a + have ha := hy a.2 + change a.1.length ≤ y.length at ha + exact ha⟩ + +instance : CompleteLattice (PartialSum x) := + completeLatticeOfCompleteSemilatticeSup _ + +instance : CompleteLinearOrder (PartialSum x) where + __ := LinearOrder.toBiheytingAlgebra _ + __ := instCompleteLattice + __ := instLinearOrder + +theorem leadingTerm_sub {y z : PartialSum x} (h : y < z) : + (x - y.carrier).leadingTerm = leadingTerm (z.carrier - y.carrier) := by + rw [← truncIdx_length_of_le h.le, carrier_truncIdx, ← z.term_eq_leadingTerm_sub h, + leadingTerm_sub_truncIdx] + +theorem mk_sub {y z : PartialSum x} (h : y < z) : + ArchimedeanClass.mk (x - y.carrier) = .mk (z.carrier - y.carrier) := by + rw [← mk_leadingTerm, leadingTerm_sub h, mk_leadingTerm] + +theorem mk_le_mk_of_sub {x y : Surreal} (h : ArchimedeanClass.mk x ≤ ArchimedeanClass.mk (x - y)) : + ArchimedeanClass.mk x ≤ .mk y := by + simpa using ArchimedeanClass.mk_left_le_mk_sub h + +theorem mk_sub_strictMono : + StrictMono fun y : PartialSum x ↦ ArchimedeanClass.mk (x - y.carrier) := by + intro y z h + obtain ⟨z, hz⟩ := z + dsimp at * + induction hz' : z.length using SuccOrder.prelimitRecOn generalizing y z with + | succ i _ IH => + have hi : i < z.length := by simp [hz'] + have H : ArchimedeanClass.mk (x - z.truncIdx i) < .mk (x - z) := by + conv_rhs => rw [toSurreal_of_length_le_add_one hz'.le, ← sub_sub] + rw [hz hi] + apply mk_lt_mk_sub_leadingTerm + rwa [ne_eq, ← leadingTerm_eq_zero, ← hz hi, term_eq_zero, not_le] + rw [← length_lt_length] at h + have hy := h.trans_eq hz' + rw [Order.lt_succ_iff] at hy + obtain hy | hy := hy.eq_or_lt + · obtain rfl := hy ▸ truncIdx_length_of_le h.le + exact H + · apply (IH _ (truncIdx ⟨z, hz⟩ i).2 (hy.trans_eq _) _).trans H <;> simp [length, hz'] + | isSuccPrelimit i hi IH => + subst hz' + have hi' := hi.add_one_lt h + apply (IH _ hi' _ (truncIdx ⟨z, hz⟩ (y.length + 1)).2 _ _).trans_le + · apply mk_le_mk_of_sub + simp_rw [sub_sub_sub_cancel_left, ← mk_leadingTerm (_ - _)] + rw [carrier_truncIdx] + rwa [← hz, ← leadingTerm_sub_truncIdx] + · rw [← length_lt_length] + simpa [length] + · simpa + +theorem wlog_sub_lt {y : PartialSum x} (h : x ≠ y.carrier) (i) : + (x - y.carrier).wlog < y.carrier.exp i := by + obtain ⟨i, hi⟩ := i + have hi' : (y.truncIdx i).length = i := by simpa using hi.le + have hy := hi' ▸ hi + rw [← wlog_term, term_eq_leadingTerm_sub _ hi, ← carrier_truncIdx, wlog_leadingTerm] + exact wlog_lt_wlog_of_vlt (by simpa [sub_eq_zero]) (vlt_def.2 <| mk_sub_strictMono hy) + +/-- Extend a partial sum by the leading term of its remaining difference from the target surreal +number. -/ +@[expose] +def succ' (y : PartialSum x) : PartialSum x where + carrier := y.carrier + single (x - y.carrier).wlog (x - y.carrier).leadingCoeff + term_eq_leadingTerm_sub {j} hj := by + obtain hx | hx := eq_or_ne x y.carrier + · simp_all [y.term_eq_leadingTerm_sub] + obtain ⟨y, hy⟩ := y + induction y using termSeqRecOn with | mk s + have hr : (x - ↑↑s).leadingCoeff ≠ 0 := by simpa [sub_eq_zero] + have he : ∀ i, (x - s).wlog < s.exp i := by simpa using wlog_sub_lt hx + rw [← TermSeq.coe_appendSingle hr he] at ⊢ hj + rw [TermSeq.length_coe, TermSeq.appendSingle_length, Order.lt_add_one_iff] at hj + rw [TermSeq.term_coe_of_lt (by simpa), TermSeq.appendSingle_coeff, + ← TermSeq.coe_trunc, TermSeq.trunc_appendSingle hj] + split_ifs with h + · subst h + simp [leadingTerm] + · have hj : j < s.length := hj.lt_of_ne h + rw [TermSeq.coe_trunc, ← hy (by simpa), term_of_lt (by simpa), TermSeq.coeffIdx_coe_of_lt hj] + grind + +private theorem length_succ'_of_ne {y : PartialSum x} (h : x ≠ y.carrier) : + (succ' y).length = y.length + 1 := by + have h' : ¬ x - y.carrier = 0 := by rwa [sub_eq_zero] + apply length_add_single + · intro i hi + obtain ⟨⟨i, hi⟩, rfl⟩ := eq_exp_of_mem_support hi + exact wlog_sub_lt h _ + · rwa [ne_eq, leadingCoeff_eq_zero] + +variable (x) in +/-- The longest partial sum is the one that we're looking for. -/ +theorem coe_carrier_top : (⊤ : PartialSum x).carrier = x := by + by_contra! h + apply (le_top (a := succ' ⊤)).not_gt + rw [← length_lt_length, length_succ'_of_ne h.symm, Order.lt_add_one_iff] + +instance : SuccOrder (PartialSum x) := + .ofCore succ' (by + intro y hy z + rw [isMax_iff_eq_top] at hy + rw [← length_lt_length, ← length_le_length, length_succ'_of_ne, Order.add_one_le_iff] + contrapose! hy + rwa [← carrier_inj, ← toSurreal_inj, coe_carrier_top, eq_comm] + ) (by simp [succ', coe_carrier_top]) + +theorem length_succ_of_ne_top (y : PartialSum x) (h : y ≠ ⊤) : + (succ y).length = y.length + 1 := by + apply length_succ'_of_ne + conv_lhs => rw [← coe_carrier_top x] + rwa [ne_eq, toSurreal_inj, carrier_inj, eq_comm] + +theorem term_succ_length (y : PartialSum x) : + (succ y).carrier.term y.length = (x - y.carrier).leadingTerm := by + obtain rfl | hy := eq_top_or_lt_top y + · rw [succ_top, coe_carrier_top, term_of_le] + · simp + · rfl + · rw [term_eq_leadingTerm_sub] + · rw [← carrier_truncIdx, truncIdx_length_of_le] + exact le_succ y + · exact lt_succ_of_not_isMax hy.not_isMax + +end PartialSum + +variable {x y : Surreal} + +/-- The **Conway normal form** of a surreal number. -/ +@[coe] +def toHahnSeries (x : Surreal) : SurrealHahnSeries := + (⊤ : PartialSum x).carrier + +@[simp] +theorem toSurreal_toHahnSeries (x : Surreal) : x.toHahnSeries = x := + PartialSum.coe_carrier_top x + +@[simp] +theorem PartialSum.carrier_top (x : Surreal) : (⊤ : PartialSum x).carrier = x.toHahnSeries := + (rfl) + +@[simp] +theorem _root_.SurrealHahnSeries.toHahnSeries_toSurreal (x : SurrealHahnSeries) : + x.toSurreal.toHahnSeries = x := by + apply SurrealHahnSeries.toSurreal_strictMono.injective + rw [toSurreal_toHahnSeries] + +/-- `Surreal.toHahnSeries` as an `OrderIso`. -/ +@[simps!, expose] +def toHahnSeriesOrderIso : Surreal ≃o SurrealHahnSeries := + .symm { + toFun := SurrealHahnSeries.toSurreal + invFun := toHahnSeries + left_inv := SurrealHahnSeries.toHahnSeries_toSurreal + right_inv := toSurreal_toHahnSeries + map_rel_iff' := SurrealHahnSeries.toSurreal_le_toSurreal_iff + } + +theorem toHahnSeries_strictMono : StrictMono toHahnSeries := + toHahnSeriesOrderIso.strictMono + +@[simp, norm_cast] +theorem toHahnSeries_lt_toHahnSeries_iff : toHahnSeries x < toHahnSeries y ↔ x < y := + toHahnSeries_strictMono.lt_iff_lt + +@[simp, norm_cast] +theorem toHahnSeries_le_toHahnSeries_iff : toHahnSeries x ≤ toHahnSeries y ↔ x ≤ y := + toHahnSeries_strictMono.le_iff_le + +@[simp, norm_cast] +theorem toHahnSeries_inj : toHahnSeries x = toHahnSeries y ↔ x = y := + toHahnSeries_strictMono.injective.eq_iff + +theorem toHahnSeries_eq {x : Surreal} {y : SurrealHahnSeries} + (h : y.toSurreal = x) : toHahnSeries x = y := by + rw [← h, y.toHahnSeries_toSurreal] + +@[simp, norm_cast] +theorem toHahnSeries_realCast (r : ℝ) : toHahnSeries r = .single 0 r := + toHahnSeries_eq (by simp) + +@[simp, norm_cast] +theorem toHahnSeries_ratCast (q : ℚ) : toHahnSeries q = .single 0 q := + mod_cast toHahnSeries_realCast q + +@[simp, norm_cast] +theorem toHahnSeries_intCast (n : ℤ) : toHahnSeries n = .single 0 n := + mod_cast toHahnSeries_realCast n + +@[simp, norm_cast] +theorem toHahnSeries_natCast (n : ℕ) : toHahnSeries n = .single 0 n := + mod_cast toHahnSeries_realCast n + +@[simp, norm_cast] +theorem toHahnSeries_zero : toHahnSeries 0 = 0 := by + simpa using toHahnSeries_natCast 0 + +@[simp] +theorem toHahnSeries_wpow (x : Surreal) : toHahnSeries (ω^ x) = .single x 1 := + toHahnSeries_eq (by simp) + +@[simp, norm_cast] +theorem toHahnSeries_eq_zero {x : Surreal} : toHahnSeries x = 0 ↔ x = 0 := by + rw [← toHahnSeries_zero, toHahnSeries_inj] + +end Surreal diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/HahnSeries/NormalFormAdd.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/HahnSeries/NormalFormAdd.lean new file mode 100644 index 0000000000..c0110d622f --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/HahnSeries/NormalFormAdd.lean @@ -0,0 +1,393 @@ +/- +Copyright (c) 2026 Violeta Hernández Palacios. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Violeta Hernández Palacios +-/ +module + +public import Mathlib.Algebra.Order.Hom.Monoid +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.HahnSeries.Transfer +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.Round + +/-! +# Additive compatibility of the surreal Conway normal form + +This module proves that the Conway normal-form order equivalence preserves addition. The argument +follows the additive part of CombinatorialGames PR #263 and fills its unfinished proof obligations +against the pinned dependency. The construction is based on pages 429–431 of Siegel. +-/ + +universe u + +public noncomputable section + +namespace Surreal + +open ArchimedeanClass Order Set SurrealHahnSeries + +namespace PartialSum + +variable {x y : Surreal} (h : x.support ⊆ Ioi y.wlog) + +/-- The Conway series of `x`, regarded as a partial sum of `x + y` when every exponent of `x` +strictly exceeds the leading exponent of `y`. -/ +def ofAdd (x y : Surreal) (h : x.support ⊆ Ioi y.wlog) : PartialSum (x + y) where + carrier := x.toHahnSeries + term_eq_leadingTerm_sub {j} hj := by + rw [← leadingTerm_sub_truncIdx, toSurreal_toHahnSeries] + obtain rfl | hy' := eq_or_ne y 0 + · simp + rw [add_sub_right_comm, leadingTerm_add_eq_left] + nth_rw 1 [← toSurreal_toHahnSeries x] + rw [vlt_def, ← mk_leadingTerm, leadingTerm_sub_truncIdx, mk_term hj, ← vlt_def, + ← wlog_lt_wlog_iff hy' (wpow_ne_zero _), wlog_wpow] + apply h + rw [← support_toHahnSeries] + exact (x.toHahnSeries.exp ⟨j, hj⟩).2 + +@[simp] +theorem carrier_ofAdd : (ofAdd x y h).carrier = x.toHahnSeries := + (rfl) + +theorem length_ofAdd : (ofAdd x y h).length = x.length := by + rw [length_eq_carrier_length, carrier_ofAdd, length_toHahnSeries] + +theorem truncIdx_top_add_length {x y : Surreal} + (h : x.support ⊆ Ioi y.wlog) : + (⊤ : PartialSum (x + y)).truncIdx x.length = ofAdd x y h := + by + rw [← length_ofAdd h] + exact PartialSum.truncIdx_length_of_le (y := ofAdd x y h) le_top + +@[simp] +theorem term_succ_ofAdd_length {x y : Surreal} (h : x.support ⊆ Ioi y.wlog) : + (succ (ofAdd x y h)).carrier.term x.length = y.leadingTerm := by + rw [← length_ofAdd h, term_succ_length, carrier_ofAdd, + toSurreal_toHahnSeries, add_sub_cancel_left] + +end PartialSum + +private theorem truncIdx_add_length_of_subset {x y : Surreal} + (hx : x.support ⊆ Ioi y.wlog) : (x + y).toHahnSeries.truncIdx x.length = x := by + have h := congrArg PartialSum.carrier (PartialSum.truncIdx_top_add_length hx) + have h' := congrArg SurrealHahnSeries.toSurreal h + simpa using h' + +private theorem le_length_add_of_subset {x y : Surreal} + (hx : x.support ⊆ Ioi y.wlog) : x.length ≤ (x + y).length := by + conv_lhs => rw [← truncIdx_add_length_of_subset hx] + simp + +open PartialSum in +private theorem lt_length_add_of_subset {x y : Surreal} + (hx : x.support ⊆ Ioi y.wlog) (hy : y ≠ 0) : x.length < (x + y).length := by + apply (le_length_add_of_subset hx).lt_of_ne + rw [← PartialSum.length_ofAdd hx, ← PartialSum.length_top] + rw [ne_eq, length_inj] + apply_fun carrier + simpa + +private theorem term_add_length_of_subset {x y : Surreal} + (hx : x.support ⊆ Ioi y.wlog) (hy : y ≠ 0) : + (x + y).toHahnSeries.term x.length = y.leadingTerm := by + have hl := lt_length_add_of_subset hx hy + have htop : x.length < (⊤ : PartialSum (x + y)).length := by + simpa using hl + have hbase : PartialSum.ofAdd x y hx < (⊤ : PartialSum (x + y)) := by + rw [← PartialSum.length_lt_length, PartialSum.length_ofAdd, + PartialSum.length_top] + exact hl + have hs : x.length < (succ (PartialSum.ofAdd x y hx)).length := by + rw [← PartialSum.length_ofAdd hx] + exact lt_succ_of_not_isMax hbase.not_isMax + calc + (x + y).toHahnSeries.term x.length = + (⊤ : PartialSum (x + y)).carrier.term x.length := + congrArg (fun q : SurrealHahnSeries ↦ q.term x.length) + (PartialSum.carrier_top (x + y)).symm + _ = (succ (PartialSum.ofAdd x y hx)).carrier.term x.length := + PartialSum.term_congr htop hs + _ = y.leadingTerm := PartialSum.term_succ_ofAdd_length hx + +private theorem exp_add_length_of_subset {x y : Surreal} + (hx : x.support ⊆ Ioi y.wlog) (hy : y ≠ 0) : + ↑((x + y).toHahnSeries.exp ⟨x.length, by + simpa using lt_length_add_of_subset hx hy⟩) = y.wlog := by + rw [← SurrealHahnSeries.wlog_term, term_add_length_of_subset hx hy, + wlog_leadingTerm] + +open PartialSum in +private theorem trunc_add_of_subset {x y i : Surreal} + (hx : x.support ⊆ Ioi i) (hy : y ≤ᵥ ω^ i) : (x + y).trunc i = x := by + obtain rfl | hy' := eq_or_ne y 0 + · rw [add_zero] + exact trunc_eq_self hx + have hy'' : y.wlog ≤ i := by + simpa using wlog_le_wlog_of_vle hy' hy + have hx' : x.support ⊆ Ioi y.wlog := hx.trans (by simpa) + have hl := lt_length_add_of_subset hx' hy' + have hl' : x.length < (x + y).toHahnSeries.length := by + simpa using hl + conv_rhs => rw [← truncIdx_add_length_of_subset hx'] + rw [truncIdx_of_lt hl'] + rw [SurrealHahnSeries.toSurreal_trunc] + rw [toSurreal_toHahnSeries] + let e : Surreal := ↑((x + y).toHahnSeries.exp ⟨x.length, hl'⟩) + have he : e = y.wlog := by + exact exp_add_length_of_subset hx' hy' + apply (trunc_eq_trunc (he.le.trans hy'') _).symm + intro k hek hki + apply notMem_support_iff.mp + intro hk + have hkTrunc : k ∈ ((x + y).trunc e).support := by + rw [support_trunc] + exact ⟨hk, hek⟩ + have htrunc : (x + y).trunc e = x := by + nth_rw 1 [← toSurreal_toHahnSeries (x + y)] + rw [← SurrealHahnSeries.toSurreal_trunc, ← truncIdx_of_lt hl', + truncIdx_add_length_of_subset hx'] + have hkx : k ∈ x.support := by + rwa [htrunc] at hkTrunc + exact (not_lt_of_ge hki) (hx hkx) + +private theorem coeff_add_of_subset {x y i : Surreal} + (hx : x.support ⊆ Ioi i) (hy : y ≤ᵥ ω^ i) : + (x + y).coeff i = stdPart (y / ω^ i) := by + obtain rfl | hy' := eq_or_ne y 0 + · simp only [add_zero, zero_div, stdPart_zero] + apply notMem_support_iff.mp + intro hi + exact (lt_irrefl i) (hx hi) + have hylog : y.wlog ≤ i := by + simpa using wlog_le_wlog_of_vle hy' hy + obtain heq | hlt := hylog.eq_or_lt + · subst i + have hexp := exp_add_length_of_subset hx hy' + rw [← coeff_toHahnSeries, ← hexp, SurrealHahnSeries.coeff_exp, + ← SurrealHahnSeries.leadingCoeff_term, + term_add_length_of_subset hx hy', leadingCoeff_leadingTerm, leadingCoeff, + hexp] + · have hxlog : x.support ⊆ Ioi y.wlog := fun _ hk ↦ hlt.trans (hx hk) + have htrunc : (x + y).trunc y.wlog = x := + trunc_add_of_subset hxlog (wpow_wlog_veq hy').symm.1 + have hcoeff : (x + y).coeff i = 0 := by + apply notMem_support_iff.mp + intro hi + have hiTrunc : i ∈ ((x + y).trunc y.wlog).support := by + rw [support_trunc] + exact ⟨hi, hlt⟩ + rw [htrunc] at hiTrunc + exact (lt_irrefl i) (hx hiTrunc) + rw [hcoeff] + symm + rw [stdPart_eq_zero] + apply ne_of_gt + rw [ArchimedeanClass.mk_div, LinearOrderedAddCommGroupWithTop.sub_pos] + left + apply vlt_def.mp + rw [← wlog_lt_wlog_iff hy' (wpow_ne_zero _), wlog_wpow] + exact hlt + +private theorem sub_trunc_vle_wpow (x i : Surreal) : x - x.trunc i ≤ᵥ ω^ i := by + let s := x.toHahnSeries + obtain ⟨j, hj⟩ := SurrealHahnSeries.trunc_mem_range_truncIdx s i + have hsx : s.toSurreal = x := by + simp [s] + have htr : (s.trunc i).toSurreal = x.trunc i := by + rw [SurrealHahnSeries.toSurreal_trunc, hsx] + have hlead : (x - x.trunc i).leadingTerm = s.term j := by + calc + (x - x.trunc i).leadingTerm = + (s.toSurreal - (s.truncIdx j).toSurreal).leadingTerm := by + rw [hsx, hj, htr] + _ = s.term j := SurrealHahnSeries.leadingTerm_sub_truncIdx + obtain hjlen | hjlen := lt_or_ge j s.length + · have hexpLe : ↑(s.exp ⟨j, hjlen⟩) ≤ i := by + by_contra hle + have hiExp : i < ↑(s.exp ⟨j, hjlen⟩) := lt_of_not_ge hle + have hmem : ↑(s.exp ⟨j, hjlen⟩) ∈ (s.trunc i).support := by + rw [SurrealHahnSeries.support_trunc] + exact ⟨(s.exp ⟨j, hjlen⟩).2, hiExp⟩ + rw [← hj, SurrealHahnSeries.support_truncIdx, dite_eq_left hjlen] at hmem + have hfalse : ↑(s.exp ⟨j, hjlen⟩) < ↑(s.exp ⟨j, hjlen⟩) := by + simpa using hmem.2 + exact (lt_irrefl _) hfalse + have hrem : x - x.trunc i ≠ 0 := by + intro hzero + have htermNe : s.term j ≠ 0 := by + rw [ne_eq, SurrealHahnSeries.term_eq_zero, not_le] + exact hjlen + apply htermNe + rw [← hlead, hzero, leadingTerm_zero] + rw [← wlog_le_wlog_iff hrem (wpow_ne_zero _), wlog_wpow, + ← wlog_leadingTerm, hlead, SurrealHahnSeries.wlog_term hjlen] + exact hexpLe + · have hzero : x - x.trunc i = 0 := by + rw [← leadingTerm_eq_zero, hlead, SurrealHahnSeries.term_of_le hjlen] + simp [hzero] + +/-- A Conway coefficient is the standard part of the remainder after truncation, divided by its +corresponding monomial. -/ +theorem coeff_eq_stdPart {x i : Surreal} : + x.coeff i = stdPart ((x - x.trunc i) / ω^ i) := by + conv_lhs => rw [← add_sub_cancel (x.trunc i) x] + apply coeff_add_of_subset + · simp + · exact sub_trunc_vle_wpow x i + +theorem support_subset_of_round_eq {x y : Surreal} (hx : x.round y = x) (hy : 0 < y) : + x.support ⊆ Ici y.wlog := by + intro z hzy + rw [mem_Ici] + contrapose! hzy + intro hz + have hz' : z ∈ x.toHahnSeries.support := by + simpa using hz + obtain ⟨i, rfl⟩ := SurrealHahnSeries.eq_exp_of_mem_support hz' + have H : ArchimedeanClass.mk y < .mk (x - x.toHahnSeries.truncIdx i) := by + nth_rw 1 [← toSurreal_toHahnSeries x] + conv_rhs => rw [← mk_leadingTerm, SurrealHahnSeries.leadingTerm_sub_truncIdx, + SurrealHahnSeries.mk_term i.2] + rw [← vlt_def, ← wlog_lt_wlog_iff (by simp) hy.ne'] + simpa + refine (@birthday_round_le x (x.toHahnSeries.truncIdx i) y ⟨?_, ?_⟩).not_gt ?_ + · rw [sub_lt_comm] + exact lt_of_mk_lt_mk_of_nonneg H hy.le + · rw [← sub_lt_iff_lt_add'] + apply lt_of_mk_lt_mk_of_nonneg _ hy.le + rwa [mk_sub_comm] + · apply (SurrealHahnSeries.birthday_truncIdx_lt i.2).trans_eq + simp [hx] + +theorem support_subset_of_round_wpow_eq {x y : Surreal} (h : x.round (ω^ y) = x) : + x.support ⊆ Ici y := by + simpa using support_subset_of_round_eq h + +theorem eq_round_of_support_subset {x y : Surreal} + (hx : x.support ⊆ Ioi y.wlog) (hy : 0 < y) : x.round y = x := by + apply round_eq_of_forall_birthday_le + · simpa + · intro w hw + convert SurrealHahnSeries.birthday_trunc_le w.toHahnSeries y.wlog + · symm + rw [SurrealHahnSeries.toSurreal_trunc, toSurreal_toHahnSeries] + calc + w.trunc y.wlog = (x + (w - x)).trunc y.wlog := by + congr 2 + abel + _ = x := trunc_add_of_subset hx <| by + have habs : |w - x| < y := by + rw [abs_lt] + constructor <;> linarith [hw.1, hw.2] + apply ValuativeRel.vle_trans _ (wpow_wlog_veq hy.ne').symm.1 + rw [vle_def] + exact ArchimedeanClass.mk_le_mk_of_abs (by simpa [abs_of_pos hy] using habs.le) + · exact (toSurreal_toHahnSeries w).symm + +theorem eq_round_wpow_of_support_subset {x y : Surreal} (hx : x.support ⊆ Ioi y) : + x.round (ω^ y) = x := + eq_round_of_support_subset (by simpa) (by simp) + +private theorem support_add_subset_Ioi {x y z : Surreal} + (hx : x.support ⊆ Ioi z) (hy : y.support ⊆ Ioi z) : (x + y).support ⊆ Ioi z := by + apply (support_subset_of_round_wpow_eq (y := !{{z} | x.support ∪ y.support}) _).trans + · aesop + · apply round_add_of_eq + all_goals + refine eq_round_wpow_of_support_subset fun w hw ↦ ?_ + aesop + +/-- The Conway normal-form order equivalence preserves addition. -/ +@[simp] +theorem toHahnSeries_add (x y : Surreal) : + (x + y).toHahnSeries = x.toHahnSeries + y.toHahnSeries := by + ext i + rw [coeff_toHahnSeries, SurrealHahnSeries.coeff_add_apply] + trans ((x.trunc i + y.trunc i) + + ((x - x.trunc i) + (y - y.trunc i))).coeff i + · abel_nf + · rw [coeff_add_of_subset, add_div, stdPart_add] + · rw [coeff_toHahnSeries x, coeff_toHahnSeries y, coeff_eq_stdPart, + coeff_eq_stdPart] + · rw [ArchimedeanClass.mk_div] + obtain heq | hlt := (vle_def.mp (sub_trunc_vle_wpow x i)).eq_or_lt + · rw [heq] + exact LinearOrderedAddCommGroupWithTop.sub_self_nonneg + · exact (LinearOrderedAddCommGroupWithTop.sub_pos.mpr (Or.inl hlt)).le + · rw [ArchimedeanClass.mk_div] + obtain heq | hlt := (vle_def.mp (sub_trunc_vle_wpow y i)).eq_or_lt + · rw [heq] + exact LinearOrderedAddCommGroupWithTop.sub_self_nonneg + · exact (LinearOrderedAddCommGroupWithTop.sub_pos.mpr (Or.inl hlt)).le + · apply support_add_subset_Ioi <;> simp + · apply ValuativeRel.vle_add <;> exact sub_trunc_vle_wpow _ _ + +/-- Conway coefficients are additive. -/ +@[simp] +theorem coeff_add (x y : Surreal) : (x + y).coeff = x.coeff + y.coeff := by + rw [← coeff_toHahnSeries, toHahnSeries_add, + SurrealHahnSeries.coeff_add, coeff_toHahnSeries, coeff_toHahnSeries] + +/-- The Conway support of a sum is contained in the union of the two source supports. -/ +theorem support_add_subset {x y : Surreal} : + (x + y).support ⊆ x.support ∪ y.support := by + intro i hi + have hi' : i ∈ (x.toHahnSeries + y.toHahnSeries).support := by + rw [← toHahnSeries_add] + simpa only [support_toHahnSeries] using hi + have hout := SurrealHahnSeries.support_add_subset hi' + simpa only [support_toHahnSeries] using hout + +/-- The Conway normal form as an order-preserving additive equivalence. -/ +def toHahnSeriesOrderAddMonoidIso : Surreal ≃+o SurrealHahnSeries where + toEquiv := toHahnSeriesOrderIso.toEquiv + map_add' := toHahnSeries_add + map_le_map_iff' := toHahnSeries_le_toHahnSeries_iff + +@[simp] +theorem toHahnSeriesOrderAddMonoidIso_apply (x : Surreal) : + toHahnSeriesOrderAddMonoidIso x = x.toHahnSeries := + (rfl) + +@[simp] +theorem toHahnSeriesOrderAddMonoidIso_symm_apply (x : SurrealHahnSeries) : + toHahnSeriesOrderAddMonoidIso.symm x = x.toSurreal := + (rfl) + +/-- The Conway normal form of one is the singleton series at exponent zero. -/ +@[simp] +theorem toHahnSeries_one : (1 : Surreal).toHahnSeries = .single 0 1 := by + simpa using toHahnSeries_realCast (1 : ℝ) + +/-- The Conway coefficient function of one is supported at exponent zero. -/ +@[simp] +theorem coeff_one : (1 : Surreal).coeff = Pi.single 0 1 := by + rw [← coeff_toHahnSeries, toHahnSeries_one, SurrealHahnSeries.coeff_single] + +/-- Negation of a surreal number agrees with coefficientwise negation of its Conway normal form. -/ +@[simp] +theorem toHahnSeries_neg (x : Surreal) : (-x).toHahnSeries = -x.toHahnSeries := by + apply eq_neg_of_add_eq_zero_left + rw [← toHahnSeries_add, neg_add_cancel, toHahnSeries_zero] + +/-- Conway coefficients commute with negation. -/ +@[simp] +theorem coeff_neg (x : Surreal) : (-x).coeff = -x.coeff := by + rw [← coeff_toHahnSeries, toHahnSeries_neg, + SurrealHahnSeries.coeff_neg, coeff_toHahnSeries] + +/-- Addition of surreal Hahn series agrees with addition of their surreal values. -/ +@[simp] +theorem _root_.SurrealHahnSeries.toSurreal_add (x y : SurrealHahnSeries) : + (x + y).toSurreal = x.toSurreal + y.toSurreal := + toHahnSeriesOrderAddMonoidIso.symm.map_add x y + +/-- Negation of a surreal Hahn series agrees with negation of its surreal value. -/ +@[simp] +theorem _root_.SurrealHahnSeries.toSurreal_neg (x : SurrealHahnSeries) : + (-x).toSurreal = -x.toSurreal := + eq_neg_of_add_eq_zero_left <| by + rw [← SurrealHahnSeries.toSurreal_add, neg_add_cancel, + SurrealHahnSeries.toSurreal_zero] + +end Surreal diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/HahnSeries/NormalFormBasic.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/HahnSeries/NormalFormBasic.lean new file mode 100644 index 0000000000..723bb36cbc --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/HahnSeries/NormalFormBasic.lean @@ -0,0 +1,263 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov, Violeta Hernández Palacios +-/ +module + +public import LeanPool.ConwayRefinement.CombinatorialGames.Surreal.HahnSeries.Basic + +/-! +# Ordinal-indexed presentations of surreal Hahn series + +This module supplies the sequence presentation used in the Conway normal-form construction. It +follows CombinatorialGames PR #316 by Violeta Hernández Palacios, adapted as a downstream module +so the pinned dependency remains unchanged. +-/ + +universe u + +public noncomputable section + +instance {α β : Type*} {r : α → α → Prop} {s} [IsWellOrder β s] : + Subsingleton (r ≃r s) where + allEq f g := by + ext x + change f.toInitialSeg x = g.toInitialSeg x + congr 1 + subsingleton + +open Order Set + +namespace SurrealHahnSeries + +open Ordinal + +/-- Vanishing of a coefficient is nonmembership in the support. -/ +theorem notMem_support_iff {x : SurrealHahnSeries} {i : Surreal} : + i ∉ x.support ↔ x.coeff i = 0 := + mem_support_iff.not_left + +/-! ### Assemble Hahn series from sequences -/ + +/-- An ordinal-indexed strictly decreasing sequence of exponents with bundled coefficients. -/ +structure TermSeq : Type (u + 1) where + /-- The length of the sequence. -/ + protected length : Ordinal.{u} + /-- The exponents in the sequence. -/ + protected exp : Iio length → Surreal.{u} + /-- The coefficients in the sequence. -/ + protected coeff : Iio length → ℝ + /-- The sequence of exponents must be strictly antitone. -/ + exp_strictAnti : StrictAnti exp + /-- All of the coefficients must be non-zero. -/ + coeff_ne_zero (i) : coeff i ≠ 0 + +namespace TermSeq + +attribute [simp, grind .] coeff_ne_zero + +@[ext] +theorem ext {s t : TermSeq} (hl : s.length = t.length) + (he : ∀ i (hs : i ∈ Iio s.length) (ht : i ∈ Iio t.length), s.exp ⟨i, hs⟩ = t.exp ⟨i, ht⟩) + (hc : ∀ i (hs : i ∈ Iio s.length) (ht : i ∈ Iio t.length), s.coeff ⟨i, hs⟩ = t.coeff ⟨i, ht⟩) : + s = t := by + cases s + cases t + cases hl + simp_rw [mk.injEq, heq_eq_eq, true_and] + constructor <;> ext + · exact he .. + · exact hc .. + +@[simp, grind =] +theorem exp_lt_exp_iff {s : TermSeq} {i j} : s.exp i < s.exp j ↔ j < i := + s.exp_strictAnti.lt_iff_gt + +@[simp, grind =] +theorem exp_le_exp_iff {s : TermSeq} {i j} : s.exp i ≤ s.exp j ↔ j ≤ i := + s.exp_strictAnti.le_iff_ge + +@[simp, grind =] +theorem exp_inj {s : TermSeq} {i j} : s.exp i = s.exp j ↔ i = j := + s.exp_strictAnti.injective.eq_iff + +@[simps] +instance : Zero TermSeq where + zero := .mk 0 0 0 (fun _ ↦ by simp) (by simp) + +@[simp, grind =] +theorem length_eq_zero {s : TermSeq} : s.length = 0 ↔ s = 0 where + mp h := by + ext x _ hx + · rw [h, zero_length] + · simp at hx + · simp at hx + mpr := by simp +contextual + +open Classical in +private theorem toSurrealHahnSeries_aux (o : Ordinal.{u}) (f : Iio o → Surreal.{u} × ℝ) : + Function.support (fun i ↦ if h : ∃ o, (f o).1 = i then (f <| Classical.choose h).2 else 0) ⊆ + range (Prod.fst ∘ f) := by + aesop + +/-- Cast a sequence of terms into a `SurrealHahnSeries`. -/ +@[coe] +def toSurrealHahnSeries (s : TermSeq) : SurrealHahnSeries := + have H := toSurrealHahnSeries_aux s.length fun i ↦ (s.exp i, s.coeff i) + .mk _ (small_subset H) (.subset (by + rw [wellFoundedOn_range] + convert wellFounded_lt (α := Iio s.length) + exact s.exp_strictAnti.lt_iff_gt + ) H) + +instance : Coe TermSeq SurrealHahnSeries where + coe := toSurrealHahnSeries + +/-- Build a `TermSeq` from a `SurrealHahnSeries`. -/ +@[simps, expose] +def ofSurrealHahnSeries (x : SurrealHahnSeries) : TermSeq where + length := x.length + exp := (↑) ∘ x.exp + coeff i := x.coeffIdx i + exp_strictAnti _ := by simp + coeff_ne_zero := by simp + +@[simp, grind =] +theorem coeff_coe {s : TermSeq} (i : Iio s.length) : coeff s (s.exp i) = s.coeff i := by + rw [toSurrealHahnSeries, coeff_mk, dite_eq_left ⟨i, rfl⟩] + generalize_proofs H + rw [s.exp_strictAnti.injective <| Classical.choose_spec H] + +theorem coeff_coe_of_notMem {s : TermSeq} {x : Surreal} (h : x ∉ range s.exp) : coeff s x = 0 := by + grind [toSurrealHahnSeries] + +@[simp, grind =] +theorem support_coe (s : TermSeq) : support s = range s.exp := by + ext i + by_cases hi : i ∈ range s.exp + · obtain ⟨i, rfl⟩ := hi + simp + · grind [coeff_coe_of_notMem hi] + +/-- Order isomorphism between `Iio x.length` and the range of `x.exp`. -/ +private def relIso' (s : TermSeq) : (· < · : Iio s.length → _) ≃r (· > · : range s.exp → _) := by + refine .ofSurjective ⟨⟨fun i ↦ ⟨s.exp i, ⟨i, rfl⟩⟩, ?_⟩, s.exp_lt_exp_iff⟩ ?_ + · intro a b h + exact s.exp_strictAnti.injective (congrArg Subtype.val h) + · rintro ⟨x, ⟨i, rfl⟩⟩ + exact ⟨i, rfl⟩ + +/-- Order isomorphism between `Iio s.length` and the support of `x`. -/ +private def relIso (s : TermSeq) : (· < · : Iio s.length → _) ≃r (· > · : support s → _) := + (relIso' s).trans (RelIso.subrel (· > ·) (by simp)) + +@[simp, grind =] +theorem length_coe (s : TermSeq) : length s = s.length := by + rw [← lift_inj, ← type_support, ← type_lt_Iio] + exact (relIso s).ordinalType_congr.symm + +@[simp, grind =] +theorem exp_coe (s : TermSeq) (i) : exp s i = s.exp ⟨i, by simpa using i.2⟩ := by + let e : (· < · : Iio (length (s : SurrealHahnSeries)) → _) ≃r + (· > · : support (s : SurrealHahnSeries) → _) := + RelIso.ofSurjective + { toFun := fun j ↦ + ⟨s.exp ⟨j, by simpa using j.2⟩, by + rw [support_coe] + exact ⟨⟨j, by simpa using j.2⟩, rfl⟩⟩ + inj' := fun a b h ↦ by + apply_fun Subtype.val at h + have hab : + (⟨a, by simpa using a.2⟩ : Iio s.length) = + ⟨b, by simpa using b.2⟩ := + s.exp_strictAnti.injective h + exact Subtype.ext (congrArg (fun z : Iio s.length ↦ z.1) hab) + map_rel_iff' := by + intro a b + change s.exp ⟨a, by simpa using a.2⟩ > s.exp ⟨b, by simpa using b.2⟩ ↔ + a < b + constructor + · intro h + exact (s.exp_strictAnti.lt_iff_gt.mp h : _) + · intro h + exact s.exp_strictAnti h } + (by + rintro ⟨j, hj⟩ + rw [support_coe] at hj + obtain ⟨k, rfl⟩ := hj + exact ⟨⟨k, by rw [length_coe]; exact k.2⟩, rfl⟩) + have hexp : exp (s : SurrealHahnSeries) = e := Subsingleton.elim _ _ + rw [hexp] + rfl + +theorem coeffIdx_coe_of_lt {s : TermSeq} {i} (h : i < s.length) : + coeffIdx s i = s.coeff ⟨i, h⟩ := by + rw [coeffIdx_of_lt (by simpa), exp_coe, coeff_coe] + +theorem coeffIdx_coe_of_le {s : TermSeq} {i} (h : s.length ≤ i) : coeffIdx s i = 0 := + coeffIdx_of_le (by simpa) + +@[aesop simp] +theorem coeffIdx_coe (s : TermSeq) (i) : + coeffIdx s i = if h : i < s.length then s.coeff ⟨i, h⟩ else 0 := by + split_ifs with h + · exact coeffIdx_coe_of_lt h + · exact coeffIdx_coe_of_le (le_of_not_gt h) + +theorem term_coe_of_lt {s : TermSeq} {i} (h : i < s.length) : + term s i = s.coeff ⟨i, h⟩ * ω^ s.exp ⟨i, h⟩ := by + rw [term_of_lt (by simpa), coeffIdx_coe_of_lt, exp_coe] + +theorem term_coe_of_le {s : TermSeq} {i} (h : s.length ≤ i) : term s i = 0 := + term_of_le (by simpa) + +@[aesop simp] +theorem term_coe (s : TermSeq) (i) : + term s i = if h : i < s.length then s.coeff ⟨i, h⟩ * ω^ s.exp ⟨i, h⟩ else 0 := by + split_ifs with h + · exact term_coe_of_lt h + · exact term_coe_of_le (le_of_not_gt h) + +/-- `TermSeq` and `SurrealHahnSeries` are alternate representations for the same structure. -/ +@[simps!, expose] +def surrealHahnSeriesEquiv : TermSeq ≃ SurrealHahnSeries where + toFun := toSurrealHahnSeries + invFun := ofSurrealHahnSeries + left_inv s := by + apply TermSeq.ext + · exact length_coe s + · intro i hs ht + exact exp_coe s ⟨i, hs⟩ + · intro i hs ht + exact coeffIdx_coe_of_lt ht + right_inv x := by + ext i + by_cases h : i ∈ x.support + · obtain ⟨i, hi, rfl⟩ := eq_exp_of_mem_support h + apply (coeff_coe (s := ofSurrealHahnSeries x) i).trans + simp + · have hx : x.coeff i = 0 := by rwa [← notMem_support_iff] + rw [coeff_coe_of_notMem, hx] + simpa [ofSurrealHahnSeries] + +@[simp] +theorem coe_ofSurrealHahnSeries (x : SurrealHahnSeries) : ofSurrealHahnSeries x = x := + surrealHahnSeriesEquiv.apply_symm_apply x + +@[simp] +theorem ofSurrealHahnSeries_coe (x : TermSeq) : ofSurrealHahnSeries x = x := + surrealHahnSeriesEquiv.symm_apply_apply x + +@[simp] +theorem coe_inj {x y : TermSeq} : (x : SurrealHahnSeries) = y ↔ x = y := + surrealHahnSeriesEquiv.apply_eq_iff_eq + +@[simp] +theorem ofSurrealHahnSeries_inj {x y : SurrealHahnSeries} : + ofSurrealHahnSeries x = ofSurrealHahnSeries y ↔ x = y := + surrealHahnSeriesEquiv.symm.apply_eq_iff_eq + +end TermSeq + +end SurrealHahnSeries diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/HahnSeries/NormalFormMul.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/HahnSeries/NormalFormMul.lean new file mode 100644 index 0000000000..c510289053 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/HahnSeries/NormalFormMul.lean @@ -0,0 +1,1251 @@ +/- +Copyright (c) 2026 Violeta Hernández Palacios. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Violeta Hernández Palacios +-/ +/- +Continues and modifies the Apache-2.0-licensed Conway normal-form work in CombinatorialGames PR +#263: https://github.com/vihdzp/combinatorial-games/pull/263 +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.HahnSeries.NormalFormAdd + +import all LeanPool.ConwayRefinement.CombinatorialGames.Surreal.HahnSeries.Basic + +/-! +# Multiplicative compatibility of the surreal Conway normal form + +This module develops the multiplication-option comparison needed to prove that the Conway +normal-form equivalence preserves multiplication. The central cofinality lemmas show that every +coefficient truncation on either side of a Hahn product is separated from the product by a Conway +multiplication option formed from coefficient truncations of its factors. + +The two elementary Hahn-series interface lemmas at the start expose multiplication facts that are +currently hidden behind the opaque `SurrealHahnSeries` field instance in CombinatorialGames. +-/ + +universe u + +open IGame Order Set + +public noncomputable section + +namespace SurrealHahnSeries + +private theorem ofLex_coe_mul (x y : SurrealHahnSeries) : + ofLex (x * y).1 = ofLex x.1 * ofLex y.1 := by + with_unfolding_all rfl + +private theorem ofLex_coe_single (p : Surreal) (r : ℝ) : + ofLex (single p r).1 = HahnSeries.single (OrderDual.toDual p) r := by + apply HahnSeries.ext + funext k + rw [HahnSeries.coeff_single] + unfold single mk + by_cases hk : k = OrderDual.toDual p + · subst k + simp + · have hk' : k.ofDual ≠ p := fun h ↦ hk (by simpa using congrArg OrderDual.toDual h) + simp [hk, hk'] + +private theorem mem_support_ofLex_coe_iff (x : SurrealHahnSeries) (k : Surreal) : + OrderDual.toDual k ∈ (ofLex x.1).support ↔ k ∈ x.support := by + rfl + +private theorem ofLex_coe_zero : ofLex (0 : SurrealHahnSeries).1 = 0 := by + with_unfolding_all rfl + +private theorem ofLex_coe_ne_zero {x : SurrealHahnSeries} (hx : x ≠ 0) : + ofLex x.1 ≠ 0 := by + intro hzero + apply hx + apply Subtype.ext + rw [← ofLex_inj, hzero, ofLex_coe_zero] + +private theorem ofLex_coe_order_eq_exp_zero {x : SurrealHahnSeries} (hx : x ≠ 0) : + (ofLex x.1).order = OrderDual.toDual (x.exp ⟨0, by + change 0 < x.length + rw [pos_iff_ne_zero, ne_eq, length_eq_zero] + exact hx⟩).1 := by + have hlength : 0 < x.length := by + rw [pos_iff_ne_zero, ne_eq, length_eq_zero] + exact hx + have hxRaw : ofLex x.1 ≠ 0 := ofLex_coe_ne_zero hx + apply WithTop.coe_inj.mp + rw [HahnSeries.order_eq_orderTop_of_ne_zero hxRaw] + apply HahnSeries.orderTop_eq_of_le + · rw [mem_support_ofLex_coe_iff] + exact (x.exp ⟨0, hlength⟩).2 + · intro k hk + have hk' : k.ofDual ∈ x.support := by + simpa using (mem_support_ofLex_coe_iff x k.ofDual).1 (by simpa using hk) + let j := x.exp.symm ⟨k.ofDual, hk'⟩ + have hj : (⟨0, hlength⟩ : Iio x.length) ≤ j := by + change (0 : Ordinal) ≤ j.1 + exact bot_le + have hexp : x.exp j ≤ x.exp ⟨0, hlength⟩ := x.exp_anti hj + change k.ofDual ≤ (x.exp ⟨0, hlength⟩).1 + change (x.exp j).1 ≤ (x.exp ⟨0, hlength⟩).1 at hexp + dsimp [j] at hexp + simpa only [x.exp.apply_symm_apply] using hexp + +private theorem ofLex_coe_leadingCoeff_eq_coeffIdx_zero {x : SurrealHahnSeries} + (hx : x ≠ 0) : + (ofLex x.1).leadingCoeff = x.coeffIdx 0 := by + rw [HahnSeries.leadingCoeff_eq, ofLex_coe_order_eq_exp_zero hx, + x.coeffIdx_of_lt (by + rw [pos_iff_ne_zero, ne_eq, length_eq_zero] + exact hx)] + rfl + +/-- Lexicographic comparison of surreal Hahn series, stated directly in terms of their public +coefficient function. -/ +theorem lt_iff_exists_coeff {x y : SurrealHahnSeries} : + x < y ↔ ∃ i : Surreal, (∀ j, i < j → x.coeff j = y.coeff j) ∧ + x.coeff i < y.coeff i := by + rfl + +/-- The multiplicative unit is the singleton surreal Hahn series at exponent zero. -/ +theorem one_eq_single_zero : (1 : SurrealHahnSeries) = single 0 1 := by + apply Subtype.ext + rw [← ofLex_inj, ofLex_coe_single] + with_unfolding_all rfl + +/-- An integer cast is the constant singleton surreal Hahn series. -/ +theorem intCast_eq_single_zero (n : ℤ) : + (n : SurrealHahnSeries) = single 0 (n : ℝ) := by + apply Subtype.ext + rw [← ofLex_inj, ofLex_coe_single] + with_unfolding_all rfl + +/-- Conway normal forms preserve multiplication by an integer on the left. -/ +theorem _root_.Surreal.toHahnSeries_intCast_mul (n : ℤ) (x : Surreal) : + ((n : Surreal) * x).toHahnSeries = + SurrealHahnSeries.single 0 (n : ℝ) * x.toHahnSeries := by + have hsource : (n : Surreal) * x = n • x := by + rw [← Int.cast_smul_eq_zsmul Surreal] + rfl + have htarget : SurrealHahnSeries.single 0 (n : ℝ) * x.toHahnSeries = + n • x.toHahnSeries := by + rw [← SurrealHahnSeries.intCast_eq_single_zero, + ← Int.cast_smul_eq_zsmul SurrealHahnSeries] + rfl + rw [hsource, htarget] + calc + (n • x).toHahnSeries = + Surreal.toHahnSeriesOrderAddMonoidIso (n • x) := + (Surreal.toHahnSeriesOrderAddMonoidIso_apply _).symm + _ = n • Surreal.toHahnSeriesOrderAddMonoidIso x := + map_zsmul Surreal.toHahnSeriesOrderAddMonoidIso.toAddEquiv n x + _ = n • x.toHahnSeries := by + rw [Surreal.toHahnSeriesOrderAddMonoidIso_apply] + +/-- Conway normal forms preserve multiplication by an integer on the right. -/ +theorem _root_.Surreal.toHahnSeries_mul_intCast (x : Surreal) (n : ℤ) : + (x * (n : Surreal)).toHahnSeries = + x.toHahnSeries * SurrealHahnSeries.single 0 (n : ℝ) := by + rw [mul_comm x, Surreal.toHahnSeries_intCast_mul, mul_comm] + +/-- The surreal value map commutes with rational scalar multiplication. -/ +theorem toSurreal_rat_smul (q : ℚ) (x : SurrealHahnSeries.{u}) : + (q • x).toSurreal = q • x.toSurreal := by + rw [← Surreal.toHahnSeriesOrderAddMonoidIso_symm_apply (q • x), + ← Surreal.toHahnSeriesOrderAddMonoidIso_symm_apply x] + exact map_rat_smul Surreal.toHahnSeriesOrderAddMonoidIso.symm.toAddMonoidHom q x + +/-- A rational cast is the constant singleton surreal Hahn series. -/ +theorem ratCast_eq_single_zero (q : ℚ) : + (q : SurrealHahnSeries.{u}) = single 0 (q : ℝ) := by + calc + (q : SurrealHahnSeries.{u}) = q • (1 : SurrealHahnSeries) := by simp + _ = q • (1 : Surreal).toHahnSeries := by + exact congrArg (fun z : SurrealHahnSeries ↦ q • z) <| + one_eq_single_zero.trans Surreal.toHahnSeries_one.symm + _ = (q • (1 : Surreal)).toHahnSeries := by + rw [← Surreal.toHahnSeriesOrderAddMonoidIso_apply, + ← Surreal.toHahnSeriesOrderAddMonoidIso_apply] + exact (map_rat_smul + Surreal.toHahnSeriesOrderAddMonoidIso.toAddMonoidHom q 1).symm + _ = (q : Surreal).toHahnSeries := by simp + _ = single 0 (q : ℝ) := Surreal.toHahnSeries_ratCast q + +/-- Conway normal forms preserve multiplication by a rational constant on the left. -/ +theorem toSurreal_single_zero_ratCast_mul (q : ℚ) (x : SurrealHahnSeries.{u}) : + (single 0 (q : ℝ) * x).toSurreal = (q : Surreal) * x.toSurreal := by + rw [← ratCast_eq_single_zero, ← Rat.smul_def, toSurreal_rat_smul] + simp [Rat.smul_def] + +/-- The product of two singleton surreal Hahn series is the singleton at the sum exponent. -/ +theorem single_mul_single (p q : Surreal.{u}) (r s : ℝ) : + single p r * single q s = single (p + q) (r * s) := by + apply Subtype.ext + rw [← ofLex_inj, ofLex_coe_mul, ofLex_coe_single, ofLex_coe_single, + HahnSeries.single_mul_single, ofLex_coe_single] + congr 2 + +/-- Multiplication by a singleton shifts exponents and scales coefficients. -/ +theorem coeff_single_mul (p : Surreal.{u}) (r : ℝ) + (y : SurrealHahnSeries.{u}) (k : Surreal) : + (single p r * y).coeff k = r * y.coeff (k - p) := by + have h := congrArg (fun z : HahnSeries Surrealᵒᵈ ℝ ↦ + z.coeff (OrderDual.toDual k)) (ofLex_coe_mul (single p r) y) + rw [ofLex_coe_single, HahnSeries.coeff_single_mul] at h + exact h + +/-- Truncation commutes with multiplication by a singleton after translating the cutoff. -/ +theorem trunc_single_mul (p q : Surreal.{u}) (r : ℝ) + (y : SurrealHahnSeries.{u}) : + (single p r * y).trunc (p + q) = single p r * y.trunc q := by + ext k + obtain hk | hk := le_or_gt k (p + q) + · rw [coeff_trunc_of_le hk, coeff_single_mul] + rw [coeff_trunc_of_le (sub_le_iff_le_add'.2 (by simpa [add_comm] using hk))] + simp + · rw [coeff_trunc_of_lt hk, coeff_single_mul] + rw [coeff_single_mul, coeff_trunc_of_lt] + exact lt_sub_iff_add_lt.mpr (by simpa [add_comm] using hk) + +/-- A coefficient perturbation of a series becomes the corresponding translated perturbation +after multiplication by a nonzero singleton. -/ +theorem single_mul_trunc_add_single_div (p q : Surreal.{u}) (r s : ℝ) + (y : SurrealHahnSeries.{u}) (hr : r ≠ 0) : + single p r * (y.trunc q + single q (s / r)) = + (single p r * y).trunc (p + q) + single (p + q) s := by + rw [mul_add, trunc_single_mul, single_mul_single, mul_div_cancel₀ s hr] + +/-- The leading indexed term of a formal product is the product of the leading indexed terms. -/ +theorem term_zero_mul (x y : SurrealHahnSeries) : + (x * y).term 0 = x.term 0 * y.term 0 := by + obtain rfl | hx := eq_or_ne x 0 + · rw [zero_mul, term_of_le (by simp), zero_mul] + obtain rfl | hy := eq_or_ne y 0 + · rw [mul_zero, term_of_le (by simp), mul_zero] + have hxy : x * y ≠ 0 := mul_ne_zero hx hy + have hxLength : 0 < x.length := by + rw [pos_iff_ne_zero, ne_eq, length_eq_zero] + exact hx + have hyLength : 0 < y.length := by + rw [pos_iff_ne_zero, ne_eq, length_eq_zero] + exact hy + have hxyLength : 0 < (x * y).length := by + rw [pos_iff_ne_zero, ne_eq, length_eq_zero] + exact hxy + have hxRaw : ofLex x.1 ≠ 0 := ofLex_coe_ne_zero hx + have hyRaw : ofLex y.1 ≠ 0 := ofLex_coe_ne_zero hy + have hleadingNe : + (ofLex x.1).leadingCoeff * (ofLex y.1).leadingCoeff ≠ 0 := by + exact mul_ne_zero (HahnSeries.leadingCoeff_ne_zero.mpr hxRaw) + (HahnSeries.leadingCoeff_ne_zero.mpr hyRaw) + have hexp := HahnSeries.order_mul_of_ne_zero hleadingNe + rw [← ofLex_coe_mul, ofLex_coe_order_eq_exp_zero hxy, + ofLex_coe_order_eq_exp_zero hx, ofLex_coe_order_eq_exp_zero hy] at hexp + have hexp' : + ((x * y).exp ⟨0, hxyLength⟩).1 = + (x.exp ⟨0, hxLength⟩).1 + (y.exp ⟨0, hyLength⟩).1 := by + simpa using congrArg OrderDual.ofDual hexp + have hcoeff := HahnSeries.leadingCoeff_mul_of_ne_zero hleadingNe + rw [← ofLex_coe_mul, ofLex_coe_leadingCoeff_eq_coeffIdx_zero hxy, + ofLex_coe_leadingCoeff_eq_coeffIdx_zero hx, + ofLex_coe_leadingCoeff_eq_coeffIdx_zero hy] at hcoeff + rw [term_of_lt hxyLength, term_of_lt hxLength, term_of_lt hyLength, + hcoeff, hexp', Real.toSurreal_mul, Surreal.wpow_add] + ring + +/-- The leading term of the surreal represented by a series is its zeroth indexed term. -/ +theorem leadingTerm_toSurreal (x : SurrealHahnSeries) : + x.toSurreal.leadingTerm = x.term 0 := by + have h := leadingTerm_sub_truncIdx (x := x) (i := 0) + have hzeroSeries : x.truncIdx 0 = 0 := by + rw [← length_eq_zero, length_truncIdx] + simp + have hzero : (x.truncIdx 0).toSurreal = 0 := by + calc + (x.truncIdx 0).toSurreal = (0 : SurrealHahnSeries).toSurreal := + congrArg toSurreal hzeroSeries + _ = 0 := toSurreal_zero + rw [hzero, sub_zero] at h + exact h + +/-- Formal Hahn multiplication and Conway multiplication have the same leading term. -/ +theorem leadingTerm_toSurreal_mul (x y : SurrealHahnSeries) : + (x * y).toSurreal.leadingTerm = (x.toSurreal * y.toSurreal).leadingTerm := by + rw [leadingTerm_toSurreal, term_zero_mul, ← leadingTerm_toSurreal, + ← leadingTerm_toSurreal, Surreal.leadingTerm_mul] + +/-- Every exponent in the support of a product is a sum of exponents from the two factors. -/ +theorem exists_add_eq_of_mem_support_mul {x y : SurrealHahnSeries.{u}} {k : Surreal} + (hk : k ∈ (x * y).support) : + ∃ p ∈ x.support, ∃ q ∈ y.support, p + q = k := by + have hk' : OrderDual.toDual k ∈ (ofLex (x * y).1).support := + (mem_support_ofLex_coe_iff (x * y) k).2 hk + rw [ofLex_coe_mul] at hk' + obtain ⟨p, hp, q, hq, hpq⟩ := HahnSeries.support_mul_subset hk' + refine ⟨p.ofDual, (mem_support_ofLex_coe_iff x p.ofDual).1 ?_, + q.ofDual, (mem_support_ofLex_coe_iff y q.ofDual).1 ?_, ?_⟩ + · simpa using hp + · simpa using hq + · simpa using congrArg OrderDual.ofDual hpq + +/-- Every left truncation option of a singleton product is the singleton times a truncation +option of the other factor; multiplication by a negative coefficient reverses the side. -/ +theorem exists_eq_single_mul_of_mem_truncLT + {p : Surreal.{u}} {r : ℝ} {y t : SurrealHahnSeries.{u}} + (ht : t ∈ truncLT (single p r * y)) : + (0 < r ∧ ∃ b ∈ truncLT y, single p r * b = t) ∨ + (r < 0 ∧ ∃ b ∈ truncGT y, single p r * b = t) := by + rw [truncLT_def] at ht + obtain ⟨k, hk, s, hs, rfl⟩ := ht + obtain ⟨p', hp', q, hq, hpq⟩ := exists_add_eq_of_mem_support_mul hk + have hp : p' = p := support_single_subset hp' + subst p' + subst k + have hr : r ≠ 0 := by + intro hr + subst r + simp at hp' + have hcoeff : (single p r * y).coeff (p + q) = r * y.coeff q := by + rw [coeff_single_mul] + congr 1 + abel_nf + rw [hcoeff] at hs + obtain hrNeg | hrPos := lt_or_gt_of_ne hr + · right + refine ⟨hrNeg, y.trunc q + single q (s / r), ?_, ?_⟩ + · exact trunc_add_single_truncGT hq <| + (lt_div_iff_of_neg hrNeg).2 (by simpa [mul_comm] using hs) + · exact single_mul_trunc_add_single_div p q r s y hr + · left + refine ⟨hrPos, y.trunc q + single q (s / r), ?_, ?_⟩ + · exact trunc_add_single_truncLT hq <| + (div_lt_iff₀ hrPos).2 (by simpa [mul_comm] using hs) + · exact single_mul_trunc_add_single_div p q r s y hr + +/-- Every right truncation option of a singleton product is the singleton times a truncation +option of the other factor; multiplication by a negative coefficient reverses the side. -/ +theorem exists_eq_single_mul_of_mem_truncGT + {p : Surreal.{u}} {r : ℝ} {y t : SurrealHahnSeries.{u}} + (ht : t ∈ truncGT (single p r * y)) : + (0 < r ∧ ∃ b ∈ truncGT y, single p r * b = t) ∨ + (r < 0 ∧ ∃ b ∈ truncLT y, single p r * b = t) := by + rw [truncGT_def] at ht + obtain ⟨k, hk, s, hs, rfl⟩ := ht + obtain ⟨p', hp', q, hq, hpq⟩ := exists_add_eq_of_mem_support_mul hk + have hp : p' = p := support_single_subset hp' + subst p' + subst k + have hr : r ≠ 0 := by + intro hr + subst r + simp at hp' + have hcoeff : (single p r * y).coeff (p + q) = r * y.coeff q := by + rw [coeff_single_mul] + congr 1 + abel_nf + rw [hcoeff] at hs + obtain hrNeg | hrPos := lt_or_gt_of_ne hr + · right + refine ⟨hrNeg, y.trunc q + single q (s / r), ?_, ?_⟩ + · exact trunc_add_single_truncLT hq <| + (div_lt_iff_of_neg hrNeg).2 (by simpa [mul_comm] using hs) + · exact single_mul_trunc_add_single_div p q r s y hr + · left + refine ⟨hrPos, y.trunc q + single q (s / r), ?_, ?_⟩ + · exact trunc_add_single_truncGT hq <| + (lt_div_iff₀ hrPos).2 (by simpa [mul_comm] using hs) + · exact single_mul_trunc_add_single_div p q r s y hr + +/-- A product of surreal Hahn series supported at nonnegative exponents is again supported at +nonnegative exponents. -/ +theorem support_mul_subset_Ici {x y : SurrealHahnSeries} + (hx : x.support ⊆ Ici 0) (hy : y.support ⊆ Ici 0) : + (x * y).support ⊆ Ici 0 := by + intro k hk + obtain ⟨p, hp, q, hq, rfl⟩ := exists_add_eq_of_mem_support_mul hk + have hpNonneg : 0 ≤ p := by simpa only [mem_Ici] using hx hp + have hqNonneg : 0 ≤ q := by simpa only [mem_Ici] using hy hq + simpa only [mem_Ici] using add_nonneg hpNonneg hqNonneg + +private theorem coeff_mul_zero_of_support_subsets {x y : SurrealHahnSeries} + (hx : x.support ⊆ Ioi 0) (hy : y.support ⊆ Ici 0) : + (x * y).coeff 0 = 0 := by + apply notMem_support_iff.mp + intro hzero + obtain ⟨p, hp, q, hq, hpq⟩ := exists_add_eq_of_mem_support_mul hzero + have hpPos : 0 < p := by simpa only [mem_Ioi] using hx hp + have hqNonneg : 0 ≤ q := by simpa only [mem_Ici] using hy hq + nlinarith + +/-- At exponent zero, multiplication of nonnegative-support surreal Hahn series is multiplication +of their constant coefficients. -/ +theorem coeff_zero_mul_of_support_subset_Ici {x y : SurrealHahnSeries} + (hx : x.support ⊆ Ici 0) (hy : y.support ⊆ Ici 0) : + (x * y).coeff 0 = x.coeff 0 * y.coeff 0 := by + have hxSplit : x.trunc 0 + single 0 (x.coeff 0) = x := + trunc_add_single fun i hi ↦ hx hi + have hySplit : y.trunc 0 + single 0 (y.coeff 0) = y := + trunc_add_single fun i hi ↦ hy hi + conv_lhs => rw [← hxSplit, ← hySplit] + rw [add_mul, mul_add, mul_add, + coeff_add_apply, coeff_add_apply, coeff_add_apply] + have hxTrunc : (x.trunc 0).support ⊆ Ioi 0 := by + intro i hi + rw [support_trunc] at hi + exact hi.2 + have hyTrunc : (y.trunc 0).support ⊆ Ioi 0 := by + intro i hi + rw [support_trunc] at hi + exact hi.2 + have hxTruncNonneg : (x.trunc 0).support ⊆ Ici 0 := fun i hi ↦ by + rw [mem_Ici] + exact (show 0 < i by simpa only [mem_Ioi] using hxTrunc hi).le + have hyTruncNonneg : (y.trunc 0).support ⊆ Ici 0 := fun i hi ↦ by + rw [mem_Ici] + exact (show 0 < i by simpa only [mem_Ioi] using hyTrunc hi).le + have hsingleNonneg (r : ℝ) : (single 0 r).support ⊆ Ici 0 := by + intro i hi + have hi' := support_single_subset hi + simp only [mem_singleton_iff] at hi' + subst i + exact le_refl (0 : Surreal) + rw [coeff_mul_zero_of_support_subsets hxTrunc hyTruncNonneg, + coeff_mul_zero_of_support_subsets hxTrunc (hsingleNonneg _)] + have hsingleTrunc : (single 0 (x.coeff 0) * y.trunc 0).coeff 0 = 0 := by + rw [mul_comm] + exact coeff_mul_zero_of_support_subsets hyTrunc (hsingleNonneg _) + rw [hsingleTrunc, single_mul_single] + simp [coeff_single_self] + +/-- The ring expression occurring in a Conway multiplication option. -/ +def mulOptionValue (x y a b : SurrealHahnSeries) : SurrealHahnSeries := + a * y + x * b - a * b + +/-- Evaluation of the Hahn-series expression attached to a Conway multiplication option. -/ +theorem mulOptionValue_eq (x y a b : SurrealHahnSeries) : + mulOptionValue x y a b = a * y + x * b - a * b := + (rfl) + +/-- Two left approximations give a multiplication option strictly below the product. -/ +theorem mulOptionValue_lt_mul_of_lt_of_lt {x y a b : SurrealHahnSeries} + (ha : a < x) (hb : b < y) : mulOptionValue x y a b < x * y := by + dsimp [mulOptionValue] + nlinarith [mul_pos (sub_pos.mpr ha) (sub_pos.mpr hb)] + +/-- Two right approximations give a multiplication option strictly below the product. -/ +theorem mulOptionValue_lt_mul_of_gt_of_gt {x y a b : SurrealHahnSeries} + (ha : x < a) (hb : y < b) : mulOptionValue x y a b < x * y := by + dsimp [mulOptionValue] + nlinarith [mul_pos_of_neg_of_neg (sub_neg.mpr ha) (sub_neg.mpr hb)] + +/-- A left and a right approximation give a multiplication option strictly above the product. -/ +theorem mul_lt_mulOptionValue_of_lt_of_gt {x y a b : SurrealHahnSeries} + (ha : a < x) (hb : y < b) : x * y < mulOptionValue x y a b := by + dsimp [mulOptionValue] + nlinarith [mul_neg_of_pos_of_neg (sub_pos.mpr ha) (sub_neg.mpr hb)] + +/-- A right and a left approximation give a multiplication option strictly above the product. -/ +theorem mul_lt_mulOptionValue_of_gt_of_lt {x y a b : SurrealHahnSeries} + (ha : x < a) (hb : b < y) : x * y < mulOptionValue x y a b := by + dsimp [mulOptionValue] + nlinarith [mul_neg_of_neg_of_pos (sub_neg.mpr ha) (sub_pos.mpr hb)] + +private theorem sub_leftApprox_pos (x : SurrealHahnSeries) (p : Surreal) (d : ℝ) + (hd : 0 < d) : + 0 < x - (x.trunc p + single p (x.coeff p - d)) := by + rw [lt_iff_exists_coeff] + refine ⟨p, ?_, ?_⟩ + · intro j hpj + rw [coeff_zero, coeff_sub_apply, coeff_add_apply, coeff_trunc_of_lt hpj, + coeff_single_of_ne hpj.ne] + simp + · rw [coeff_zero, coeff_sub_apply, coeff_add_apply, coeff_trunc_of_le le_rfl, + coeff_single_self] + simp only [Pi.zero_apply] + linarith + +private theorem sub_leftApprox_lt_single (x : SurrealHahnSeries) (p : Surreal) + (d C : ℝ) (hdC : d < C) : + x - (x.trunc p + single p (x.coeff p - d)) < single p C := by + rw [lt_iff_exists_coeff] + refine ⟨p, ?_, ?_⟩ + · intro j hpj + rw [coeff_sub_apply, coeff_add_apply, coeff_trunc_of_lt hpj, + coeff_single_of_ne hpj.ne, coeff_single_of_ne hpj.ne] + simp + · rw [coeff_sub_apply, coeff_add_apply, coeff_trunc_of_le le_rfl, + coeff_single_self, coeff_single_self] + linarith + +private theorem rightApprox_sub_pos (x : SurrealHahnSeries) (p : Surreal) (d : ℝ) + (hd : 0 < d) : + 0 < (x.trunc p + single p (x.coeff p + d)) - x := by + rw [lt_iff_exists_coeff] + refine ⟨p, ?_, ?_⟩ + · intro j hpj + rw [coeff_zero, coeff_sub_apply, coeff_add_apply, coeff_trunc_of_lt hpj, + coeff_single_of_ne hpj.ne] + simp + · rw [coeff_zero, coeff_sub_apply, coeff_add_apply, coeff_trunc_of_le le_rfl, + coeff_single_self] + simp only [Pi.zero_apply] + linarith + +private theorem rightApprox_sub_lt_single (x : SurrealHahnSeries) (p : Surreal) + (d C : ℝ) (hdC : d < C) : + (x.trunc p + single p (x.coeff p + d)) - x < single p C := by + rw [lt_iff_exists_coeff] + refine ⟨p, ?_, ?_⟩ + · intro j hpj + rw [coeff_sub_apply, coeff_add_apply, coeff_trunc_of_lt hpj, + coeff_single_of_ne hpj.ne, coeff_single_of_ne hpj.ne] + simp + · rw [coeff_sub_apply, coeff_add_apply, coeff_trunc_of_le le_rfl, + coeff_single_self, coeff_single_self] + linarith + +private theorem exists_small_square {d : ℝ} (hd : 0 < d) : + ∃ e : ℝ, 0 < e ∧ 4 * e ^ 2 < d := by + let e := min 1 (d / 8) + have he1 : e ≤ 1 := min_le_left _ _ + have hed : e ≤ d / 8 := min_le_right _ _ + have he : 0 < e := lt_min zero_lt_one (by linarith) + refine ⟨e, he, ?_⟩ + nlinarith [sq_nonneg e] + +private theorem single_lt_sub_leftApprox (x : SurrealHahnSeries) (k : Surreal) + (r C : ℝ) (hC : C < x.coeff k - r) : + single k C < x - (x.trunc k + single k r) := by + rw [lt_iff_exists_coeff] + refine ⟨k, ?_, ?_⟩ + · intro j hkj + rw [coeff_sub_apply, coeff_add_apply, coeff_trunc_of_lt hkj, + coeff_single_of_ne hkj.ne, coeff_single_of_ne hkj.ne] + simp + · rw [coeff_sub_apply, coeff_add_apply, coeff_trunc_of_le le_rfl, + coeff_single_self, coeff_single_self] + linarith + +private theorem single_lt_rightApprox_sub (x : SurrealHahnSeries) (k : Surreal) + (r C : ℝ) (hC : C < r - x.coeff k) : + single k C < (x.trunc k + single k r) - x := by + rw [lt_iff_exists_coeff] + refine ⟨k, ?_, ?_⟩ + · intro j hkj + rw [coeff_sub_apply, coeff_add_apply, coeff_trunc_of_lt hkj, + coeff_single_of_ne hkj.ne, coeff_single_of_ne hkj.ne] + simp + · rw [coeff_sub_apply, coeff_add_apply, coeff_trunc_of_le le_rfl, + coeff_single_self, coeff_single_self] + linarith + +/-- Every left coefficient truncation of a product is strictly dominated by a same-side +multiplication option, which is itself strictly below the product. -/ +theorem exists_mulOptionValue_between_of_mem_truncLT + {x y t : SurrealHahnSeries} (ht : t ∈ truncLT (x * y)) : + ∃ a ∈ truncLT x, ∃ b ∈ truncLT y, + t < mulOptionValue x y a b ∧ mulOptionValue x y a b < x * y := by + rw [truncLT_def] at ht + obtain ⟨k, hk, r, hr, rfl⟩ := ht + obtain ⟨p, hp, q, hq, hpq⟩ := exists_add_eq_of_mem_support_mul hk + obtain ⟨e, he, heSmall⟩ := exists_small_square (sub_pos.mpr hr) + let a := x.trunc p + single p (x.coeff p - e) + let b := y.trunc q + single q (y.coeff q - e) + have ha : a ∈ truncLT x := by + apply trunc_add_single_truncLT hp + linarith + have hb : b ∈ truncLT y := by + apply trunc_add_single_truncLT hq + linarith + have hxaPos : 0 < x - a := sub_leftApprox_pos x p e he + have hybPos : 0 < y - b := sub_leftApprox_pos y q e he + have hxaBound : x - a < single p (2 * e) := by + apply sub_leftApprox_lt_single + linarith + have hybBound : y - b < single q (2 * e) := by + apply sub_leftApprox_lt_single + linarith + have hpMonoPos : 0 < single p (2 * e) := hxaPos.trans hxaBound + have hproductBound : + (x - a) * (y - b) < single (p + q) (4 * e ^ 2) := by + calc + (x - a) * (y - b) < single p (2 * e) * (y - b) := + mul_lt_mul_of_pos_right hxaBound hybPos + _ < single p (2 * e) * single q (2 * e) := + mul_lt_mul_of_pos_left hybBound hpMonoPos + _ = single (p + q) ((2 * e) * (2 * e)) := + single_mul_single p q (2 * e) (2 * e) + _ = single (p + q) (4 * e ^ 2) := by ring_nf + have hmonoGap : + single (p + q) (4 * e ^ 2) < + x * y - ((x * y).trunc k + single k r) := by + rw [hpq] + exact single_lt_sub_leftApprox (x * y) k r (4 * e ^ 2) heSmall + refine ⟨a, ha, b, hb, ?_, ?_⟩ + · dsimp [mulOptionValue] + have := hproductBound.trans hmonoGap + nlinarith + · exact mulOptionValue_lt_mul_of_lt_of_lt + (lt_of_truncLT ha) (lt_of_truncLT hb) + +/-- Every right coefficient truncation of a product strictly dominates an opposite-side +multiplication option, which is itself strictly above the product. -/ +theorem exists_mulOptionValue_between_of_mem_truncGT + {x y t : SurrealHahnSeries} (ht : t ∈ truncGT (x * y)) : + ∃ a ∈ truncLT x, ∃ b ∈ truncGT y, + x * y < mulOptionValue x y a b ∧ mulOptionValue x y a b < t := by + rw [truncGT_def] at ht + obtain ⟨k, hk, r, hr, rfl⟩ := ht + obtain ⟨p, hp, q, hq, hpq⟩ := exists_add_eq_of_mem_support_mul hk + obtain ⟨e, he, heSmall⟩ := exists_small_square (sub_pos.mpr hr) + let a := x.trunc p + single p (x.coeff p - e) + let b := y.trunc q + single q (y.coeff q + e) + have ha : a ∈ truncLT x := by + apply trunc_add_single_truncLT hp + linarith + have hb : b ∈ truncGT y := by + apply trunc_add_single_truncGT hq + linarith + have hxaPos : 0 < x - a := sub_leftApprox_pos x p e he + have hbyPos : 0 < b - y := rightApprox_sub_pos y q e he + have hxaBound : x - a < single p (2 * e) := by + apply sub_leftApprox_lt_single + linarith + have hbyBound : b - y < single q (2 * e) := by + apply rightApprox_sub_lt_single + linarith + have hpMonoPos : 0 < single p (2 * e) := hxaPos.trans hxaBound + have hproductBound : + (x - a) * (b - y) < single (p + q) (4 * e ^ 2) := by + calc + (x - a) * (b - y) < single p (2 * e) * (b - y) := + mul_lt_mul_of_pos_right hxaBound hbyPos + _ < single p (2 * e) * single q (2 * e) := + mul_lt_mul_of_pos_left hbyBound hpMonoPos + _ = single (p + q) ((2 * e) * (2 * e)) := + single_mul_single p q (2 * e) (2 * e) + _ = single (p + q) (4 * e ^ 2) := by ring_nf + have hmonoGap : + single (p + q) (4 * e ^ 2) < + ((x * y).trunc k + single k r) - x * y := by + rw [hpq] + exact single_lt_rightApprox_sub (x * y) k r (4 * e ^ 2) heSmall + refine ⟨a, ha, b, hb, ?_, ?_⟩ + · exact mul_lt_mulOptionValue_of_lt_of_gt + (lt_of_truncLT ha) (gt_of_truncGT hb) + · dsimp [mulOptionValue] + have := hproductBound.trans hmonoGap + nlinarith + +private theorem mulOption_equiv + {x y a b : SurrealHahnSeries.{u}} + (hay : (a * y).toSurreal = a.toSurreal * y.toSurreal) + (hxb : (x * b).toSurreal = x.toSurreal * b.toSurreal) + (hab : (a * b).toSurreal = a.toSurreal * b.toSurreal) : + IGame.mulOption x.toIGame y.toIGame a.toIGame b.toIGame ≈ + (mulOptionValue x y a b).toIGame := by + rw [← Surreal.mk_eq_mk] + simp only [IGame.mulOption, Surreal.mk_sub, Surreal.mk_add, Surreal.mk_mul, + mk_toIGame] + rw [mulOptionValue_eq] + simp only [sub_eq_add_neg, toSurreal_add, toSurreal_neg] + rw [hay, hxb, hab] + +private theorem cutMulOption_equiv + {x y a b : SurrealHahnSeries.{u}} + (hay : (a * y).toSurreal = a.toSurreal * y.toSurreal) + (hxb : (x * b).toSurreal = x.toSurreal * b.toSurreal) + (hab : (a * b).toSurreal = a.toSurreal * b.toSurreal) : + IGame.mulOption !{toIGame '' truncLT x | toIGame '' truncGT x} + !{toIGame '' truncLT y | toIGame '' truncGT y} a.toIGame b.toIGame ≈ + (mulOptionValue x y a b).toIGame := by + exact (Numeric.mulOption_congr₁ (toIGame_equiv x).symm).trans <| + (Numeric.mulOption_congr₂ (toIGame_equiv y).symm).trans <| + mulOption_equiv hay hxb hab + +/-- Truncation options of a series of limit length are strictly shorter. -/ +private theorem length_lt_of_mem_truncLT_or_mem_truncGT {y b : SurrealHahnSeries.{u}} + (hy : IsSuccPrelimit y.length) (hb : b ∈ truncLT y ∨ b ∈ truncGT y) : + b.length < y.length := + hb.elim (length_lt_of_truncLT hy) (length_lt_of_truncGT hy) + +/-- The constant series `single 0 r` represents the real number `r`. -/ +private theorem toIGame_single_zero_equiv (r : ℝ) : (single 0 r).toIGame ≈ (r : IGame) := by + rw [← Surreal.mk_eq_mk, mk_toIGame] + simp [toSurreal_single] + +/-- The constant series with dyadic coefficient `q` represents the dyadic `q`. -/ +private theorem toIGame_single_zero_dyadic_equiv (q : Dyadic) : + (single 0 (q.toRat : ℝ)).toIGame ≈ (q : IGame) := by + apply AntisymmRel.trans ?_ (Real.toIGame_dyadic_equiv q) + rw [← Surreal.mk_eq_mk, mk_toIGame] + simp [toSurreal_single] + +/-- Constant series are ordered by their coefficients. -/ +private theorem single_zero_lt_single_zero {q r : ℝ} (h : q < r) : + single 0 q < single 0 r := by + rw [← toSurreal_lt_toSurreal_iff, toSurreal_single, toSurreal_single, Surreal.wpow_zero, + mul_one, mul_one] + exact Real.toSurreal_lt_iff.mpr h + +/-- The Conway multiplication option of the real `r` against the cut of `y`, at the dyadic option +`q` of `r` and the truncation option `b` of `y`, is the Hahn-series multiplication option +`mulOptionValue (single 0 r) y (single 0 q) b`, provided multiplication by `single 0 r` is +already compatible on `b`. -/ +private theorem mulOption_real_equiv (r : ℝ) (y : SurrealHahnSeries.{u}) (q : Dyadic) + {b : SurrealHahnSeries.{u}} + (hb : (single 0 r * b).toSurreal = (r : Surreal) * b.toSurreal) : + IGame.mulOption (r : IGame) !{toIGame '' truncLT y | toIGame '' truncGT y} + (q : IGame) b.toIGame ≈ + (mulOptionValue (single 0 r) y (single 0 (q.toRat : ℝ)) b).toIGame := + (Numeric.mulOption_congr₁ (toIGame_single_zero_equiv r).symm).trans <| + (Numeric.mulOption_congr₂ (toIGame_equiv y).symm).trans <| + (Numeric.mulOption_congr₃ (toIGame_single_zero_dyadic_equiv q).symm).trans <| + mulOption_equiv + (by simpa [toSurreal_single] using toSurreal_single_zero_ratCast_mul q.toRat y) + (by simpa [toSurreal_single] using hb) + (by simpa [toSurreal_single] using toSurreal_single_zero_ratCast_mul q.toRat b) + +/-- The Conway multiplication option at the dyadic option `0` of `r` is the truncation option +`single 0 r * b` itself. -/ +private theorem mulOption_real_zero_equiv (r : ℝ) (y : SurrealHahnSeries.{u}) + {b : SurrealHahnSeries.{u}} + (hb : (single 0 r * b).toSurreal = (r : Surreal) * b.toSurreal) : + IGame.mulOption (r : IGame) !{toIGame '' truncLT y | toIGame '' truncGT y} + ((0 : Dyadic) : IGame) b.toIGame ≈ (single 0 r * b).toIGame := by + grw [mulOption_real_equiv r y 0 hb] + simp [mulOptionValue_eq] + +/-- The cut of `single 0 r * y`, for `y` of limit length, fits between the options of the Conway +product of `r` with the cut of `y`: every option is a multiplication option at a dyadic option of +`r` and a truncation option of `y`, and lies on the correct side of the product. -/ +private theorem fits_single_zero_mul (r : ℝ) {y : SurrealHahnSeries.{u}} + (hy : IsSuccPrelimit y.length) + (hmul : ∀ b : SurrealHahnSeries.{u}, b.length < y.length → + (single 0 r * b).toSurreal = (r : Surreal) * b.toSurreal) : + Fits !{toIGame '' truncLT (single 0 r * y) | toIGame '' truncGT (single 0 r * y)} + ((r : IGame) * !{toIGame '' truncLT y | toIGame '' truncGT y}) := by + have hoption (q : Dyadic) {b : SurrealHahnSeries.{u}} + (hb : b ∈ truncLT y ∨ b ∈ truncGT y) := + mulOption_real_equiv r y q (hmul b (length_lt_of_mem_truncLT_or_mem_truncGT hy hb)) + simp only [Fits, forall_moves_mul, moves_ofSets, Player.cases] + constructor + · intro p + cases p <;> simp only [Real.forall_leftMoves_toIGame, + Real.forall_rightMoves_toIGame, forall_mem_image] + · intro q hq b hb + rw [Numeric.not_le] + grw [hoption q (Or.inl hb), ← toIGame_equiv (single 0 r * y)] + exact_mod_cast mulOptionValue_lt_mul_of_lt_of_lt + (single_zero_lt_single_zero hq) (lt_of_truncLT hb) + · intro q hq b hb + rw [Numeric.not_le] + grw [hoption q (Or.inr hb), ← toIGame_equiv (single 0 r * y)] + exact_mod_cast mulOptionValue_lt_mul_of_gt_of_gt + (single_zero_lt_single_zero hq) (gt_of_truncGT hb) + · intro p + cases p <;> simp only [Real.forall_leftMoves_toIGame, + Real.forall_rightMoves_toIGame, forall_mem_image] + · intro q hq b hb + rw [Numeric.not_le] + grw [← toIGame_equiv (single 0 r * y), hoption q (Or.inr hb)] + exact_mod_cast mul_lt_mulOptionValue_of_lt_of_gt + (single_zero_lt_single_zero hq) (gt_of_truncGT hb) + · intro q hq b hb + rw [Numeric.not_le] + grw [← toIGame_equiv (single 0 r * y), hoption q (Or.inl hb)] + exact_mod_cast mul_lt_mulOptionValue_of_gt_of_lt + (single_zero_lt_single_zero hq) (lt_of_truncLT hb) + +/-- Every left truncation option of `single 0 r * y` is dominated by a left option of the Conway +product of `r` with the cut of `y`. The truncation option is `single 0 r * b` for a truncation +option `b` of `y` on the side determined by the sign of `r`, and the multiplication option at the +dyadic `0` and `b` represents it. -/ +private theorem exists_leftMove_ge_of_mem_truncLT_single_zero_mul (r : ℝ) + {y : SurrealHahnSeries.{u}} (hy : IsSuccPrelimit y.length) + (hmul : ∀ b : SurrealHahnSeries.{u}, b.length < y.length → + (single 0 r * b).toSurreal = (r : Surreal) * b.toSurreal) : + ∀ z ∈ !{toIGame '' truncLT (single 0 r * y) | toIGame '' truncGT (single 0 r * y)}ᴸ, + ∃ w ∈ ((r : IGame) * !{toIGame '' truncLT y | toIGame '' truncGT y})ᴸ, z ≤ w := by + rw [moves_ofSets] + rintro _ ⟨t, ht, rfl⟩ + obtain ⟨hrPos, b, hb, rfl⟩ | ⟨hrNeg, b, hb, rfl⟩ := + exists_eq_single_mul_of_mem_truncLT ht + · refine ⟨_, mulOption_mem_moves_mul (b := b.toIGame) (px := left) (py := left) + (Real.mem_leftMoves_toIGame_of_lt (q := 0) (by simpa using hrPos)) ?_, ?_⟩ + · rw [moves_ofSets] + exact mem_image_of_mem toIGame hb + · exact (mulOption_real_zero_equiv r y + (hmul b (length_lt_of_mem_truncLT_or_mem_truncGT hy (Or.inl hb)))).symm.le + · refine ⟨_, mulOption_mem_moves_mul (b := b.toIGame) (px := right) (py := right) + (Real.mem_rightMoves_toIGame_of_lt (q := 0) (by simpa using hrNeg)) ?_, ?_⟩ + · rw [moves_ofSets] + exact mem_image_of_mem toIGame hb + · exact (mulOption_real_zero_equiv r y + (hmul b (length_lt_of_mem_truncLT_or_mem_truncGT hy (Or.inr hb)))).symm.le + +/-- Every right truncation option of `single 0 r * y` dominates a right option of the Conway +product of `r` with the cut of `y`, namely the multiplication option at the dyadic `0` and the +truncation option `b` of `y` with `single 0 r * b` the given option. -/ +private theorem exists_rightMove_le_of_mem_truncGT_single_zero_mul (r : ℝ) + {y : SurrealHahnSeries.{u}} (hy : IsSuccPrelimit y.length) + (hmul : ∀ b : SurrealHahnSeries.{u}, b.length < y.length → + (single 0 r * b).toSurreal = (r : Surreal) * b.toSurreal) : + ∀ z ∈ !{toIGame '' truncLT (single 0 r * y) | toIGame '' truncGT (single 0 r * y)}ᴿ, + ∃ w ∈ ((r : IGame) * !{toIGame '' truncLT y | toIGame '' truncGT y})ᴿ, w ≤ z := by + rw [moves_ofSets] + rintro _ ⟨t, ht, rfl⟩ + obtain ⟨hrPos, b, hb, rfl⟩ | ⟨hrNeg, b, hb, rfl⟩ := + exists_eq_single_mul_of_mem_truncGT ht + · refine ⟨_, mulOption_mem_moves_mul (b := b.toIGame) (px := left) (py := right) + (Real.mem_leftMoves_toIGame_of_lt (q := 0) (by simpa using hrPos)) ?_, ?_⟩ + · rw [moves_ofSets] + exact mem_image_of_mem toIGame hb + · exact (mulOption_real_zero_equiv r y + (hmul b (length_lt_of_mem_truncLT_or_mem_truncGT hy (Or.inr hb)))).le + · refine ⟨_, mulOption_mem_moves_mul (b := b.toIGame) (px := right) (py := left) + (Real.mem_rightMoves_toIGame_of_lt (q := 0) (by simpa using hrNeg)) ?_, ?_⟩ + · rw [moves_ofSets] + exact mem_image_of_mem toIGame hb + · exact (mulOption_real_zero_equiv r y + (hmul b (length_lt_of_mem_truncLT_or_mem_truncGT hy (Or.inl hb)))).le + +/-- The limit step for multiplication by a real constant. Rational options of the real constant +are handled by additive compatibility, while truncation options of the other factor are strictly +shorter recursive inputs. -/ +theorem toSurreal_single_zero_mul_of_isSuccPrelimit (r : ℝ) + {y : SurrealHahnSeries.{u}} (hy : IsSuccPrelimit y.length) + (hmul : ∀ b : SurrealHahnSeries.{u}, b.length < y.length → + (single 0 r * b).toSurreal = (r : Surreal) * b.toSurreal) : + (single 0 r * y).toSurreal = (r : Surreal) * y.toSurreal := by + rw [← mk_toIGame (single 0 r * y), ← mk_toIGame y, ← Surreal.mk_real_toIGame, + ← Surreal.mk_mul] + apply Surreal.mk_eq + rw [toIGame_limit hy] + exact (toIGame_equiv (single 0 r * y)).trans + (Fits.equiv_of_forall_moves (fits_single_zero_mul r hy hmul) + (exists_leftMove_ge_of_mem_truncLT_single_zero_mul r hy hmul) + (exists_rightMove_le_of_mem_truncGT_single_zero_mul r hy hmul)) + +/-- Conway normal forms preserve multiplication by every real constant on the left. -/ +theorem toSurreal_single_zero_mul (r : ℝ) (y : SurrealHahnSeries.{u}) : + (single 0 r * y).toSurreal = (r : Surreal) * y.toSurreal := by + induction y using lengthRecOn with + | succ y i s hi hs IH => + rw [mul_add, toSurreal_add, IH, single_mul_single, toSurreal_single, + toSurreal_succ hi, Real.toSurreal_mul] + ring_nf + | limit y hy IH => exact toSurreal_single_zero_mul_of_isSuccPrelimit r hy IH + +private theorem toSurreal_single_mul_of_one (p : Surreal.{u}) (r : ℝ) + (y : SurrealHahnSeries.{u}) + (hone : (single p 1 * y).toSurreal = ω^ p * y.toSurreal) : + (single p r * y).toSurreal = (r : Surreal) * ω^ p * y.toSurreal := by + have hfactor : single p r = single 0 r * single p 1 := by + rw [single_mul_single] + simp + rw [hfactor, mul_assoc, toSurreal_single_zero_mul, hone] + ring + +private theorem toSurreal_single_one_mul_succ (g : IGame.{u}) [Numeric g] + {y : SurrealHahnSeries.{u}} {i : Surreal} {s : ℝ} + (hi : ∀ j ∈ y.support, i < j) + (IH : (single (Surreal.mk g) 1 * y).toSurreal = + ω^ (Surreal.mk g) * y.toSurreal) : + (single (Surreal.mk g) 1 * (y + single i s)).toSurreal = + ω^ (Surreal.mk g) * (y + single i s).toSurreal := by + rw [mul_add, toSurreal_add, IH, single_mul_single, toSurreal_single, + toSurreal_succ hi, Surreal.wpow_add] + ring_nf + +/-- The monomial `single (mk g) 1` represents `ω^ g`. -/ +private theorem toIGame_single_one_equiv (g : IGame.{u}) [Numeric g] : + (single (Surreal.mk g) 1).toIGame ≈ ω^ g := by + rw [← Surreal.mk_eq_mk, mk_toIGame, Surreal.mk_wpow] + simp [toSurreal_single] + +/-- The monomial `single (mk z) q` with dyadic coefficient `q` represents `q * ω^ z`. -/ +private theorem toIGame_single_dyadic_equiv (q : Dyadic) (z : IGame.{u}) [Numeric z] : + (single (Surreal.mk z) (q.toRat : ℝ)).toIGame ≈ (q : IGame) * ω^ z := by + rw [← Surreal.mk_eq_mk, mk_toIGame, Surreal.mk_mul, Surreal.mk_wpow, Surreal.mk_dyadic] + simp [toSurreal_single] + +/-- A dyadic multiple of the monomial at a left option `z` of `g` is below the monomial at `g`, +since `q * ω^ z < ω^ g` for `z < g`. -/ +private theorem single_dyadic_lt_single_one_of_mem_leftMoves (g : IGame.{u}) [Numeric g] + (q : Dyadic) {z : IGame.{u}} [Numeric z] (hz : z ∈ gᴸ) : + single (Surreal.mk z) (q.toRat : ℝ) < single (Surreal.mk g) 1 := by + rw [← toSurreal_lt_toSurreal_iff] + simp only [toSurreal_single] + simpa using + Surreal.mul_wpow_lt_wpow q.toRat (Surreal.mk_lt_mk.mpr (Numeric.left_lt hz)) + +/-- The monomial at `g` is below every positive dyadic multiple of the monomial at a right option +`z` of `g`, since `ω^ g < q * ω^ z` for `g < z` and `0 < q`. -/ +private theorem single_one_lt_single_dyadic_of_mem_rightMoves (g : IGame.{u}) [Numeric g] + {q : Dyadic} {z : IGame.{u}} [Numeric z] (hq : 0 < q) (hz : z ∈ gᴿ) : + single (Surreal.mk g) 1 < single (Surreal.mk z) (q.toRat : ℝ) := by + rw [← toSurreal_lt_toSurreal_iff] + simp only [toSurreal_single] + have hqReal : (0 : ℝ) < (q.toRat : ℝ) := by exact_mod_cast hq + simpa using Surreal.wpow_lt_mul_wpow hqReal + (Surreal.mk_lt_mk.mpr (Numeric.lt_right hz)) + +/-- The Conway multiplication option of `ω^ g` against the cut of `y`, at the option `q * ω^ z` +of `ω^ g` and the truncation option `b` of `y`, is the Hahn-series multiplication option +`mulOptionValue (single (mk g) 1) y (single (mk z) q) b`, provided multiplication by +`single (mk z) 1` is compatible everywhere and multiplication by `single (mk g) 1` is compatible +on `b`. -/ +private theorem mulOption_wpow_equiv (g : IGame.{u}) [Numeric g] (y : SurrealHahnSeries.{u}) + (q : Dyadic) {z : IGame.{u}} [Numeric z] + (hz : ∀ c : SurrealHahnSeries.{u}, + (single (Surreal.mk z) 1 * c).toSurreal = ω^ (Surreal.mk z) * c.toSurreal) + {b : SurrealHahnSeries.{u}} + (hb : (single (Surreal.mk g) 1 * b).toSurreal = ω^ (Surreal.mk g) * b.toSurreal) : + IGame.mulOption (ω^ g) !{toIGame '' truncLT y | toIGame '' truncGT y} + ((q : IGame) * ω^ z) b.toIGame ≈ + (mulOptionValue (single (Surreal.mk g) 1) y + (single (Surreal.mk z) (q.toRat : ℝ)) b).toIGame := by + have hAcompat (c : SurrealHahnSeries.{u}) : + (single (Surreal.mk z) (q.toRat : ℝ) * c).toSurreal = + (single (Surreal.mk z) (q.toRat : ℝ)).toSurreal * c.toSurreal := by + simpa [toSurreal_single, mul_assoc] using + toSurreal_single_mul_of_one (Surreal.mk z) (q.toRat : ℝ) c (hz c) + exact (Numeric.mulOption_congr₁ (toIGame_single_one_equiv g).symm).trans <| + (Numeric.mulOption_congr₂ (toIGame_equiv y).symm).trans <| + (Numeric.mulOption_congr₃ (toIGame_single_dyadic_equiv q z).symm).trans <| + mulOption_equiv (hAcompat y) (by simpa [toSurreal_single] using hb) (hAcompat b) + +/-- The Conway multiplication option at the option `0` of `ω^ g` is the truncation option +`single (mk g) 1 * b` itself. -/ +private theorem mulOption_wpow_zero_equiv (g : IGame.{u}) [Numeric g] + (y : SurrealHahnSeries.{u}) {b : SurrealHahnSeries.{u}} + (hb : (single (Surreal.mk g) 1 * b).toSurreal = ω^ (Surreal.mk g) * b.toSurreal) : + IGame.mulOption (ω^ g) !{toIGame '' truncLT y | toIGame '' truncGT y} 0 b.toIGame ≈ + (single (Surreal.mk g) 1 * b).toIGame := + (Numeric.mulOption_congr₁ (toIGame_single_one_equiv g).symm).trans <| + (Numeric.mulOption_congr₂ (toIGame_equiv y).symm).trans <| + (Numeric.mulOption_congr₃ toIGame_zero.symm.antisymmRel).trans <| by + grw [mulOption_equiv (x := single (Surreal.mk g) 1) (y := y) (a := 0) (b := b) + (by simp) (by simpa [toSurreal_single] using hb) (by simp)] + simp [mulOptionValue_eq] + +/-- The cut of `single (mk g) 1 * y`, for `y` of limit length, fits between the options of the +Conway product of `ω^ g` with the cut of `y`: every option is a multiplication option at an +option `0` or `q * ω^ z` of `ω^ g` and a truncation option of `y`, and lies on the correct side +of the product. -/ +private theorem fits_single_one_mul (g : IGame.{u}) [Numeric g] {y : SurrealHahnSeries.{u}} + (hy : IsSuccPrelimit y.length) + (hmove : ∀ p z [Numeric z], z ∈ g.moves p → ∀ b : SurrealHahnSeries.{u}, + (single (Surreal.mk z) 1 * b).toSurreal = ω^ (Surreal.mk z) * b.toSurreal) + (hlenRec : ∀ b : SurrealHahnSeries.{u}, b.length < y.length → + (single (Surreal.mk g) 1 * b).toSurreal = ω^ (Surreal.mk g) * b.toSurreal) : + Fits !{toIGame '' truncLT (single (Surreal.mk g) 1 * y) | + toIGame '' truncGT (single (Surreal.mk g) 1 * y)} + (ω^ g * !{toIGame '' truncLT y | toIGame '' truncGT y}) := by + have hoption (q : Dyadic) {p : Player} {z : IGame.{u}} [Numeric z] (hz : z ∈ g.moves p) + {b : SurrealHahnSeries.{u}} (hb : b ∈ truncLT y ∨ b ∈ truncGT y) := + mulOption_wpow_equiv g y q (hmove p z hz) + (hlenRec b (length_lt_of_mem_truncLT_or_mem_truncGT hy hb)) + have hzeroOption {b : SurrealHahnSeries.{u}} (hb : b ∈ truncLT y ∨ b ∈ truncGT y) := + mulOption_wpow_zero_equiv g y (hlenRec b (length_lt_of_mem_truncLT_or_mem_truncGT hy hb)) + have hxpos : 0 < single (Surreal.mk g) 1 := by + rw [← toSurreal_lt_toSurreal_iff] + simp [toSurreal_single] + simp only [Fits, forall_moves_mul, moves_ofSets, Player.cases] + constructor + · intro p + cases p <;> simp only [forall_leftMoves_wpow, forall_rightMoves_wpow, + forall_mem_image] + · constructor + · intro b hb + rw [Numeric.not_le] + grw [hzeroOption (Or.inl hb), ← toIGame_equiv (single (Surreal.mk g) 1 * y)] + exact_mod_cast mul_lt_mul_of_pos_left (lt_of_truncLT hb) hxpos + · intro q _ z hz b hb + let := Numeric.of_mem_moves hz + rw [Numeric.not_le] + grw [hoption q hz (Or.inl hb), ← toIGame_equiv (single (Surreal.mk g) 1 * y)] + exact_mod_cast mulOptionValue_lt_mul_of_lt_of_lt + (single_dyadic_lt_single_one_of_mem_leftMoves g q hz) (lt_of_truncLT hb) + · intro q hq z hz b hb + let := Numeric.of_mem_moves hz + rw [Numeric.not_le] + grw [hoption q hz (Or.inr hb), ← toIGame_equiv (single (Surreal.mk g) 1 * y)] + exact_mod_cast mulOptionValue_lt_mul_of_gt_of_gt + (single_one_lt_single_dyadic_of_mem_rightMoves g hq hz) (gt_of_truncGT hb) + · intro p + cases p <;> simp only [forall_leftMoves_wpow, forall_rightMoves_wpow, + forall_mem_image] + · constructor + · intro b hb + rw [Numeric.not_le] + grw [← toIGame_equiv (single (Surreal.mk g) 1 * y), hzeroOption (Or.inr hb)] + exact_mod_cast mul_lt_mul_of_pos_left (gt_of_truncGT hb) hxpos + · intro q _ z hz b hb + let := Numeric.of_mem_moves hz + rw [Numeric.not_le] + grw [← toIGame_equiv (single (Surreal.mk g) 1 * y), hoption q hz (Or.inr hb)] + exact_mod_cast mul_lt_mulOptionValue_of_lt_of_gt + (single_dyadic_lt_single_one_of_mem_leftMoves g q hz) (gt_of_truncGT hb) + · intro q hq z hz b hb + let := Numeric.of_mem_moves hz + rw [Numeric.not_le] + grw [← toIGame_equiv (single (Surreal.mk g) 1 * y), hoption q hz (Or.inl hb)] + exact_mod_cast mul_lt_mulOptionValue_of_gt_of_lt + (single_one_lt_single_dyadic_of_mem_rightMoves g hq hz) (lt_of_truncLT hb) + +/-- Every left truncation option of `single (mk g) 1 * y` is dominated by a left option of the +Conway product of `ω^ g` with the cut of `y`: it is `single (mk g) 1 * b` for a left truncation +option `b` of `y`, represented by the multiplication option at `0` and `b`. -/ +private theorem exists_leftMove_ge_of_mem_truncLT_single_one_mul (g : IGame.{u}) [Numeric g] + {y : SurrealHahnSeries.{u}} (hy : IsSuccPrelimit y.length) + (hlenRec : ∀ b : SurrealHahnSeries.{u}, b.length < y.length → + (single (Surreal.mk g) 1 * b).toSurreal = ω^ (Surreal.mk g) * b.toSurreal) : + ∀ z ∈ !{toIGame '' truncLT (single (Surreal.mk g) 1 * y) | + toIGame '' truncGT (single (Surreal.mk g) 1 * y)}ᴸ, + ∃ w ∈ (ω^ g * !{toIGame '' truncLT y | toIGame '' truncGT y})ᴸ, z ≤ w := by + rw [moves_ofSets] + rintro _ ⟨t, ht, rfl⟩ + obtain ⟨-, b, hb, rfl⟩ | ⟨hfalse, -⟩ := exists_eq_single_mul_of_mem_truncLT ht + · refine ⟨_, mulOption_mem_moves_mul (b := b.toIGame) (px := left) (py := left) + (zero_mem_leftMoves_wpow g) ?_, ?_⟩ + · rw [moves_ofSets] + exact mem_image_of_mem toIGame hb + · exact (mulOption_wpow_zero_equiv g y + (hlenRec b (length_lt_of_mem_truncLT_or_mem_truncGT hy (Or.inl hb)))).symm.le + · norm_num at hfalse + +/-- Every right truncation option of `single (mk g) 1 * y` dominates a right option of the +Conway product of `ω^ g` with the cut of `y`: it is `single (mk g) 1 * b` for a right truncation +option `b` of `y`, represented by the multiplication option at `0` and `b`. -/ +private theorem exists_rightMove_le_of_mem_truncGT_single_one_mul (g : IGame.{u}) [Numeric g] + {y : SurrealHahnSeries.{u}} (hy : IsSuccPrelimit y.length) + (hlenRec : ∀ b : SurrealHahnSeries.{u}, b.length < y.length → + (single (Surreal.mk g) 1 * b).toSurreal = ω^ (Surreal.mk g) * b.toSurreal) : + ∀ z ∈ !{toIGame '' truncLT (single (Surreal.mk g) 1 * y) | + toIGame '' truncGT (single (Surreal.mk g) 1 * y)}ᴿ, + ∃ w ∈ (ω^ g * !{toIGame '' truncLT y | toIGame '' truncGT y})ᴿ, w ≤ z := by + rw [moves_ofSets] + rintro _ ⟨t, ht, rfl⟩ + obtain ⟨-, b, hb, rfl⟩ | ⟨hfalse, -⟩ := exists_eq_single_mul_of_mem_truncGT ht + · refine ⟨_, mulOption_mem_moves_mul (b := b.toIGame) (px := left) (py := right) + (zero_mem_leftMoves_wpow g) ?_, ?_⟩ + · rw [moves_ofSets] + exact mem_image_of_mem toIGame hb + · exact (mulOption_wpow_zero_equiv g y + (hlenRec b (length_lt_of_mem_truncLT_or_mem_truncGT hy (Or.inr hb)))).le + · norm_num at hfalse + +/-- The limit step for multiplication by the monomial `single (mk g) 1`, given compatibility of +the monomials at the options of `g` on every input and of this monomial on strictly shorter +inputs. -/ +private theorem toSurreal_single_one_mul_limit (g : IGame.{u}) [Numeric g] + {y : SurrealHahnSeries.{u}} (hy : IsSuccPrelimit y.length) + (hmove : ∀ p z [Numeric z], z ∈ g.moves p → ∀ b : SurrealHahnSeries.{u}, + (single (Surreal.mk z) 1 * b).toSurreal = ω^ (Surreal.mk z) * b.toSurreal) + (hlenRec : ∀ b : SurrealHahnSeries.{u}, b.length < y.length → + (single (Surreal.mk g) 1 * b).toSurreal = ω^ (Surreal.mk g) * b.toSurreal) : + (single (Surreal.mk g) 1 * y).toSurreal = ω^ (Surreal.mk g) * y.toSurreal := by + rw [← mk_toIGame (single (Surreal.mk g) 1 * y), ← mk_toIGame y, ← Surreal.mk_wpow, + ← Surreal.mk_mul] + apply Surreal.mk_eq + rw [toIGame_limit hy] + exact (toIGame_equiv (single (Surreal.mk g) 1 * y)).trans + (Fits.equiv_of_forall_moves (fits_single_one_mul g hy hmove hlenRec) + (exists_leftMove_ge_of_mem_truncLT_single_one_mul g hy hlenRec) + (exists_rightMove_le_of_mem_truncGT_single_one_mul g hy hlenRec)) + +private theorem toSurreal_single_one_mul (g : IGame.{u}) [Numeric g] + (y : SurrealHahnSeries.{u}) : + (single (Surreal.mk g) 1 * y).toSurreal = ω^ (Surreal.mk g) * y.toSurreal := by + let motive := fun g : IGame.{u} ↦ ∀ (_hg : Numeric g) (y : SurrealHahnSeries.{u}), + (single (Surreal.mk g) 1 * y).toSurreal = ω^ (Surreal.mk g) * y.toSurreal + apply IGame.moveRecOn (motive := motive) g + intro g IH hg y + induction y using lengthRecOn with + | succ y i s hi hs IHlen => exact toSurreal_single_one_mul_succ g hi IHlen + | limit y hy IHlen => + apply toSurreal_single_one_mul_limit g hy + · intro p z hzNumeric hz b + exact IH p z hz hzNumeric b + · exact IHlen + +/-- Conway normal forms preserve multiplication by an arbitrary singleton on the left. -/ +theorem toSurreal_single_mul (p : Surreal.{u}) (r : ℝ) (y : SurrealHahnSeries.{u}) : + (single p r * y).toSurreal = (single p r).toSurreal * y.toSurreal := by + calc + (single p r * y).toSurreal = (r : Surreal) * ω^ p * y.toSurreal := + toSurreal_single_mul_of_one p r y (by simpa using toSurreal_single_one_mul p.out y) + _ = (single p r).toSurreal * y.toSurreal := by rw [toSurreal_single] + +/-- The limit-by-limit induction step for Conway normal-form multiplication, stated with the two +recursive axes it uses. Compatibility for shorter left inputs is needed only against right inputs +no longer than the fixed right input; compatibility for shorter right inputs is needed only against +the fixed left input. -/ +theorem toSurreal_mul_of_isSuccPrelimit_of_axes + {x y : SurrealHahnSeries.{u}} + (hx : IsSuccPrelimit x.length) (hy : IsSuccPrelimit y.length) + (hmulLeft : ∀ a b : SurrealHahnSeries.{u}, + a.length < x.length → b.length ≤ y.length → + (a * b).toSurreal = a.toSurreal * b.toSurreal) + (hmulRight : ∀ b : SurrealHahnSeries.{u}, b.length < y.length → + (x * b).toSurreal = x.toSurreal * b.toSurreal) : + (x * y).toSurreal = x.toSurreal * y.toSurreal := by + have hlenX {a : SurrealHahnSeries.{u}} + (ha : a ∈ truncLT x ∨ a ∈ truncGT x) : a.length < x.length := + ha.elim (length_lt_of_truncLT hx) (length_lt_of_truncGT hx) + have hlenY {b : SurrealHahnSeries.{u}} + (hb : b ∈ truncLT y ∨ b ∈ truncGT y) : b.length < y.length := + hb.elim (length_lt_of_truncLT hy) (length_lt_of_truncGT hy) + have hmulAY {a : SurrealHahnSeries.{u}} (ha : a ∈ truncLT x ∨ a ∈ truncGT x) : + (a * y).toSurreal = a.toSurreal * y.toSurreal := + hmulLeft a y (hlenX ha) le_rfl + have hmulXB {b : SurrealHahnSeries.{u}} (hb : b ∈ truncLT y ∨ b ∈ truncGT y) : + (x * b).toSurreal = x.toSurreal * b.toSurreal := + hmulRight b (hlenY hb) + have hmulAB {a b : SurrealHahnSeries.{u}} + (ha : a ∈ truncLT x ∨ a ∈ truncGT x) + (hb : b ∈ truncLT y ∨ b ∈ truncGT y) : + (a * b).toSurreal = a.toSurreal * b.toSurreal := + hmulLeft a b (hlenX ha) (hlenY hb).le + rw [← mk_toIGame (x * y), ← mk_toIGame x, ← mk_toIGame y, + ← Surreal.mk_mul] + apply Surreal.mk_eq + rw [toIGame_limit hx, toIGame_limit hy] + apply (toIGame_equiv (x * y)).trans + apply Fits.equiv_of_forall_moves + · simp only [Fits, forall_moves_mul, moves_ofSets, Player.cases] + constructor + · intro p + cases p <;> simp only [forall_mem_image] + · intro a ha b hb + rw [Numeric.not_le] + grw [cutMulOption_equiv (hmulAY (Or.inl ha)) (hmulXB (Or.inl hb)) + (hmulAB (Or.inl ha) (Or.inl hb)), ← toIGame_equiv (x * y)] + exact_mod_cast mulOptionValue_lt_mul_of_lt_of_lt + (lt_of_truncLT ha) (lt_of_truncLT hb) + · intro a ha b hb + rw [Numeric.not_le] + grw [cutMulOption_equiv (hmulAY (Or.inr ha)) (hmulXB (Or.inr hb)) + (hmulAB (Or.inr ha) (Or.inr hb)), ← toIGame_equiv (x * y)] + exact_mod_cast mulOptionValue_lt_mul_of_gt_of_gt + (gt_of_truncGT ha) (gt_of_truncGT hb) + · intro p + cases p <;> simp only [forall_mem_image] + · intro a ha b hb + rw [Numeric.not_le] + grw [← toIGame_equiv (x * y), + cutMulOption_equiv (hmulAY (Or.inl ha)) (hmulXB (Or.inr hb)) + (hmulAB (Or.inl ha) (Or.inr hb))] + exact_mod_cast mul_lt_mulOptionValue_of_lt_of_gt + (lt_of_truncLT ha) (gt_of_truncGT hb) + · intro a ha b hb + rw [Numeric.not_le] + grw [← toIGame_equiv (x * y), + cutMulOption_equiv (hmulAY (Or.inr ha)) (hmulXB (Or.inl hb)) + (hmulAB (Or.inr ha) (Or.inl hb))] + exact_mod_cast mul_lt_mulOptionValue_of_gt_of_lt + (gt_of_truncGT ha) (lt_of_truncLT hb) + · rw [moves_ofSets] + rintro _ ⟨t, ht, rfl⟩ + obtain ⟨a, ha, b, hb, htb, -⟩ := + exists_mulOptionValue_between_of_mem_truncLT ht + let w := IGame.mulOption + !{toIGame '' truncLT x | toIGame '' truncGT x} + !{toIGame '' truncLT y | toIGame '' truncGT y} + a.toIGame b.toIGame + refine ⟨w, ?_, ?_⟩ + · dsimp only [w] + apply mulOption_mem_moves_mul (px := left) (py := left) + · rw [moves_ofSets] + exact mem_image_of_mem toIGame ha + · rw [moves_ofSets] + exact mem_image_of_mem toIGame hb + · dsimp only [w] + grw [cutMulOption_equiv (hmulAY (Or.inl ha)) (hmulXB (Or.inl hb)) + (hmulAB (Or.inl ha) (Or.inl hb))] + exact (toIGame_lt_toIGame_iff.mpr htb).le + · rw [moves_ofSets] + rintro _ ⟨t, ht, rfl⟩ + obtain ⟨a, ha, b, hb, -, hbt⟩ := + exists_mulOptionValue_between_of_mem_truncGT ht + let w := IGame.mulOption + !{toIGame '' truncLT x | toIGame '' truncGT x} + !{toIGame '' truncLT y | toIGame '' truncGT y} + a.toIGame b.toIGame + refine ⟨w, ?_, ?_⟩ + · dsimp only [w] + apply mulOption_mem_moves_mul (px := left) (py := right) + · rw [moves_ofSets] + exact mem_image_of_mem toIGame ha + · rw [moves_ofSets] + exact mem_image_of_mem toIGame hb + · dsimp only [w] + grw [cutMulOption_equiv (hmulAY (Or.inl ha)) (hmulXB (Or.inr hb)) + (hmulAB (Or.inl ha) (Or.inr hb))] + exact (toIGame_lt_toIGame_iff.mpr hbt).le + +/-- The limit-by-limit induction step for Conway normal-form multiplication. If multiplication is +already compatible whenever at least one input has strictly shorter support, it is compatible for +two inputs whose support lengths are successor prelimits. -/ +theorem toSurreal_mul_of_isSuccPrelimit + {x y : SurrealHahnSeries.{u}} + (hx : IsSuccPrelimit x.length) (hy : IsSuccPrelimit y.length) + (hmul : ∀ a b : SurrealHahnSeries.{u}, + a.length ≤ x.length → b.length ≤ y.length → + (a.length < x.length ∨ b.length < y.length) → + (a * b).toSurreal = a.toSurreal * b.toSurreal) : + (x * y).toSurreal = x.toSurreal * y.toSurreal := + toSurreal_mul_of_isSuccPrelimit_of_axes hx hy + (fun a b ha hb ↦ hmul a b ha.le hb (Or.inl ha)) + (fun b hb ↦ hmul x b le_rfl hb.le (Or.inr hb)) + +/-- The Conway normal-form equivalence from surreal Hahn series to surreal numbers preserves +multiplication. -/ +theorem toSurreal_mul (x y : SurrealHahnSeries.{u}) : + (x * y).toSurreal = x.toSurreal * y.toSurreal := by + apply lengthRecOn (motive := fun x ↦ ∀ y, + (x * y).toSurreal = x.toSurreal * y.toSurreal) x + · intro x i r hi _ IH y + rw [add_mul, toSurreal_add, IH, toSurreal_single_mul, toSurreal_succ hi, + toSurreal_single] + ring + · intro x hx IHx y + apply lengthRecOn (motive := fun y ↦ + (x * y).toSurreal = x.toSurreal * y.toSurreal) y + · intro y i r hi _ IHy + have hsingle : + (x * single i r).toSurreal = x.toSurreal * (single i r).toSurreal := by + rw [mul_comm, toSurreal_single_mul, mul_comm] + rw [mul_add, toSurreal_add, IHy, hsingle, toSurreal_succ hi, toSurreal_single] + ring + · intro y hy IHy + exact toSurreal_mul_of_isSuccPrelimit_of_axes hx hy + (fun a b ha _ ↦ IHx a ha b) IHy + +/-- Conway normal forms preserve arbitrary surreal products. -/ +@[simp] +theorem _root_.Surreal.toHahnSeries_mul (x y : Surreal.{u}) : + (x * y).toHahnSeries = x.toHahnSeries * y.toHahnSeries := by + apply toSurreal_strictMono.injective + rw [toSurreal_mul, Surreal.toSurreal_toHahnSeries, + Surreal.toSurreal_toHahnSeries, Surreal.toSurreal_toHahnSeries] + +/-- Conway normal form as a ring equivalence between surreals and small surreal Hahn series. -/ +def _root_.Surreal.toHahnSeriesRingEquiv : + Surreal.{u} ≃+* SurrealHahnSeries.{u} where + toEquiv := Surreal.toHahnSeriesOrderIso.toEquiv + map_add' := Surreal.toHahnSeries_add + map_mul' := Surreal.toHahnSeries_mul + +@[simp] +theorem _root_.Surreal.toHahnSeriesRingEquiv_apply (x : Surreal.{u}) : + Surreal.toHahnSeriesRingEquiv x = x.toHahnSeries := + (rfl) + +@[simp] +theorem _root_.Surreal.toHahnSeriesRingEquiv_symm_apply (x : SurrealHahnSeries.{u}) : + Surreal.toHahnSeriesRingEquiv.symm x = x.toSurreal := + (rfl) + +end SurrealHahnSeries diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/HahnSeries/NormalFormRecursion.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/HahnSeries/NormalFormRecursion.lean new file mode 100644 index 0000000000..62a9438c81 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/HahnSeries/NormalFormRecursion.lean @@ -0,0 +1,543 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov, Violeta Hernández Palacios +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.HahnSeries.NormalFormBasic +public import LeanPool.ConwayRefinement.CombinatorialGames.Surreal.Leading + +/-! +# Recursion on the length of a surreal Hahn series + +This module supplies successor decomposition and transfinite length recursion for the Conway +normal-form construction. It follows the corresponding axiom-free infrastructure from +CombinatorialGames PR #263, adapted to the pinned public API. +-/ + +universe u + +public noncomputable section + +attribute [grind =] Subtype.mk_le_mk Subtype.mk_lt_mk Order.lt_add_one_iff + +open Order Set + +namespace SurrealHahnSeries + +open Ordinal + +@[simp] +theorem truncIdx_eq_self {x : SurrealHahnSeries} {i : Ordinal} : + x.truncIdx i = x ↔ x.length ≤ i where + mp h := by + contrapose! h + exact truncIdx_ne h + mpr := truncIdx_of_le + +@[simp] +theorem truncIdx_length (x : SurrealHahnSeries) : x.truncIdx x.length = x := by + simp + +theorem self_mem_range_truncIdx (x : SurrealHahnSeries) : x ∈ range x.truncIdx := + ⟨_, x.truncIdx_length⟩ + +theorem self_mem_range_trunc (x : SurrealHahnSeries) : x ∈ range x.trunc := by + refine ⟨!{∅ | x.support}, trunc_eq_self ?_⟩ + aesop + +theorem range_truncIdx_eq_range_trunc (x : SurrealHahnSeries) : + range x.truncIdx = range x.trunc := by + ext y + constructor + · rintro ⟨i, rfl⟩ + obtain h | h := lt_or_ge i x.length + · rw [truncIdx_of_lt h] + exact mem_range_self _ + · rw [truncIdx_of_le h] + exact self_mem_range_trunc x + · rintro ⟨i, rfl⟩ + by_cases! hx : ∀ j ∈ x.support, i < j + · rw [trunc_eq_self_iff.2 hx] + use x.length + simp + · have H : {j : x.support | j.1 ≤ i}.Nonempty := by + obtain ⟨j, hj, hj'⟩ := hx + exact ⟨⟨j, hj⟩, hj'⟩ + obtain ⟨j, hj, hj'⟩ := wellFounded_gt.has_min _ H + use x.exp.symm j + rw [truncIdx_symm_exp] + refine trunc_eq_trunc hj fun k hk hk' ↦ ?_ + by_contra hk'' + exact hj' ⟨k, hk''⟩ hk' hk + +theorem truncIdx_mem_range_trunc (x : SurrealHahnSeries) (i : Ordinal) : + x.truncIdx i ∈ range x.trunc := by + simp [← range_truncIdx_eq_range_trunc] + +theorem trunc_mem_range_truncIdx (x : SurrealHahnSeries) (i : Surreal) : + x.trunc i ∈ range x.truncIdx := by + simp [range_truncIdx_eq_range_trunc] +@[simp] +theorem leadingTerm_term (x : SurrealHahnSeries) (i : Ordinal) : + (x.term i).leadingTerm = x.term i := by + by_cases hi : i < x.length + · rw [term_of_lt hi] + simp + · rw [term_of_le (le_of_not_gt hi)] + simp + +@[simp] +theorem leadingCoeff_term (x : SurrealHahnSeries) (i : Ordinal) : + (x.term i).leadingCoeff = x.coeffIdx i := by + by_cases hi : i < x.length + · rw [term_of_lt hi, coeffIdx_of_lt hi] + simp + · rw [term_of_le (le_of_not_gt hi), coeffIdx_of_le (le_of_not_gt hi)] + simp + +theorem wlog_term {x : SurrealHahnSeries} {i : Ordinal} (hi : i ∈ Iio x.length) : + (x.term i).wlog = x.exp ⟨i, hi⟩ := by + have hc : x.coeffIdx i ≠ 0 := by + rw [ne_eq, coeffIdx_eq_zero_iff] + exact not_le_of_gt hi + have hc' : (x.coeffIdx i : Surreal) ≠ 0 := by exact_mod_cast hc + rw [term_of_lt hi, Surreal.wlog_mul hc' (by simp)] + simp + +theorem mk_term {x : SurrealHahnSeries} {i : Ordinal} (hi : i ∈ Iio x.length) : + ArchimedeanClass.mk (x.term i) = .mk (ω^ (x.exp ⟨i, hi⟩)) := by + have hc : x.coeffIdx i ≠ 0 := by + rw [ne_eq, coeffIdx_eq_zero_iff] + exact not_le_of_gt hi + rw [term_of_lt hi, ArchimedeanClass.mk_mul, Surreal.mk_realCast hc] + simp + +namespace TermSeq + +/-- A `TermSeq` with a single term. -/ +@[simps (attr := grind =), expose] +def single (r : ℝ) (e : Surreal) (hr : r ≠ 0) : TermSeq where + length := 1 + exp _ := e + coeff _ := r + exp_strictAnti _ := by simp + coeff_ne_zero _ := hr + +/-- Appends a single term at the end of a `TermSeq`. -/ +@[simps (attr := grind =) -isSimp length, expose] +def appendSingle (s : TermSeq) (r : ℝ) (e : Surreal) (hr : r ≠ 0) (he : ∀ i, e < s.exp i) : + TermSeq where + length := s.length + 1 + exp i := if h : i = s.length then e else s.exp ⟨i, by grind⟩ + coeff i := if h : i = s.length then r else s.coeff ⟨i, by grind⟩ + exp_strictAnti := by grind [StrictAnti] + coeff_ne_zero := by grind + +attribute [simp] appendSingle_length + +@[grind =] +theorem appendSingle_exp (s : TermSeq) (r : ℝ) (e : Surreal) (hr : r ≠ 0) + (he : ∀ i, e < s.exp i) (i : Iio (s.appendSingle r e hr he).length) : + (s.appendSingle r e hr he).exp i = + if h : (i : Ordinal) = s.length then e else s.exp ⟨i, by + have hi := i.property + change (i : Ordinal) < s.length + 1 at hi + exact lt_of_le_of_ne (Order.lt_add_one_iff.mp hi) h⟩ := rfl + +@[grind =] +theorem appendSingle_coeff (s : TermSeq) (r : ℝ) (e : Surreal) (hr : r ≠ 0) + (he : ∀ i, e < s.exp i) (i : Iio (s.appendSingle r e hr he).length) : + (s.appendSingle r e hr he).coeff i = + if h : (i : Ordinal) = s.length then r else s.coeff ⟨i, by + have hi := i.property + change (i : Ordinal) < s.length + 1 at hi + exact lt_of_le_of_ne (Order.lt_add_one_iff.mp hi) h⟩ := rfl + +theorem exp_eq_exp_appendSingle (s : TermSeq) (i r e hr he) : + s.exp i = (s.appendSingle r e hr he).exp ⟨i.1, by grind⟩ := by + rw [appendSingle_exp, dite_eq_right (ne_of_lt i.2)] + +theorem coeff_eq_coeff_appendSingle (s : TermSeq) (i r e hr he) : + s.coeff i = (s.appendSingle r e hr he).coeff ⟨i.1, by grind⟩ := by + rw [appendSingle_coeff, dite_eq_right (ne_of_lt i.2)] + +@[simp, grind =] +theorem exp_appendSingle_same (s : TermSeq) (r e hr he) : + (s.appendSingle r e hr he).exp ⟨s.length, by grind⟩ = e := by + rw [appendSingle_exp, dite_eq_left rfl] + +@[simp, grind =] +theorem coeff_appendSingle_same (s : TermSeq) (r e hr he) : + (s.appendSingle r e hr he).coeff ⟨s.length, by grind⟩ = r := by + rw [appendSingle_coeff, dite_eq_left rfl] + +@[simp] +theorem coe_appendSingle {s : TermSeq} {r : ℝ} {e : Surreal} (hr : r ≠ 0) (he : ∀ i, e < s.exp i) : + appendSingle s r e hr he = s + SurrealHahnSeries.single e r := by + ext j + by_cases hj : j ∈ range s.exp + · obtain ⟨j, rfl⟩ := hj + rw [coeff_add_apply] + conv_lhs => rw [exp_eq_exp_appendSingle s j r e hr he] + rw [coeff_coe, appendSingle_coeff, dite_eq_right (ne_of_lt j.2), coeff_coe, + coeff_single_of_ne (ne_of_lt (he j)), add_zero] + · rw [coeff_add_apply, coeff_coe_of_notMem hj, zero_add] + obtain rfl | he := eq_or_ne e j + · conv_lhs => right; rw [← exp_appendSingle_same s r e hr he] + rw [coeff_coe] + simp + · rw [coeff_single_of_ne he, coeff_coe_of_notMem] + rintro ⟨k, hk⟩ + rw [appendSingle_exp] at hk + split at hk + · exact he hk + · apply hj + refine ⟨⟨k, ?_⟩, hk⟩ + have hk' : ↑k ≤ s.length := by + rw [← Order.lt_add_one_iff, ← appendSingle_length] + exact k.2 + exact lt_of_le_of_ne hk' ‹↑k ≠ s.length› + +/-- Truncate a `TermSeq` at the i-th term. -/ +@[simps (attr := grind =) length, expose] +def trunc (s : TermSeq) (i : Ordinal) : TermSeq where + length := min i s.length + exp i := s.exp ⟨i, by grind⟩ + coeff i := s.coeff ⟨i, by grind⟩ + exp_strictAnti _ := by grind + coeff_ne_zero := by grind + +@[simp, grind =] +theorem trunc_exp (s : TermSeq) (j : Ordinal) (i : Iio (s.trunc j).length) : + (s.trunc j).exp i = s.exp ⟨i, by + have hi := i.property + change (i : Ordinal) < min j s.length at hi + exact hi.trans_le (min_le_right ..)⟩ := rfl + +@[simp, grind =] +theorem trunc_coeff (s : TermSeq) (j : Ordinal) (i : Iio (s.trunc j).length) : + (s.trunc j).coeff i = s.coeff ⟨i, by + have hi := i.property + change (i : Ordinal) < min j s.length at hi + exact hi.trans_le (min_le_right ..)⟩ := rfl + +@[simp] +theorem trunc_of_le {s : TermSeq} {i : Ordinal} (h : s.length ≤ i) : s.trunc i = s := by + ext + · simpa + · rfl + · rfl + +@[simp] +theorem trunc_trunc (s : TermSeq) (i j : Ordinal) : (s.trunc i).trunc j = s.trunc (min i j) := by + ext + · simp only [trunc_length] + ac_rfl + · simp + · simp + +@[simp ←] +theorem coe_trunc (s : TermSeq) (i : Ordinal) : s.trunc i = truncIdx s i := by + obtain hi | hi := lt_or_ge i s.length + · rw [truncIdx_of_lt (by simpa), exp_coe] + ext j + by_cases hj : j ∈ range s.exp + · obtain ⟨⟨j, hj⟩, _, rfl⟩ := hj + obtain hj' | hj' := lt_or_ge j i + · rw [coeff_trunc_of_lt] + · have hj'' : j ∈ Iio (s.trunc i).length := by + simpa only [trunc_length, mem_Iio, lt_inf_iff] using And.intro hj' hj + change + coeff (s.trunc i : SurrealHahnSeries) + ((s.trunc i).exp ⟨j, hj''⟩) = + coeff (s : SurrealHahnSeries) (s.exp ⟨j, hj⟩) + rw [coeff_coe, coeff_coe] + rw [trunc_coeff] + · simpa + · rw [coeff_trunc_of_le, coeff_coe_of_notMem] + · grind + · simpa + · rw [coeff_trunc_eq_zero, coeff_coe_of_notMem] + · grind + · rwa [← support_coe, mem_support_iff, not_ne_iff] at hj + · rw [trunc_of_le hi, truncIdx_of_le (by simpa)] + +theorem trunc_appendSingle {s : TermSeq} {r e hr he} {i} (hi : i ≤ s.length) : + trunc (s.appendSingle r e hr he) i = trunc s i := by + apply TermSeq.ext + · have hi' : i ≤ s.length + 1 := hi.trans (by simp) + rw [trunc_length, trunc_length, appendSingle_length, min_eq_left hi, min_eq_left hi'] + · intro k hs ht + have hk : k < s.length := by + apply lt_of_lt_of_le ht + rw [trunc_length] + exact min_le_right .. + rw [trunc_exp, trunc_exp, appendSingle_exp, dite_eq_right (ne_of_lt hk)] + · intro k hs ht + have hk : k < s.length := by + apply lt_of_lt_of_le ht + rw [trunc_length] + exact min_le_right .. + rw [trunc_coeff, trunc_coeff, appendSingle_coeff, dite_eq_right (ne_of_lt hk)] + +@[simp] +theorem trunc_appendSingle_self (s : TermSeq) {r e} (hr he) : + trunc (s.appendSingle r e hr he) s.length = s := by + rw [trunc_appendSingle le_rfl , trunc_of_le le_rfl] + +theorem trunc_add_one {s : TermSeq} {i} (hi : i ∈ Iio s.length) : + s.trunc (i + 1) = + (s.trunc i).appendSingle (s.coeff ⟨i, hi⟩) (s.exp ⟨i, hi⟩) (by simp) (by grind) := by + have hi' : i + 1 ≤ s.length := Order.add_one_le_iff.mpr hi + have hlength : (s.trunc i).length = i := by + rw [trunc_length, min_eq_left hi.le] + apply TermSeq.ext + · rw [trunc_length, appendSingle_length, hlength, min_eq_left hi'] + · intro k hs ht + have hk : k < i + 1 := by + apply lt_of_lt_of_le hs + rw [trunc_length] + exact min_le_left .. + rw [appendSingle_exp] + by_cases hki : k = i + · rw [dite_eq_left (hki.trans hlength.symm), trunc_exp] + subst k + rfl + · rw [dite_eq_right (by + intro h + exact hki (h.trans hlength)), trunc_exp, trunc_exp] + · intro k hs ht + have hk : k < i + 1 := by + apply lt_of_lt_of_le hs + rw [trunc_length] + exact min_le_left .. + rw [appendSingle_coeff] + by_cases hki : k = i + · rw [dite_eq_left (hki.trans hlength.symm), trunc_coeff] + subst k + rfl + · rw [dite_eq_right (by + intro h + exact hki (h.trans hlength)), trunc_coeff, trunc_coeff] + + +end TermSeq + +/-! ### Recursion principles -/ + +/-- Build data for a `SurrealHahnSeries` by building it for a `TermSeq`. -/ +def termSeqRecOn {motive : SurrealHahnSeries → Sort*} (x : SurrealHahnSeries) + (mk : ∀ s : TermSeq, motive s) : motive x := + cast (congrArg _ (by simp)) (mk (.ofSurrealHahnSeries x)) + +@[simp] +theorem termSeqRecOn_coe {motive : SurrealHahnSeries → Sort*} {mk} (s : TermSeq) : + termSeqRecOn (motive := motive) s mk = mk s := by + rw [termSeqRecOn, cast_eq_iff_heq] + congr + simp + +theorem length_add_single {x : SurrealHahnSeries} {i : Surreal} {r : ℝ} + (h : ∀ j ∈ x.support, i < j) (hr : r ≠ 0) : (x + single i r).length = x.length + 1 := by + induction x using termSeqRecOn with | mk s + rw [← TermSeq.coe_appendSingle hr fun _ ↦ h _ (by simp)] + rw [TermSeq.length_coe] + simp + +theorem length_add_single_le {x : SurrealHahnSeries} {i : Surreal} {r : ℝ} + (h : ∀ j ∈ x.support, i < j) : (x + single i r).length ≤ x.length + 1 := by + obtain rfl | hr := eq_or_ne r 0 + · simp + · rw [length_add_single h hr] + +@[simp] +theorem length_single (i : Surreal) {r : ℝ} (hr : r ≠ 0) : length (.single i r) = 1 := by + rw [← zero_add (single i r), length_add_single _ hr] <;> simp + +theorem length_single_le (i : Surreal) (r : ℝ) : length (.single i r) ≤ 1 := by + obtain rfl | hr := eq_or_ne r 0 <;> simp_all + +private theorem isLeast_support_succ {x : SurrealHahnSeries} {o : Ordinal} (h : x.length = o + 1) : + (x.exp ⟨o, by simp_all⟩).1 ∈ lowerBounds x.support := by + refine fun j hj ↦ ?_ + change _ ≤ ↑(⟨j, hj⟩ : x.support) + rw [← symm_exp_le_symm_exp_iff, x.exp.symm_apply_apply, ← Subtype.coe_le_coe, ← lt_add_one_iff] + exact h ▸ symm_exp_lt _ + +-- Auxiliary construction for `lengthRecOn`. +private def lengthRecOnAux {motive : SurrealHahnSeries → Sort*} (o : Ordinal) + (succ : ∀ y i r, (∀ j ∈ y.support, i < j) → r ≠ 0 → motive y → motive (y + single i r)) + (limit : ∀ y, IsSuccPrelimit y.length → (∀ z, length z < length y → motive z) → motive y) : + ∀ x, x.length = o → motive x := + SuccOrder.prelimitRecOn o + (by + refine fun a _ IH x hx ↦ cast (congrArg _ <| trunc_add_single (isLeast_support_succ hx)) + (succ (x.trunc <| x.exp ⟨a, ?_⟩) _ _ ?_ ?_ (IH _ ?_)) + all_goals aesop + ) + (fun a ha IH x hx ↦ limit _ (hx ▸ ha) fun y hy ↦ IH _ (hx ▸ hy) _ rfl) + +private theorem lengthRecOnAux_succ {motive : SurrealHahnSeries → Sort*} + {o a : Ordinal} (ha : a = o + 1) {succ limit} : + lengthRecOnAux (motive := motive) a succ limit = fun x _ ↦ + cast (congrArg _ <| trunc_add_single (isLeast_support_succ <| by simp_all)) + (succ (x.trunc <| x.exp ⟨o, _⟩) _ _ (by grind) (by simp_all) + (lengthRecOnAux o succ limit _ (by grind))) := by + subst ha; exact SuccOrder.prelimitRecOn_succ .. + +private theorem lengthRecOnAux_limit {motive : SurrealHahnSeries → Sort*} + {o : Ordinal} (ho : IsSuccPrelimit o) {succ limit} : + lengthRecOnAux (motive := motive) o succ limit = fun y hy ↦ + limit y (by simp_all) fun z _ ↦ lengthRecOnAux _ succ limit z rfl := + SuccOrder.prelimitRecOn_of_isSuccPrelimit _ _ ho + +/-- Recursion on the length of a Hahn series, separating out the case where it's a +succesor ordinal. -/ +def lengthRecOn {motive : SurrealHahnSeries → Sort*} (x : SurrealHahnSeries) + (succ : ∀ y i r, (∀ j ∈ y.support, i < j) → r ≠ 0 → motive y → motive (y + single i r)) + (limit : ∀ y, IsSuccPrelimit y.length → (∀ z, length z < length y → motive z) → motive y) : + motive x := + lengthRecOnAux _ succ limit _ rfl + +theorem lengthRecOn_succ {motive : SurrealHahnSeries → Sort*} {succ limit} + {x : SurrealHahnSeries} {i : Surreal} {r : ℝ} (hi : ∀ j ∈ x.support, i < j) (hr : r ≠ 0) : + lengthRecOn (motive := motive) (x + single i r) succ limit = + succ _ _ _ hi hr (lengthRecOn x succ limit) := by + rw [lengthRecOn, lengthRecOnAux_succ (o := x.length), cast_eq_iff_heq, lengthRecOn] + · have H : ∀ {hx}, ↑((x + single i r).exp ⟨x.length, hx⟩) = i := by + induction x using termSeqRecOn with | mk s + rw [← TermSeq.coe_appendSingle hr fun _ ↦ hi _ (by simp)] + simp + congr! + · rw [H, trunc_add, trunc_single_of_le le_rfl, add_zero, trunc_eq_self hi] + · exact H + · rw [H] + simpa using mt (hi i) (lt_irrefl i) + · exact length_add_single hi hr + +theorem lengthRecOn_limit {motive : SurrealHahnSeries → Sort*} + {x : SurrealHahnSeries} (hx : IsSuccPrelimit x.length) {succ limit} : + lengthRecOn (motive := motive) x succ limit = + limit x hx fun y _ ↦ lengthRecOn y succ limit := by + rw [lengthRecOn, lengthRecOnAux_limit hx] + rfl + +/-! ### Extra lemmas -/ + +theorem length_truncIdx_add_single {x : SurrealHahnSeries} (i : Iio x.length) {r : ℝ} (hr : r ≠ 0) : + (x.truncIdx i + single (x.exp i) r).length = i + 1 := by + rw [length_add_single _ hr, length_truncIdx] + · grind + · rw [truncIdx_of_lt i.2, support_trunc] + aesop + +theorem length_truncIdx_add_single_le {x : SurrealHahnSeries} (i : Iio x.length) (r : ℝ) : + (x.truncIdx i + single (x.exp i) r).length ≤ i + 1 := by + obtain rfl | hr := eq_or_ne r 0 + · simp + · rw [length_truncIdx_add_single _ hr] + +@[simp] +theorem truncIdx_truncIdx (x : SurrealHahnSeries) (i j : Ordinal) : + (x.truncIdx i).truncIdx j = x.truncIdx (min i j) := by + induction x using termSeqRecOn with | mk s + simp + +@[aesop simp] +theorem coeffIdx_truncIdx (x : SurrealHahnSeries) (i : Ordinal) : + (x.truncIdx i).coeffIdx = fun j ↦ if j < i then x.coeffIdx j else 0 := by + ext j + induction x using termSeqRecOn with | mk s + aesop + +theorem coeffIdx_truncIdx_of_lt {x : SurrealHahnSeries} {i j : Ordinal} (h : j < i) : + (x.truncIdx i).coeffIdx j = x.coeffIdx j := by + rw [coeffIdx_truncIdx] + exact ite_eq_left h + +theorem coeffIdx_truncIdx_of_le {x : SurrealHahnSeries} {i j : Ordinal} (h : i ≤ j) : + (x.truncIdx i).coeffIdx j = 0 := by + rw [coeffIdx_truncIdx] + exact ite_eq_right h.not_gt + +theorem truncIdx_add_one {x : SurrealHahnSeries} {i : Ordinal} (hi : i ∈ Iio x.length) : + x.truncIdx (i + 1) = x.truncIdx i + single (x.exp ⟨i, hi⟩) (x.coeffIdx i) := by + induction x using termSeqRecOn with | mk s + have hs : i ∈ Iio s.length := by simpa using hi + have hseq := congrArg (fun t : TermSeq ↦ (t : SurrealHahnSeries)) (TermSeq.trunc_add_one hs) + rw [TermSeq.coe_appendSingle] at hseq + simpa only [TermSeq.coe_trunc, TermSeq.exp_coe, TermSeq.coeffIdx_coe_of_lt hs] using hseq + +theorem eq_of_length_eq_add_one {x : SurrealHahnSeries} {i : Ordinal} (hi : x.length = i + 1) : + x = x.truncIdx i + single (x.exp ⟨i, by simp [hi]⟩) (x.coeffIdx i) := by + rw [← truncIdx_add_one, truncIdx_of_le hi.le] + +theorem support_truncIdx_strictMonoOn {x : SurrealHahnSeries} : + StrictMonoOn (fun i ↦ (truncIdx x i).support) (Iio x.length) := by + intro i hi j hj h + dsimp + rw [← min_eq_right h.le, ← truncIdx_truncIdx] + apply support_truncIdx_ssubset + simp_all + +theorem support_truncIdx_mono {x : SurrealHahnSeries} : + Monotone fun i ↦ (truncIdx x i).support := by + intro i j h + dsimp + rw [← min_eq_right h, ← truncIdx_truncIdx] + exact support_truncIdx_subset .. + +@[simp] +theorem exp_truncIdx {x : SurrealHahnSeries} {i : Ordinal} (j : Iio (x.truncIdx i).length) : + (x.truncIdx i).exp j = ⟨x.exp ⟨j, by + exact j.property.trans_le ((length_truncIdx x i).le.trans (min_le_right ..))⟩, by + rw [support_truncIdx] + split_ifs with h + · refine ⟨(x.exp _).property, ?_⟩ + change x.exp _ > x.exp ⟨i, h⟩ + apply x.exp.map_rel_iff.mpr + change (j : Ordinal) < i + exact j.property.trans_le ((length_truncIdx x i).le.trans (min_le_left ..)) + · exact (x.exp _).property⟩ := by + induction x using termSeqRecOn with | mk s + apply Subtype.val_injective + rw [exp_congr (TermSeq.coe_trunc s i).symm] + simp + +theorem term_truncIdx_of_lt {x : SurrealHahnSeries} {i j : Ordinal} (h : j < i) : + (x.truncIdx i).term j = x.term j := by + obtain h' | h' := le_or_gt x.length j + · rw [truncIdx_of_le (h'.trans h.le)] + · rw [term_of_lt, term_of_lt h', coeffIdx_truncIdx_of_lt h] + · simp + · simpa [h] + +theorem term_truncIdx_of_le {x : SurrealHahnSeries} {i j : Ordinal} (h : i ≤ j) : + (x.truncIdx i).term j = 0 := by + rw [term_of_le] + simp [h] + +theorem term_injective : term.Injective := by + intro x y h + induction x using termSeqRecOn with | mk s + induction y using termSeqRecOn with | mk t + congr + ext i hs ht + · refine eq_of_forall_ge_iff fun _ ↦ ?_ + simp_rw [← TermSeq.length_coe, ← term_eq_zero, h] + · have he := congrArg Surreal.wlog (congrFun h i) + rw [wlog_term (by simpa using hs), wlog_term (by simpa using ht), + TermSeq.exp_coe, TermSeq.exp_coe] at he + exact he + · have hc := congrArg Surreal.leadingCoeff (congrFun h i) + rw [leadingCoeff_term, leadingCoeff_term, + TermSeq.coeffIdx_coe_of_lt hs, TermSeq.coeffIdx_coe_of_lt ht] at hc + exact hc + +@[simp] +theorem term_inj {x y : SurrealHahnSeries} : x.term = y.term ↔ x = y := + term_injective.eq_iff + +end SurrealHahnSeries diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/HahnSeries/NormalFormSupport.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/HahnSeries/NormalFormSupport.lean new file mode 100644 index 0000000000..6ee38be01c --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/HahnSeries/NormalFormSupport.lean @@ -0,0 +1,158 @@ +/- +Copyright (c) 2026 Dan Abramov, Violeta Hernández Palacios. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov, Violeta Hernández Palacios +-/ +module + +public import LeanPool.ConwayRefinement.CombinatorialGames.Surreal.Birthday.Basic +public import LeanPool.ConwayRefinement.CombinatorialGames.Surreal.Pow + +/-! +# Support lemmas for the Conway normal-form construction + +These inequalities and equivalences are used in the axiom-free Conway normal-form construction +of CombinatorialGames PR #263. Their names, statements, and namespaces agree with the +corresponding upstream declarations. +-/ + +public noncomputable section + +universe u + +namespace IGame + +namespace Numeric + +theorem mul_wpow_lt_mul_wpow_of_pos {x y : IGame} [Numeric x] [Numeric y] + (r : ℝ) {s : ℝ} (hs : 0 < s) (h : x < y) : r * ω^ x < s * ω^ y := + mul_wpow_lt_mul_wpow r hs h + +theorem mul_wpow_lt_mul_wpow_of_neg {x y : IGame} [Numeric x] [Numeric y] + {r : ℝ} (s : ℝ) (hr : r < 0) (h : y < x) : r * ω^ x < s * ω^ y := by + rw [← Surreal.mk_lt_mk] + change (r : Surreal) * ω^ (Surreal.mk x) < (s : Surreal) * ω^ (Surreal.mk y) + rw [← neg_lt_neg_iff] + simpa [neg_mul] using + Surreal.mul_wpow_lt_mul_wpow (-s) (Left.neg_pos_iff.mpr hr) + (Surreal.mk_lt_mk.mpr h) + +theorem realCast_mul_wpow_equiv (r : ℝ) (x : IGame.{u}) [Numeric x] : + r * ω^ x ≈ !{(fun s : ℝ ↦ s * ω^ x) '' Set.Iio r | (fun s : ℝ ↦ s * ω^ x) '' Set.Ioi r} := by + apply Fits.equiv_of_forall_moves + · simp [Fits] + all_goals + simp only [forall_moves_mul, Player.mul_left, Player.mul_right, + moves_ofSets, Player.cases, Set.mem_image] + rintro (_ | _) a ha b hb + · rw [Real.leftMoves_toIGame] at ha + rw [leftMoves_wpow] at hb + obtain ⟨s, hs, rfl⟩ := ha + obtain (rfl | ⟨a, -, y, hy, rfl⟩) := hb + · aesop + numeric + obtain ⟨t, ht, ht'⟩ := exists_between (α := ℝ) hs + refine ⟨(t : IGame) * ω^ x, ⟨t, ht', rfl⟩, ?_⟩ + rw [← Surreal.mk_le_mk] + dsimp [mulOption] + simp_rw [Surreal.mk_dyadic] + rw [add_sub_assoc, ← sub_mul, ← le_sub_iff_add_le, sub_eq_add_neg, add_comm, + ← sub_le_iff_le_add, le_neg, neg_sub, ← sub_mul, ← mul_assoc] + convert Surreal.mk_le_mk.mpr + (mul_wpow_lt_mul_wpow_of_pos ((r - s) * a) (s := t - s) _ (left_lt hy)).le <;> + simp_all + · rw [Real.rightMoves_toIGame] at ha + rw [rightMoves_wpow] at hb + obtain ⟨s, hs, rfl⟩ := ha + obtain ⟨a, ha, y, hy, rfl⟩ := hb + numeric + obtain ⟨t, ht⟩ := exists_lt r + refine ⟨(t : IGame) * ω^ x, ⟨t, ht, rfl⟩, ?_⟩ + rw [← Surreal.mk_le_mk] + dsimp [mulOption] + simp_rw [Surreal.mk_dyadic] + rw [add_sub_assoc, ← sub_mul, ← le_sub_iff_add_le, sub_eq_add_neg, add_comm, + ← sub_le_iff_le_add, ← neg_mul, ← sub_mul, neg_sub, ← mul_assoc] + convert Surreal.mk_le_mk.mpr + (mul_wpow_lt_mul_wpow_of_pos (s - t) (s := (s - r) * a) _ (lt_right hy)).le <;> + simp_all + · rw [Real.leftMoves_toIGame] at ha + rw [Player.neg_left, rightMoves_wpow] at hb + obtain ⟨s, hs, rfl⟩ := ha + obtain ⟨a, ha, y, hy, rfl⟩ := hb + numeric + obtain ⟨t, ht⟩ := exists_gt r + refine ⟨(t : IGame) * ω^ x, ⟨t, ht, rfl⟩, ?_⟩ + rw [← Surreal.mk_le_mk] + dsimp [mulOption] + simp_rw [Surreal.mk_dyadic] + rw [add_sub_assoc, ← sub_mul, ← sub_le_iff_le_add', ← sub_mul, ← mul_assoc] + convert Surreal.mk_le_mk.mpr + (mul_wpow_lt_mul_wpow_of_pos (t - s) (s := (r - s) * a) _ (lt_right hy)).le <;> + simp_all + · rw [Real.rightMoves_toIGame] at ha + rw [Player.neg_right, leftMoves_wpow] at hb + obtain ⟨s, hs, rfl⟩ := ha + obtain (rfl | ⟨a, -, y, hy, rfl⟩) := hb + · aesop + numeric + obtain ⟨t, ht, ht'⟩ := exists_between (α := ℝ) hs + refine ⟨(t : IGame) * ω^ x, ⟨t, ht, rfl⟩, ?_⟩ + rw [← Surreal.mk_le_mk] + dsimp [mulOption] + simp_rw [Surreal.mk_dyadic] + rw [add_sub_assoc, ← sub_mul, ← sub_le_iff_le_add', ← sub_mul, ← neg_le_neg_iff, + ← neg_mul, neg_sub, ← neg_mul, neg_sub, ← mul_assoc] + convert Surreal.mk_le_mk.mpr + (mul_wpow_lt_mul_wpow_of_pos ((s - r) * a) (s := s - t) _ (left_lt hy)).le <;> + simp_all + +end Numeric + +/-- A simplicity-theorem variant using an equivalent game whose moves are easier to enumerate. -/ +theorem Fits.equiv_of_forall_moves_of_equiv {x y : IGame} (a : IGame) (h : x ≈ a) + (hx : x.Fits y) (hl : ∀ z ∈ aᴸ, ∃ w ∈ yᴸ, z ≤ w) + (hr : ∀ z ∈ aᴿ, ∃ w ∈ yᴿ, w ≤ z) : x ≈ y := + h.trans <| Fits.equiv_of_forall_moves (hx.congr h) hl hr + +end IGame + +namespace Surreal + +theorem birthday_eq_iInf_fits (x : IGame) [hx : IGame.Numeric x] : + birthday (.mk x) = + ⨅ y : {y : Subtype IGame.Numeric // IGame.Fits y x}, birthday (.mk y.1.1) := by + let f (y : {y : Subtype IGame.Numeric // IGame.Fits y x}) := birthday (.mk y.1) + let : Inhabited {y : Subtype IGame.Numeric // IGame.Fits y x} := + ⟨⟨x, hx⟩, IGame.Fits.refl _⟩ + apply (ciInf_le' f default).antisymm' + obtain ⟨⟨⟨y, _⟩, hy⟩, hy'⟩ := ciInf_mem f + obtain ⟨z, _, hz, hz'⟩ := birthday_eq_iGameBirthday (.mk y) + rw [← hz'.trans hy'] + apply (birthday_mk_le z).trans' + congr! 1 + rw [eq_comm, mk_eq_mk] at hz ⊢ + refine (hy.congr hz).equiv_of_forall_birthday_le fun w hw hw' ↦ hz' ▸ ?_ + exact hy'.trans_le <| (ciInf_le' f ⟨⟨w, hw⟩, hw'⟩).trans (birthday_mk_le _) + +end Surreal + +namespace IGame + +theorem Fits.birthday_le {x y : IGame} [hx : Numeric x] [Numeric y] (h : Fits x y) : + Surreal.birthday (.mk y) ≤ Surreal.birthday (.mk x) := by + let f (x : {x : Subtype Numeric // Fits x y}) := Surreal.birthday (.mk x.1) + rw [Surreal.birthday_eq_iInf_fits y] + exact ciInf_le' f ⟨⟨x, hx⟩, h⟩ + +theorem Fits.birthday_lt {x y : IGame} [Numeric x] [Numeric y] + (h : Fits x y) (he : ¬ x ≈ y) : Surreal.birthday (.mk y) < Surreal.birthday (.mk x) := by + apply h.birthday_le.lt_of_not_ge + contrapose he + obtain ⟨z, _, hz, hz'⟩ := Surreal.birthday_eq_iGameBirthday (.mk x) + rw [← hz'] at he + rw [eq_comm, Surreal.mk_eq_mk] at hz + exact hz.trans <| (h.congr hz).equiv_of_forall_birthday_le fun w _ hw ↦ + he.trans (hw.birthday_le.trans <| Surreal.birthday_mk_le _) + +end IGame diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/HahnSeries/RealLeadingSplit.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/HahnSeries/RealLeadingSplit.lean new file mode 100644 index 0000000000..49a75d1583 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/HahnSeries/RealLeadingSplit.lean @@ -0,0 +1,531 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.IrreducibilityTransfer +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Reduced +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.ArchimedeanAssumptions +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.HahnSeries.CardinalIntegerPart +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.HahnSeries.IntegerPart +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.NonpositiveCoefficientMap +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.NonpositiveDomainEquiv +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.HahnSeries.NormalForm +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.HahnSeries.SignedFull +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.HahnSeries.Transfer +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.RealArchimedeanStratum + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.CardinalTruncationIrreducible +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.DomainEmbedding +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.DomainEquiv +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.ReducedCharacterization +import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.HahnSeries.DegreeTransfer + +/-! +# Real leading splits of surreal Hahn series + +Embed a nonpositive real-exponent Hahn series into the surreal exponent group. Its leading +Archimedean class is the real class, its open truncation retains only the constant coefficient, +and splitting at that class simply extends each coefficient by a constant infinitesimal Hahn +series. + +The irreducibility theorem combines this description with the residue-one case of LM24, +Proposition 8.3.6(5): irreducibility after coefficient extension implies irreducibility in the +surreal truncation integer part. The same description shows that a constant-coefficient-one series +is reduced in the sense of LM24, Definition 8.2.1, after the embedding. + +The last section passes to Conway's omnific integers. A real-exponent series with integer +constant coefficient determines the omnific integer `ofRealSeries` whose signed Conway normal form +is the embedded series; its Conway coefficients, support, normal form, and length are read off +from the series, and irreducibility and reducedness transfer. This is the natural route to +omnific integers whose Conway normal forms have real exponents. + +## References + +* S. L'Innocente, V. Mantova, *A factorisation theory for generalised power series and omnific + integers*, Adv. Math. 442 (2024) 109513, cited as [LM24]. +-/ + +universe u v + +open scoped HahnSeries + +public noncomputable section + +namespace HahnSeries.Nonpositive + +open FiniteArchimedeanClass + +variable {R : Type v} [Field R] + +private def realToSurrealAddMonoidHom : ℝ →+ Surreal.{u} := + Real.toSurrealRingHom.toRingHom.toAddMonoidHom + +/-- Map a real-exponent nonpositive Hahn series into the surreal exponent group. -/ +def mapRealDomainToSurreal : Nonpositive ℝ R →+* Nonpositive Surreal.{u} R := + mapDomain realToSurrealAddMonoidHom + (by + intro r s h + change (r : Surreal.{u}) = (s : Surreal.{u}) at h + exact_mod_cast h) + (fun r s ↦ Real.toSurreal_le_iff) + +/-- Mapping the real exponent domain into the surreal numbers is injective. -/ +theorem mapRealDomainToSurreal_injective : + Function.Injective (mapRealDomainToSurreal : + Nonpositive ℝ R → Nonpositive Surreal.{u} R) := by + intro a b hab + apply mapDomain_injective realToSurrealAddMonoidHom + (by + intro x y h + change (x : Surreal.{u}) = (y : Surreal.{u}) at h + exact_mod_cast h) + (fun x y ↦ Real.toSurreal_le_iff) + change mapRealDomainToSurreal a = mapRealDomainToSurreal b + exact hab + +@[simp] +theorem mapRealDomainToSurreal_coeff_real (a : Nonpositive ℝ R) (r : ℝ) : + (mapRealDomainToSurreal a : R⟦Surreal.{u}⟧).coeff (r : Surreal.{u}) = + (a : R⟦ℝ⟧).coeff r := by + exact mapDomain_coeff_image realToSurrealAddMonoidHom + (by + intro x y h + change (x : Surreal.{u}) = (y : Surreal.{u}) at h + exact_mod_cast h) + (fun x y ↦ Real.toSurreal_le_iff) a r + +/-- Mapping the real exponent domain preserves the constant coefficient. -/ +theorem constantCoeff_mapRealDomainToSurreal (a : Nonpositive ℝ R) : + constantCoeff (mapRealDomainToSurreal a : Nonpositive Surreal.{u} R) = + constantCoeff a := by + rw [mapRealDomainToSurreal] + exact constantCoeff_mapDomain realToSurrealAddMonoidHom + (by + intro x y h + change (x : Surreal.{u}) = (y : Surreal.{u}) at h + exact_mod_cast h) + (fun x y ↦ Real.toSurreal_le_iff) a + +/-- Mapping the real exponent domain sends the support pointwise into the surreal real line. -/ +theorem mapRealDomainToSurreal_support (a : Nonpositive ℝ R) : + (mapRealDomainToSurreal a : R⟦Surreal.{u}⟧).support = + (fun r : ℝ ↦ (r : Surreal.{u})) '' (a : R⟦ℝ⟧).support := by + exact support_mapDomain realToSurrealAddMonoidHom + (by + intro x y h + change (x : Surreal.{u}) = (y : Surreal.{u}) at h + exact_mod_cast h) + (fun x y ↦ Real.toSurreal_le_iff) a + +/-- Mapping the real exponent domain preserves support order type, up to universe lift. -/ +theorem lift_supportOrderType_mapRealDomainToSurreal (a : Nonpositive ℝ R) : + Ordinal.lift.{0, u + 1} + (mapRealDomainToSurreal a : R⟦Surreal.{u}⟧).supportOrderType = + Ordinal.lift.{u + 1, 0} (a : R⟦ℝ⟧).supportOrderType := by + rw [mapRealDomainToSurreal] + exact lift_supportOrderType_mapDomain realToSurrealAddMonoidHom + (by + intro x y h + change (x : Surreal.{u}) = (y : Surreal.{u}) at h + exact_mod_cast h) + (fun x y ↦ Real.toSurreal_le_iff) a + +/-- The leading Archimedean class of a nonconstant series supported on the embedded real line is +the real Archimedean class. -/ +theorem leadingClass_mapRealDomainToSurreal_eq_realFiniteClass + {a : Nonpositive ℝ R} (ha : a ≠ 0) + (horder : ((mapRealDomainToSurreal a : Nonpositive Surreal.{u} R) : + R⟦Surreal.{u}⟧).order ≠ 0) : + leadingClass (mapRealDomainToSurreal a) horder = + Surreal.realFiniteClass := by + apply Subtype.ext + rw [leadingClass_val, Surreal.realFiniteClass_val] + have hmappedNe : (mapRealDomainToSurreal a : Nonpositive Surreal.{u} R) ≠ 0 := + fun hzero ↦ ha (mapRealDomainToSurreal_injective (by simpa using hzero)) + have horderMem : ((mapRealDomainToSurreal a : Nonpositive Surreal.{u} R) : + R⟦Surreal.{u}⟧).order ∈ + (mapRealDomainToSurreal a : R⟦Surreal.{u}⟧).support := by + rw [HahnSeries.mem_support] + exact HahnSeries.coeff_order_eq_zero.not.mpr + (fun h ↦ hmappedNe (Subtype.ext h)) + rw [mapRealDomainToSurreal_support] at horderMem + obtain ⟨r, _hr, hrorder⟩ := horderMem + rw [← hrorder] + apply Surreal.mk_realCast + intro hr0 + subst r + apply horder + simpa using hrorder.symm + +/-- The open truncation at the real Archimedean class retains only the constant coefficient of a +series whose exponents are embedded reals. -/ +theorem tau_mapRealDomainToSurreal + (a : Nonpositive ℝ R) : + tau (K := ℝ) + (Surreal.realFiniteClass : FiniteArchimedeanClass Surreal.{u}) + (mapRealDomainToSurreal a) = + C (constantCoeff a) := by + apply Subtype.ext + apply HahnSeries.coeff_injective + funext g + by_cases hgBall : g ∈ ball ℝ + (Surreal.realFiniteClass : FiniteArchimedeanClass Surreal.{u}) + · rw [coeff_tau_of_mem _ _ hgBall] + by_cases hg0 : g = 0 + · subst g + rw [coe_C, HahnSeries.C_apply] + simp only [HahnSeries.coeff_single_same] + have hcoeff := mapRealDomainToSurreal_coeff_real a 0 + have hzero : ((0 : ℝ) : Surreal.{u}) = 0 := + Real.toSurrealRingHom.map_zero + rw [constantCoeff_apply] + rw [← hzero] + exact hcoeff + · have hgNotSupport : g ∉ + (mapRealDomainToSurreal a : R⟦Surreal.{u}⟧).support := by + rw [mapRealDomainToSurreal_support] + rintro ⟨r, _hr, hrg⟩ + have hrealG : g ∈ + (Surreal.realStratum : Submodule ℝ Surreal.{u}) := by + rw [Surreal.mem_realStratum_iff] + exact ⟨r, hrg⟩ + have hzero := Submodule.disjoint_def.mp + Surreal.disjoint_ball_realStratum + g hgBall hrealG + exact hg0 hzero + have hcoeff : (mapRealDomainToSurreal a : R⟦Surreal.{u}⟧).coeff g = 0 := by + rw [← not_ne_iff, ← HahnSeries.mem_support] + exact hgNotSupport + rw [hcoeff, coe_C, HahnSeries.C_apply, + HahnSeries.coeff_single_of_ne hg0] + · rw [coeff_tau_of_not_mem _ _ hgBall] + have hg0 : g ≠ 0 := by + intro hzero + subst g + exact hgBall (zero_mem _) + rw [coe_C, HahnSeries.C_apply, HahnSeries.coeff_single_of_ne hg0] + +/-- The real-supported series belongs to a truncation integer part whenever its constant +coefficient belongs to the chosen coefficient subring. -/ +def mapRealDomainToSurrealIntegerPart (Z : Subring R) (a : Nonpositive ℝ R) + (haConstant : constantCoeff a ∈ Z) : + HahnSeries.truncationIntegerPart Surreal.{u} Z := + ⟨mapRealDomainToSurreal a, by + rw [mem_truncationIntegerPart, ← constantCoeff_apply] + exact (constantCoeff_mapDomain realToSurrealAddMonoidHom + (by + intro x y h + change (x : Surreal.{u}) = (y : Surreal.{u}) at h + exact_mod_cast h) + (fun x y ↦ Real.toSurreal_le_iff) a).symm ▸ haConstant⟩ + +@[simp] +theorem coe_mapRealDomainToSurrealIntegerPart + (Z : Subring R) (a : Nonpositive ℝ R) + (haConstant : constantCoeff a ∈ Z) : + (mapRealDomainToSurrealIntegerPart Z a haConstant : Nonpositive Surreal.{u} R) = + mapRealDomainToSurreal a := + (rfl) + +/-- Splitting a real-supported surreal Hahn series at the real Archimedean class extends its +coefficients by constant infinitesimal Hahn series and leaves its real exponents unchanged. -/ +theorem splitTruncation_mapRealDomainToSurreal + (u : HahnEmbedding.ArchimedeanStrata ℝ Surreal.{u}) (a : Nonpositive ℝ R) : + splitTruncation (Surreal.archimedeanStrataWithReal u) + Surreal.realFiniteClass (mapRealDomainToSurreal a) = + embDomainRingEquiv + (Surreal.archimedeanStrataWithRealOrderAddMonoidIso u) + (nonpositiveCoefficientMap + (HahnSeries.C : R →+* R⟦ball ℝ Surreal.realFiniteClass⟧) a) := by + apply Subtype.ext + apply HahnSeries.ext + funext s + apply HahnSeries.ext + funext b + let e := Surreal.archimedeanStrataWithRealOrderAddMonoidIso u + let r := e.symm s + have hs : e r = s := e.apply_symm_apply s + rw [← hs] + rw [coe_splitTruncation, coe_embDomainRingEquiv, + HahnSeries.archimedeanSplitRingEquiv_coeff, + TClosed_coeff, coeff_T_of_mem] + · rw [HahnSeries.embDomainRingEquiv_coeff, + coe_nonpositiveCoefficientMap] + rw [HahnEmbedding.ArchimedeanStrata.stratumLexBallEquivClosedBall_apply] + by_cases hb0 : (b : Surreal.{u}) = 0 + · have hb : b = 0 := Subtype.ext hb0 + subst b + simp only [ofLex_toLex] + rw [Surreal.coe_archimedeanStrataWithRealOrderAddMonoidIso] + rw [show ((0 : ball ℝ Surreal.realFiniteClass) : Surreal.{u}) = 0 from rfl, add_zero] + rw [mapRealDomainToSurreal_coeff_real] + simp [HahnSeries.C_apply] + · have hb : b ≠ 0 := fun h ↦ hb0 (congrArg Subtype.val h) + have hleft : (mapRealDomainToSurreal a : R⟦Surreal.{u}⟧).coeff + ((e r : (Surreal.archimedeanStrataWithReal u).stratum + Surreal.realFiniteClass) + (b : Surreal.{u})) = 0 := by + rw [← not_ne_iff, ← HahnSeries.mem_support, + mapRealDomainToSurreal_support] + rintro ⟨q, _hq, hqeq⟩ + have hrealB : (b : Surreal.{u}) ∈ Surreal.realStratum := by + rw [Surreal.mem_realStratum_iff] + refine ⟨q - r, ?_⟩ + have hscoe : (e r : Surreal.{u}) = (r : Surreal.{u}) := by + exact Surreal.coe_archimedeanStrataWithRealOrderAddMonoidIso _ _ + change (q : Surreal.{u}) = (e r : Surreal.{u}) + (b : Surreal.{u}) at hqeq + rw [hscoe] at hqeq + rw [show ((q - r : ℝ) : Surreal.{u}) = (q : Surreal.{u}) - (r : Surreal.{u}) by + exact Real.toSurrealRingHom.map_sub q r] + apply sub_eq_iff_eq_add.mpr + simpa [add_comm] using hqeq + have hzero := Submodule.disjoint_def.mp Surreal.disjoint_ball_realStratum + (b : Surreal.{u}) b.2 hrealB + exact hb (Subtype.ext hzero) + simp only [ofLex_toLex] + rw [hleft] + change 0 = (HahnSeries.C ((a : R⟦ℝ⟧).coeff r)).coeff b + exact (HahnSeries.coeff_single_of_ne hb).symm + · exact (HahnEmbedding.ArchimedeanStrata.stratumLexBallEquivClosedBall + (Surreal.archimedeanStrataWithReal u) Surreal.realFiniteClass (toLex (e r, b))).2 + +/-- A real-supported constant-one series gives an irreducible surreal truncation-integer-part +element when its coefficient extension to the infinitesimal Hahn field is irreducible. -/ +theorem irreducible_mapRealDomainToSurrealIntegerPart + (u : HahnEmbedding.ArchimedeanStrata ℝ Surreal.{u}) (Z : Subring R) + (a : Nonpositive ℝ R) (ha : a ≠ 0) + (haOrder : (mapRealDomainToSurreal a : R⟦Surreal.{u}⟧).order ≠ 0) + (haConstant : constantCoeff a = 1) + (hirr : Irreducible + (nonpositiveCoefficientMap + (HahnSeries.C : R →+* R⟦ball ℝ + (Surreal.realFiniteClass : FiniteArchimedeanClass Surreal.{u})⟧) a)) : + Irreducible + (mapRealDomainToSurrealIntegerPart Z a + (haConstant.symm ▸ Z.one_mem) : + HahnSeries.truncationIntegerPart Surreal.{u} Z) := by + let b : HahnSeries.truncationIntegerPart Surreal.{u} Z := + mapRealDomainToSurrealIntegerPart Z a + (haConstant.symm ▸ Z.one_mem) + have hbCoe : (b : Nonpositive Surreal.{u} R) = mapRealDomainToSurreal a := + (rfl) + have hbOrder : ((b : Nonpositive Surreal.{u} R) : R⟦Surreal.{u}⟧).order ≠ 0 := by + rw [hbCoe] + exact haOrder + have hb0 : (b : Nonpositive Surreal.{u} R) ≠ 0 := by + rw [hbCoe] + intro hzero + exact ha (mapRealDomainToSurreal_injective (by simpa using hzero)) + have hleading : leadingClass (b : Nonpositive Surreal.{u} R) hbOrder = + Surreal.realFiniteClass := by + apply Subtype.ext + rw [leadingClass_val] + have hval := congrArg Subtype.val + (leadingClass_mapRealDomainToSurreal_eq_realFiniteClass ha haOrder) + rw [leadingClass_val] at hval + simpa only [hbCoe] using hval + apply irreducible_of_irreducible_splitTruncation_of_tau_eq_one + (Surreal.archimedeanStrataWithReal u) Z b hb0 hbOrder + · rw [hleading] + apply tauBall_eq_one_of_tau_eq_one + rw [hbCoe, tau_mapRealDomainToSurreal, haConstant] + apply Subtype.ext + simpa only [coe_C, Subring.coe_one] using + (HahnSeries.C_one (Γ := Surreal.{u}) (R := R)) + · rw [hleading, hbCoe, + splitTruncation_mapRealDomainToSurreal] + exact hirr.map + (embDomainRingEquiv + (Surreal.archimedeanStrataWithRealOrderAddMonoidIso u)) + +/-- A real-supported series with constant coefficient one is reduced after embedding its exponents +into the surreal numbers: its open truncation at the leading class is the constant one. -/ +theorem isReduced_mapRealDomainToSurreal {a : Nonpositive ℝ R} + (haOrder : (mapRealDomainToSurreal a : R⟦Surreal.{u}⟧).order ≠ 0) + (haConstant : constantCoeff a = 1) : + IsReduced (mapRealDomainToSurreal a : Nonpositive Surreal.{u} R) := by + have ha : a ≠ 0 := fun h ↦ haOrder (by + rw [h, map_zero, ZeroMemClass.coe_zero, HahnSeries.order_zero]) + have hmappedNe : (mapRealDomainToSurreal a : Nonpositive Surreal.{u} R) ≠ 0 := + fun hzero ↦ ha (mapRealDomainToSurreal_injective (by simpa using hzero)) + apply (isReduced_iff_tau_leadingClass_eq_zero_or_one (K := ℝ) _ hmappedNe haOrder).mpr + right + rw [leadingClass_mapRealDomainToSurreal_eq_realFiniteClass ha haOrder, + tau_mapRealDomainToSurreal, haConstant] + apply Subtype.ext + simpa only [coe_C, Subring.coe_one] using (HahnSeries.C_one (Γ := Surreal.{u}) (R := R)) + +end HahnSeries.Nonpositive + +/-! ### Surreal numbers whose signed Conway normal form has real exponents -/ + +namespace Surreal + +open HahnSeries.Nonpositive + +variable {x : Surreal.{u}} {a : HahnSeries.Nonpositive ℝ ℝ} + +/-- The Conway coefficient at `-r` of a surreal whose signed Conway normal form is a +real-exponent series is the series coefficient at `r`. -/ +theorem coeff_neg_realCast_of_toSignedFullHahnSeries_eq + (hx : x.toSignedFullHahnSeries = mapRealDomainToSurreal a) (r : ℝ) : + x.coeff (-(r : Surreal.{u})) = (a : ℝ⟦ℝ⟧).coeff r := by + rw [← coeff_toSignedFullHahnSeries, hx, mapRealDomainToSurreal_coeff_real] + +/-- The Conway support of a surreal whose signed Conway normal form is a real-exponent series is +the negated image of the series support. -/ +theorem support_of_toSignedFullHahnSeries_eq + (hx : x.toSignedFullHahnSeries = mapRealDomainToSurreal a) : + x.support = (fun r : ℝ ↦ -(r : Surreal.{u})) '' (a : ℝ⟦ℝ⟧).support := by + ext i + constructor + · intro hi + have hsigned : -i ∈ x.toSignedFullHahnSeries.support := + mem_support_toSignedFullHahnSeries.mpr (by rwa [neg_neg]) + rw [hx, mapRealDomainToSurreal_support] at hsigned + obtain ⟨r, hr, hri⟩ := hsigned + have hri' : (r : Surreal.{u}) = -i := hri + refine ⟨r, hr, ?_⟩ + change -(r : Surreal.{u}) = i + rw [hri', neg_neg] + · rintro ⟨r, hr, rfl⟩ + apply mem_support_toSignedFullHahnSeries.mp + rw [hx, mapRealDomainToSurreal_support] + exact ⟨r, hr, rfl⟩ + +/-- The Conway normal form of a surreal whose signed Conway normal form is a real-exponent series +is the surreal Hahn series supported on negated reals whose coefficient at `-r` is the series +coefficient at `r`. -/ +theorem toHahnSeries_eq_of_toSignedFullHahnSeries_eq + (hx : x.toSignedFullHahnSeries = mapRealDomainToSurreal a) (N : SurrealHahnSeries.{u}) + (hN : ∀ r : ℝ, N.coeff (-(r : Surreal.{u})) = (a : ℝ⟦ℝ⟧).coeff r) + (hNsupport : N.support ⊆ Set.range (fun r : ℝ ↦ -(r : Surreal.{u}))) : + x.toHahnSeries = N := by + apply SurrealHahnSeries.ext + funext i + rw [coeff_toHahnSeries] + by_cases hi : i ∈ Set.range (fun r : ℝ ↦ -(r : Surreal.{u})) + · obtain ⟨r, rfl⟩ := hi + change x.coeff (-(r : Surreal.{u})) = N.coeff (-(r : Surreal.{u})) + rw [hN, coeff_neg_realCast_of_toSignedFullHahnSeries_eq hx] + · have hxi : x.coeff i = 0 := by + rw [← notMem_support_iff, support_of_toSignedFullHahnSeries_eq hx] + rintro ⟨r, -, hri⟩ + exact hi ⟨r, hri⟩ + have hNi : N.coeff i = 0 := by + by_contra hne + exact hi (hNsupport (SurrealHahnSeries.mem_support_iff.mpr hne)) + rw [hxi, hNi] + +/-- The lifted Conway length of a surreal whose signed Conway normal form is a real-exponent +series is the lifted support order type of the series. -/ +theorem lift_length_of_toSignedFullHahnSeries_eq + (hx : x.toSignedFullHahnSeries = mapRealDomainToSurreal a) : + Ordinal.lift.{u + 1, u} x.length = + Ordinal.lift.{u + 1, 0} (a : ℝ⟦ℝ⟧).supportOrderType := by + have h : Ordinal.lift.{0, u + 1} + (mapRealDomainToSurreal a : ℝ⟦Surreal.{u}⟧).supportOrderType = + Ordinal.lift.{u + 1, 0} (a : ℝ⟦ℝ⟧).supportOrderType := + lift_supportOrderType_mapRealDomainToSurreal a + rw [← hx, toSignedFullHahnSeries_eq, HahnSeries.supportOrderType_embDomainRingEquiv, + supportOrderType_toFullHahnSeries, Ordinal.lift_id'] at h + exact h + +end Surreal + +/-! ### Omnific integers with real Conway exponents -/ + +namespace Surreal.OmnificInteger + +open HahnSeries.Nonpositive + +variable (a : HahnSeries.Nonpositive ℝ ℝ) + +private theorem cardSupp_mapRealDomainToSurreal_lt : + (mapRealDomainToSurreal a : ℝ⟦Surreal.{u}⟧).cardSupp < Surreal.smallSupportCardinal.{u} := by + have hsmall : Small.{u, u + 1} (mapRealDomainToSurreal a : ℝ⟦Surreal.{u}⟧).support := by + rw [mapRealDomainToSurreal_support] + infer_instance + rw [HahnSeries.cardSupp, Surreal.smallSupportCardinal_eq_univ] + simpa only [Cardinal.lift_id] using (Cardinal.small_iff_lift_mk_lt_univ + (α := (mapRealDomainToSurreal a : ℝ⟦Surreal.{u}⟧).support)).mp hsmall + +private def boundedOfRealSeries (ha : constantCoeff a ∈ Surreal.realIntegerSubring) : + SignedSmallSupportIntegerPart.{u} := + ⟨⟨mapRealDomainToSurreal a, cardSupp_mapRealDomainToSurreal_lt a⟩, by + rw [HahnSeries.mem_cardSuppLTTruncationIntegerPart] + refine ⟨support_subset _, ?_⟩ + rw [← constantCoeff_apply, constantCoeff_mapRealDomainToSurreal] + exact ha⟩ + +private theorem toTruncationIntegerPartRingHom_boundedOfRealSeries + (ha : constantCoeff a ∈ Surreal.realIntegerSubring) : + HahnSeries.CardSuppLTTruncationIntegerPart.toTruncationIntegerPartRingHom + Surreal.realIntegerSubring (boundedOfRealSeries a ha) = + mapRealDomainToSurrealIntegerPart Surreal.realIntegerSubring a ha := by + apply Subtype.ext + apply Subtype.ext + rw [HahnSeries.CardSuppLTTruncationIntegerPart.coe_toTruncationIntegerPartRingHom, + HahnSeries.CardSuppLTTruncationIntegerPart.coe_toNonpositiveRingHom, + coe_mapRealDomainToSurrealIntegerPart] + rfl + +/-- The omnific integer whose signed Conway normal form is the real-exponent series `a`: the +Conway normal form `∑ a_r ω ^ (-r)` over the support of `a`. -/ +def ofRealSeries (ha : constantCoeff a ∈ Surreal.realIntegerSubring) : + Surreal.OmnificInteger.{u} := + signedSmallSupportIntegerPartRingEquiv.symm (boundedOfRealSeries a ha) + +variable (ha : constantCoeff a ∈ Surreal.realIntegerSubring) + +/-- The signed Conway normal form of `ofRealSeries a ha` is `a` with surreal exponents. -/ +theorem toSignedFullHahnSeries_ofRealSeries : + (ofRealSeries.{u} a ha).1.toSignedFullHahnSeries = mapRealDomainToSurreal a := by + have h := signedSmallSupportIntegerPartRingEquiv.apply_symm_apply (boundedOfRealSeries a ha) + rw [signedSmallSupportIntegerPartRingEquiv_apply] at h + have hraw := congrArg (fun q : SignedSmallSupportIntegerPart.{u} ↦ + ((q : HahnSeries.CardSuppLTField (G := Surreal) (R := ℝ) + (κ := Surreal.smallSupportCardinal.{u})) : HahnSeries Surreal ℝ)) h + rw [coe_toSignedSmallSupportIntegerPart] at hraw + exact hraw + +/-- The signed nonpositive Hahn series of `ofRealSeries a ha` is `a` with surreal exponents. -/ +theorem toSignedNonpositiveHahn_ofRealSeries : + (ofRealSeries.{u} a ha).toSignedNonpositiveHahn = mapRealDomainToSurreal a := by + apply Subtype.ext + rw [coe_toSignedNonpositiveHahn, toSignedFullHahnSeries_ofRealSeries] + +/-- The Conway normal form of `ofRealSeries a ha` has the support order type of `a`, lifted to +the universe of the surreal model. -/ +theorem length_ofRealSeries : + (ofRealSeries.{u} a ha).1.length = Ordinal.lift.{u, 0} (a : ℝ⟦ℝ⟧).supportOrderType := by + apply Ordinal.lift_inj.{u + 1, u}.mp + rw [Ordinal.lift_lift] + exact Surreal.lift_length_of_toSignedFullHahnSeries_eq (toSignedFullHahnSeries_ofRealSeries a ha) + +/-- `ofRealSeries a ha` is irreducible when `a` is irreducible in the surreal truncation integer +part. -/ +theorem irreducible_ofRealSeries + (hirr : Irreducible (mapRealDomainToSurrealIntegerPart Surreal.realIntegerSubring a ha : + HahnSeries.truncationIntegerPart Surreal.{u} Surreal.realIntegerSubring)) : + Irreducible (ofRealSeries.{u} a ha) := by + have h : Irreducible (boundedOfRealSeries a ha) := by + apply + HahnSeries.CardSuppLTTruncationIntegerPart.irreducible_of_irreducible_toTruncationIntegerPart + Surreal.realIntegerSubring + rw [toTruncationIntegerPartRingHom_boundedOfRealSeries] + exact hirr + exact h.map signedSmallSupportIntegerPartRingEquiv.symm + +/-- `ofRealSeries a ha` is reduced when `a` is nonzero and nonconstant with constant coefficient +one. -/ +theorem isReduced_ofRealSeries + (haOrder : (mapRealDomainToSurreal a : ℝ⟦Surreal.{u}⟧).order ≠ 0) + (haConstant : constantCoeff a = 1) : + IsReduced (ofRealSeries.{u} a ha).toSignedNonpositiveHahn := by + rw [toSignedNonpositiveHahn_ofRealSeries] + exact isReduced_mapRealDomainToSurreal haOrder haConstant + +end Surreal.OmnificInteger diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/HahnSeries/SignedFull.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/HahnSeries/SignedFull.lean new file mode 100644 index 0000000000..b7bb2b1af9 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/HahnSeries/SignedFull.lean @@ -0,0 +1,167 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.DomainOrderType +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.HahnSeries.Full + +/-! +# Conway normal forms with signed surreal exponents + +The order dual in `Surreal.toFullHahnSeries` records the reversal from Conway's `ω` to +LM24's `t = ω⁻¹`. Sending a dual exponent `i` to the ordinary surreal exponent `-i` makes +that reversal explicit and places the normal form in a Hahn field whose exponent group is +`Surreal` itself. This is the orientation in which the surreal Archimedean-stratum assumptions +apply directly. +-/ + +universe u + +public noncomputable section + +namespace Surreal + +/-- Negation identifies dual Conway exponents with signed ordinary surreal exponents. -/ +def dualExponentOrderAddMonoidIso : Surrealᵒᵈ ≃+o Surreal := + { toFun := fun x ↦ -x.ofDual + invFun := fun x ↦ OrderDual.toDual (-x) + left_inv := by intro x; simp + right_inv := by intro x; simp + map_add' := by intro x y; simp [add_comm] + map_le_map_iff' := by + intro x y + change -x.ofDual ≤ -y.ofDual ↔ y.ofDual ≤ x.ofDual + exact neg_le_neg_iff } + +/-- The signed-exponent map sends a dual exponent to the negative underlying surreal. -/ +@[simp] +theorem dualExponentOrderAddMonoidIso_apply (x : Surrealᵒᵈ) : + dualExponentOrderAddMonoidIso x = -x.ofDual := + (rfl) + +/-- The inverse signed-exponent map sends `x` to the dual of `-x`. -/ +@[simp] +theorem dualExponentOrderAddMonoidIso_symm_apply (x : Surreal.{u}) : + dualExponentOrderAddMonoidIso.symm x = OrderDual.toDual (-x) := + (rfl) + +/-- The full Conway normal form with the exponent of `t = ω⁻¹` written as an ordinary +surreal number. -/ +def toSignedFullHahnSeries (x : Surreal.{u}) : HahnSeries Surreal ℝ := + HahnSeries.embDomainRingEquiv dualExponentOrderAddMonoidIso x.toFullHahnSeries + +/-- The signed full series is exponent reindexing of the dual-exponent full series. -/ +theorem toSignedFullHahnSeries_eq (x : Surreal.{u}) : + toSignedFullHahnSeries x = + HahnSeries.embDomainRingEquiv dualExponentOrderAddMonoidIso x.toFullHahnSeries := + (rfl) + +/-- Evaluation of the signed Conway normal form at exponent `g`. -/ +@[simp] +theorem coeff_toSignedFullHahnSeries (x g : Surreal.{u}) : + x.toSignedFullHahnSeries.coeff g = x.coeff (-g) := by + rw [toSignedFullHahnSeries_eq, + ← dualExponentOrderAddMonoidIso.apply_symm_apply g, + HahnSeries.embDomainRingEquiv_coeff, + dualExponentOrderAddMonoidIso_symm_apply, + coeff_toFullHahnSeries] + simp + +/-- Signed exponent reindexing preserves the zero Conway normal form. -/ +@[simp] +theorem toSignedFullHahnSeries_zero : + toSignedFullHahnSeries (0 : Surreal.{u}) = 0 := by + rw [toSignedFullHahnSeries, toFullHahnSeries_zero, map_zero] + +/-- Signed exponent reindexing preserves addition of Conway normal forms. -/ +theorem toSignedFullHahnSeries_add (x y : Surreal.{u}) : + toSignedFullHahnSeries (x + y) = + toSignedFullHahnSeries x + toSignedFullHahnSeries y := by + rw [toSignedFullHahnSeries_eq, toSignedFullHahnSeries_eq, + toSignedFullHahnSeries_eq, toFullHahnSeries_add, map_add] + +/-- Signed exponent reindexing preserves negation of Conway normal forms. -/ +@[simp] +theorem toSignedFullHahnSeries_neg (x : Surreal.{u}) : + toSignedFullHahnSeries (-x) = -toSignedFullHahnSeries x := by + rw [toSignedFullHahnSeries_eq, toSignedFullHahnSeries_eq, + toFullHahnSeries_neg, map_neg] + +/-- Signed exponent reindexing preserves subtraction of Conway normal forms. -/ +@[simp] +theorem toSignedFullHahnSeries_sub (x y : Surreal.{u}) : + toSignedFullHahnSeries (x - y) = + toSignedFullHahnSeries x - toSignedFullHahnSeries y := by + rw [sub_eq_add_neg, toSignedFullHahnSeries_add, toSignedFullHahnSeries_neg] + rfl + +/-- The signed full Conway normal-form map is injective. -/ +theorem toSignedFullHahnSeries_injective : + Function.Injective (toSignedFullHahnSeries : + Surreal.{u} → HahnSeries Surreal ℝ) := + (HahnSeries.embDomainRingEquiv dualExponentOrderAddMonoidIso).injective.comp + toFullHahnSeries_injective + +/-- A signed Hahn exponent occurs exactly when its negation occurs in the unsigned Conway +support. -/ +theorem mem_support_toSignedFullHahnSeries {x g : Surreal.{u}} : + g ∈ x.toSignedFullHahnSeries.support ↔ -g ∈ x.support := by + rw [toSignedFullHahnSeries_eq, HahnSeries.support_embDomainRingEquiv] + constructor + · rintro ⟨i, hi, rfl⟩ + simpa using (mem_support_toFullHahnSeries.mp hi) + · intro hg + refine ⟨OrderDual.toDual (-g), mem_support_toFullHahnSeries.mpr ?_, ?_⟩ + · simpa using hg + · simp + +/-- Signed exponent reindexing preserves the LM24 degree of the Conway normal form. -/ +@[simp] +theorem degree_toSignedFullHahnSeries (x : Surreal.{u}) : + x.toSignedFullHahnSeries.degree = x.toFullHahnSeries.degree := by + rw [HahnSeries.degree_eq_cantorDegree, HahnSeries.degree_eq_cantorDegree, + toSignedFullHahnSeries_eq, HahnSeries.supportOrderType_embDomainRingEquiv] + +/-- The signed full Conway normal form of a real is concentrated at exponent zero. -/ +@[simp] +theorem toSignedFullHahnSeries_realCast (r : ℝ) : + toSignedFullHahnSeries (r : Surreal.{u}) = HahnSeries.single 0 r := by + rw [toSignedFullHahnSeries_eq, toFullHahnSeries_realCast] + ext g + rw [← dualExponentOrderAddMonoidIso.apply_symm_apply g, + HahnSeries.embDomainRingEquiv_coeff] + rw [dualExponentOrderAddMonoidIso_symm_apply] + simp [HahnSeries.coeff_single] + +/-- The signed full Conway normal form of `ω ^ x` is the monomial at exponent `-x`. -/ +@[simp] +theorem toSignedFullHahnSeries_wpow (x : Surreal.{u}) : + toSignedFullHahnSeries (ω^ x) = HahnSeries.single (-x) 1 := by + rw [toSignedFullHahnSeries_eq, toFullHahnSeries_wpow, + HahnSeries.embDomainRingEquiv_single] + rfl + +/-- The signed full Conway Hahn-series map preserves arbitrary surreal products. -/ +@[simp] +theorem toSignedFullHahnSeries_mul (x y : Surreal.{u}) : + toSignedFullHahnSeries (x * y) = + toSignedFullHahnSeries x * toSignedFullHahnSeries y := by + rw [toSignedFullHahnSeries_eq, toSignedFullHahnSeries_eq, + toSignedFullHahnSeries_eq, toFullHahnSeries_mul, map_mul] + +/-- Full Hahn multiplication compatibility is equivalent to its signed-exponent form. -/ +theorem toSignedFullHahnSeries_mul_iff (x y : Surreal.{u}) : + toSignedFullHahnSeries (x * y) = + toSignedFullHahnSeries x * toSignedFullHahnSeries y ↔ + toFullHahnSeries (x * y) = toFullHahnSeries x * toFullHahnSeries y := by + change HahnSeries.embDomainRingEquiv dualExponentOrderAddMonoidIso + (x * y).toFullHahnSeries = + HahnSeries.embDomainRingEquiv dualExponentOrderAddMonoidIso x.toFullHahnSeries * + HahnSeries.embDomainRingEquiv dualExponentOrderAddMonoidIso y.toFullHahnSeries ↔ _ + rw [← map_mul] + exact (HahnSeries.embDomainRingEquiv dualExponentOrderAddMonoidIso).injective.eq_iff + +end Surreal diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/HahnSeries/Tests.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/HahnSeries/Tests.lean new file mode 100644 index 0000000000..2e00cd5857 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/HahnSeries/Tests.lean @@ -0,0 +1,17 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.HahnSeries.Tests.CardinalIntegerPart +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.HahnSeries.Tests.DegreeTransfer +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.HahnSeries.Tests.Full +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.HahnSeries.Tests.Multiplication +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.HahnSeries.Tests.NormalForm +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.HahnSeries.Tests.NormalFormAdd +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.HahnSeries.Tests.NormalFormMul + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/HahnSeries/Tests/CardinalIntegerPart.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/HahnSeries/Tests/CardinalIntegerPart.lean new file mode 100644 index 0000000000..a95908f4ca --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/HahnSeries/Tests/CardinalIntegerPart.lean @@ -0,0 +1,82 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.HahnSeries.CardinalIntegerPart + +/-! +# Checks for the bounded omnific-integer correspondence + +This separately compiled client checks both directions of the public additive equivalence and +the conditional ring-equivalence constructor. The generic raw-series equality exercises the +normal-form content; the two-term example excludes the zero and single-monomial degeneracies. +-/ + +universe u + +public noncomputable section + +namespace Tests + +open Surreal + +/-- The monomial `ω` as an omnific integer. -/ +def omegaOmnific : Surreal.OmnificInteger.{u} := + ⟨ω^ (1 : Surreal.{u}), mem_omnificIntegers.mpr + (isOmnificInteger_iff_normalForm.mpr ⟨by + intro i hi + rw [support_wpow, Set.mem_singleton_iff] at hi + subst i + simp, by + rw [coeff_wpow] + refine ⟨0, ?_⟩ + simp⟩)⟩ + +/-- The omnific integer `ω + 3`, with two distinct Conway exponents. -/ +def omegaAddThree : Surreal.OmnificInteger.{u} := + omegaOmnific + 3 + +/-- The bounded image retains exactly the full Conway normal form. -/ +theorem smallSupportIntegerPart_rawSeries + (x : Surreal.OmnificInteger.{u}) : + ((x.toSmallSupportIntegerPart : + HahnSeries.CardSuppLTField (G := Surrealᵒᵈ) (R := ℝ) + (κ := Surreal.smallSupportCardinal.{u})) : HahnSeries Surrealᵒᵈ ℝ) = + x.1.toFullHahnSeries := + Surreal.OmnificInteger.coe_toSmallSupportIntegerPart x + +/-- The nondegenerate two-term example survives the public round trip. -/ +theorem omegaAddThree_smallSupport_roundTrip : + Surreal.OmnificInteger.ofSmallSupportIntegerPart + omegaAddThree.toSmallSupportIntegerPart = omegaAddThree := + Surreal.OmnificInteger.ofSmallSupportIntegerPart_toSmallSupportIntegerPart _ + +/-- The bounded Conway/Hahn correspondence preserves multiplication without an extra premise. -/ +theorem smallSupportIntegerPart_map_mul + (x y : Surreal.OmnificInteger.{u}) : + Surreal.OmnificInteger.smallSupportIntegerPartRingEquiv (x * y) = + Surreal.OmnificInteger.smallSupportIntegerPartRingEquiv x * + Surreal.OmnificInteger.smallSupportIntegerPartRingEquiv y := + map_mul _ x y + +/-- Signed exponent reindexing retains exactly the signed Conway normal form. -/ +theorem signedSmallSupportIntegerPart_rawSeries + (x : Surreal.OmnificInteger.{u}) : + ((x.toSignedSmallSupportIntegerPart : + HahnSeries.CardSuppLTField (G := Surreal) (R := ℝ) + (κ := Surreal.smallSupportCardinal.{u})) : HahnSeries Surreal ℝ) = + x.1.toSignedFullHahnSeries := + Surreal.OmnificInteger.coe_toSignedSmallSupportIntegerPart x + +/-- The signed Conway/Hahn correspondence preserves multiplication without an extra premise. -/ +theorem signedSmallSupportIntegerPart_map_mul + (x y : Surreal.OmnificInteger.{u}) : + Surreal.OmnificInteger.signedSmallSupportIntegerPartRingEquiv (x * y) = + Surreal.OmnificInteger.signedSmallSupportIntegerPartRingEquiv x * + Surreal.OmnificInteger.signedSmallSupportIntegerPartRingEquiv y := + map_mul _ x y + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/HahnSeries/Tests/DegreeTransfer.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/HahnSeries/Tests/DegreeTransfer.lean new file mode 100644 index 0000000000..0a6c5dbb8b --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/HahnSeries/Tests/DegreeTransfer.lean @@ -0,0 +1,64 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.HahnSeries.DegreeTransfer + +/-! +# Checks for Conway-to-Hahn degree transfer + +The two-term example `ω + 1` has distinct nonzero exponents, so it excludes the zero and +single-monomial degeneracies. Its finite support gives degree zero on both sides of the full Hahn +embedding, while the generic equality gives degree preservation for every surreal number. +-/ + +universe u + +public noncomputable section + +namespace Tests + +open Surreal + +/-- The nondegenerate two-term surreal used by the degree-transfer check. -/ +def twoTermDegreeSurreal : Surreal.{u} := + ω^ (1 : Surreal.{u}) + ((1 : ℝ) : Surreal.{u}) + +private theorem twoTermDegreeSurreal_support_finite : + ((twoTermDegreeSurreal : Surreal.{u}).support).Finite := by + rw [twoTermDegreeSurreal] + have hwpow : (support (ω^ (1 : Surreal.{u}))).Finite := by + rw [support_wpow] + exact Set.finite_singleton _ + exact (hwpow.union (support_realCast_finite (1 : ℝ))).subset support_add_subset + +private theorem twoTermDegreeSurreal_ne_zero : + (twoTermDegreeSurreal : Surreal.{u}) ≠ 0 := by + rw [twoTermDegreeSurreal] + exact (add_pos (Surreal.wpow_pos _) (by norm_num)).ne' + +/-- The public full Hahn embedding preserves degree for an arbitrary surreal. -/ +theorem surrealFullHahn_supportDegree (x : Surreal.{u}) : + x.toFullHahnSeries.degree = x.supportDegree := + supportDegree_toFullHahnSeries x + +/-- The nondegenerate two-term Conway normal form has degree zero. -/ +theorem twoTermDegreeSurreal_supportDegree : + (twoTermDegreeSurreal : Surreal.{u}).supportDegree = 0 := by + rw [← supportDegree_toFullHahnSeries, HahnSeries.degree_eq_zero] + constructor + · intro hzero + apply twoTermDegreeSurreal_ne_zero + apply toFullHahnSeries_injective + rw [hzero, toFullHahnSeries_zero] + · have himage : + (twoTermDegreeSurreal : Surreal.{u}).toFullHahnSeries.support ⊆ + OrderDual.toDual '' (twoTermDegreeSurreal : Surreal.{u}).support := by + intro i hi + exact ⟨i.ofDual, mem_support_toFullHahnSeries.mp hi, by simp⟩ + exact (twoTermDegreeSurreal_support_finite.image OrderDual.toDual).subset himage + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/HahnSeries/Tests/Full.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/HahnSeries/Tests/Full.lean new file mode 100644 index 0000000000..29a2f98da3 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/HahnSeries/Tests/Full.lean @@ -0,0 +1,59 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.HahnSeries.Full + +/-! +# Checks for full Conway Hahn series + +The square of `ω + 1` exercises two distinct nonzero exponents and the mixed convolution term. +Its coefficient at exponent one is two, separating genuine multiplication from a plausible wrong +operation that keeps only products of matching or leading exponents. +-/ + +universe u + +public noncomputable section + +namespace Tests + +open Surreal + +/-- The nondegenerate two-term surreal `ω + 1`. -/ +def twoTermSurreal : Surreal.{u} := + ω^ (1 : Surreal.{u}) + ((1 : ℝ) : Surreal.{u}) + + +/-- The full Hahn embedding preserves arbitrary surreal products. -/ +example (x y : Surreal.{u}) : + toFullHahnSeries (x * y) = toFullHahnSeries x * toFullHahnSeries y := + toFullHahnSeries_mul x y + +/-- The full Conway map preserves the square of the nondegenerate two-term example. -/ +theorem toFullHahnSeries_twoTerm_square : + toFullHahnSeries + ((twoTermSurreal : Surreal.{u}) * twoTermSurreal) = + toFullHahnSeries (twoTermSurreal : Surreal.{u}) * + toFullHahnSeries twoTermSurreal := + toFullHahnSeries_mul _ _ + +/-- The mixed coefficient in the nondegenerate square is two. -/ +theorem toFullHahnSeries_twoTerm_square_coeff_one : + (toFullHahnSeries + ((twoTermSurreal : Surreal.{u}) * twoTermSurreal)).coeff + (OrderDual.toDual (1 : Surreal.{u})) = 2 := by + rw [toFullHahnSeries_twoTerm_square] + simp only [twoTermSurreal, toFullHahnSeries_add, + toFullHahnSeries_wpow, toFullHahnSeries_realCast] + rw [add_mul, mul_add, mul_add] + simp only [HahnSeries.single_mul_single] + rw [HahnSeries.coeff_add, HahnSeries.coeff_add, HahnSeries.coeff_add] + simp only [HahnSeries.coeff_single] + simp + norm_num + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/HahnSeries/Tests/Multiplication.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/HahnSeries/Tests/Multiplication.lean new file mode 100644 index 0000000000..5787890f8e --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/HahnSeries/Tests/Multiplication.lean @@ -0,0 +1,47 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.HahnSeries.Multiplication + +/-! +# Checks for omnific-integer normal-form multiplication + +These checks exercise closure and the public characteristic theorem for the transported +normal-form product without unfolding its definition. +-/ + +public noncomputable section + +namespace Tests + +open Surreal + +/-- Formal Hahn multiplication of omnific-integer normal forms again represents an omnific +integer. -/ +example {x y : Surreal} (hx : x.IsOmnificInteger) (hy : y.IsOmnificInteger) : + ((x.toHahnSeries * y.toHahnSeries).toSurreal).IsOmnificInteger := + hx.toHahnSeries_mul_toSurreal hy + +/-- Compatibility on positive truncations is sufficient for arbitrary omnific integers. -/ +example {x y : Surreal} (hx : x.IsOmnificInteger) (hy : y.IsOmnificInteger) + (hpositive : (x.trunc 0 * y.trunc 0).toHahnSeries = + x.toHahnSeries.trunc 0 * y.toHahnSeries.trunc 0) : + (x * y).toHahnSeries = x.toHahnSeries * y.toHahnSeries := + hx.toHahnSeries_mul_of_trunc_zero hy hpositive + +/-- The public normal form of the transported product computes to the Hahn product. -/ +example (x y : Surreal.OmnificInteger) : + (x.normalFormProduct y : Surreal).toHahnSeries = + x.1.toHahnSeries * y.1.toHahnSeries := + Surreal.OmnificInteger.toHahnSeries_normalFormProduct x y + +/-- Transported normal-form multiplication is the ordinary omnific-integer multiplication. -/ +example (x y : Surreal.OmnificInteger) : + x.normalFormProduct y = x * y := + Surreal.OmnificInteger.normalFormProduct_eq_mul x y + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/HahnSeries/Tests/NormalForm.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/HahnSeries/Tests/NormalForm.lean new file mode 100644 index 0000000000..54824122cf --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/HahnSeries/Tests/NormalForm.lean @@ -0,0 +1,59 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.HahnSeries.NormalForm + +/-! +# API checks for the Conway normal form of surreal numbers + +The two-term example has distinct exponents and nonzero coefficients, so it separates the Conway +normal form from the false conversion that retains only the leading term. Both directions of the +normal-form equivalence are evaluated on this example. +-/ + +public noncomputable section + +namespace Tests + +open Set SurrealHahnSeries + +theorem surrealNormalForm_zero : + SurrealHahnSeries.toSurreal (Surreal.toHahnSeries 0) = 0 := by + simp + +theorem surrealNormalForm_single_real (r : ℝ) : + SurrealHahnSeries.toSurreal (.single 0 r) = r := by + simp + +private theorem zero_lt_support_single_one {j : Surreal} + (hj : j ∈ (SurrealHahnSeries.single 1 1).support) : 0 < j := by + have : j = 1 := mem_singleton_iff.mp (support_single_subset hj) + simp [this] + +theorem surrealNormalForm_twoTerm : + SurrealHahnSeries.toSurreal + (SurrealHahnSeries.single 1 1 + SurrealHahnSeries.single 0 1) = + ω^ (1 : Surreal) + 1 := by + rw [SurrealHahnSeries.toSurreal_succ] + · simp + · exact fun j hj ↦ zero_lt_support_single_one hj + +theorem surrealNormalForm_twoTerm_roundTrip : + Surreal.toHahnSeries + (SurrealHahnSeries.toSurreal + (SurrealHahnSeries.single 1 1 + SurrealHahnSeries.single 0 1)) = + SurrealHahnSeries.single 1 1 + SurrealHahnSeries.single 0 1 := by + simp + +theorem surrealNormalForm_twoTerm_ne_leadingTerm : + SurrealHahnSeries.toSurreal + (SurrealHahnSeries.single 1 1 + SurrealHahnSeries.single 0 1) ≠ + SurrealHahnSeries.toSurreal (SurrealHahnSeries.single 1 1) := by + rw [surrealNormalForm_twoTerm] + simp + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/HahnSeries/Tests/NormalFormAdd.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/HahnSeries/Tests/NormalFormAdd.lean new file mode 100644 index 0000000000..6d0a41777d --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/HahnSeries/Tests/NormalFormAdd.lean @@ -0,0 +1,48 @@ +/- +Copyright (c) 2026 Dan Abramov, Violeta Hernández Palacios. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov, Violeta Hernández Palacios +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.HahnSeries.NormalFormAdd + +/-! +# API checks for additive Conway normal forms + +These checks exercise additive compatibility through the public module boundary. The two-term +example is nondegenerate: its exponents are distinct and both coefficients are nonzero. Its +coefficient at exponent zero separates the result from the plausible but incorrect operation that +retains only the leading term. +-/ + +public noncomputable section + +namespace Tests + +open SurrealHahnSeries + +theorem surrealNormalForm_add (x y : Surreal) : + Surreal.toHahnSeries (x + y) = x.toHahnSeries + y.toHahnSeries := + Surreal.toHahnSeries_add x y + +theorem surrealValue_add (x y : SurrealHahnSeries) : + (x + y).toSurreal = x.toSurreal + y.toSurreal := + SurrealHahnSeries.toSurreal_add x y + +theorem surrealNormalForm_neg (x : Surreal) : + Surreal.toHahnSeries (-x) = -x.toHahnSeries := + Surreal.toHahnSeries_neg x + +theorem surrealNormalForm_twoTerm_add : + Surreal.toHahnSeries (ω^ (1 : Surreal) + 1) = + single 1 1 + single 0 1 := by + simp + +theorem surrealNormalForm_twoTerm_add_constantCoeff : + (Surreal.toHahnSeries (ω^ (1 : Surreal) + 1)).coeff 0 = 1 := by + simp only [Surreal.toHahnSeries_add, Surreal.toHahnSeries_wpow, + Surreal.toHahnSeries_one, coeff_add, Pi.add_apply, coeff_single_self, add_eq_right] + exact coeff_single_of_ne one_ne_zero 1 + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/HahnSeries/Tests/NormalFormMul.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/HahnSeries/Tests/NormalFormMul.lean new file mode 100644 index 0000000000..e02242d56e --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/HahnSeries/Tests/NormalFormMul.lean @@ -0,0 +1,137 @@ +/- +Copyright (c) 2026 Violeta Hernández Palacios. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Violeta Hernández Palacios +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.HahnSeries.NormalFormMul + +/-! +# Checks for Conway normal-form multiplication options + +These checks exercise the public multiplication-option and truncation-cofinality interface without +unfolding the Conway normal-form or surreal Hahn-series definitions. +-/ + +open Order Set + +public noncomputable section + +namespace Tests + +open SurrealHahnSeries + +/-- Integer casts use the public constant-singleton representation. -/ +example (n : ℤ) : + (n : SurrealHahnSeries) = single 0 (n : ℝ) := + intCast_eq_single_zero n + +/-- Arbitrary Conway normal forms preserve multiplication by integer constants. -/ +example (n : ℤ) (x : Surreal) : + ((n : Surreal) * x).toHahnSeries = + single 0 (n : ℝ) * x.toHahnSeries := + Surreal.toHahnSeries_intCast_mul n x + +/-- Arbitrary normal forms preserve multiplication by rational constants. -/ +example (q : ℚ) (x : SurrealHahnSeries) : + (single 0 (q : ℝ) * x).toSurreal = (q : Surreal) * x.toSurreal := + toSurreal_single_zero_ratCast_mul q x + +/-- Arbitrary normal forms preserve multiplication by every real constant. -/ +example (r : ℝ) (x : SurrealHahnSeries) : + (single 0 r * x).toSurreal = (r : Surreal) * x.toSurreal := + toSurreal_single_zero_mul r x + +/-- Arbitrary normal forms preserve multiplication by every singleton normal form. -/ +example (p : Surreal) (r : ℝ) (x : SurrealHahnSeries) : + (single p r * x).toSurreal = (single p r).toSurreal * x.toSurreal := + toSurreal_single_mul p r x + +/-- Singleton multiplication is available without exposing the underlying Hahn-series subtype. -/ +example (p q : Surreal) (r s : ℝ) : + single p r * single q s = single (p + q) (r * s) := + single_mul_single p q r s + +/-- Singleton multiplication translates arbitrary coefficients and truncation cutoffs. -/ +example (p q k : Surreal) (r : ℝ) (y : SurrealHahnSeries) : + (single p r * y).coeff k = r * y.coeff (k - p) ∧ + (single p r * y).trunc (p + q) = single p r * y.trunc q := + ⟨coeff_single_mul p r y k, trunc_single_mul p q r y⟩ + +/-- Product truncations expose exact source truncation options with the expected sign reversal. -/ +example {p : Surreal} {r : ℝ} {y t : SurrealHahnSeries} : + (t ∈ truncLT (single p r * y) → + (0 < r ∧ ∃ b ∈ truncLT y, single p r * b = t) ∨ + (r < 0 ∧ ∃ b ∈ truncGT y, single p r * b = t)) ∧ + (t ∈ truncGT (single p r * y) → + (0 < r ∧ ∃ b ∈ truncGT y, single p r * b = t) ∨ + (r < 0 ∧ ∃ b ∈ truncLT y, single p r * b = t)) := + ⟨exists_eq_single_mul_of_mem_truncLT, exists_eq_single_mul_of_mem_truncGT⟩ + +/-- The public option value evaluates to its defining ring expression without unfolding. -/ +example (x y a b : SurrealHahnSeries) : + mulOptionValue x y a b = a * y + x * b - a * b := + mulOptionValue_eq x y a b + +/-- Formal and Conway multiplication agree on the leading normal-form term. -/ +example (x y : SurrealHahnSeries) : + (x * y).toSurreal.leadingTerm = (x.toSurreal * y.toSurreal).leadingTerm := + leadingTerm_toSurreal_mul x y + +/-- A nonzero product coefficient publicly yields a contributing pair of source exponents. -/ +example {x y : SurrealHahnSeries} {k : Surreal} (hk : k ∈ (x * y).support) : + ∃ p ∈ x.support, ∃ q ∈ y.support, p + q = k := + exists_add_eq_of_mem_support_mul hk + +/-- Nonnegative support and integer-part constant coefficients are stable under multiplication. -/ +example {x y : SurrealHahnSeries} + (hx : x.support ⊆ Set.Ici 0) (hy : y.support ⊆ Set.Ici 0) : + (x * y).support ⊆ Set.Ici 0 ∧ + (x * y).coeff 0 = x.coeff 0 * y.coeff 0 := + ⟨support_mul_subset_Ici hx hy, coeff_zero_mul_of_support_subset_Ici hx hy⟩ + +/-- Every left truncation of a product is dominated by a genuine left product option. -/ +example {x y t : SurrealHahnSeries} (ht : t ∈ truncLT (x * y)) : + ∃ a ∈ truncLT x, ∃ b ∈ truncLT y, + t < mulOptionValue x y a b ∧ mulOptionValue x y a b < x * y := + exists_mulOptionValue_between_of_mem_truncLT ht + +/-- Every right truncation of a product dominates a genuine right product option. -/ +example {x y t : SurrealHahnSeries} (ht : t ∈ truncGT (x * y)) : + ∃ a ∈ truncLT x, ∃ b ∈ truncGT y, + x * y < mulOptionValue x y a b ∧ mulOptionValue x y a b < t := + exists_mulOptionValue_between_of_mem_truncGT ht + +/-- The limit-by-limit step consumes multiplication only for strictly shorter recursive inputs. -/ +example {x y : SurrealHahnSeries} + (hx : IsSuccPrelimit x.length) (hy : IsSuccPrelimit y.length) + (hmul : ∀ a b : SurrealHahnSeries, + a.length ≤ x.length → b.length ≤ y.length → + (a.length < x.length ∨ b.length < y.length) → + (a * b).toSurreal = a.toSurreal * b.toSurreal) : + (x * y).toSurreal = x.toSurreal * y.toSurreal := + toSurreal_mul_of_isSuccPrelimit hx hy hmul + +/-- The exact recursive limit step accepts the left and right length axes independently. -/ +example {x y : SurrealHahnSeries} + (hx : IsSuccPrelimit x.length) (hy : IsSuccPrelimit y.length) + (hmulLeft : ∀ a b : SurrealHahnSeries, + a.length < x.length → b.length ≤ y.length → + (a * b).toSurreal = a.toSurreal * b.toSurreal) + (hmulRight : ∀ b : SurrealHahnSeries, b.length < y.length → + (x * b).toSurreal = x.toSurreal * b.toSurreal) : + (x * y).toSurreal = x.toSurreal * y.toSurreal := + toSurreal_mul_of_isSuccPrelimit_of_axes hx hy hmulLeft hmulRight + +/-- The Conway normal-form map preserves arbitrary Hahn-series products. -/ +example (x y : SurrealHahnSeries) : + (x * y).toSurreal = x.toSurreal * y.toSurreal := + toSurreal_mul x y + +/-- The inverse Conway normal-form map preserves arbitrary surreal products. -/ +example (x y : Surreal) : + (x * y).toHahnSeries = x.toHahnSeries * y.toHahnSeries := + Surreal.toHahnSeries_mul x y + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/HahnSeries/Transfer.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/HahnSeries/Transfer.lean new file mode 100644 index 0000000000..20703aca75 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/HahnSeries/Transfer.lean @@ -0,0 +1,217 @@ +/- +Copyright (c) 2026 Violeta Hernández Palacios. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Violeta Hernández Palacios +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.HahnSeries.NormalForm + +/-! +# Transfer surreal Hahn-series definitions to surreal numbers + +This module transfers coefficients, support, length, and truncation along the Conway normal-form +order equivalence. It follows CombinatorialGames PR #263, adapted to the pinned module-safe API. +Arithmetic compatibility is proved in later modules. +-/ + +universe u + +public noncomputable section + +namespace Surreal + +open Set + +/-! ### Coefficients -/ + +/-- The coefficient of `ω ^ i` in the Conway normal form of a surreal number. -/ +def coeff (x : Surreal) : Surreal → ℝ := + x.toHahnSeries.coeff + +@[simp] +theorem coeff_zero : coeff 0 = 0 := by + simp [coeff] + +@[simp] +theorem coeff_wpow (x : Surreal) : coeff (ω^ x) = Pi.single x 1 := by + rw [coeff, toHahnSeries_wpow, SurrealHahnSeries.coeff_single] + +/-- A real surreal has only its constant Conway coefficient. -/ +@[simp] +theorem coeff_realCast (r : ℝ) : + coeff (r : Surreal.{u}) = Pi.single 0 r := by + rw [coeff, toHahnSeries_realCast, SurrealHahnSeries.coeff_single] + +@[simp] +theorem coeff_toHahnSeries (x : Surreal) : x.toHahnSeries.coeff = x.coeff := + (rfl) + +@[simp] +theorem _root_.SurrealHahnSeries.coeff_toSurreal (x : SurrealHahnSeries) : + x.toSurreal.coeff = x.coeff := by + simp [coeff] + +/-! ### Support -/ + +/-- The support of the Conway normal form of a surreal number. -/ +def support (x : Surreal) : Set Surreal := + x.toHahnSeries.support + +@[simp] +theorem support_coeff (x : Surreal) : x.coeff.support = x.support := + (rfl) + +@[simp] +theorem support_zero : support 0 = ∅ := by + simp [support] + +@[simp] +theorem support_wpow (x : Surreal) : support (ω^ x) = {x} := by + aesop (add simp [support]) + +/-- The Conway support of a real surreal is finite. -/ +theorem support_realCast_finite (r : ℝ) : + (support (r : Surreal.{u})).Finite := by + rw [← support_coeff, coeff_realCast] + exact Set.Finite.subset (Set.finite_singleton 0) Pi.support_single_subset + +@[simp] +theorem support_eq_empty {x : Surreal} : x.support = ∅ ↔ x = 0 := by + simp [support] + +@[simp] +theorem support_toHahnSeries (x : Surreal) : x.toHahnSeries.support = x.support := + (rfl) + +@[simp] +theorem _root_.SurrealHahnSeries.support_toSurreal (x : SurrealHahnSeries) : + x.toSurreal.support = x.support := by + simp [support] + +theorem wellFoundedOn_support (x : Surreal) : x.support.WellFoundedOn (fun a b ↦ a > b) := + x.toHahnSeries.wellFoundedOn_support + +instance (x : Surreal.{u}) : Small.{u} x.support := + inferInstanceAs (Small (SurrealHahnSeries.support _)) + +instance (x : Surreal) : WellFoundedGT x.support := + inferInstanceAs (WellFoundedGT (SurrealHahnSeries.support _)) + +/-! ### Length -/ + +/-- The ordinal length of the Conway normal form of a surreal number. -/ +def length (x : Surreal) : Ordinal := + x.toHahnSeries.length + +@[simp] +theorem length_zero : length 0 = 0 := by + simp [length] + +@[simp] +theorem length_wpow (x : Surreal) : length (ω^ x) = 1 := by + simp [length] + +@[simp, grind =] +theorem mem_support_iff {x i : Surreal} : i ∈ x.support ↔ x.coeff i ≠ 0 := + (Iff.rfl) + +theorem notMem_support_iff {x i : Surreal} : i ∉ x.support ↔ x.coeff i = 0 := + mem_support_iff.not_left + +@[simp] +theorem length_toHahnSeries (x : Surreal) : x.toHahnSeries.length = x.length := + (rfl) + +theorem PartialSum.length_top (x : Surreal) : (⊤ : PartialSum x).length = x.length := by + rw [PartialSum.length_eq_carrier_length, PartialSum.carrier_top, length_toHahnSeries] + +@[simp] +theorem type_support (x : Surreal.{u}) : + @Ordinal.type x.support (fun a b ↦ a > b) _ = Ordinal.lift.{u + 1} x.length := + SurrealHahnSeries.type_support _ + +@[simp] +theorem _root_.SurrealHahnSeries.length_toSurreal (x : SurrealHahnSeries) : + x.toSurreal.length = x.length := by + simp [length] + +/-! ### Truncation -/ + +/-- Remove the terms of the Conway normal form whose exponents are at most `i`. -/ +def trunc (x i : Surreal) : Surreal := + x.toHahnSeries.trunc i + +@[simp] +theorem trunc_zero (i : Surreal) : trunc 0 i = 0 := by + rw [trunc] + have h : (0 : SurrealHahnSeries).trunc i = 0 := + SurrealHahnSeries.trunc_eq_self fun j hj ↦ by simp at hj + rw [toHahnSeries_zero, h, SurrealHahnSeries.toSurreal_zero] + +@[simp] +theorem toHahnSeries_trunc (x i : Surreal) : + (x.trunc i).toHahnSeries = x.toHahnSeries.trunc i := by + simp [trunc] + +@[simp] +theorem _root_.SurrealHahnSeries.toSurreal_trunc (x : SurrealHahnSeries) (i : Surreal) : + x.trunc i = x.toSurreal.trunc i := by + simp [trunc] + +@[aesop simp] +theorem coeff_trunc (x i : Surreal) : + (x.trunc i).coeff = fun j ↦ if i < j then x.coeff j else 0 := by + unfold coeff + aesop + +@[simp] +theorem coeff_trunc_of_lt {x i j : Surreal} (h : i < j) : + (x.trunc i).coeff j = x.coeff j := by + rw [coeff_trunc] + exact ite_eq_left h + +@[simp] +theorem coeff_trunc_of_le {x i j : Surreal} (h : j ≤ i) : + (x.trunc i).coeff j = 0 := by + rw [coeff_trunc] + exact ite_eq_right h.not_gt + +@[simp, grind =] +theorem support_trunc (x i : Surreal) : (x.trunc i).support = x.support ∩ Ioi i := by + aesop + +theorem support_trunc_subset (x i : Surreal) : (x.trunc i).support ⊆ x.support := by + simp + +theorem support_trunc_anti {x : Surreal} : Antitone fun i ↦ (trunc x i).support := + fun _ _ _ _ ↦ by aesop (add safe tactic (by order)) + +theorem coeff_trunc_eq_zero {x i j : Surreal} (h : x.coeff i = 0) : + (x.trunc j).coeff i = 0 := by + aesop + +theorem coeff_trunc_of_mem {x i j : Surreal} (h : j ∈ (x.trunc i).support) : + (x.trunc i).coeff j = x.coeff j := by + aesop + +theorem trunc_eq_self_iff {x i : Surreal} : x.trunc i = x ↔ ∀ j ∈ x.support, i < j := by + nth_rw 2 [← toSurreal_toHahnSeries x] + rw [trunc, SurrealHahnSeries.toSurreal_inj] + exact SurrealHahnSeries.trunc_eq_self_iff + +alias ⟨_, trunc_eq_self⟩ := trunc_eq_self_iff + +theorem trunc_eq_trunc {x i j : Surreal} (h : i ≤ j) + (H : ∀ k, i < k → k ≤ j → x.coeff k = 0) : x.trunc i = x.trunc j := by + simpa [← toHahnSeries_trunc] using x.toHahnSeries.trunc_eq_trunc h H + +open SurrealHahnSeries in +theorem PartialSum.mem_range_trunc {x : Surreal} (y : PartialSum x) : + y.carrier.toSurreal ∈ range x.trunc := by + rw [← truncIdx_length_of_le (y := y) le_top, carrier_truncIdx, carrier_top] + obtain ⟨z, hz⟩ := truncIdx_mem_range_trunc x.toHahnSeries y.length + rw [← hz] + simp + +end Surreal diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/OmnificInteger.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/OmnificInteger.lean new file mode 100644 index 0000000000..60ef3d09f5 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/OmnificInteger.lean @@ -0,0 +1,17 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.OmnificInteger.Basic +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.OmnificInteger.NormalForm +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.OmnificInteger.Ordinal +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.OmnificInteger.Primality +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.OmnificInteger.Refinement +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.OmnificInteger.RefinementConjecture +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.OmnificInteger.Tests + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/OmnificInteger/Basic.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/OmnificInteger/Basic.lean new file mode 100644 index 0000000000..4b30101c4b --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/OmnificInteger/Basic.lean @@ -0,0 +1,324 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.CombinatorialGames.Surreal.Division +public import Mathlib.Algebra.Ring.Subring.Defs +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.Round + +import LeanPool.ConwayRefinement.CombinatorialGames.Tactic.GameCmp +import Mathlib.Tactic.Abel +import Mathlib.Tactic.Ring + +/-! +# Omnific integers + +Conway defines a surreal number `x` to be an omnific integer when +`x = {x - 1 | x + 1}`. This file uses that fixed-point equation as the direct definition and +proves Conway's closure statements, so the resulting carrier is a subring of the surreal numbers. +The proofs use the exact option formulae for addition and multiplication of numeric pregames. + +Conway's normal-form criterion, and the equivalent criterion recalled in LM24, Section 1.1, is a +theorem about this carrier rather than its definition. The pinned CombinatorialGames revision does +not yet construct the full surreal-to-Hahn normal-form map, so this file does not assume such a map +or use an unrelated Hahn-series presentation as the definition. + +The source is *On Numbers and Games*, pages 45--46: the definition preceding Theorem 30, Theorem 30 +for ring closure, and Theorem 31 for the later normal-form characterization. +-/ + +universe u + +public noncomputable section + +namespace Surreal + +namespace OmnificInteger + +private def cutGame (x : IGame.{u}) : IGame.{u} := + !{{x - 1} | {x + 1}} + +private instance cutGameNumeric (x : IGame.{u}) [IGame.Numeric x] : + IGame.Numeric (cutGame x) := by + rw [IGame.numeric_def] + constructor + · simp only [cutGame, IGame.leftMoves_ofSets, IGame.rightMoves_ofSets, + Set.mem_singleton_iff, forall_eq] + rw [← Surreal.mk_lt_mk] + simp only [Surreal.mk_sub, Surreal.mk_add, Surreal.mk_one] + simp [sub_eq_add_neg, add_comm] + · intro p y hy + cases p with + | left => + simp only [cutGame, IGame.leftMoves_ofSets, Set.mem_singleton_iff] at hy + subst y + infer_instance + | right => + simp only [cutGame, IGame.rightMoves_ofSets, Set.mem_singleton_iff] at hy + subst y + infer_instance + +private def IsOmnificGame (x : IGame.{u}) : Prop := + x ≈ cutGame x + +private theorem isOmnificGame_zero : IsOmnificGame (0 : IGame.{u}) := by + apply AntisymmRel.symm + rw [← IGame.fits_zero_iff_equiv] + simp [IGame.Fits, cutGame] + +private theorem isOmnificGame_one : IsOmnificGame (1 : IGame.{u}) := by + apply AntisymmRel.symm + apply IGame.equiv_one_of_fits + · rw [IGame.Fits] + constructor + · intro z hz + simp only [cutGame, IGame.leftMoves_ofSets, Set.mem_singleton_iff] at hz + subst z + game_cmp + · intro z hz + simp only [cutGame, IGame.rightMoves_ofSets, Set.mem_singleton_iff] at hz + subst z + game_cmp + · intro h + have hz : ((1 : IGame.{u}) - 1) ⧏ cutGame 1 := + IGame.left_lf (by simp [cutGame]) + exact hz (h.1.trans (IGame.sub_self_equiv 1).2) + +private theorem neg_cutGame (x : IGame.{u}) : -cutGame x = cutGame (-x) := by + simp only [cutGame, IGame.neg_ofSets] + congr! 2 + · simp [sub_eq_add_neg, add_comm] + · simp [sub_eq_add_neg, add_comm] + +private theorem IsOmnificGame.neg {x : IGame.{u}} (hx : IsOmnificGame x) : + IsOmnificGame (-x) := by + rw [IsOmnificGame, ← neg_cutGame] + exact IGame.neg_congr hx + +private theorem cutGame_add_cutGame_equiv {x y : IGame.{u}} + (hx : IsOmnificGame x) (hy : IsOmnificGame y) : + cutGame x + cutGame y ≈ cutGame (x + y) := by + have hx' : ConwayGame.mk !{{x - 1} | {x + 1}} = ConwayGame.mk x := (ConwayGame.mk_eq hx).symm + have hy' : ConwayGame.mk !{{y - 1} | {y + 1}} = ConwayGame.mk y := (ConwayGame.mk_eq hy).symm + apply ConwayGame.mk_eq_mk.mp + simp only [cutGame, IGame.ofSets_add_ofSets, ConwayGame.mk_ofSets, Set.image_union, + Set.image_singleton] + simp only [ConwayGame.mk_add, ConwayGame.mk_sub, ConwayGame.mk_one, hx', hy'] + abel_nf + congr <;> simp + +private theorem IsOmnificGame.add {x y : IGame.{u}} + (hx : IsOmnificGame x) (hy : IsOmnificGame y) : IsOmnificGame (x + y) := by + exact (IGame.add_congr hx hy).trans (cutGame_add_cutGame_equiv hx hy) + +private theorem mulOption_cutGame_equiv {x y s t : IGame.{u}} + [IGame.Numeric x] [IGame.Numeric y] [IGame.Numeric s] [IGame.Numeric t] + (hx : IsOmnificGame x) (hy : IsOmnificGame y) : + IGame.mulOption !{{x - 1} | {x + 1}} !{{y - 1} | {y + 1}} + (x + s) (y + t) ≈ x * y - s * t := by + let : IGame.Numeric !{{x - 1} | {x + 1}} := cutGameNumeric x + let : IGame.Numeric !{{y - 1} | {y + 1}} := cutGameNumeric y + have hx' : Surreal.mk !{{x - 1} | {x + 1}} = Surreal.mk x := (Surreal.mk_eq hx).symm + have hy' : Surreal.mk !{{y - 1} | {y + 1}} = Surreal.mk y := (Surreal.mk_eq hy).symm + apply Surreal.mk_eq_mk.mp + simp only [IGame.mulOption, Surreal.mk_sub, Surreal.mk_add, Surreal.mk_mul] + rw [hx', hy'] + ring + +private theorem cutGame_mul_cutGame_equiv {x y : IGame.{u}} + [IGame.Numeric x] [IGame.Numeric y] + (hx : IsOmnificGame x) (hy : IsOmnificGame y) : + cutGame x * cutGame y ≈ cutGame (x * y) := by + rw [cutGame, cutGame, IGame.ofSets_mul_ofSets] + apply IGame.equiv_of_exists + · intro a ha + simp only [IGame.leftMoves_ofSets, Set.mem_image, Set.mem_union, Set.mem_prod, + Set.mem_singleton_iff, Prod.exists] at ha + obtain ⟨a₁, b₁, (⟨rfl, rfl⟩ | ⟨rfl, rfl⟩), rfl⟩ := ha + · refine ⟨x * y - 1, by simp [cutGame], ?_⟩ + simpa [sub_eq_add_neg] using + mulOption_cutGame_equiv (x := x) (y := y) (s := (-1)) (t := (-1)) hx hy + · refine ⟨x * y - 1, by simp [cutGame], ?_⟩ + simpa using mulOption_cutGame_equiv (x := x) (y := y) (s := 1) (t := 1) hx hy + · intro a ha + simp only [IGame.rightMoves_ofSets, Set.mem_image, Set.mem_union, Set.mem_prod, + Set.mem_singleton_iff, Prod.exists] at ha + obtain ⟨a₁, b₁, (⟨rfl, rfl⟩ | ⟨rfl, rfl⟩), rfl⟩ := ha + · refine ⟨x * y + 1, by simp [cutGame], ?_⟩ + simpa [sub_eq_add_neg] using + mulOption_cutGame_equiv (x := x) (y := y) (s := (-1)) (t := 1) hx hy + · refine ⟨x * y + 1, by simp [cutGame], ?_⟩ + simpa [sub_eq_add_neg] using + mulOption_cutGame_equiv (x := x) (y := y) (s := 1) (t := (-1)) hx hy + · intro b hb + simp only [cutGame, IGame.leftMoves_ofSets, Set.mem_singleton_iff] at hb + subst b + refine ⟨IGame.mulOption !{{x - 1} | {x + 1}} !{{y - 1} | {y + 1}} + (x - 1) (y - 1), ?_, ?_⟩ + · simp + · simpa [cutGame, sub_eq_add_neg] using + mulOption_cutGame_equiv (x := x) (y := y) (s := (-1)) (t := (-1)) hx hy + · intro b hb + simp only [cutGame, IGame.rightMoves_ofSets, Set.mem_singleton_iff] at hb + subst b + refine ⟨IGame.mulOption !{{x - 1} | {x + 1}} !{{y - 1} | {y + 1}} + (x - 1) (y + 1), ?_, ?_⟩ + · simp + · simpa [cutGame, sub_eq_add_neg] using + mulOption_cutGame_equiv (x := x) (y := y) (s := (-1)) (t := 1) hx hy + +private theorem IsOmnificGame.mul {x y : IGame.{u}} [IGame.Numeric x] [IGame.Numeric y] + (hx : IsOmnificGame x) (hy : IsOmnificGame y) : IsOmnificGame (x * y) := by + exact (IGame.Numeric.mul_congr hx hy).trans (cutGame_mul_cutGame_equiv hx hy) + +private theorem not_isOmnificGame_half : ¬IsOmnificGame (IGame.half : IGame.{u}) := by + intro hhalf + have hcut : cutGame (IGame.half : IGame.{u}) ≈ 0 := + IGame.fits_zero_iff_equiv.mp (by + rw [IGame.Fits] + constructor <;> intro z hz <;> + simp only [cutGame, IGame.leftMoves_ofSets, IGame.rightMoves_ofSets, + Set.mem_singleton_iff] at hz <;> + subst z <;> game_cmp) + exact IGame.zero_lt_half.not_ge (hhalf.trans hcut).1 + +end OmnificInteger + +/-- The singleton cut `{x - 1 | x + 1}` associated with a surreal number `x`. -/ +def omnificIntegerCut (x : Surreal.{u}) : Surreal.{u} := + !{{x - 1} | {x + 1}}' (by + simp only [Set.mem_singleton_iff] + intro a ha b hb + subst a + subst b + simp [sub_eq_add_neg]) + +/-- Conway's omnific-integer cut is definitionally the singleton cut at distance one. -/ +theorem omnificIntegerCut_eq (x : Surreal.{u}) : + omnificIntegerCut x = + !{{x - 1} | {x + 1}}' (by + simp only [Set.mem_singleton_iff] + rintro _ rfl _ rfl + simp [sub_eq_add_neg]) := + (rfl) + +/-- A surreal number is an omnific integer when it equals `{x - 1 | x + 1}`. -/ +def IsOmnificInteger (x : Surreal.{u}) : Prop := + x = omnificIntegerCut x + +/-- The defining fixed-point equation for an omnific integer. -/ +theorem isOmnificInteger_iff {x : Surreal.{u}} : + IsOmnificInteger x ↔ x = omnificIntegerCut x := + Iff.rfl + +/-- Conway's singleton-cut definition of an omnific integer is equivalently fixedness under +rounding with radius one. -/ +theorem isOmnificInteger_iff_round_one {x : Surreal.{u}} : + IsOmnificInteger x ↔ x.round 1 = x := by + rw [IsOmnificInteger, omnificIntegerCut, round_of_pos zero_lt_one] + exact eq_comm + +open OmnificInteger + +private theorem omnificIntegerCut_mk (x : IGame.{u}) [IGame.Numeric x] : + omnificIntegerCut (Surreal.mk x) = Surreal.mk (cutGame x) := by + rw [omnificIntegerCut] + symm + let : IGame.Numeric !{{x - 1} | {x + 1}} := cutGameNumeric x + change Surreal.mk !{{x - 1} | {x + 1}} = _ + rw [Surreal.mk_ofSets] + congr! 2 <;> simp + +/-- The omnific-integer predicate expressed on a numeric pregame representative. -/ +theorem isOmnificInteger_mk_iff (x : IGame.{u}) [IGame.Numeric x] : + IsOmnificInteger (Surreal.mk x) ↔ + x ≈ !{{x - 1} | {x + 1}} := by + rw [IsOmnificInteger, omnificIntegerCut_mk, Surreal.mk_eq_mk] + rfl + +/-- Zero is an omnific integer. -/ +theorem isOmnificInteger_zero : IsOmnificInteger (0 : Surreal.{u}) := by + rw [← Surreal.mk_zero, isOmnificInteger_mk_iff] + exact OmnificInteger.isOmnificGame_zero + +/-- One is an omnific integer. -/ +theorem isOmnificInteger_one : IsOmnificInteger (1 : Surreal.{u}) := by + rw [← Surreal.mk_one, isOmnificInteger_mk_iff] + exact OmnificInteger.isOmnificGame_one + +/-- The negative of an omnific integer is an omnific integer. -/ +theorem IsOmnificInteger.neg {x : Surreal.{u}} (hx : IsOmnificInteger x) : + IsOmnificInteger (-x) := by + induction x using Surreal.ind with + | mk x => + rw [← Surreal.mk_neg, isOmnificInteger_mk_iff] + exact OmnificInteger.IsOmnificGame.neg ((isOmnificInteger_mk_iff x).mp hx) + +/-- The sum of two omnific integers is an omnific integer. -/ +theorem IsOmnificInteger.add {x y : Surreal.{u}} + (hx : IsOmnificInteger x) (hy : IsOmnificInteger y) : IsOmnificInteger (x + y) := by + induction x using Surreal.ind with + | mk x => + induction y using Surreal.ind with + | mk y => + rw [← Surreal.mk_add, isOmnificInteger_mk_iff] + exact OmnificInteger.IsOmnificGame.add + ((isOmnificInteger_mk_iff x).mp hx) ((isOmnificInteger_mk_iff y).mp hy) + +/-- The product of two omnific integers is an omnific integer. -/ +theorem IsOmnificInteger.mul {x y : Surreal.{u}} + (hx : IsOmnificInteger x) (hy : IsOmnificInteger y) : IsOmnificInteger (x * y) := by + induction x using Surreal.ind with + | mk x => + induction y using Surreal.ind with + | mk y => + rw [← Surreal.mk_mul, isOmnificInteger_mk_iff] + exact OmnificInteger.IsOmnificGame.mul + ((isOmnificInteger_mk_iff x).mp hx) ((isOmnificInteger_mk_iff y).mp hy) + +/-- Omnific integers are closed under subtraction. -/ +theorem IsOmnificInteger.sub {x y : Surreal.{u}} + (hx : IsOmnificInteger x) (hy : IsOmnificInteger y) : + IsOmnificInteger (x - y) := + hx.add hy.neg + +/-- The subring of surreal numbers satisfying Conway's omnific-integer equation. -/ +def omnificIntegers : Subring Surreal.{u} where + carrier := {x | IsOmnificInteger x} + zero_mem' := isOmnificInteger_zero + one_mem' := isOmnificInteger_one + add_mem' := IsOmnificInteger.add + neg_mem' := IsOmnificInteger.neg + mul_mem' := IsOmnificInteger.mul + +/-- Membership in `omnificIntegers` is Conway's omnific-integer predicate. -/ +@[simp] +theorem mem_omnificIntegers {x : Surreal.{u}} : + x ∈ omnificIntegers ↔ IsOmnificInteger x := + Iff.rfl + +/-- Omnific integers, with the ring structure inherited from the surreal numbers. -/ +abbrev OmnificInteger := ↥(omnificIntegers : Subring Surreal.{u}) + +/-- Every natural number is an omnific integer. -/ +@[simp] +theorem IsOmnificInteger.natCast (n : ℕ) : + IsOmnificInteger (n : Surreal.{u}) := + mem_omnificIntegers.mp (n : OmnificInteger.{u}).2 + +/-- Every integer is an omnific integer. -/ +@[simp] +theorem IsOmnificInteger.intCast (n : ℤ) : + IsOmnificInteger (n : Surreal.{u}) := + mem_omnificIntegers.mp (n : OmnificInteger.{u}).2 + +/-- The surreal number `2⁻¹` is not an omnific integer. -/ +theorem two_inv_not_mem_omnificIntegers : + (2 : Surreal.{u})⁻¹ ∉ omnificIntegers := by + rw [← IGame.mk_half, mem_omnificIntegers, isOmnificInteger_mk_iff] + exact OmnificInteger.not_isOmnificGame_half + +end Surreal diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/OmnificInteger/NormalForm.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/OmnificInteger/NormalForm.lean new file mode 100644 index 0000000000..d451f0cbb9 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/OmnificInteger/NormalForm.lean @@ -0,0 +1,144 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Copyright (c) 2026 Violeta Hernández Palacios. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov, Violeta Hernández Palacios +-/ +/- +Partly adapted and modified from the Apache-2.0-licensed CombinatorialGames PR #317: +https://github.com/vihdzp/combinatorial-games/pull/317 +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.HahnSeries.NormalFormAdd +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.OmnificInteger.Basic + +/-! +# Conway normal forms of omnific integers + +This module proves Conway's normal-form characterization of the omnific integers: a surreal is an +omnific integer exactly when its Conway support consists of nonnegative exponents and its constant +coefficient is an integer. The proof uses the fixed-point definition from +`ConwayRefinement.Surreal.OmnificInteger.Basic` and the Conway normal-form rounding +criterion. + +The characterization is Theorem 31 of *On Numbers and Games* and is the presentation of `Oz` +recalled in LM24, Section 1.1. +-/ + +universe u + +public noncomputable section + +namespace Surreal + +open Set + +/-- A positive omnific integer is at least one. -/ +theorem IsOmnificInteger.one_le_iff_pos {x : Surreal.{u}} + (h : IsOmnificInteger x) : 1 ≤ x ↔ 0 < x where + mp := zero_lt_one.trans_le + mpr hx := by + rw [isOmnificInteger_iff_round_one] at h + by_contra hnot + have hxle : x ≤ 1 := le_of_not_ge hnot + have hzero : 0 ∈ Ioo (x - 1) (x + 1) := by + constructor <;> linarith + rw [round_of_zero_mem hzero] at h + exact hx.ne h + +/-- An omnific integer below one is nonpositive. -/ +theorem IsOmnificInteger.lt_one_iff_nonpos {x : Surreal.{u}} + (h : IsOmnificInteger x) : x < 1 ↔ x ≤ 0 := by + rw [← not_iff_not] + simpa only [not_le, not_lt] using h.one_le_iff_pos + +/-- An omnific integer strictly between negative one and one is zero. -/ +theorem IsOmnificInteger.eq_zero_of_mem_Ioo_neg_one_one {x : Surreal.{u}} + (hx : IsOmnificInteger x) (hbound : x ∈ Ioo (-1) 1) : x = 0 := by + have hxNonpos : x ≤ 0 := hx.lt_one_iff_nonpos.mp hbound.2 + have hnegNonpos : -x ≤ 0 := hx.neg.lt_one_iff_nonpos.mp (by linarith [hbound.1]) + linarith + +/-- Two omnific integers whose difference is strictly between negative one and one are equal. -/ +theorem IsOmnificInteger.eq_of_sub_mem_Ioo_neg_one_one {x y : Surreal.{u}} + (hx : IsOmnificInteger x) (hy : IsOmnificInteger y) + (hbound : x - y ∈ Ioo (-1) 1) : x = y := by + have hzero := (hx.sub hy).eq_zero_of_mem_Ioo_neg_one_one hbound + linarith + +/-- A real number is an omnific integer exactly when it is the image of an integer. -/ +@[simp] +theorem isOmnificInteger_realCast_iff {r : ℝ} : + IsOmnificInteger (r : Surreal.{u}) ↔ r ∈ range ((↑) : ℤ → ℝ) where + mpr := by + rintro ⟨n, rfl⟩ + simpa only [Real.toSurreal_intCast] using IsOmnificInteger.intCast n + mp h := by + rw [← Int.fract_eq_zero_iff] + apply (Int.fract_nonneg r).antisymm' + rw [← Real.toSurreal_le_iff, Real.toSurreal_zero, + ← IsOmnificInteger.lt_one_iff_nonpos] + · exact_mod_cast Int.fract_lt_one r + · rw [Int.fract, Real.toSurreal_sub] + apply h.sub + simpa only [Real.toSurreal_intCast] using IsOmnificInteger.intCast ⌊r⌋ + +/-- If a Conway support is nonnegative, removing its positive truncation leaves its real constant +coefficient. -/ +theorem sub_trunc_zero_eq_realCast_of_support_subset_Ici {x : Surreal.{u}} + (hx : x.support ⊆ Ici 0) : + x - x.trunc 0 = (x.coeff 0 : Surreal) := by + rw [← toHahnSeries_inj] + ext i + simp only [sub_eq_add_neg, toHahnSeries_add, toHahnSeries_neg, + SurrealHahnSeries.coeff_add_apply, SurrealHahnSeries.coeff_neg, + Pi.neg_apply, coeff_toHahnSeries, toHahnSeries_trunc, + SurrealHahnSeries.coeff_trunc, toHahnSeries_realCast, + SurrealHahnSeries.coeff_single] + rcases lt_trichotomy i 0 with hi | rfl | hi + · have hcoeff : x.coeff i = 0 := by + rw [← notMem_support_iff] + exact fun hmem ↦ (not_le_of_gt hi) (hx hmem) + simp [hcoeff, hi.ne] + · simp + · simp [hi, hi.ne'] + +/-- Conway's normal-form characterization: `x` is an omnific integer exactly when all exponents +in its support are nonnegative and its coefficient at exponent zero is an integer. -/ +theorem isOmnificInteger_iff_normalForm {x : Surreal.{u}} : + IsOmnificInteger x ↔ + x.support ⊆ Ici 0 ∧ x.coeff 0 ∈ range ((↑) : ℤ → ℝ) := by + constructor + · intro hx + have hround : x.round 1 = x := isOmnificInteger_iff_round_one.mp hx + have hsupp : x.support ⊆ Ici 0 := by + simpa only [wlog_one] using support_subset_of_round_eq hround zero_lt_one + refine ⟨hsupp, ?_⟩ + rw [← isOmnificInteger_realCast_iff] + rw [← sub_trunc_zero_eq_realCast_of_support_subset_Ici hsupp] + apply hx.sub + rw [isOmnificInteger_iff_round_one] + apply eq_round_of_support_subset + · simpa only [wlog_one, support_trunc] using + (inter_subset_right : x.support ∩ Ioi 0 ⊆ Ioi 0) + · exact zero_lt_one + · rintro ⟨hsupp, hcoeff⟩ + have htrunc : IsOmnificInteger (x.trunc 0) := by + rw [isOmnificInteger_iff_round_one] + apply eq_round_of_support_subset + · simpa only [wlog_one, support_trunc] using + (inter_subset_right : x.support ∩ Ioi 0 ⊆ Ioi 0) + · exact zero_lt_one + have hconstant : IsOmnificInteger (x.coeff 0 : Surreal) := + isOmnificInteger_realCast_iff.mpr hcoeff + rw [← sub_add_cancel x (x.trunc 0), + sub_trunc_zero_eq_realCast_of_support_subset_Ici hsupp] + exact hconstant.add htrunc + +end Surreal diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/OmnificInteger/Ordinal.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/OmnificInteger/Ordinal.lean new file mode 100644 index 0000000000..ce04c141a7 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/OmnificInteger/Ordinal.lean @@ -0,0 +1,71 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.OmnificInteger.Basic +public import LeanPool.ConwayRefinement.CombinatorialGames.Surreal.Ordinal + +import LeanPool.ConwayRefinement.CombinatorialGames.Tactic.GameCmp + +/-! +# Ordinals as omnific integers + +This file proves the final assertion of Conway's Theorem 31: every ordinal, embedded in the +surreal numbers, is an omnific integer. The proof uses the canonical ordinal pregame and Conway's +fixed-point definition directly; it does not presuppose a surreal normal-form map. +-/ + +universe u + +public noncomputable section + +open IGame Order + +namespace NatOrdinal + +private theorem toIGame_le_sub_one_of_lt {a o : NatOrdinal.{u}} (hao : a < o) : + a.toIGame ≤ o.toIGame - 1 := by + rw [← ConwayGame.mk_le_mk] + simp only [ConwayGame.mk_sub, ConwayGame.mk_one, ConwayGame.mk_natOrdinal_toIGame] + rw [le_sub_iff_add_le, ← NatOrdinal.toGame_one, ← NatOrdinal.toGame_add] + apply NatOrdinal.toGame.monotone + simpa only [Order.succ_eq_add_one] using succ_le_of_lt hao + +private theorem toIGame_equiv_omnificIntegerCut (o : NatOrdinal.{u}) : + o.toIGame ≈ !{{o.toIGame - 1} | {o.toIGame + 1}} := by + apply IGame.Fits.equiv_of_forall_moves + · rw [IGame.Fits] + constructor + · intro z hz + simp only [IGame.leftMoves_ofSets, Set.mem_singleton_iff] at hz + subst z + exact IGame.Numeric.not_le.mpr (by + rw [← Surreal.mk_lt_mk] + simp) + · intro z hz + simp only [IGame.rightMoves_ofSets, Set.mem_singleton_iff] at hz + subst z + exact IGame.Numeric.not_le.mpr (by + rw [← Surreal.mk_lt_mk] + simp) + · intro z hz + rw [NatOrdinal.leftMoves_toIGame] at hz + obtain ⟨a, ha, rfl⟩ := hz + exact ⟨o.toIGame - 1, by simp, toIGame_le_sub_one_of_lt ha⟩ + · simp + +/-- Every ordinal, under its canonical embedding in the surreal numbers, is an omnific integer. -/ +theorem isOmnificInteger_toSurreal (o : NatOrdinal.{u}) : + Surreal.IsOmnificInteger o.toSurreal := by + rw [← Surreal.mk_natOrdinal_toIGame, Surreal.isOmnificInteger_mk_iff] + exact toIGame_equiv_omnificIntegerCut o + +/-- Every ordinal belongs to the omnific-integer subring of the surreal numbers. -/ +theorem toSurreal_mem_omnificIntegers (o : NatOrdinal.{u}) : + o.toSurreal ∈ Surreal.omnificIntegers := + Surreal.mem_omnificIntegers.mpr (isOmnificInteger_toSurreal o) + +end NatOrdinal diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/OmnificInteger/Primality.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/OmnificInteger/Primality.lean new file mode 100644 index 0000000000..b35d18e64f --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/OmnificInteger/Primality.lean @@ -0,0 +1,15 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.OmnificInteger.Primality.FiniteClasses +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.OmnificInteger.Primality.IrreducibleOmnificIntegers +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.OmnificInteger.Primality.OmnificIntegers +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.OmnificInteger.Primality.OrdinaryIntegers +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.OmnificInteger.Primality.ZFC + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/OmnificInteger/Primality/FiniteClasses.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/OmnificInteger/Primality/FiniteClasses.lean new file mode 100644 index 0000000000..8ec0142c70 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/OmnificInteger/Primality/FiniteClasses.lean @@ -0,0 +1,186 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.OmnificInteger.Primality.IrreducibleOmnificIntegers +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.FiniteClassPrimality + +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.CardinalTruncationResidue + +/-! +# Primality for finitely many support classes + +Integer constants are primal in the bounded Hahn integer part. The generic finite-class theorem +then gives primality for omnific integers whose support meets finitely many Archimedean classes. +-/ + +public noncomputable section + +open Cardinal FiniteArchimedeanClass +open scoped HahnSeries + +namespace HahnSeries.Nonpositive + +variable {K G R : Type*} {κ : Cardinal} +variable [DivisionRing K] [LinearOrder K] [IsOrderedRing K] [Archimedean K] +variable [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] +variable [Module K G] [IsOrderedModule K G] +variable [Field R] [Fact (ℵ₀ < κ)] +variable (Z : Subring R) (hZ : ∀ r : R, r ∈ Z ↔ ∃ z : ℤ, (z : R) = r) +include hZ + +/-- Every integer constant is primal in the bounded integer part over the integers. -/ +theorem isPrimal_intCast [CharZero R] (z : ℤ) : + IsPrimal (z : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) := by + refine UniqueFactorizationMonoid.induction_on_prime + (P := fun z : ℤ ↦ IsPrimal + (z : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z)) z ?_ ?_ ?_ + · simpa using (isPrimal_zero : IsPrimal + (0 : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z)) + · intro a ha + exact (ha.map (Int.castRingHom _)).isPrimal + · intro a p _ hp ha + rw [Int.cast_mul] + exact (prime_intCast Z hZ hp).isPrimal.mul ha + +/-- A bounded integer-part series of order zero is an integer constant and hence primal. -/ +theorem isPrimal_of_order_eq_zero [CharZero R] + (x : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) + (horder : ((CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z x : + Nonpositive G R) : R⟦G⟧).order = 0) : IsPrimal x := by + let xN := CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z x + have hconstant : (xN : R⟦G⟧) = HahnSeries.C ((xN : R⟦G⟧).coeff 0) := by + ext g + by_cases hg : g = 0 + · subst g + simp + · rw [HahnSeries.C_apply, HahnSeries.coeff_single_of_ne hg] + by_contra hcoeff + have hgNonpos : g ≤ 0 := support_subset xN ((HahnSeries.mem_support _ _).mpr hcoeff) + have hzeroLe : 0 ≤ g := horder ▸ HahnSeries.order_le_of_coeff_ne_zero hcoeff + exact hg (le_antisymm hgNonpos hzeroLe) + have hcoeffMem : (xN : R⟦G⟧).coeff 0 ∈ Z := by + simpa only [xN, CardSuppLTTruncationIntegerPart.coe_toNonpositiveRingHom] using + ((mem_cardSuppLTTruncationIntegerPart (Z := Z)).mp x.2).2 + obtain ⟨z, hz⟩ := (hZ _).mp hcoeffMem + have hxz : x = (z : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) := by + apply CardSuppLTTruncationIntegerPart.toNonpositiveRingHom_injective Z + rw [map_intCast] + apply Subtype.ext + change (xN : R⟦G⟧) = HahnSeries.C (z : R) + rw [hconstant, hz] + rw [hxz] + exact isPrimal_intCast Z hZ z + +end HahnSeries.Nonpositive + +namespace Surreal + +universe u + +/-- A bounded signed surreal integer-part series whose support meets only finitely many +Archimedean classes is primal. -/ +theorem isPrimal_cardSuppLTTruncationIntegerPart_of_supportArchimedeanClasses_finite + (a : HahnSeries.cardSuppLTTruncationIntegerPart + (G := Surreal.{u}) (R := ℝ) (κ := smallSupportCardinal.{u}) realIntegerSubring) + (hfinite : (HahnSeries.Nonpositive.supportArchimedeanClasses + (HahnSeries.CardSuppLTTruncationIntegerPart.toNonpositiveRingHom + realIntegerSubring a)).Finite) : IsPrimal a := by + apply HahnSeries.Nonpositive.isPrimal_of_supportArchimedeanClasses_finite_of_reduced + realIntegerSubring archimedeanStrata + · exact HahnSeries.Nonpositive.isPrimal_of_order_eq_zero realIntegerSubring + OmnificInteger.realIntegerSubring_mem_iff + · intro y hyOrder hyReduced + have hy0 : HahnSeries.CardSuppLTTruncationIntegerPart.toNonpositiveRingHom + realIntegerSubring y ≠ 0 := by + intro hyzero + apply hyOrder + rw [hyzero, Subring.coe_zero, HahnSeries.order_zero] + let c := HahnSeries.Nonpositive.leadingClass + (HahnSeries.CardSuppLTTruncationIntegerPart.toNonpositiveRingHom + realIntegerSubring y) hyOrder + exact HahnSeries.Nonpositive.isPrimal_of_isReduced_of_leadingClass_orderIso_real + archimedeanStrata realIntegerSubring y hy0 hyOrder hyReduced + (assumptionA2AtFiniteClass realIntegerSubring c) + (stratumOrderAddMonoidIsoReal archimedeanStrata c) + · exact hfinite + +/-- The finite-class endpoint stated directly using the underlying support image. -/ +theorem isPrimal_cardSuppLTTruncationIntegerPart_of_image_mk_support_finite + (a : HahnSeries.cardSuppLTTruncationIntegerPart + (G := Surreal.{u}) (R := ℝ) (κ := smallSupportCardinal.{u}) realIntegerSubring) + (hfinite : (ArchimedeanClass.mk '' (a : ℝ⟦Surreal.{u}⟧).support).Finite) : + IsPrimal a := by + apply isPrimal_cardSuppLTTruncationIntegerPart_of_supportArchimedeanClasses_finite + rw [HahnSeries.CardSuppLTTruncationIntegerPart.supportArchimedeanClasses_toNonpositiveRingHom] + exact hfinite + +end Surreal + +namespace Surreal.OmnificInteger + +universe u + +open HahnSeries.Nonpositive + +/-- Changing from Conway normal-form exponents to signed Hahn exponents preserves the set of +support classes, including the zero class. -/ +theorem supportArchimedeanClasses_toSignedNonpositiveHahn (x : Surreal.OmnificInteger.{u}) : + supportArchimedeanClasses x.toSignedNonpositiveHahn = + ArchimedeanClass.mk '' (x : Surreal.{u}).support := by + ext c + rw [mem_supportArchimedeanClasses] + constructor + · rintro ⟨g, hg, rfl⟩ + refine ⟨-g, ?_, by simp⟩ + rw [coe_toSignedNonpositiveHahn] at hg + exact Surreal.mem_support_toSignedFullHahnSeries.mp hg + · rintro ⟨g, hg, rfl⟩ + refine ⟨-g, ?_, by simp⟩ + rw [coe_toSignedNonpositiveHahn, Surreal.mem_support_toSignedFullHahnSeries] + simpa only [neg_neg] using hg + +/-- An omnific integer whose support meets only finitely many Archimedean classes is primal. +The signed support includes exponent zero, whose class is `⊤`; sign reversal does not change +Archimedean classes. The conclusion also holds for zero. -/ +@[blueprint "cor:omnific-finite-classes" + (phase := "Surreal numbers and omnific integers") + (title := "Primality for finitely many Archimedean classes") + (statement := /-- + Every omnific integer whose normal-form exponents meet only finitely many + Archimedean classes is primal in $\Oz$. + -/) + (proof := /-- + Pass to the signed Hahn presentation and induct on the finite set of + occupied Archimedean classes. A series of order zero is an integer + constant. Otherwise, split off its leading class. The reduced factor is + primal by \ref{cor:reduced-hahn-integer-part-primal}, using + \ref{fact:surreal-archimedean-strata} for $(A1)_\sigma$ and + \ref{fact:surreal-archimedean-ball-cofinality} for $(A2)_\sigma$; the lower truncation + has fewer occupied classes and is primal by induction. Their product is + primal. By \ref{thm:signed-normal-form-omnific-integer-equivalence}, + signed normal form transfers primality back to the original omnific integer. + -/)] +theorem isPrimal_of_supportArchimedeanClasses_finite (x : Surreal.OmnificInteger.{u}) + (hfinite : (supportArchimedeanClasses x.toSignedNonpositiveHahn).Finite) : IsPrimal x := by + let b : SignedSmallSupportIntegerPart.{u} := toSignedSmallSupportIntegerPart x + have himage : HahnSeries.CardSuppLTTruncationIntegerPart.toNonpositiveRingHom + Surreal.realIntegerSubring b = x.toSignedNonpositiveHahn := by + apply Subtype.ext + rw [HahnSeries.CardSuppLTTruncationIntegerPart.coe_toNonpositiveRingHom, + coe_toSignedNonpositiveHahn] + exact coe_toSignedSmallSupportIntegerPart x + have hbPrimal : IsPrimal b := by + apply Surreal.isPrimal_cardSuppLTTruncationIntegerPart_of_supportArchimedeanClasses_finite + rwa [himage] + let E : Surreal.OmnificInteger.{u} ≃+* SignedSmallSupportIntegerPart.{u} := + signedSmallSupportIntegerPartRingEquiv + apply (RingEquiv.isPrimal_iff E x).mp + simpa only [E, signedSmallSupportIntegerPartRingEquiv_apply, b] using hbPrimal + +end Surreal.OmnificInteger diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/OmnificInteger/Primality/IrreducibleOmnificIntegers.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/OmnificInteger/Primality/IrreducibleOmnificIntegers.lean new file mode 100644 index 0000000000..10a7072fc9 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/OmnificInteger/Primality/IrreducibleOmnificIntegers.lean @@ -0,0 +1,427 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.OmnificInteger.Primality.OmnificIntegers +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.CardinalFiniteClassReduction +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Reduction +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.ReducedCharacterization +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.ReducedDivisibility +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Monomial +public import Mathlib.RingTheory.UniqueFactorizationDomain.Basic + +import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.ArchimedeanAssumptions + +/-! +# Every irreducible omnific integer is prime + +Let `b` be an omnific integer, read as a bounded integer-part element of the signed Hahn series +`ℝ⟦Surreal⟧` with nonpositive exponents. If `b` is not an ordinary integer, its lowest exponent is +nonzero, and at the Archimedean class `σ` of that exponent LM24's reduction `ρ_σ(b)` divides `b` +with cofactor the open truncation `τ_σ(b)` (LM24, Definition 8.2.4): `b = ρ_σ(b) · τ_σ(b)`. Both +factors lie in the integer part, the units of the integer part are `±1`, and `ρ_σ(b)` is not a +unit. So an irreducible `b` has `τ_σ(b) ∈ {0, 1, -1}`: `b` or `-b` is reduced (LM24, +Proposition 8.2.5), hence primal (`Surreal.OmnificInteger.isPrimal_of_isReduced`, resting on the +primality of every series), hence prime. An irreducible ordinary integer is a prime number, and +a prime number `p` is prime in the omnific integers: `p` divides an omnific integer exactly when +it divides its integer constant coefficient, since a series without constant term is divisible +by every nonzero integer. + +Hence every irreducible omnific integer is prime, and factorisations into irreducibles are unique +up to order and units (`Surreal.OmnificInteger.factorization_unique`). +-/ + +universe u + +public noncomputable section + +open Cardinal FiniteArchimedeanClass +open scoped HahnSeries + +namespace HahnSeries.Nonpositive + +variable {K G R : Type*} {κ : Cardinal} +variable [DivisionRing K] [LinearOrder K] [IsOrderedRing K] [Archimedean K] +variable [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] +variable [Module K G] [IsOrderedModule K G] +variable [Field R] [Fact (ℵ₀ < κ)] + +/-! ### Units of the integer part over the integers -/ + +variable (Z : Subring R) (hZ : ∀ r : R, r ∈ Z ↔ ∃ z : ℤ, (z : R) = r) +include hZ + +/-- When `Z` is the image of `ℤ`, the units of the integer part are `1` and `-1`. -/ +theorem eq_one_or_eq_neg_one_of_isUnit [CharZero R] + {x : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z} (hx : IsUnit x) : + x = 1 ∨ x = -1 := by + obtain ⟨v, rfl⟩ := hx + set x : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z := ↑v with hxdef + let y : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z := ↑v⁻¹ + have hxy : x * y = 1 := by rw [hxdef]; exact v.mul_inv + have hxN := eq_C_constantCoeff_of_isUnit + ((CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z).isUnit_map v.isUnit) + have hyN := eq_C_constantCoeff_of_isUnit + ((CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z).isUnit_map (v⁻¹).isUnit) + obtain ⟨m, hm⟩ := (hZ _).mp ((mem_cardSuppLTTruncationIntegerPart (Z := Z)).mp x.2).2 + obtain ⟨n, hn⟩ := (hZ _).mp ((mem_cardSuppLTTruncationIntegerPart (Z := Z)).mp y.2).2 + have hxC : CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z x = C (m : R) := by + rw [hxN, constantCoeff_apply, CardSuppLTTruncationIntegerPart.coe_toNonpositiveRingHom, hm] + have hyC : CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z y = C (n : R) := by + rw [hyN, constantCoeff_apply, CardSuppLTTruncationIntegerPart.coe_toNonpositiveRingHom, hn] + have hmn : ((m * n : ℤ) : R) = 1 := by + have h := congrArg (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z) hxy + rw [map_mul, map_one, hxC, hyC, ← map_mul] at h + have h' := congrArg (fun q : Nonpositive G R ↦ (q : R⟦G⟧)) h + simp only [coe_C, Subring.coe_one] at h' + rw [← HahnSeries.C_one] at h' + rw [Int.cast_mul] + exact HahnSeries.C_injective h' + have hm1 : m * n = 1 := by exact_mod_cast hmn + rcases Int.eq_one_or_neg_one_of_mul_eq_one hm1 with h1 | h1 + · left + apply CardSuppLTTruncationIntegerPart.toNonpositiveRingHom_injective Z + rw [hxC, h1, map_one, Int.cast_one, map_one] + · right + apply CardSuppLTTruncationIntegerPart.toNonpositiveRingHom_injective Z + rw [hxC, h1, map_neg, map_one, Int.cast_neg, Int.cast_one, map_neg, map_one] + +/-! ### Irreducible elements of the integer part are reduced up to sign -/ + +/-- An irreducible bounded integer-part element with nonzero lowest exponent is reduced up to +sign: at the class of its lowest exponent, `x = ρ_σ(x) τ_σ(x)` with `ρ_σ(x)` not a unit, so +`τ_σ(x) ∈ {0, 1, -1}` (LM24, Proposition 8.2.5). -/ +theorem isReduced_or_isReduced_neg_of_irreducible [CharZero R] + (u : HahnEmbedding.ArchimedeanStrata K G) + {x : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z} (hirr : Irreducible x) + (horder : ((CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z x : + Nonpositive G R) : R⟦G⟧).order ≠ 0) : + IsReduced (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z x) ∨ + IsReduced (-CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z x) := by + set xN := CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z x with hxN + have hx0 : xN ≠ 0 := by + intro h + apply horder + rw [h, Subring.coe_zero, HahnSeries.order_zero] + set c := leadingClass xN horder with hc + have hT : T (K := K) c xN = xN := T_leadingClass xN horder + by_cases htau : tau (K := K) c xN = 0 + · left + exact (isReduced_iff_tau_leadingClass_eq_zero_or_one xN hx0 horder).mpr (Or.inl htau) + have hfac := rhoIntegerPart_mul_tauIntegerPart u c Z x hT htau + rcases hirr.isUnit_or_isUnit hfac.symm with hρ | hτ + · -- the reduction is not a unit: it would be `1`, forcing `x = τ_σ(x)` + exfalso + have hρN : CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z + (rhoIntegerPart u c Z x hT htau) = 1 := by + rcases eq_one_or_eq_neg_one_of_isUnit Z hZ hρ with h1 | h1 + · rw [h1, map_one] + · exfalso + have hcoeff := coeff_zero_rho_of_tau_ne_zero u c xN htau + rw [← toNonpositive_rhoIntegerPart u c Z x hT htau, h1, map_neg, map_one] at hcoeff + have : ((-1 : Nonpositive G R) : R⟦G⟧).coeff 0 = -1 := by + rw [Subring.coe_neg, Subring.coe_one, HahnSeries.coeff_neg, HahnSeries.coeff_one, + ite_eq_left rfl] + rw [this] at hcoeff + have h2 : (1 : R) + 1 = 0 := by + calc (1 : R) + 1 = -1 + 1 := by rw [hcoeff] + _ = 0 := neg_add_cancel 1 + exact two_ne_zero (one_add_one_eq_two.symm.trans h2) + have hxτ : xN = tau (K := K) c xN := by + have h := congrArg (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z) hfac + rw [map_mul, hρN, one_mul, toNonpositive_tauIntegerPart] at h + exact h.symm + have hcmk : c = FiniteArchimedeanClass.mk (xN : R⟦G⟧).order horder := by + apply Subtype.ext + rw [hc, leadingClass_val, FiniteArchimedeanClass.val_mk] + have hnot : (xN : R⟦G⟧).order ∉ ball K c := by + intro hmem + have hlt := (FiniteArchimedeanClass.mem_ball_iff (K := K)).mp hmem horder + rw [← hcmk] at hlt + exact lt_irrefl _ hlt + have h0 : ((tau (K := K) c xN : Nonpositive G R) : R⟦G⟧).coeff (xN : R⟦G⟧).order = 0 := + coeff_tau_of_not_mem c xN hnot + rw [← hxτ] at h0 + exact hx0 (Subtype.ext (HahnSeries.coeff_order_eq_zero.mp h0)) + · rcases eq_one_or_eq_neg_one_of_isUnit Z hZ hτ with h1 | h1 + · left + refine (isReduced_iff_tau_leadingClass_eq_zero_or_one (K := K) xN hx0 horder).mpr (Or.inr ?_) + have h := congrArg (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z) h1 + rw [toNonpositive_tauIntegerPart, map_one] at h + exact h + · right + have hx0' : -xN ≠ 0 := neg_ne_zero.mpr hx0 + have horder' : ((-xN : Nonpositive G R) : R⟦G⟧).order ≠ 0 := by + rw [Subring.coe_neg, HahnSeries.order_neg]; exact horder + refine (isReduced_iff_tau_leadingClass_eq_zero_or_one (K := K) (-xN) hx0' horder').mpr + (Or.inr ?_) + have hclass : leadingClass (-xN) horder' = c := by + apply Subtype.ext + rw [leadingClass_val, leadingClass_val, Subring.coe_neg, HahnSeries.order_neg] + rw [hclass, map_neg] + have h := congrArg (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z) h1 + rw [toNonpositive_tauIntegerPart, map_neg, map_one] at h + rw [h, neg_neg] + +/-! ### Prime numbers are prime in the integer part over the integers -/ + +/-- The integer constant coefficient of a bounded integer-part element over the integers. -/ +def intCoeff (x : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) : ℤ := + Classical.choose ((hZ _).mp ((mem_cardSuppLTTruncationIntegerPart (Z := Z)).mp x.2).2) + +theorem intCoeff_spec (x : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) : + ((intCoeff Z hZ x : ℤ) : R) = + ((x : CardSuppLTField (G := G) (R := R) (κ := κ)) : R⟦G⟧).coeff 0 := + Classical.choose_spec ((hZ _).mp ((mem_cardSuppLTTruncationIntegerPart (Z := Z)).mp x.2).2) + +/-- The integer constant coefficient is a ring homomorphism to `ℤ`. -/ +@[expose] def intCoeffRingHom [CharZero R] : + cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z →+* ℤ where + toFun := intCoeff Z hZ + map_one' := by + apply Int.cast_injective (α := R) + rw [intCoeff_spec, Int.cast_one, Subring.coe_one, Subfield.coe_one, HahnSeries.coeff_one, + ite_eq_left rfl] + map_mul' x y := by + apply Int.cast_injective (α := R) + rw [Int.cast_mul, intCoeff_spec, intCoeff_spec, intCoeff_spec] + have h := coeff_zero_mul (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z x) + (CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z y) + rw [Subring.coe_mul, Subfield.coe_mul] + simpa only [CardSuppLTTruncationIntegerPart.coe_toNonpositiveRingHom] using h + map_zero' := by + apply Int.cast_injective (α := R) + rw [intCoeff_spec, Int.cast_zero, Subring.coe_zero, Subfield.coe_zero, HahnSeries.coeff_zero] + map_add' x y := by + apply Int.cast_injective (α := R) + rw [Int.cast_add, intCoeff_spec, intCoeff_spec, intCoeff_spec, Subring.coe_add, + Subfield.coe_add, HahnSeries.coeff_add] + +theorem intCoeffRingHom_apply [CharZero R] + (x : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) : + intCoeffRingHom Z hZ x = intCoeff Z hZ x := + rfl + +omit hZ in +/-- A constant series, in the `κ`-bounded field. -/ +@[expose] def constField (r : R) : CardSuppLTField (G := G) (R := R) (κ := κ) := + ⟨HahnSeries.C r, by + rw [mem_cardSuppLTSubfield, HahnSeries.C_apply] + exact (HahnSeries.cardSupp_single_le _ _).trans_lt (one_lt_aleph0.trans Fact.out)⟩ + +omit hZ in +theorem coe_constField (r : R) : + ((constField (G := G) (κ := κ) r : CardSuppLTField (G := G) (R := R) (κ := κ)) : R⟦G⟧) = + HahnSeries.C r := + rfl + +/-- An integer `z ≠ 0` divides a bounded integer-part element exactly when it divides its integer +constant coefficient: a series without constant term is divisible by every nonzero integer. -/ +theorem intCast_dvd_iff [CharZero R] {z : ℤ} (hz : z ≠ 0) + (a : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) : + (z : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) ∣ a ↔ + z ∣ intCoeffRingHom Z hZ a := by + constructor + · intro h + have := map_dvd (intCoeffRingHom Z hZ) h + rwa [map_intCast, Int.cast_id] at this + · rintro ⟨k, hk⟩ + have hzR : (z : R) ≠ 0 := Int.cast_ne_zero.mpr hz + have ha0 : ((a : CardSuppLTField (G := G) (R := R) (κ := κ)) : R⟦G⟧).coeff 0 = + ((z * k : ℤ) : R) := by + rw [← hk, intCoeffRingHom_apply, intCoeff_spec] + -- the quotient `(a - a₀) / z + k` + let w : CardSuppLTField (G := G) (R := R) (κ := κ) := + constField ((z : R)⁻¹) * ((a : CardSuppLTField (G := G) (R := R) (κ := κ)) - + constField ((z * k : ℤ) : R)) + constField (k : R) + have hw : (w : R⟦G⟧) = HahnSeries.C ((z : R)⁻¹) * + (((a : CardSuppLTField (G := G) (R := R) (κ := κ)) : R⟦G⟧) - + HahnSeries.C ((z * k : ℤ) : R)) + + HahnSeries.C (k : R) := by + simp only [w, Subfield.coe_add, Subfield.coe_mul, Subfield.coe_sub, coe_constField] + have hwmem : w ∈ cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z := by + rw [mem_cardSuppLTTruncationIntegerPart, hw] + constructor + · intro g hg + rcases HahnSeries.support_add_subset _ _ hg with hg | hg + · obtain ⟨i, hi, j, hj, rfl⟩ := HahnSeries.support_mul_subset hg + rw [HahnSeries.C_apply] at hi + have hi0 : i = 0 := HahnSeries.support_single_subset hi + change i + j ∈ Set.Iic 0 + rw [hi0, zero_add] + rw [sub_eq_add_neg] at hj + rcases HahnSeries.support_add_subset _ _ hj with hj | hj + · exact ((mem_cardSuppLTTruncationIntegerPart (Z := Z)).mp a.2).1 hj + · have hj' := HahnSeries.support_neg_subset _ hj + rw [HahnSeries.C_apply] at hj' + exact (HahnSeries.support_single_subset hj').le + · rw [HahnSeries.C_apply] at hg + exact (HahnSeries.support_single_subset hg).le + · rw [HahnSeries.coeff_add, HahnSeries.C_mul_eq_smul, HahnSeries.coeff_smul, + HahnSeries.coeff_sub, ha0, HahnSeries.C_apply, HahnSeries.coeff_single_same, sub_self, + smul_zero, zero_add, HahnSeries.C_apply, HahnSeries.coeff_single_same] + exact (hZ _).mpr ⟨k, rfl⟩ + refine ⟨⟨w, hwmem⟩, ?_⟩ + apply Subtype.ext + apply Subtype.ext + rw [Subring.coe_mul, Subfield.coe_mul, SubringClass.coe_intCast, SubringClass.coe_intCast] + change ((a : CardSuppLTField (G := G) (R := R) (κ := κ)) : R⟦G⟧) = (z : R⟦G⟧) * (w : R⟦G⟧) + rw [hw, ← map_intCast (HahnSeries.C : R →+* R⟦G⟧), mul_add, ← mul_assoc, ← map_mul, + mul_inv_cancel₀ hzR, map_one, one_mul, ← map_mul, ← Int.cast_mul, sub_add_cancel] + +/-- A prime number is prime in the integer part over the integers. -/ +theorem prime_intCast [CharZero R] {z : ℤ} (hz : Prime z) : + Prime (z : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) := by + refine ⟨?_, ?_, fun a b hab ↦ ?_⟩ + · intro h + apply hz.ne_zero + have := congrArg (intCoeffRingHom Z hZ) h + rwa [map_intCast, Int.cast_id, map_zero] at this + · intro h + apply hz.not_isUnit + rcases eq_one_or_eq_neg_one_of_isUnit Z hZ h with h1 | h1 + · have := congrArg (intCoeffRingHom Z hZ) h1 + rw [map_intCast, Int.cast_id, map_one] at this + rw [this]; exact isUnit_one + · have := congrArg (intCoeffRingHom Z hZ) h1 + rw [map_intCast, Int.cast_id, map_neg, map_one] at this + rw [this]; exact isUnit_one.neg + · rw [intCast_dvd_iff Z hZ hz.ne_zero, map_mul] at hab + rcases hz.dvd_or_dvd hab with h | h + · exact Or.inl ((intCast_dvd_iff Z hZ hz.ne_zero a).mpr h) + · exact Or.inr ((intCast_dvd_iff Z hZ hz.ne_zero b).mpr h) + +/-- An integer irreducible in the integer part over the integers is irreducible in `ℤ`. -/ +theorem irreducible_int_of_irreducible_intCast [CharZero R] {z : ℤ} + (hz : Irreducible (z : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z)) : + Irreducible z := by + refine ⟨fun h ↦ hz.not_isUnit (h.map (Int.castRingHom _)), fun a b hab ↦ ?_⟩ + have hab' : (z : cardSuppLTTruncationIntegerPart (G := G) (R := R) (κ := κ) Z) = a * b := by + rw [hab, Int.cast_mul] + rcases hz.isUnit_or_isUnit hab' with h | h + · left + rcases eq_one_or_eq_neg_one_of_isUnit Z hZ h with h1 | h1 + · have := congrArg (intCoeffRingHom Z hZ) h1 + rw [map_intCast, Int.cast_id, map_one] at this + rw [this]; exact isUnit_one + · have := congrArg (intCoeffRingHom Z hZ) h1 + rw [map_intCast, Int.cast_id, map_neg, map_one] at this + rw [this]; exact isUnit_one.neg + · right + rcases eq_one_or_eq_neg_one_of_isUnit Z hZ h with h1 | h1 + · have := congrArg (intCoeffRingHom Z hZ) h1 + rw [map_intCast, Int.cast_id, map_one] at this + rw [this]; exact isUnit_one + · have := congrArg (intCoeffRingHom Z hZ) h1 + rw [map_intCast, Int.cast_id, map_neg, map_one] at this + rw [this]; exact isUnit_one.neg + +end HahnSeries.Nonpositive + +namespace Surreal.OmnificInteger + +open HahnSeries.Nonpositive + +theorem not_isOrdinaryInteger_neg {x : Surreal.OmnificInteger.{u}} (hx : ¬ IsOrdinaryInteger x) : + ¬ IsOrdinaryInteger (-x) := by + intro h + obtain ⟨z, hz⟩ := (isOrdinaryInteger_iff _).mp h + apply hx + rw [isOrdinaryInteger_iff] + refine ⟨-z, ?_⟩ + rw [Int.cast_neg, ← hz, Subring.coe_neg, neg_neg] + +theorem toSignedNonpositiveHahn_neg (x : Surreal.OmnificInteger.{u}) : + (-x).toSignedNonpositiveHahn = -x.toSignedNonpositiveHahn := by + apply Subtype.ext + rw [coe_toSignedNonpositiveHahn, Subring.coe_neg, Surreal.toSignedFullHahnSeries_neg, + ← coe_toSignedNonpositiveHahn] + exact (Subring.coe_neg _ _).symm + +theorem realIntegerSubring_mem_iff (r : ℝ) : + r ∈ Surreal.realIntegerSubring ↔ ∃ z : ℤ, (z : ℝ) = r := by + rw [Surreal.mem_realIntegerSubring] + exact Iff.rfl + +/-- An irreducible omnific integer that is not an ordinary integer is primal: it or its negative +is reduced (LM24, Proposition 8.2.5), and reduced nonordinary omnific integers are primal. -/ +theorem isPrimal_of_irreducible_of_not_isOrdinaryInteger (x : Surreal.OmnificInteger.{u}) + (hirr : Irreducible x) (hx : ¬ IsOrdinaryInteger x) : IsPrimal x := by + have hb : Irreducible (toSignedSmallSupportIntegerPart x) := by + rw [← signedSmallSupportIntegerPartRingEquiv_apply] + exact (MulEquiv.irreducible_iff (f := signedSmallSupportIntegerPartRingEquiv.{u})).mpr hirr + have horder := boundedSignedHahn_order_ne_zero_of_not_isOrdinaryInteger x hx + have himage : HahnSeries.CardSuppLTTruncationIntegerPart.toNonpositiveRingHom + Surreal.realIntegerSubring (toSignedSmallSupportIntegerPart x) = + x.toSignedNonpositiveHahn := by + apply Subtype.ext + rw [HahnSeries.CardSuppLTTruncationIntegerPart.coe_toNonpositiveRingHom, + coe_toSignedNonpositiveHahn] + exact coe_toSignedSmallSupportIntegerPart x + rcases isReduced_or_isReduced_neg_of_irreducible Surreal.realIntegerSubring + realIntegerSubring_mem_iff Surreal.archimedeanStrata hb horder with hred | hred + · rw [himage] at hred + exact isPrimal_of_isReduced x hx hred + · rw [himage, ← toSignedNonpositiveHahn_neg] at hred + have hneg := isPrimal_of_isReduced (-x) (not_isOrdinaryInteger_neg hx) hred + have hx' : x = (-1) * (-x) := by rw [neg_one_mul, neg_neg] + rw [hx'] + exact isUnit_neg_one.isPrimal.mul hneg + +/-- An irreducible omnific integer that is not an ordinary integer is prime. -/ +theorem prime_of_irreducible_of_not_isOrdinaryInteger (x : Surreal.OmnificInteger.{u}) + (hirr : Irreducible x) (hx : ¬ IsOrdinaryInteger x) : Prime x := + hirr.prime_of_isPrimal (isPrimal_of_irreducible_of_not_isOrdinaryInteger x hirr hx) + +/-- An irreducible ordinary integer is prime in the omnific integers. -/ +theorem prime_of_irreducible_of_isOrdinaryInteger (x : Surreal.OmnificInteger.{u}) + (hirr : Irreducible x) (hx : IsOrdinaryInteger x) : Prime x := by + obtain ⟨z, hz⟩ := (isOrdinaryInteger_iff x).mp hx + have hxz : x = (z : Surreal.OmnificInteger.{u}) := Subtype.ext (by rw [hz]; simp) + rw [hxz] at hirr ⊢ + rw [← MulEquiv.prime_iff signedSmallSupportIntegerPartRingEquiv.{u}, map_intCast] + have hirr' : Irreducible (z : SignedSmallSupportIntegerPart.{u}) := by + rw [← map_intCast signedSmallSupportIntegerPartRingEquiv.{u}] + exact (MulEquiv.irreducible_iff (f := signedSmallSupportIntegerPartRingEquiv.{u})).mpr hirr + exact prime_intCast Surreal.realIntegerSubring realIntegerSubring_mem_iff + (irreducible_iff_prime.mp + (irreducible_int_of_irreducible_intCast Surreal.realIntegerSubring + realIntegerSubring_mem_iff hirr')) + +/-- **Every irreducible omnific integer is prime.** -/ +@[blueprint "thm:omnific-factorisation" + (phase := "Surreal numbers and omnific integers") + (title := "Irreducible omnific integers are prime") + (statement := /-- + Every irreducible element of $\mathbf{Oz}$ is prime in $\mathbf{Oz}$. + -/) + (proof := /-- + Let $x\in\mathbf{Oz}$ be irreducible. If $x$ is not an ordinary integer, the + factorisation at its leading Archimedean class shows that either $x$ or $-x$ + is reduced. The reduced element is primal by + \ref{thm:reduced-omnific-primal}; multiplication by $-1$ preserves primality, + so $x$ is primal and hence prime. If $x$ is an ordinary integer, its + irreducibility in $\mathbf{Oz}$ makes the corresponding integer irreducible in + $\mathbb Z$, hence a prime integer. Divisibility of integer constants in + $\mathbf{Oz}$ is detected by the ordinary integer constant coefficient, so + $x$ is prime in $\mathbf{Oz}$ in this case as well. + -/)] +theorem prime_of_irreducible (x : Surreal.OmnificInteger.{u}) (hirr : Irreducible x) : Prime x := by + by_cases hx : IsOrdinaryInteger x + · exact prime_of_irreducible_of_isOrdinaryInteger x hirr hx + · exact prime_of_irreducible_of_not_isOrdinaryInteger x hirr hx + +/-- Unique factorisation in the omnific integers: two factorisations of an omnific integer into +irreducibles agree up to order and units. -/ +theorem factorization_unique {f g : Multiset Surreal.OmnificInteger.{u}} + (hf : ∀ x ∈ f, Irreducible x) (hg : ∀ x ∈ g, Irreducible x) + (hfg : Associated f.prod g.prod) : + Multiset.Rel Associated f g := + prime_factors_unique (fun x hx ↦ prime_of_irreducible x (hf x hx)) + (fun x hx ↦ prime_of_irreducible x (hg x hx)) hfg + +end Surreal.OmnificInteger diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/OmnificInteger/Primality/OmnificIntegers.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/OmnificInteger/Primality/OmnificIntegers.lean new file mode 100644 index 0000000000..971c2a0e71 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/OmnificInteger/Primality/OmnificIntegers.lean @@ -0,0 +1,119 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.ReducedPrimality +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.OmnificInteger.Primality.OrdinaryIntegers + +import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.ArchimedeanAssumptions + +/-! +# Every nonordinary reduced omnific integer is primal + +The leading-class transfer of [LM24, Prop. 9.2.2] reduces a nonordinary reduced omnific integer +to a reduced generalised power series with real exponents. Every such series is primal, and every +Archimedean stratum of the surreal exponent group is order-isomorphic to `ℝ` [LM24, +Prop. 2.4.3]. Hence every nonordinary reduced omnific integer is primal, and every irreducible one +is prime. +-/ + +public noncomputable section + +open Cardinal FiniteArchimedeanClass +open scoped HahnSeries NatOrdinal + +namespace Surreal.OmnificInteger + +universe u + +/-- Every nonordinary reduced omnific integer is primal. -/ +@[blueprint "thm:reduced-omnific-primal" + (phase := "Surreal numbers and omnific integers") + (title := "Primality of reduced omnific integers outside $\\mathbb Z$") + (statement := /-- + Let $x\in\mathbf{Oz}$ be an omnific integer whose underlying surreal + number is not equal to any integer. Write $s$ for its signed nonpositive + series representation. Suppose that $s$ is reduced: $s\ne0$ and, for + some Archimedean class $\sigma$, + \[ + \operatorname{supp}(s)\cap\operatorname{supp}(s-1) + \subseteq\{y:[y]=\sigma\}. + \] + Then $x$ is primal in $\mathbf{Oz}$. + -/) + (proof := /-- + By \ref{thm:signed-normal-form-omnific-integer-equivalence}, $x$ + corresponds to a bounded integer-part series $b$. Since $x$ is not an ordinary integer, the + underlying series of $b$ is nonzero and has nonzero order; reducedness + transfers from $s$ to $b$. At the leading Archimedean class of $b$, the + surreal exponent group satisfies $(A2)_\sigma$ by + \ref{fact:surreal-archimedean-ball-cofinality}, and its stratum is + order-isomorphic to $\mathbb R$ by + \ref{fact:surreal-archimedean-strata}. Hence + \ref{cor:reduced-hahn-integer-part-primal} makes $b$ primal. Transport + primality back through the ring equivalence. + -/)] +theorem isPrimal_of_isReduced + (x : Surreal.OmnificInteger.{u}) (hxInteger : ¬ IsOrdinaryInteger x) + (hxReduced : HahnSeries.Nonpositive.IsReduced x.toSignedNonpositiveHahn) : + IsPrimal x := by + let b : SignedSmallSupportIntegerPart.{u} := toSignedSmallSupportIntegerPart x + let hbOrder := boundedSignedHahn_order_ne_zero_of_not_isOrdinaryInteger x hxInteger + have himage : + HahnSeries.CardSuppLTTruncationIntegerPart.toNonpositiveRingHom + Surreal.realIntegerSubring b = x.toSignedNonpositiveHahn := by + apply Subtype.ext + rw [HahnSeries.CardSuppLTTruncationIntegerPart.coe_toNonpositiveRingHom, + coe_toSignedNonpositiveHahn] + exact coe_toSignedSmallSupportIntegerPart x + have hx0 : x ≠ 0 := by + intro hxzero + subst x + apply hxInteger + rw [isOrdinaryInteger_iff] + exact ⟨0, rfl⟩ + have hb0 : + HahnSeries.CardSuppLTTruncationIntegerPart.toNonpositiveRingHom + Surreal.realIntegerSubring b ≠ 0 := by + rw [himage] + intro hxHahn + apply hx0 + apply Subtype.ext + apply Surreal.toSignedFullHahnSeries_injective + have hraw := congrArg (fun q : HahnSeries.Nonpositive Surreal ℝ ↦ + (q : HahnSeries Surreal ℝ)) hxHahn + rw [coe_toSignedNonpositiveHahn] at hraw + exact hraw.trans Surreal.toSignedFullHahnSeries_zero.symm + have hbReduced : HahnSeries.Nonpositive.IsReduced + (HahnSeries.CardSuppLTTruncationIntegerPart.toNonpositiveRingHom + Surreal.realIntegerSubring b) := by + rw [himage] + exact hxReduced + let c := HahnSeries.Nonpositive.leadingClass + (HahnSeries.CardSuppLTTruncationIntegerPart.toNonpositiveRingHom + Surreal.realIntegerSubring b) hbOrder + have hbPrimal : IsPrimal b := + HahnSeries.Nonpositive.isPrimal_of_isReduced_of_leadingClass_orderIso_real + Surreal.archimedeanStrata Surreal.realIntegerSubring b hb0 hbOrder hbReduced + (Surreal.assumptionA2AtFiniteClass Surreal.realIntegerSubring c) + (Surreal.stratumOrderAddMonoidIsoReal Surreal.archimedeanStrata c) + let E : Surreal.OmnificInteger.{u} ≃+* SignedSmallSupportIntegerPart.{u} := + signedSmallSupportIntegerPartRingEquiv + have hmap : IsPrimal (E x) := by + simpa only [E, signedSmallSupportIntegerPartRingEquiv_apply, b] using hbPrimal + exact (RingEquiv.isPrimal_iff E x).mp hmap + +/-- Every irreducible nonordinary reduced omnific integer is prime. -/ +theorem prime_of_irreducible_of_isReduced + (x : Surreal.OmnificInteger.{u}) (hirr : Irreducible x) + (hxInteger : ¬ IsOrdinaryInteger x) + (hxReduced : HahnSeries.Nonpositive.IsReduced x.toSignedNonpositiveHahn) : + Prime x := + hirr.prime_of_isPrimal (isPrimal_of_isReduced x hxInteger hxReduced) + +end Surreal.OmnificInteger diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/OmnificInteger/Primality/OrdinaryIntegers.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/OmnificInteger/Primality/OrdinaryIntegers.lean new file mode 100644 index 0000000000..d7c14828c7 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/OmnificInteger/Primality/OrdinaryIntegers.lean @@ -0,0 +1,103 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.CardinalTruncation +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.HahnSeries.CardinalIntegerPart +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.HahnSeries.DegreeTransfer + +/-! +# Ordinary omnific integers + +An omnific integer is ordinary when it is an integer. A non-ordinary omnific integer has nonzero +lowest exponent in the signed Hahn orientation, and conversely; these are the hypotheses under +which the LM24 leading-class transfer applies. +-/ + +public noncomputable section + +open Cardinal FiniteArchimedeanClass +open scoped HahnSeries NatOrdinal + +namespace Surreal.OmnificInteger + +universe u + +/-- An omnific integer is ordinary when its underlying surreal is an integer. -/ +def IsOrdinaryInteger (x : Surreal.OmnificInteger.{u}) : Prop := + ∃ z : ℤ, x.1 = (z : Surreal) + +/-- Characterization of ordinary omnific integers by an integer witness. -/ +theorem isOrdinaryInteger_iff (x : Surreal.OmnificInteger.{u}) : + IsOrdinaryInteger x ↔ ∃ z : ℤ, x.1 = (z : Surreal) := + (Iff.rfl) + +/-- A non-ordinary omnific integer has nonzero order in the signed Hahn orientation. -/ +theorem signedFullHahnSeries_order_ne_zero_of_not_isOrdinaryInteger + (x : Surreal.OmnificInteger.{u}) (hx : ¬ IsOrdinaryInteger x) : + x.1.toSignedFullHahnSeries.order ≠ 0 := by + intro horder + have hsupport : x.1.toSignedFullHahnSeries.support ⊆ Set.Iic 0 := by + intro g hg + exact x.toSignedNonpositiveHahn.2 (by + simpa only [coe_toSignedNonpositiveHahn] using hg) + have hconstant : x.1.toSignedFullHahnSeries = + HahnSeries.C (x.1.toSignedFullHahnSeries.coeff 0) := by + ext g + rcases eq_or_ne g 0 with rfl | hg + · simp + · rw [HahnSeries.C_apply, HahnSeries.coeff_single_of_ne hg] + by_contra hcoeff + exact hg (le_antisymm (hsupport hcoeff) + (horder ▸ HahnSeries.order_le_of_coeff_ne_zero hcoeff)) + have hb := (HahnSeries.mem_cardSuppLTTruncationIntegerPart + (Z := Surreal.realIntegerSubring)).mp (toSignedSmallSupportIntegerPart x).2 + have hcoeff : x.1.toSignedFullHahnSeries.coeff 0 ∈ + Surreal.realIntegerSubring := by + rw [← coe_toSignedSmallSupportIntegerPart x] + exact hb.2 + rw [Surreal.mem_realIntegerSubring] at hcoeff + obtain ⟨z, hz⟩ := hcoeff + apply hx + rw [isOrdinaryInteger_iff] + refine ⟨z, ?_⟩ + apply Surreal.toSignedFullHahnSeries_injective + calc + x.1.toSignedFullHahnSeries = + HahnSeries.C (x.1.toSignedFullHahnSeries.coeff 0) := hconstant + _ = HahnSeries.single 0 (x.1.toSignedFullHahnSeries.coeff 0) := by + ext g + rw [HahnSeries.C_apply] + _ = HahnSeries.single 0 (z : ℝ) := by rw [hz] + _ = ((z : Surreal).toSignedFullHahnSeries) := by + simpa using (Surreal.toSignedFullHahnSeries_realCast (z : ℝ)).symm + +/-- An omnific integer whose signed Conway normal form has nonzero order is not an ordinary +integer. -/ +theorem not_isOrdinaryInteger_of_signedFullHahnSeries_order_ne_zero + (x : Surreal.OmnificInteger.{u}) (horder : x.1.toSignedFullHahnSeries.order ≠ 0) : + ¬ IsOrdinaryInteger x := by + rintro ⟨z, hz⟩ + apply horder + have hcast : x.1.toSignedFullHahnSeries = HahnSeries.single 0 (z : ℝ) := by + rw [hz] + simpa using Surreal.toSignedFullHahnSeries_realCast (z : ℝ) + rw [hcast] + rcases eq_or_ne (z : ℝ) 0 with hz0 | hz0 + · rw [hz0, HahnSeries.single_eq_zero, HahnSeries.order_zero] + · exact HahnSeries.order_single hz0 + +/-- The bounded signed Hahn image of a non-ordinary omnific integer has nonzero order. -/ +theorem boundedSignedHahn_order_ne_zero_of_not_isOrdinaryInteger + (x : Surreal.OmnificInteger.{u}) (hx : ¬ IsOrdinaryInteger x) : + ((HahnSeries.CardSuppLTTruncationIntegerPart.toNonpositiveRingHom + Surreal.realIntegerSubring (toSignedSmallSupportIntegerPart x) : + HahnSeries.Nonpositive Surreal ℝ) : HahnSeries Surreal ℝ).order ≠ 0 := by + rw [HahnSeries.CardSuppLTTruncationIntegerPart.coe_toNonpositiveRingHom, + coe_toSignedSmallSupportIntegerPart] + exact signedFullHahnSeries_order_ne_zero_of_not_isOrdinaryInteger x hx + +end Surreal.OmnificInteger diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/OmnificInteger/Primality/ZFC.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/OmnificInteger/Primality/ZFC.lean new file mode 100644 index 0000000000..68f8ade7ae --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/OmnificInteger/Primality/ZFC.lean @@ -0,0 +1,85 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.ZFC.OmnificInteger +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.ZFC.OmnificCodes +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.ZFC.Reduced +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.OmnificInteger.Primality.IrreducibleOmnificIntegers +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.OmnificInteger.Primality.FiniteClasses + +import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Divisibility.PrimalPreimage + +/-! +# Factorisation in the class presentation of the omnific integers + +The cut-preserving ring equivalence carries factors and divisibility witnesses in both directions. +Consequently the factorisation conclusions hold for the proper-class presentation as well. +-/ + +universe u + +public noncomputable section + +namespace ZFSet.Surreal.OmnificInteger + +/-- An ordinary omnific class value is an integer cast. -/ +def IsOrdinaryInteger (x : OmnificInteger.{u}) : Prop := ∃ z : ℤ, x = z + +/-- Ordinary integers agree in the class and library presentations. -/ +theorem isOrdinaryInteger_iff (x : OmnificInteger.{u}) : + x.IsOrdinaryInteger ↔ _root_.Surreal.OmnificInteger.IsOrdinaryInteger (ringEquiv x) := by + rw [IsOrdinaryInteger, _root_.Surreal.OmnificInteger.isOrdinaryInteger_iff] + constructor + · rintro ⟨z, rfl⟩ + exact ⟨z, by simp⟩ + · rintro ⟨z, hz⟩ + refine ⟨z, ringEquiv.injective ?_⟩ + rw [map_intCast] + exact Subtype.ext hz + +/-- Every irreducible omnific class value is prime. -/ +theorem prime_of_irreducible (x : OmnificInteger.{u}) (hx : Irreducible x) : Prime x := + (MulEquiv.prime_iff ringEquiv).1 + (_root_.Surreal.OmnificInteger.prime_of_irreducible (ringEquiv x) + ((MulEquiv.irreducible_iff ringEquiv).2 hx)) + +/-- Two finite factorisations into irreducible class values agree up to order and units. -/ +theorem factorization_unique {f g : Multiset OmnificInteger.{u}} + (hf : ∀ x ∈ f, Irreducible x) (hg : ∀ x ∈ g, Irreducible x) + (hfg : Associated f.prod g.prod) : + Multiset.Rel Associated f g := + prime_factors_unique (fun x hx ↦ prime_of_irreducible x (hf x hx)) + (fun x hx ↦ prime_of_irreducible x (hg x hx)) hfg + +/-- Every reduced, nonordinary omnific class value is primal. -/ +theorem isPrimal_of_isReduced (x : OmnificInteger.{u}) (hx : ¬x.IsOrdinaryInteger) + (hred : ZFSet.Surreal.IsReduced (x : ZFSet.Surreal.{u})) : IsPrimal x := + (RingEquiv.isPrimal_iff ringEquiv x).1 + (_root_.Surreal.OmnificInteger.isPrimal_of_isReduced (ringEquiv x) + (fun h ↦ hx ((isOrdinaryInteger_iff x).2 h)) + ((isReduced_iff_toSignedNonpositiveHahn x).1 hred)) + +/-- A nonzero omnific class value meeting finitely many support classes is primal. -/ +theorem isPrimal_of_hasFiniteSupportClasses (x : OmnificInteger.{u}) (_hx : x ≠ 0) + (hfinite : ZFSet.Surreal.HasFiniteSupportClasses (x : ZFSet.Surreal.{u})) : IsPrimal x := by + apply (RingEquiv.isPrimal_iff ringEquiv x).1 + apply _root_.Surreal.OmnificInteger.isPrimal_of_supportArchimedeanClasses_finite + rw [_root_.Surreal.OmnificInteger.supportArchimedeanClasses_toSignedNonpositiveHahn, + ringEquiv_apply, coe_toOmnificInteger] + exact (ZFSet.Surreal.hasFiniteSupportClasses_iff_toSurreal _).1 hfinite + + +end ZFSet.Surreal.OmnificInteger + +namespace ZFSet.OmnificCode + +/-- Every irreducible omnific set code is prime, with no restriction on factor codes. -/ +theorem isPrime_of_isIrreducible (x : OmnificCode.{u}) (hx : x.IsIrreducible) : x.IsPrime := + (isPrime_iff x).2 (_root_.Surreal.OmnificInteger.prime_of_irreducible x.value + ((isIrreducible_iff x).1 hx)) + +end ZFSet.OmnificCode diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/OmnificInteger/Refinement.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/OmnificInteger/Refinement.lean new file mode 100644 index 0000000000..b92f08b0d3 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/OmnificInteger/Refinement.lean @@ -0,0 +1,11 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.OmnificInteger.Refinement.ConwayRefinement + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/OmnificInteger/Refinement/ConwayRefinement.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/OmnificInteger/Refinement/ConwayRefinement.lean new file mode 100644 index 0000000000..4ef5faa1b3 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/OmnificInteger/Refinement/ConwayRefinement.lean @@ -0,0 +1,116 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.LimitTailPrimality +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.HahnSeries.CardinalIntegerPart +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.OmnificInteger.RefinementConjecture +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.RationalTailQuotient + +import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Divisibility.PrimalPreimage +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint + +/-! +# Conway's refinement conjecture for omnific integers + +The signed Conway normal form identifies the omnific integers with the cardinal-bounded +generalised-power-series integer part over the integer subring of the reals. Finite support-class +primality and the common-tail theorem prove that this integer part is pre-Schreier. Transporting +through signed normal form gives Conway's four-factor refinement theorem. +-/ + +open Cardinal FiniteArchimedeanClass +open HahnSeries.CardSuppLTTruncationIntegerPart + +universe u + +public noncomputable section + +namespace Surreal.OmnificInteger + +private theorem small_of_card_lt_smallSupportCardinal + {S : Set (FiniteArchimedeanClass Surreal.{u})} + (hS : #S < Surreal.smallSupportCardinal.{u}) : Small.{u} S := by + rw [Cardinal.small_iff_lift_mk_lt_univ, Cardinal.lift_id] + rw [Surreal.smallSupportCardinal_eq_univ] at hS + exact hS + +/-- Every element of the signed bounded Hahn integer part corresponding to the omnific integers +is primal. -/ +@[blueprint "thm:surreal-hahn-integer-part-primality" + (phase := "Surreal numbers and omnific integers") + (title := "Primality of the surreal Hahn integer part") + (statement := /-- + Every element of + \[ + \mathbb Z+\mathbb R((\mathbf{No}_u^{<0}))_{\kappa_u} + \] + is primal, where $\kappa_u$ is the universe cardinal. + -/) + (proof := /-- + The two Archimedean hypotheses follow from + \ref{fact:surreal-archimedean-strata} and + \ref{fact:surreal-archimedean-ball-cofinality}. Therefore + \ref{thm:finite-support-classes-primality} handles series whose support + meets finitely many Archimedean classes. For a small limit family, the + quotient by its common tail is Cauchy complete by + \ref{lem:surreal-common-tail-quotient-complete}. The common tail has + the required fraction-field property by + \ref{thm:surreal-common-tail-integer-part-fraction-field}. Finally, + \ref{thm:limit-tail-primality} proves primality for arbitrary support-class + order type. + -/)] +theorem signedSmallSupportIntegerPart_isPrimal + (a : SignedSmallSupportIntegerPart.{u}) : IsPrimal a := by + apply isPrimal_of_finite_classes_and_limit_tail_conditions Surreal.realIntegerSubring + · intro y hy + apply HahnSeries.Nonpositive.isPrimal_of_supportArchimedeanClasses_finite + Surreal.realIntegerSubring Surreal.archimedeanStrata + (fun c ↦ ⟨Surreal.stratumOrderAddMonoidIsoReal Surreal.archimedeanStrata c⟩) + (Surreal.assumptionA2AtFiniteClass Surreal.realIntegerSubring) y + rw [supportArchimedeanClasses_toNonpositiveRingHom] + exact hy + · intro T hTne hTlimit hTcard + let : Small.{u} T := small_of_card_lt_smallSupportCardinal hTcard + let : Nonempty T := Set.nonempty_coe_sort.mpr hTne + exact ⟨Surreal.completeSpace_rationalTailQuotient T hTlimit⟩ + · intro T _hTne hTlimit hTcard + let : Small.{u} T := small_of_card_lt_smallSupportCardinal hTcard + exact Surreal.fracSubring_cardSuppLTTruncationIntegerPart_tailSubmodule_eq_top + Surreal.realIntegerSubring T hTlimit + +/-- The signed bounded Hahn integer part corresponding to the omnific integers is pre-Schreier. -/ +theorem signedSmallSupportIntegerPart_decompositionMonoid : + DecompositionMonoid SignedSmallSupportIntegerPart.{u} := + ⟨signedSmallSupportIntegerPart_isPrimal⟩ + +/-- The omnific-integer subring has the four-factor refinement property. -/ +@[blueprint "thm:omnific-integer-refinement-property" + (phase := "Surreal numbers and omnific integers") + (title := "Refinement property of $\\mathbf{Oz}_u$") + (statement := /-- + If $a,b,c,d\in\mathbf{Oz}$ and $ab=cd$, then there are + $e,f,g,h\in\mathbf{Oz}$ such that + \[ + a=ef,\qquad b=gh,\qquad c=eg,\qquad d=fh. + \] + -/) + (proof := /-- + By \ref{thm:signed-normal-form-omnific-integer-equivalence}, + $\mathbf{Oz}_u$ is isomorphic to its bounded generalised-power-series + integer part. + By \ref{thm:surreal-hahn-integer-part-primality}, that integer part is + pre-Schreier and therefore has four-factor refinement. Transport the + refinement back through signed normal form. + -/)] +theorem conwayRefinement : ConwayRefinementConjecture.{u} := by + rw [conwayRefinementConjecture_def, ← hasFourFactorRefinement_def] + let : DecompositionMonoid SignedSmallSupportIntegerPart.{u} := + signedSmallSupportIntegerPart_decompositionMonoid + exact signedSmallSupportIntegerPartRingEquiv.toMulEquiv.hasFourFactorRefinement_iff.mpr + hasFourFactorRefinement_of_decompositionMonoid + +end Surreal.OmnificInteger diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/OmnificInteger/RefinementConjecture.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/OmnificInteger/RefinementConjecture.lean new file mode 100644 index 0000000000..5ceb8a0482 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/OmnificInteger/RefinementConjecture.lean @@ -0,0 +1,41 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.OmnificInteger.Basic + +import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Divisibility.Refinement + +/-! +# Conway's four-factor refinement conjecture + +This file states the second conjecture on omnific integers from *On Numbers and Games*, page 46, +and LM24, Conjecture 1.1.1(2). There are no nonzero hypotheses: every equality `a * b = c * d` +must have factors `e`, `f`, `g`, and `h` satisfying the four displayed equations. + +The four inputs and four witnesses range over `Surreal.OmnificInteger.{u}`. The class presentation +by set-coded Conway cuts, modulo Conway equivalence, gives an equivalent formula in Mathlib's +ZFC model; the comparison is proved in +`ConwayRefinement.Surreal.ZFC.Refinement`. Its universe parameter is the universe +of sets in that model, not a bound on the allowed option sets within it. + +-/ + +universe u + +public section + +/-- The fixed-universe four-factor refinement conjecture for omnific integers. -/ +def ConwayRefinementConjecture : Prop := + HasFourFactorRefinement Surreal.OmnificInteger.{u} + +/-- The four equations in the fixed-universe refinement conjecture. -/ +theorem conwayRefinementConjecture_def : + ConwayRefinementConjecture.{u} ↔ + ∀ a b c d : Surreal.OmnificInteger.{u}, a * b = c * d → + ∃ e f g h : Surreal.OmnificInteger.{u}, + a = e * f ∧ b = g * h ∧ c = e * g ∧ d = f * h := + hasFourFactorRefinement_def diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/OmnificInteger/Tests.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/OmnificInteger/Tests.lean new file mode 100644 index 0000000000..518789ce43 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/OmnificInteger/Tests.lean @@ -0,0 +1,16 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.OmnificInteger.Tests.Basic +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.OmnificInteger.Tests.ConwayRefinement +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.OmnificInteger.Tests.DegreeTwoOzPrime +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.OmnificInteger.Tests.FiniteClasses +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.OmnificInteger.Tests.NormalForm +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.OmnificInteger.Tests.ZFC + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/OmnificInteger/Tests/Basic.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/OmnificInteger/Tests/Basic.lean new file mode 100644 index 0000000000..c08a5d5317 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/OmnificInteger/Tests/Basic.lean @@ -0,0 +1,91 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.OmnificInteger.RefinementConjecture +public import LeanPool.ConwayRefinement.CombinatorialGames.Surreal.Ordinal + +import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.OmnificInteger.Ordinal +import Mathlib.Algebra.Order.Ring.Cast + +/-! +# API checks for omnific integers + +This file checks the public fixed-point and subring interfaces from a separate module. The ordinary +integer `2` is only an interface smoke test. The semantic checks prove that `ω - 1` belongs to the +carrier but is not the image of an ordinary integer, and that `2⁻¹` does not belong to the +carrier. Together, the latter checks distinguish Conway's carrier from both the ordinary integers +and all surreal numbers. +-/ + +universe u + +public noncomputable section + +namespace Tests + +open Surreal + +/-- Interface smoke test: addition in the predicate proves that `2` is an omnific integer. -/ +theorem two_mem_omnificIntegers : + (2 : Surreal.{u}) ∈ omnificIntegers := by + apply mem_omnificIntegers.mpr + rw [← one_add_one_eq_two] + exact isOmnificInteger_one.add isOmnificInteger_one + +/-- For `2`, subring membership reduces to Conway's fixed-point equation. -/ +theorem two_mem_omnificIntegers_iff_cut : + (2 : Surreal.{u}) ∈ omnificIntegers ↔ + (2 : Surreal.{u}) = omnificIntegerCut 2 := + mem_omnificIntegers.trans isOmnificInteger_iff + +/-- The ordinal `ω`, embedded in the surreal numbers, is an omnific integer. -/ +theorem omega_mem_omnificIntegers : + (NatOrdinal.of Ordinal.omega0).toSurreal ∈ omnificIntegers := + NatOrdinal.toSurreal_mem_omnificIntegers _ + +/-- The omnific integer `ω - 1` is larger than every embedded natural number. -/ +theorem natCast_lt_omega_sub_one (n : ℕ) : + (n : Surreal.{u}) < (NatOrdinal.of Ordinal.omega0).toSurreal - 1 := by + rw [lt_sub_iff_add_lt] + rw [← NatOrdinal.toSurreal_natCast n, ← NatOrdinal.toSurreal_one, + ← NatOrdinal.toSurreal_add] + apply NatOrdinal.toSurreal.strictMono + simpa using NatOrdinal.natCast_lt_omega0 (n + 1) + +/-- The omnific integer `ω - 1` is larger than every embedded ordinary integer. -/ +theorem intCast_lt_omega_sub_one (z : ℤ) : + (z : Surreal.{u}) < (NatOrdinal.of Ordinal.omega0).toSurreal - 1 := by + apply lt_of_le_of_lt (b := (z.natAbs : Surreal.{u})) + · simpa using + (Int.cast_mono (R := Surreal.{u}) (Int.le_natAbs : z ≤ z.natAbs)) + · exact natCast_lt_omega_sub_one z.natAbs + +/-- The surreal number `ω - 1` belongs to the omnific-integer subring. -/ +theorem omega_sub_one_mem_omnificIntegers : + (NatOrdinal.of Ordinal.omega0).toSurreal - 1 ∈ omnificIntegers := by + apply mem_omnificIntegers.mpr + exact (NatOrdinal.isOmnificInteger_toSurreal _).add isOmnificInteger_one.neg + +/-- The omnific integer `ω - 1` is not the image of an ordinary integer. -/ +theorem omega_sub_one_ne_intCast (z : ℤ) : + (NatOrdinal.of Ordinal.omega0).toSurreal - 1 ≠ (z : Surreal.{u}) := + (intCast_lt_omega_sub_one z).ne' + +/-- The surreal number `2⁻¹` does not belong to the omnific-integer subring. -/ +theorem two_inv_not_mem_omnificIntegers : + (2 : Surreal.{u})⁻¹ ∉ omnificIntegers := + Surreal.two_inv_not_mem_omnificIntegers + +/-- The refinement conjecture includes product equalities involving zero. -/ +theorem conwayRefinementConjecture_zero_product + (hC : ConwayRefinementConjecture.{u}) {a b : OmnificInteger.{u}} (hab : a * b = 0) : + ∃ e f g h : OmnificInteger.{u}, + a = e * f ∧ b = g * h ∧ (0 : OmnificInteger.{u}) = e * g ∧ 0 = f * h := by + apply conwayRefinementConjecture_def.mp hC a b 0 0 + simpa using hab + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/OmnificInteger/Tests/ConwayRefinement.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/OmnificInteger/Tests/ConwayRefinement.lean new file mode 100644 index 0000000000..b5e25ffdfd --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/OmnificInteger/Tests/ConwayRefinement.lean @@ -0,0 +1,58 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.ConwayRefinementProof +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Support.ConwayNormalForm +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.OmnificInteger.Ordinal + +/-! +# Checks for the native Conway target + +The cut-defined carrier excludes one half, separating it from the entire surreal field. +The public equivalence exposes native subring divisibility. The zero-input certificate ensures +that the standalone statement does not silently exclude the cancellation boundary. +-/ + +public noncomputable section + +universe u + +namespace Tests.Conway + +open ConwayRefinement.Standalone.Oz + +/-- The target's carrier is not the whole field of surreal numbers. -/ +theorem half_not_in_carrier : ¬ IsConwayOmnificInteger ((2 : Surreal.{u})⁻¹) := by + rw [isConwayOmnificInteger_iff_mem] + exact Surreal.two_inv_not_mem_omnificIntegers + +/-- The carrier includes an actual infinite omnific integer, so it is not just the integers. -/ +theorem omega_in_carrier : + IsConwayOmnificInteger (NatOrdinal.of Ordinal.omega0).toSurreal ∧ + ∀ n : ℕ, (n : Surreal.{u}) < (NatOrdinal.of Ordinal.omega0).toSurreal := by + refine ⟨isConwayOmnificInteger_iff_mem.mpr (NatOrdinal.toSurreal_mem_omnificIntegers _), ?_⟩ + intro n + rw [← NatOrdinal.toSurreal_natCast n] + exact NatOrdinal.toSurreal.strictMono (NatOrdinal.natCast_lt_omega0 n) + +/-- The endpoint uses divisibility in the actual omnific subring. -/ +theorem native_endpoint (h : ConwayConjecture.{u}) (b : Surreal.OmnificInteger.{u}) : + IsPrimal b := conwayConjecture_iff_forall_isPrimal.mp h b + +/-- A zero top row remains within the standalone conjecture's quantifiers. -/ +theorem zero_row (h : ConwayConjecture.{u}) : + ∃ e f g h : Surreal.{u}, + IsConwayOmnificInteger e ∧ IsConwayOmnificInteger f ∧ + IsConwayOmnificInteger g ∧ IsConwayOmnificInteger h ∧ + 0 = e * f ∧ 3 = g * h ∧ 0 = e * g ∧ 2 = f * h := by + have hz : IsConwayOmnificInteger (0 : Surreal.{u}) := + isConwayOmnificInteger_iff_mem.mpr (Subring.zero_mem _) + exact h 0 3 0 2 hz + (isConwayOmnificInteger_iff_mem.mpr ((3 : Surreal.OmnificInteger).2)) hz + (isConwayOmnificInteger_iff_mem.mpr ((2 : Surreal.OmnificInteger).2)) (by simp) + +end Tests.Conway diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/OmnificInteger/Tests/DegreeTwoOzPrime.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/OmnificInteger/Tests/DegreeTwoOzPrime.lean new file mode 100644 index 0000000000..8d02780882 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/OmnificInteger/Tests/DegreeTwoOzPrime.lean @@ -0,0 +1,56 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.CombinatorialGames.Examples.DegreeTwoPrimeProof + +/-! +# API checks for the explicit degree-two prime + +This separately compiled client consumes only the public standalone statement/proof boundary. It +checks the literal prime, the coefficient-doubled reducible foil, their exact common support order +type, and the support equality that makes the comparison mathematically sharp, in the surreal +numbers of an arbitrary universe. +-/ + +universe u + +public noncomputable section + +namespace Tests.DegreeTwoOz + +open ConwayRefinement.Standalone.Oz.DegreeTwoExample + +/-- The literal coefficient-one normal form is certified prime. -/ +example : Prime degreeTwoOz.{u} := + IsPrime.proof + +/-- Its Conway support has exact order type `ω² + 1`. -/ +example : HasExactSupportOrderType.{u} := + HasExactSupportOrderType.proof + +/-- The coefficient-doubled comparison has the same exact order type. -/ +example : FoilHasExactSupportOrderType.{u} := + FoilHasExactSupportOrderType.proof + +/-- The comparison element has an explicit factorisation into two nonunits. -/ +example : FoilHasNontrivialFactorization.{u} := + FoilHasNontrivialFactorization.proof + +/-- The prime and reducible foil have literally equal Conway supports. -/ +example : degreeTwoFoil.{u}.1.support = degreeTwoOz.1.support := + degreeTwoFoil_support + +/-- The two normal forms differ; their constant coefficients are two and one. -/ +theorem degreeTwoFoil_ne_degreeTwoOz : degreeTwoFoil.{u} ≠ degreeTwoOz := by + intro h + have hcoeff := congrArg + (fun q : ConwayRefinement.Standalone.Oz.OmnificInteger.{u} ↦ q.1.coeff 0) h + rw [degreeTwoFoil_val, degreeTwoOz_val, two_mul] at hcoeff + rw [SurrealHahnSeries.coeff_add_apply, normalForm_coeff_zero] at hcoeff + norm_num at hcoeff + +end Tests.DegreeTwoOz diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/OmnificInteger/Tests/FiniteClasses.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/OmnificInteger/Tests/FiniteClasses.lean new file mode 100644 index 0000000000..e9456d78f6 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/OmnificInteger/Tests/FiniteClasses.lean @@ -0,0 +1,37 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.OmnificInteger.Primality.FiniteClasses +public import LeanPool.ConwayRefinement.ConwayRefinement.Examples.OmnificInteger.OneRowPrime + +/-! +# A downstream client of finite-class omnific primality + +Conway's one-row omnific integer has support order type `ω + 1`, so this client uses a genuinely +infinite support. Its reducedness supplies the finite support-class hypothesis. The stronger +prime theorem for this example is not used to obtain the primality conclusion here. +-/ + +public noncomputable section + +namespace Tests + +open Surreal.OmnificInteger.OneRowExample + +/-- The infinite Conway normal form meets finitely many classes, in the same orientation as +the paper's hypothesis. -/ +theorem oneRow_normalForm_classes_finite : + (ArchimedeanClass.mk '' (oneRowOz : Surreal).support).Finite := by + rw [← Surreal.OmnificInteger.supportArchimedeanClasses_toSignedNonpositiveHahn] + exact oneRowOz_isReduced.supportArchimedeanClasses_finite + +/-- The one-row omnific integer is primal by the finite-class theorem. -/ +theorem oneRow_primal_of_finite_classes : IsPrimal oneRowOz := + Surreal.OmnificInteger.isPrimal_of_supportArchimedeanClasses_finite oneRowOz + oneRowOz_isReduced.supportArchimedeanClasses_finite + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/OmnificInteger/Tests/NormalForm.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/OmnificInteger/Tests/NormalForm.lean new file mode 100644 index 0000000000..e1da3eece8 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/OmnificInteger/Tests/NormalForm.lean @@ -0,0 +1,83 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.OmnificInteger.NormalForm + +/-! +# Checks for Conway normal forms of omnific integers + +The positive example `ω + 3` has both a genuinely positive exponent and a nonzero integral +constant coefficient, so it excludes the degenerate pure-constant and zero cases. The negative +monomial `ω⁻¹` separates the intended nonnegative-support criterion from the nearby wrong +definition that permits arbitrary exponents with an integral constant coefficient. +-/ + +universe u + +noncomputable section + +public section + +namespace Tests + +open Set Surreal + +/-- The monomial `ω` satisfies the normal-form criterion for omnific integers. -/ +theorem omega_isOmnificInteger : + IsOmnificInteger (ω^ (1 : Surreal.{u})) := by + rw [isOmnificInteger_iff_normalForm] + constructor + · simp + · simp + +/-- The nonconstant surreal `ω + 3` is an omnific integer. -/ +theorem omega_add_three_isOmnificInteger : + IsOmnificInteger (ω^ (1 : Surreal.{u}) + 3) := + omega_isOmnificInteger.add (IsOmnificInteger.natCast 3) + +/-- The nonconstant check has the expected integral coefficient at exponent zero. -/ +theorem omega_add_three_coeff_zero : + (ω^ (1 : Surreal.{u}) + 3).coeff 0 = 3 := by + have homega : + (ω^ (1 : Surreal.{u})).toHahnSeries.coeff 0 = 0 := by + rw [toHahnSeries_wpow, + SurrealHahnSeries.coeff_single_of_ne (by norm_num)] + have hthree : (3 : Surreal.{u}).toHahnSeries.coeff 0 = 3 := by + calc + (3 : Surreal.{u}).toHahnSeries.coeff 0 = + (SurrealHahnSeries.single 0 3).coeff 0 := + congrArg (fun q : SurrealHahnSeries ↦ q.coeff 0) + (toHahnSeries_natCast 3) + _ = 3 := SurrealHahnSeries.coeff_single_self 0 3 + calc + (ω^ (1 : Surreal.{u}) + 3).coeff 0 = + (ω^ (1 : Surreal.{u}) + 3).toHahnSeries.coeff 0 := + congrFun (coeff_toHahnSeries _).symm 0 + _ = ((ω^ (1 : Surreal.{u})).toHahnSeries + + (3 : Surreal.{u}).toHahnSeries).coeff 0 := by + rw [toHahnSeries_add] + _ = (ω^ (1 : Surreal.{u})).toHahnSeries.coeff 0 + + (3 : Surreal.{u}).toHahnSeries.coeff 0 := + SurrealHahnSeries.coeff_add_apply _ _ _ + _ = 3 := by rw [homega, hthree, zero_add] + +/-- A negative monomial is not an omnific integer. -/ +theorem wpow_neg_one_not_isOmnificInteger : + ¬IsOmnificInteger (ω^ (-1 : Surreal.{u})) := by + rw [isOmnificInteger_iff_normalForm] + rintro ⟨hsupport, _⟩ + have hnonnegative : (0 : Surreal.{u}) ≤ -1 := hsupport (by + rw [support_wpow] + exact mem_singleton _) + norm_num at hnonnegative + +/-- The unit gap makes two sufficiently close omnific integers equal. -/ +example {x y : Surreal.{u}} (hx : IsOmnificInteger x) (hy : IsOmnificInteger y) + (hbound : x - y ∈ Ioo (-1) 1) : x = y := + hx.eq_of_sub_mem_Ioo_neg_one_one hy hbound + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/OmnificInteger/Tests/ZFC.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/OmnificInteger/Tests/ZFC.lean new file mode 100644 index 0000000000..19eb808a10 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/OmnificInteger/Tests/ZFC.lean @@ -0,0 +1,105 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.OmnificInteger.Primality.ZFC +public import LeanPool.ConwayRefinement.ConwayRefinement.Examples.OmnificInteger.ZFCDegreeTwoPrime +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.ZFC.Properness +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.ZFC.Refinement + +/-! +# Certificates for factorisation over the class of omnific codes + +The explicit degree-two example supplies an irreducible code with infinite support, so the +irreducible-to-prime implication is not vacuous and does not describe only ordinary integers. +The zero and unit cases check the public factorisation predicates. The remaining certificates +check the exported conclusions for native class values and their normal forms. +-/ + +universe u + +public noncomputable section + +namespace Tests.ZFC + +open ZFSet + +/-- A nonordinary, infinite-support irreducible code exercises the class-wide prime theorem. -/ +theorem exists_degreeTwo_prime_code : + ∃ c : OmnificCode.{u}, + c.value = _root_.Surreal.OmnificInteger.DegreeTwoExample.degreeTwoOz ∧ + c.IsIrreducible ∧ c.IsPrime := by + obtain ⟨c, hc⟩ := OmnificCode.value_surjective + _root_.Surreal.OmnificInteger.DegreeTwoExample.degreeTwoOz.{u} + have hp : Prime c.value := by + rw [hc] + exact _root_.Surreal.OmnificInteger.DegreeTwoExample.degreeTwoOz_prime + have hi := (OmnificCode.isIrreducible_iff c).2 hp.irreducible + exact ⟨c, hc, hi, OmnificCode.isPrime_of_isIrreducible c hi⟩ + +example : ¬(0 : OmnificCode.{u}).IsPrime := by + simp [OmnificCode.isPrime_iff] + +example : ¬(1 : OmnificCode.{u}).IsIrreducible := by + simp [OmnificCode.isIrreducible_iff] + +example : (1 : OmnificCode.{u}).IsUnit := by + simp [OmnificCode.isUnit_iff] + +example : OmnificCode.Divides (0 : OmnificCode.{u}) 0 := by + simp [OmnificCode.divides_iff] + +example : ¬OmnificCode.Divides (0 : OmnificCode.{u}) 1 := by + simp [OmnificCode.divides_iff] + +example (z : ZFSet.{u}) (h : IsGameCode z) + (hz : (GameCode.mk z h).IsOmnificInteger) + (hi : (⟨GameCode.mk z h, hz⟩ : OmnificCode.{u}).IsIrreducible) : + (⟨GameCode.mk z h, hz⟩ : OmnificCode.{u}).IsPrime := + OmnificCode.isPrime_of_isIrreducible _ hi + +example : ∀ s : ZFSet.{u}, omnificGameCodes ≠ Class.ofSet s := + omnificGameCodes_ne_ofSet + +example (x : ZFSet.Surreal.OmnificInteger.{u}) (hx : Irreducible x) : Prime x := + ZFSet.Surreal.OmnificInteger.prime_of_irreducible x hx + +example (x : ZFSet.Surreal.OmnificInteger.{u}) (hx : x ≠ 0) + (hf : ZFSet.Surreal.HasFiniteSupportClasses (x : ZFSet.Surreal.{u})) : IsPrimal x := + ZFSet.Surreal.OmnificInteger.isPrimal_of_hasFiniteSupportClasses x hx hf + +example (x : ZFSet.Surreal.OmnificInteger.{u}) + (hx : ¬x.IsOrdinaryInteger) (hr : ZFSet.Surreal.IsReduced (x : ZFSet.Surreal.{u})) : + IsPrimal x := + ZFSet.Surreal.OmnificInteger.isPrimal_of_isReduced x hx hr + +open ZFSet.Surreal.OmnificInteger.DegreeTwoExample + +example : + ZFSet.Surreal.toHahnSeries (degreeTwoOz.{u} : ZFSet.Surreal.{u}) = + _root_.Surreal.OmnificInteger.DegreeTwoExample.normalForm := + degreeTwoOz_toHahnSeries + +example (x : ZFSet.Surreal.OmnificInteger.{u}) : + ZFSet.Surreal.toHahnSeries (x : ZFSet.Surreal.{u}) = + _root_.Surreal.OmnificInteger.DegreeTwoExample.normalForm ↔ x = degreeTwoOz := + toHahnSeries_eq_normalForm_iff x + +example : + (ZFSet.Surreal.toHahnSeries (degreeTwoOz.{u} : ZFSet.Surreal.{u})).length = + Ordinal.omega0 ^ (2 : Ordinal) + 1 := + degreeTwoOz_length + +example : ZFSet.Surreal.IsReduced (degreeTwoOz.{u} : ZFSet.Surreal.{u}) := + degreeTwoOz_isReduced + +example : Prime degreeTwoOz.{u} := degreeTwoOz_prime + +example : ZFSet.Surreal.OmnificInteger.RefinementConjecture.{u} ↔ + ConwayRefinementConjecture.{u} := + ZFSet.Surreal.OmnificInteger.refinementConjecture_iff + +end Tests.ZFC diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/RationalTailQuotient.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/RationalTailQuotient.lean new file mode 100644 index 0000000000..a7bbd4ef35 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/RationalTailQuotient.lean @@ -0,0 +1,322 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Order.Module.ConvexQuotientSplitting +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.CutFilling +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.RealModule +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.SupportArchimedeanClasses +public import LeanPool.ConwayRefinement.ConwayRefinement.Topology.Order.OrderedAddGroup +public import Mathlib.Algebra.Algebra.Rat +public import Mathlib.Algebra.Order.Module.Rat +public import Mathlib.Topology.Algebra.IsUniformGroup.Basic + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint + +/-! +# Rational tail quotients of the surreals + +For a family of finite Archimedean classes, its common tail is a rational subspace of the +surreals. Quotienting by that subspace gives the usual ordered tail quotient together with its +native rational-vector-space structure. At a nonempty limit family, the quotient is Cauchy +complete for its additive uniformity: the canonical representatives of the family are a small +positive coinitial family, and surreal simplicity fills every cut indexed by that family. + +This presentation is used when a small closed rational subspace of the tail quotient must be +formed. Its additive subgroup is exactly the tail kernel used by the older additive presentation. +-/ + +open Set + +universe u + +public noncomputable section + +namespace Surreal + +/-- The quotient by the rational subspace underlying a family of Archimedean tails. -/ +abbrev RationalTailQuotient (T : Set (FiniteArchimedeanClass Surreal.{u})) := + Surreal.{u} ⧸ FiniteArchimedeanClass.tailSubmodule ℚ T + +noncomputable instance rationalTailQuotientLinearOrder + (T : Set (FiniteArchimedeanClass Surreal.{u})) : LinearOrder (RationalTailQuotient T) := + ConvexQuotient.instLinearOrder (H := + (FiniteArchimedeanClass.tailSubmodule ℚ T).toAddSubgroup) + +instance rationalTailQuotientIsOrderedAddMonoid + (T : Set (FiniteArchimedeanClass Surreal.{u})) : + IsOrderedAddMonoid (RationalTailQuotient T) := + ConvexQuotient.instIsOrderedAddMonoid (H := + (FiniteArchimedeanClass.tailSubmodule ℚ T).toAddSubgroup) + +instance rationalTailQuotientPosSMulMono + (T : Set (FiniteArchimedeanClass Surreal.{u})) : + PosSMulMono ℚ (RationalTailQuotient T) where + smul_le_smul_of_nonneg_left q hq x y hxy := by + change ∃ a b : Surreal.{u}, Submodule.Quotient.mk a = x ∧ + Submodule.Quotient.mk b = y ∧ a ≤ b at hxy + obtain ⟨a, b, ha, hb, hab⟩ := hxy + change ∃ a b : Surreal.{u}, Submodule.Quotient.mk a = q • x ∧ + Submodule.Quotient.mk b = q • y ∧ a ≤ b + refine ⟨q • a, q • b, ?_, ?_, smul_le_smul_of_nonneg_left hab hq⟩ + · simpa only [Submodule.Quotient.mk_smul] using congrArg (q • ·) ha + · simpa only [Submodule.Quotient.mk_smul] using congrArg (q • ·) hb + +instance rationalTailQuotientPosSMulStrictMono + (T : Set (FiniteArchimedeanClass Surreal.{u})) : + PosSMulStrictMono ℚ (RationalTailQuotient T) := + PosSMulMono.toPosSMulStrictMono + +/-- Absolute value commutes with projection to a rational tail quotient. -/ +theorem rationalTailQuotient_abs + (T : Set (FiniteArchimedeanClass Surreal.{u})) (x : Surreal.{u}) : + |(Submodule.Quotient.mk x : RationalTailQuotient T)| = Submodule.Quotient.mk |x| := by + rcases le_total 0 x with hx | hx + · have hxq : (0 : RationalTailQuotient T) ≤ Submodule.Quotient.mk x := by + rw [← Submodule.Quotient.mk_zero] + exact ConvexQuotient.mk_le_mk hx + rw [abs_of_nonneg hx, abs_of_nonneg hxq] + · have hxq : (Submodule.Quotient.mk x : RationalTailQuotient T) ≤ 0 := by + rw [← Submodule.Quotient.mk_zero] + exact ConvexQuotient.mk_le_mk hx + rw [abs_of_nonpos hx, abs_of_nonpos hxq, ← Submodule.Quotient.mk_neg] + +/-- A strict comparison of quotient Archimedean classes reflects to the chosen surreal +representatives. -/ +theorem archimedeanClass_mk_lt_of_rationalTailQuotient_mk_lt + (T : Set (FiniteArchimedeanClass Surreal.{u})) {x y : Surreal.{u}} + (h : ArchimedeanClass.mk (Submodule.Quotient.mk x : RationalTailQuotient T) < + ArchimedeanClass.mk (Submodule.Quotient.mk y : RationalTailQuotient T)) : + ArchimedeanClass.mk x < ArchimedeanClass.mk y := by + rw [ArchimedeanClass.mk_lt_mk] at h ⊢ + intro n + have hn := h n + have hn' : (Submodule.Quotient.mk (n • |y|) : RationalTailQuotient T) < + Submodule.Quotient.mk |x| := by + have heq : (Submodule.Quotient.mk (n • |y|) : RationalTailQuotient T) = + n • Submodule.Quotient.mk |y| := by + change QuotientAddGroup.mk' _ (n • |y|) = n • QuotientAddGroup.mk' _ |y| + exact map_nsmul (QuotientAddGroup.mk' _) n |y| + rw [heq] + simpa only [rationalTailQuotient_abs] using hn + exact ConvexQuotient.lt_of_mk_lt_mk hn' + +/-- Suppose a chosen quotient class is met by `S`, and every nonzero member of `W` lies outside +its quotient closed ball while retaining a class met by `S`. Then the nonzero support classes of +`W` form a strict initial segment of the support classes of `S`. -/ +theorem exists_nonzeroSupportClass_bound + (T : Set (FiniteArchimedeanClass Surreal.{u})) + (q : FiniteArchimedeanClass (RationalTailQuotient T)) + (S W : Set Surreal.{u}) + (hqocc : q.1 ∈ ArchimedeanClass.mk '' + (Submodule.Quotient.mk (p := FiniteArchimedeanClass.tailSubmodule ℚ T) '' S)) + (hW : ∀ g ∈ W, g ≠ 0 → + Submodule.Quotient.mk g ∉ FiniteArchimedeanClass.closedBallAddSubgroup q) + (hWocc : ∀ g ∈ W, g ≠ 0 → ArchimedeanClass.mk g ∈ ArchimedeanClass.mk '' S) : + ∃ c ∈ ArchimedeanClass.mk '' (S \ {0}), + ArchimedeanClass.mk '' (W \ {0}) ⊆ + (ArchimedeanClass.mk '' (S \ {0})) ∩ Set.Iio c := by + obtain ⟨yq, ⟨y, hyS, rfl⟩, hyq⟩ := hqocc + have hy0 : y ≠ 0 := by + intro hy + subst y + have hqtop : q.1 = ⊤ := by + rw [← hyq] + exact ArchimedeanClass.mk_eq_top_iff.mpr (Submodule.Quotient.mk_zero _) + exact q.2 hqtop + refine ⟨ArchimedeanClass.mk y, ⟨y, ⟨hyS, by simpa using hy0⟩, rfl⟩, ?_⟩ + rintro c ⟨g, ⟨hgW, hg0⟩, rfl⟩ + rw [Set.mem_singleton_iff] at hg0 + obtain ⟨z, hzS, hzg⟩ := hWocc g hgW hg0 + have hz0 : z ≠ 0 := by + intro hz + subst z + rw [ArchimedeanClass.mk_zero] at hzg + have hgtop : ArchimedeanClass.mk g = ⊤ := hzg.symm + exact hg0 (ArchimedeanClass.mk_eq_top_iff.mp hgtop) + refine ⟨⟨z, ⟨hzS, by simpa using hz0⟩, hzg⟩, ?_⟩ + have hgq : ArchimedeanClass.mk (Submodule.Quotient.mk g : RationalTailQuotient T) < + ArchimedeanClass.mk (Submodule.Quotient.mk y : RationalTailQuotient T) := by + apply ArchimedeanClass.mk_lt_of_not_mem_closedBallAddSubgroup + intro hmem + apply hW g hgW hg0 + apply FiniteArchimedeanClass.mem_closedBallAddSubgroup_iff.mpr + intro hgq0 + change q.1 ≤ ArchimedeanClass.mk (Submodule.Quotient.mk g : RationalTailQuotient T) + rw [← hyq] + exact ArchimedeanClass.mem_closedBallAddSubgroup_iff.mp hmem + exact archimedeanClass_mk_lt_of_rationalTailQuotient_mk_lt T hgq + +noncomputable instance rationalTailQuotientTopologicalSpace + (T : Set (FiniteArchimedeanClass Surreal.{u})) : + TopologicalSpace (RationalTailQuotient T) := + Preorder.topology (RationalTailQuotient T) + +instance rationalTailQuotientOrderTopology + (T : Set (FiniteArchimedeanClass Surreal.{u})) : + OrderTopology (RationalTailQuotient T) := + ⟨rfl⟩ + +instance rationalTailQuotientDenselyOrdered + (T : Set (FiniteArchimedeanClass Surreal.{u})) : + DenselyOrdered (RationalTailQuotient T) := by + constructor + intro a b hab + refine ⟨(2 : ℚ)⁻¹ • (a + b), ?_, ?_⟩ + · calc + a = (2 : ℚ)⁻¹ • (a + a) := by rw [smul_add, ← add_smul]; norm_num + _ < (2 : ℚ)⁻¹ • (a + b) := + smul_lt_smul_of_pos_left + (add_lt_add_left hab a |>.trans_eq (add_comm _ _)) (by norm_num) + · calc + (2 : ℚ)⁻¹ • (a + b) < (2 : ℚ)⁻¹ • (b + b) := + smul_lt_smul_of_pos_left + (by simpa [add_comm] using (add_lt_add_left hab b)) (by norm_num) + _ = b := by rw [smul_add, ← add_smul]; norm_num + +instance rationalTailQuotientIsTopologicalAddGroup + (T : Set (FiniteArchimedeanClass Surreal.{u})) : + IsTopologicalAddGroup (RationalTailQuotient T) where + toContinuousAdd := continuousAdd_of_orderTopology (RationalTailQuotient T) + toContinuousNeg := continuousNeg_of_orderTopology (RationalTailQuotient T) + +noncomputable instance rationalTailQuotientUniformSpace + (T : Set (FiniteArchimedeanClass Surreal.{u})) : + UniformSpace (RationalTailQuotient T) := + IsTopologicalAddGroup.rightUniformSpace (RationalTailQuotient T) + +instance rationalTailQuotientIsUniformAddGroup + (T : Set (FiniteArchimedeanClass Surreal.{u})) : + IsUniformAddGroup (RationalTailQuotient T) := + isUniformAddGroup_of_addCommGroup + +/-- Canonical positive scales in a rational tail quotient, indexed by a small copy of the +class family. -/ +def rationalTailQuotientScale + (T : Set (FiniteArchimedeanClass Surreal.{u})) [Small.{u} T] + (i : Shrink.{u} T) : + RationalTailQuotient T := + Submodule.Quotient.mk + (FiniteArchimedeanClass.positiveRepresentative ((equivShrink T).symm i).1) + +/-- The canonical quotient scale is represented by the positive representative of its class. -/ +@[simp] +theorem rationalTailQuotientScale_apply + (T : Set (FiniteArchimedeanClass Surreal.{u})) [Small.{u} T] + (i : Shrink.{u} T) : + rationalTailQuotientScale T i = Submodule.Quotient.mk + (FiniteArchimedeanClass.positiveRepresentative ((equivShrink T).symm i).1) := + (rfl) + +/-- At a limit family, every canonical tail-quotient scale is positive. -/ +theorem rationalTailQuotientScale_pos + (T : Set (FiniteArchimedeanClass Surreal.{u})) [Small.{u} T] + (hT : ∀ c ∈ T, ∃ d ∈ T, c < d) (i : Shrink.{u} T) : + 0 < rationalTailQuotientScale T i := by + rw [← Submodule.Quotient.mk_zero] + apply ConvexQuotient.mk_lt_mk_iff.mpr + constructor + · exact FiniteArchimedeanClass.positiveRepresentative_pos _ + · intro hmem + have htail : FiniteArchimedeanClass.positiveRepresentative ((equivShrink T).symm i).1 ∈ + FiniteArchimedeanClass.tailKernel T := by + rw [← FiniteArchimedeanClass.tailSubmodule_toAddSubgroup ℚ T] + simpa using hmem + exact FiniteArchimedeanClass.positiveRepresentative_not_mem_tailKernel hT _ htail + +/-- The canonical scales are coinitial among the positive elements of the tail quotient. -/ +theorem exists_rationalTailQuotientScale_le + (T : Set (FiniteArchimedeanClass Surreal.{u})) [Small.{u} T] + {x : RationalTailQuotient T} (hx : 0 < x) : + ∃ i : Shrink.{u} T, rationalTailQuotientScale T i ≤ x := by + induction x using Submodule.Quotient.induction_on with + | H x => + have hxq : (Submodule.Quotient.mk (0 : Surreal.{u}) : RationalTailQuotient T) < + (Submodule.Quotient.mk x : RationalTailQuotient T) := by + simpa using hx + have hx0 : 0 < x := ConvexQuotient.lt_of_mk_lt_mk hxq + have hxH : x ∉ FiniteArchimedeanClass.tailKernel T := by + intro hmem + apply (ConvexQuotient.mk_lt_mk_iff.mp hxq).2 + have : x ∈ (FiniteArchimedeanClass.tailSubmodule ℚ T).toAddSubgroup := by + simpa only [FiniteArchimedeanClass.tailSubmodule_toAddSubgroup ℚ T] using hmem + simpa using this + rw [FiniteArchimedeanClass.mem_tailKernel_iff] at hxH + push Not at hxH + obtain ⟨c, hxc⟩ := hxH + refine ⟨equivShrink T c, ConvexQuotient.mk_le_mk ?_⟩ + apply (ArchimedeanClass.lt_of_mk_lt_mk_of_nonneg ?_ hx0.le).le + rw [FiniteArchimedeanClass.mk_positiveRepresentative] + simpa using hxc + +/-- The positive representatives of a limit family give a small coinitial family in its rational +tail quotient. -/ +@[blueprint "lem:surreal-common-tail-quotient-coinitial-scales" + (phase := "Surreal numbers and omnific integers") + (title := "A coinitial family of positive elements in surreal common-tail quotients") + (statement := /-- + Let $T$ be a $u$-small family of nonzero Archimedean classes of + $\mathbf{No}_u$ with no least member in the magnitude order. Index $T$ by + a $u$-small type $I$, and let $\varepsilon_i$ be the image in + $\mathbf{No}_u/H_T$ of the positive representative of the class indexed + by $i$. Then every $\varepsilon_i$ is positive, and for every $x>0$ in + the quotient there is $i\in I$ such that $\varepsilon_i\le x$. + -/) + (proof := /-- + A positive representative cannot lie in $H_T$: a later class in $T$ + excludes it from the common tail. Conversely, lift $x>0$ to a positive + surreal representative. Since that representative is not in $H_T$, its + Archimedean class lies above some member of $T$; the corresponding positive + representative therefore maps below $x$ in the quotient. + -/)] +theorem rationalTailQuotientScale_pos_and_coinitial + (T : Set (FiniteArchimedeanClass Surreal.{u})) [Small.{u} T] + (hT : ∀ c ∈ T, ∃ d ∈ T, c < d) : + (∀ i : Shrink.{u} T, 0 < rationalTailQuotientScale T i) ∧ + ∀ x : RationalTailQuotient T, 0 < x → + ∃ i : Shrink.{u} T, rationalTailQuotientScale T i ≤ x := + ⟨rationalTailQuotientScale_pos T hT, fun _ hx ↦ exists_rationalTailQuotientScale_le T hx⟩ + +/-- A rational tail quotient at a nonempty limit family is Cauchy complete for its additive +uniformity. -/ +@[blueprint "lem:surreal-common-tail-quotient-complete" + (phase := "Surreal numbers and omnific integers") + (title := "Cauchy completeness of surreal common-tail quotients") + (statement := /-- + Let $T$ be a $u$-small nonempty family of nonzero Archimedean classes of + $\mathbf{No}_u$ with no least member in the magnitude order. The ordered + rational vector space obtained by quotienting $\mathbf{No}_u$ by the + common tail below $T$ is Cauchy complete in its additive uniformity. + -/) + (proof := /-- + By \ref{lem:surreal-common-tail-quotient-coinitial-scales}, a small copy + of $T$ indexes positive scales coinitial in the quotient, and rational + halving supplies the doubled-scale hypothesis of + \ref{lem:complete-of-coinitial-scales-and-cut-filling}. To fill a cut in + the quotient, \ref{lem:cut-filling-order-reflecting-surjection} lifts its + two small indexed families to surreal representatives. Strict order in a + convex quotient reflects to those representatives, so + \ref{thm:surreal-simplicity-small-cuts} fills the lifted cut inside + $\mathbf{No}_u$; the monotone quotient map sends the filler back between + the original families. The Cauchy-completeness criterion now applies. + -/)] +theorem completeSpace_rationalTailQuotient + (T : Set (FiniteArchimedeanClass Surreal.{u})) [Small.{u} T] [Nonempty T] + (hT : ∀ c ∈ T, ∃ d ∈ T, c < d) : CompleteSpace (RationalTailQuotient T) := by + let : Nonempty (Shrink.{u} T) := ⟨equivShrink T (Classical.arbitrary T)⟩ + obtain ⟨hpos, hcoinitial⟩ := rationalTailQuotientScale_pos_and_coinitial T hT + apply completeSpace_of_coinitial_of_exists_half (rationalTailQuotientScale T) + · exact hpos + · exact hcoinitial + · intro x hx + exact ⟨(2 : ℚ)⁻¹ • x, smul_pos (by norm_num) hx, by + rw [← add_smul] + norm_num⟩ + · exact FillsCuts.of_surjective (Submodule.Quotient.mk_surjective _) + (fun _ _ h ↦ ConvexQuotient.mk_le_mk h) + (fun _ _ h ↦ ConvexQuotient.lt_of_mk_lt_mk h) Surreal.fillsCuts + +end Surreal diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/RealArchimedeanStratum.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/RealArchimedeanStratum.lean new file mode 100644 index 0000000000..8a19ea2ac1 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/RealArchimedeanStratum.lean @@ -0,0 +1,183 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.RealModule +public import LeanPool.ConwayRefinement.CombinatorialGames.Surreal.Leading +public import Mathlib.Algebra.Order.Module.HahnEmbedding +public import Mathlib.Algebra.Order.Ring.StandardPart + +/-! +# The real Archimedean stratum of the surreal numbers + +The embedded real line complements the infinitesimal surreal numbers inside the finite surreal +numbers. This module packages that familiar standard-part decomposition as a distinguished +Archimedean stratum. All other strata may still be chosen arbitrarily. + +This choice makes splitting a surreal Hahn series supported on real exponents transparent: the +outer exponents remain real and every inner exponent is zero. +-/ + +public noncomputable section + +open FiniteArchimedeanClass + +namespace Surreal + +/-- The standard embedding of the reals into the surreal numbers as a linear map. -/ +def realLinearMap : ℝ →ₗ[ℝ] Surreal where + toFun r := (r : Surreal) + map_add' r s := by simp + map_smul' r s := by + change ((r * s : ℝ) : Surreal) = (r : Surreal) * (s : Surreal) + exact Real.toSurrealRingHom.map_mul r s + +/-- The embedded real line as a real subspace of the surreal numbers. -/ +def realStratum : Submodule ℝ Surreal := LinearMap.range realLinearMap + +/-- A surreal number belongs to the real stratum exactly when it is an embedded real number. -/ +theorem mem_realStratum_iff {x : Surreal} : + x ∈ realStratum ↔ ∃ r : ℝ, (r : Surreal) = x := + Iff.rfl + +/-- The ordered additive identification of the real line with the real surreal stratum. -/ +def realOrderAddMonoidIso : ℝ ≃+o realStratum := + { LinearEquiv.ofInjective realLinearMap (by + intro r s h + change (r : Surreal) = (s : Surreal) at h + exact_mod_cast h) with + map_le_map_iff' := by + intro r s + change (r : Surreal) ≤ (s : Surreal) ↔ r ≤ s + exact Real.toSurreal_le_iff } + +@[simp] +theorem coe_realOrderAddMonoidIso (r : ℝ) : + (realOrderAddMonoidIso r : Surreal) = r := + (rfl) + +/-- The finite Archimedean class of every nonzero real surreal number. -/ +def realFiniteClass : FiniteArchimedeanClass Surreal := + FiniteArchimedeanClass.mk (1 : Surreal) one_ne_zero + +@[simp] +theorem realFiniteClass_val : realFiniteClass.val = 0 := by + rw [realFiniteClass] + exact ArchimedeanClass.mk_one + +/-- The infinitesimal ball and the embedded real line meet only at zero. -/ +theorem disjoint_ball_realStratum : + Disjoint (ball ℝ realFiniteClass) realStratum := by + rw [Submodule.disjoint_def] + intro x hxBall hxReal + obtain ⟨r, rfl⟩ := hxReal + by_cases hr : r = 0 + · simp [hr] + have hrSurreal : (r : Surreal) ≠ 0 := by simp [hr] + have hlt := (mem_ball_iff ℝ).mp hxBall hrSurreal + exfalso + change (realFiniteClass : ArchimedeanClass Surreal) < + ArchimedeanClass.mk (r : Surreal) at hlt + rw [realFiniteClass_val, Surreal.mk_realCast hr] at hlt + exact (lt_irrefl _ hlt).elim + +/-- Every finite surreal number is uniquely a real number plus an infinitesimal. -/ +theorem ball_sup_realStratum_eq : + ball ℝ realFiniteClass ⊔ realStratum = closedBall ℝ realFiniteClass := by + apply le_antisymm + · rw [sup_le_iff] + refine ⟨(ball_lt_closedBall (K := ℝ)).le, ?_⟩ + rintro _ ⟨r, rfl⟩ + rw [mem_closedBall_iff] + intro hr + apply le_of_eq + apply Subtype.ext + rw [realFiniteClass_val] + change 0 = ArchimedeanClass.mk (r : Surreal) + exact (Surreal.mk_realCast (by simpa [realLinearMap] using hr)).symm + · intro x hx + by_cases hx0 : x = 0 + · simp [hx0] + have hxmk : 0 ≤ ArchimedeanClass.mk x := by + have h := (mem_closedBall_iff ℝ).mp hx hx0 + change (realFiniteClass : ArchimedeanClass Surreal) ≤ ArchimedeanClass.mk x at h + simpa only [realFiniteClass_val] using h + let r := ArchimedeanClass.stdPart x + have hresidual : x - (r : Surreal) ∈ ball ℝ realFiniteClass := by + rw [mem_ball_iff] + intro _hne + rw [← Subtype.coe_lt_coe, realFiniteClass_val] + exact ArchimedeanClass.mk_sub_stdPart_pos Real.toSurrealRingHom hxmk + have hreal : (r : Surreal) ∈ realStratum := ⟨r, rfl⟩ + rw [← sub_add_cancel x (r : Surreal)] + have hresidual' : x - (r : Surreal) ∈ ball ℝ realFiniteClass ⊔ realStratum := + (show ball ℝ realFiniteClass ≤ ball ℝ realFiniteClass ⊔ realStratum from le_sup_left) + hresidual + have hreal' : (r : Surreal) ∈ ball ℝ realFiniteClass ⊔ realStratum := + (show realStratum ≤ ball ℝ realFiniteClass ⊔ realStratum from le_sup_right) hreal + exact (ball ℝ realFiniteClass ⊔ realStratum).add_mem hresidual' hreal' + +/-- Replace the stratum at the real Archimedean class by the embedded real line. -/ +def archimedeanStrataWithReal + (u : HahnEmbedding.ArchimedeanStrata ℝ Surreal) : + HahnEmbedding.ArchimedeanStrata ℝ Surreal where + stratum c := if c = realFiniteClass then realStratum else u.stratum c + disjoint_ball_stratum c := by + classical + by_cases hc : c = realFiniteClass + · subst c + simpa using disjoint_ball_realStratum + · simp only [hc, ↓reduceIte] + exact u.disjoint_ball_stratum c + ball_sup_stratum_eq c := by + classical + by_cases hc : c = realFiniteClass + · subst c + simpa using ball_sup_realStratum_eq + · simp only [hc, ↓reduceIte] + exact u.ball_sup_stratum_eq c + +@[simp] +theorem archimedeanStrataWithReal_stratum_real + (u : HahnEmbedding.ArchimedeanStrata ℝ Surreal) : + (archimedeanStrataWithReal u).stratum realFiniteClass = realStratum := by + simp [archimedeanStrataWithReal] + +/-- The real coordinate on the distinguished stratum of `archimedeanStrataWithReal`. -/ +def archimedeanStrataWithRealOrderAddMonoidIso + (u : HahnEmbedding.ArchimedeanStrata ℝ Surreal) : + ℝ ≃+o (archimedeanStrataWithReal u).stratum realFiniteClass where + toFun r := ⟨(r : Surreal), by + rw [archimedeanStrataWithReal_stratum_real] + exact ⟨r, rfl⟩⟩ + invFun x := ArchimedeanClass.stdPart (x : Surreal) + left_inv r := ArchimedeanClass.stdPart_map_real Real.toSurrealRingHom r + right_inv x := by + apply Subtype.ext + have hx : (x : Surreal) ∈ realStratum := by + rw [← archimedeanStrataWithReal_stratum_real u] + exact x.2 + obtain ⟨r, hr⟩ := hx + change ((ArchimedeanClass.stdPart (x : Surreal) : ℝ) : Surreal) = x + rw [← hr] + change ((ArchimedeanClass.stdPart (r : Surreal) : ℝ) : Surreal) = (r : Surreal) + exact congrArg (fun s : ℝ ↦ (s : Surreal)) + (ArchimedeanClass.stdPart_map_real Real.toSurrealRingHom r) + map_add' r s := by + apply Subtype.ext + simp + map_le_map_iff' := by + intro r s + change (r : Surreal) ≤ (s : Surreal) ↔ r ≤ s + exact Real.toSurreal_le_iff + +@[simp] +theorem coe_archimedeanStrataWithRealOrderAddMonoidIso + (u : HahnEmbedding.ArchimedeanStrata ℝ Surreal) (r : ℝ) : + (archimedeanStrataWithRealOrderAddMonoidIso u r : Surreal) = r := + (rfl) + +end Surreal diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/RealModule.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/RealModule.lean new file mode 100644 index 0000000000..940779aa6f --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/RealModule.lean @@ -0,0 +1,46 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.CombinatorialGames.Surreal.Real +public import Mathlib.Algebra.Algebra.Defs +public import Mathlib.Algebra.Order.Module.Defs + +/-! +# Surreal numbers as an ordered real vector space + +The standard ordered embedding of `ℝ` into the surreal field makes `Surreal` an algebra over +`ℝ`. Its scalar multiplication is ordinary multiplication by the embedded real, so it respects +the orders in both arguments. + +These instances are natural candidates for CombinatorialGames. They live here rather than in the +pinned dependency so later surreal constructions can use real-linear Archimedean strata without +modifying the dependency revision. +-/ + +public noncomputable section + +namespace Surreal + +/-- The surreal field as an algebra over its standard embedded copy of `ℝ`. -/ +noncomputable instance instAlgebraReal : Algebra ℝ Surreal := + Real.toSurrealRingHom.toRingHom.toAlgebra + +/-- Real scalar multiplication on surreal numbers is ordered in both arguments. -/ +instance instIsOrderedModuleReal : IsOrderedModule ℝ Surreal where + smul_le_smul_of_nonneg_left r hr x y hxy := by + rw [Algebra.smul_def, Algebra.smul_def] + exact mul_le_mul_of_nonneg_left hxy (Real.toSurreal_nonneg_iff.mpr hr) + smul_le_smul_of_nonneg_right x hx r s hrs := by + rw [Algebra.smul_def, Algebra.smul_def] + exact mul_le_mul_of_nonneg_right (Real.toSurreal_le_iff.mpr hrs) hx + +/-- Real scalar multiplication is multiplication by the standard surreal embedding. -/ +theorem real_smul_def (r : ℝ) (x : Surreal) : + r • x = (r : Surreal) * x := + Algebra.smul_def r x + +end Surreal diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/Round.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/Round.lean new file mode 100644 index 0000000000..cfa0c9c130 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/Round.lean @@ -0,0 +1,240 @@ +/- +Copyright (c) 2026 Violeta Hernández Palacios. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Violeta Hernández Palacios +-/ +module + +public import LeanPool.ConwayRefinement.CombinatorialGames.Surreal.Real +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.HahnSeries.NormalFormSupport + +/-! +# Rounding surreal numbers by a positive radius + +For positive `r`, `x.round r` is the simplest surreal strictly between `x - r` and `x + r`. +For nonpositive `r` it is defined to be `x`. The addition and multiplication fixed-point lemmas +follow the option formulas for surreal arithmetic. This downstream module follows the rounding +infrastructure from CombinatorialGames PR #317. +-/ + +universe u + +public noncomputable section + +namespace Surreal + +open IGame Set + +/-- A surreal cut is represented by the game cut on chosen representatives of its options. -/ +theorem ofSets_eq_mk {s t : Set Surreal.{u}} [Small.{u} s] [Small.{u} t] + {H : ∀ x ∈ s, ∀ y ∈ t, x < y} : + !{s | t} = @mk !{out '' s | out '' t} (.mk (by + rw [moves_ofSets, moves_ofSets] + rintro _ ⟨x, hx, rfl⟩ _ ⟨y, hy, rfl⟩ + rw [← Surreal.mk_lt_mk, out_eq, out_eq] + exact H x hx y hy) (by simp)) := by + rw [← toGame_inj, toGame_ofSets, toGame_mk, ConwayGame.mk_ofSets] + simp_rw [image_image, gameMk_out] + +/-- A surreal cut is no more complex than any surreal strictly between all its options. -/ +theorem birthday_ofSets_le_of_mem {s t : Set Surreal.{u}} {z : Surreal} + [Small.{u} s] [Small.{u} t] {H : ∀ x ∈ s, ∀ y ∈ t, x < y} + (hL : ∀ x ∈ s, x < z) (hR : ∀ y ∈ t, z < y) : + !{s | t}.birthday ≤ z.birthday := by + rw [ofSets_eq_mk, ← out_eq z] + generalize_proofs + apply IGame.Fits.birthday_le + constructor + · intro x hx + let := IGame.Numeric.of_mem_moves hx + rw [IGame.Numeric.not_le] + simp only [moves_ofSets, Player.cases] at hx + obtain ⟨a, ha, rfl⟩ := hx + rw [← Surreal.mk_lt_mk, out_eq, out_eq] + exact hL a ha + · intro y hy + let := IGame.Numeric.of_mem_moves hy + rw [IGame.Numeric.not_le] + simp only [moves_ofSets, Player.cases] at hy + obtain ⟨a, ha, rfl⟩ := hy + rw [← Surreal.mk_lt_mk, out_eq, out_eq] + exact hR a ha + +/-- A distinct surreal strictly between all options of a cut has strictly larger birthday. -/ +theorem birthday_ofSets_lt_of_mem {s t : Set Surreal.{u}} {z : Surreal} + [Small.{u} s] [Small.{u} t] {H : ∀ x ∈ s, ∀ y ∈ t, x < y} + (hL : ∀ x ∈ s, x < z) (hR : ∀ y ∈ t, z < y) (h : !{s | t} ≠ z) : + !{s | t}.birthday < z.birthday := by + rw [ofSets_eq_mk, ← out_eq z] + generalize_proofs + apply IGame.Fits.birthday_lt + · constructor + · intro x hx + let := IGame.Numeric.of_mem_moves hx + rw [IGame.Numeric.not_le] + simp only [moves_ofSets, Player.cases] at hx + obtain ⟨a, ha, rfl⟩ := hx + rw [← Surreal.mk_lt_mk, out_eq, out_eq] + exact hL a ha + · intro y hy + let := IGame.Numeric.of_mem_moves hy + rw [IGame.Numeric.not_le] + simp only [moves_ofSets, Player.cases] at hy + obtain ⟨a, ha, rfl⟩ := hy + rw [← Surreal.mk_lt_mk, out_eq, out_eq] + exact hR a ha + · rwa [← mk_eq_mk, ← ofSets_eq_mk, out_eq, eq_comm] + +/-- The least-birthday surreal lying strictly between all options is the surreal cut. -/ +theorem ofSets_eq_of_forall_birthday_le {s t : Set Surreal.{u}} {z : Surreal} + [Small.{u} s] [Small.{u} t] {H : ∀ x ∈ s, ∀ y ∈ t, x < y} + (hL : ∀ x ∈ s, x < z) (hR : ∀ y ∈ t, z < y) + (h : ∀ w, (∀ x ∈ s, x < w) → (∀ y ∈ t, w < y) → + z.birthday ≤ w.birthday) : + !{s | t} = z := by + by_contra hz + exact (birthday_ofSets_lt_of_mem hL hR hz).not_ge <| + h _ (fun _ ↦ lt_ofSets_of_mem_left) (fun _ ↦ ofSets_lt_of_mem_right) + +private theorem sub_lt_add_of_pos (x : Surreal) {r : Surreal} (hr : 0 < r) : + x - r < x + r := by + simpa only [sub_eq_add_neg, add_comm] using add_lt_add_left (neg_lt_self hr) x + +/-- For positive `r`, the simplest surreal strictly between `x - r` and `x + r`; for nonpositive +`r`, the junk value `x`. -/ +def round (x r : Surreal) : Surreal := + if hr : 0 < r then !{{x - r} | {x + r}}' (by + rintro _ rfl _ rfl + exact sub_lt_add_of_pos x hr) else x + +theorem round_of_pos {x r : Surreal} (hr : 0 < r) : + x.round r = !{{x - r} | {x + r}}' (by + rintro _ rfl _ rfl + exact sub_lt_add_of_pos x hr) := + dite_eq_left hr + +theorem round_of_nonpos {x r : Surreal} (hr : r ≤ 0) : x.round r = x := + dite_eq_right hr.not_gt + +/-- The singleton rounding cut of a positive numeric game is numeric. -/ +theorem roundGameNumeric {x r : IGame} [x.Numeric] [r.Numeric] (hr : 0 < r) : + IGame.Numeric !{{x - r} | {x + r}} := + .mk (by + intro y hy z hz + simp only [IGame.leftMoves_ofSets, IGame.rightMoves_ofSets, + mem_singleton_iff] at hy hz + subst y + subst z + rw [← Surreal.mk_lt_mk] + simpa only [Surreal.mk_sub, Surreal.mk_add] using + sub_lt_add_of_pos (Surreal.mk x) (by + simpa only [Surreal.mk_zero] using + (Surreal.mk_lt_mk (x := (0 : IGame)) (y := r)).mpr hr)) (by + intro p y hy + cases p with + | left => + simp only [IGame.leftMoves_ofSets, mem_singleton_iff] at hy + subst y + infer_instance + | right => + simp only [IGame.rightMoves_ofSets, mem_singleton_iff] at hy + subst y + infer_instance) + +theorem round_mk_of_pos {x r : IGame} (hr : 0 < r) [x.Numeric] [r.Numeric] : + (mk x).round (mk r) = @mk !{{x - r} | {x + r}} + (roundGameNumeric hr) := by + rw [round_of_pos hr, mk_ofSets] + congr + · rw [range_singleton] + congr 1 + · rw [range_singleton] + congr 1 + +/-- The rounding cut is no more complex than any surreal strictly inside its defining interval. -/ +theorem birthday_round_le {x y r : Surreal} (h : y ∈ Ioo (x - r) (x + r)) : + (x.round r).birthday ≤ y.birthday := by + have hr : 0 < r := by + rw [← neg_lt_self_iff] + apply (add_lt_add_iff_left x).mp + simpa only [sub_eq_add_neg] using h.1.trans h.2 + cases h + rw [round_of_pos hr] + apply birthday_ofSets_le_of_mem <;> simpa + +/-- The simplest surreal in the open rounding interval is the rounding cut. -/ +theorem round_eq_of_forall_birthday_le {x y r : Surreal} + (h : y ∈ Ioo (x - r) (x + r)) + (hy : ∀ z, z ∈ Ioo (x - r) (x + r) → y.birthday ≤ z.birthday) : + x.round r = y := by + have hr : 0 < r := by + rw [← neg_lt_self_iff] + apply (add_lt_add_iff_left x).mp + simpa only [sub_eq_add_neg] using h.1.trans h.2 + cases h + rw [round_of_pos hr, ofSets_eq_of_forall_birthday_le] + · simpa + · simpa + · simpa using hy + +theorem round_of_zero_mem {x r : Surreal} (h : 0 ∈ Ioo (x - r) (x + r)) : x.round r = 0 := by + have hr : 0 < r := by + rw [← neg_lt_self_iff] + apply (add_lt_add_iff_left x).mp + simpa only [sub_eq_add_neg] using h.1.trans h.2 + cases x with | mk x + cases r with | mk r + have hr' : (0 : IGame) < r := by + rw [← Surreal.mk_lt_mk] + simpa only [Surreal.mk_zero] using hr + let : IGame.Numeric !{{x - r} | {x + r}} := + roundGameNumeric (x := x) (r := r) hr' + rw [← mk_zero, round_mk_of_pos hr, mk_eq_mk, ← fits_zero_iff_equiv] + simpa [Fits] + +@[simp] +theorem round_zero (r : Surreal) : round 0 r = 0 := by + obtain h | h := le_or_gt r 0 + · rw [round_of_nonpos h] + · apply round_of_zero_mem + simpa + +@[simp] +theorem round_neg {x r : Surreal} : (-x).round r = -x.round r := by + obtain h | h := le_or_gt r 0 + · simp_rw [round_of_nonpos h] + cases x with | mk x + cases r with | mk r + simp only [← mk_neg, round_mk_of_pos h, neg_ofSets, neg_singleton, + sub_eq_add_neg, neg_add, neg_neg] + +theorem round_add_of_eq {x y r : Surreal} (hx : x.round r = x) (hy : y.round r = y) : + (x + y).round r = x + y := by + obtain h | h := le_or_gt r 0 + · rw [round_of_nonpos h] + cases x with | mk x + cases y with | mk y + cases r with | mk r + conv_rhs => rw [← hx, ← hy] + simp only [← mk_add, round_mk_of_pos h] at * + generalize_proofs at hx hy + simp only [ofSets_add_ofSets, mk_ofSets, image_singleton, union_singleton, + range_singleton, range_insert] + dsimp + congr <;> rw [hx, hy] <;> grind + +theorem round_mul_of_eq {x y r : Surreal} (h : 0 < r) + (hx : x.round r = x) (hy : y.round r = y) : + (x * y).round (r * r) = x * y := by + have h' : 0 < r * r := mul_self_pos.2 h.ne' + cases x with | mk x + cases y with | mk y + cases r with | mk r + conv_rhs => rw [← hx, ← hy] + simp only [← mk_mul, round_mk_of_pos h, round_mk_of_pos h'] at * + generalize_proofs at hx hy + simp only [ofSets_mul_ofSets, mk_ofSets, mulOption, singleton_prod_singleton, + union_singleton, image_insert_eq, image_singleton, range_singleton, range_insert] + congr <;> dsimp <;> rw [hx, hy] <;> grind + +end Surreal diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/SmallDiscrete.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/SmallDiscrete.lean new file mode 100644 index 0000000000..60c87d173c --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/SmallDiscrete.lean @@ -0,0 +1,73 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.CombinatorialGames.Surreal.Basic +public import Mathlib.Logic.Small.Set + +/-! +# Small sets of surreals are discrete + +No small family of positive surreals reaches down to zero: the surreal born between zero and the +family is positive and below all of it (`exists_pos_lt_of_small`). Every small set of surreals is +therefore discrete — around any point sits an interval meeting the set only there +(`exists_Ioo_inter_subset_singleton_of_small`). + +This is why an analysis by limit points of a support has to be carried out over a small group of +exponents rather than over the surreals themselves. A surreal has a small support, so its support +has no limit points at all inside the surreals, and every rank computed there collapses. Over a +small exponent group the positive elements do have a small coinitial family, limit points exist, +and the analysis has content; the factorisations it produces are equations, and equations transfer +back along the embedding of exponents whatever the ranks do. +-/ + +universe u + +public noncomputable section + +namespace Surreal + +/-- **No small family of positive surreals is coinitial.** The surreal born from zero on the left +and the family on the right is positive and lies below every member. -/ +theorem exists_pos_lt_of_small {P : Set Surreal.{u}} [Small.{u} P] (hP : ∀ p ∈ P, 0 < p) : + ∃ q : Surreal.{u}, 0 < q ∧ ∀ p ∈ P, q < p := by + have hsep : ∀ x ∈ ({0} : Set Surreal.{u}), ∀ y ∈ P, x < y := by + rintro _ rfl y hy + exact hP y hy + refine ⟨!{({0} : Set Surreal.{u}) | P}, ?_, fun p hp ↦ ?_⟩ + · exact lt_ofSets_of_mem_left (H := hsep) rfl + · exact ofSets_lt_of_mem_right (H := hsep) hp + +/-- **A small set of surreals is discrete.** Around any surreal there is an interval meeting a +given small set only at that surreal, obtained from a positive surreal below all the distances +from it to the other members. -/ +theorem exists_Ioo_inter_subset_singleton_of_small {S : Set Surreal.{u}} [Small.{u} S] + (p : Surreal.{u}) : + ∃ a b : Surreal.{u}, a < p ∧ p < b ∧ Set.Ioo a b ∩ S ⊆ {p} := by + classical + set d : Surreal.{u} → Surreal.{u} := fun s ↦ max (s - p) (p - s) with hd + have hsub : (S \ {p} : Set Surreal.{u}) ⊆ S := Set.sdiff_subset + have : Small.{u} (S \ {p} : Set Surreal.{u}) := small_subset hsub + obtain ⟨q, hq, hlt⟩ := exists_pos_lt_of_small (P := d '' (S \ {p})) (by + rintro _ ⟨s, hs, rfl⟩ + rw [hd, lt_max_iff] + rcases lt_trichotomy s p with h | h | h + · exact Or.inr (sub_pos.mpr h) + · exact absurd h fun h' ↦ hs.2 (by simp [h']) + · exact Or.inl (sub_pos.mpr h)) + refine ⟨p - q, p + q, sub_lt_self p hq, lt_add_of_pos_right p hq, fun s hs ↦ ?_⟩ + by_contra hne + obtain ⟨h₁, h₂⟩ := hs.1 + have hclose : d s < q := by + rw [hd, max_lt_iff] + refine ⟨?_, ?_⟩ + · rw [sub_lt_iff_lt_add, add_comm] + exact h₂ + · rw [sub_lt_iff_lt_add, add_comm, ← sub_lt_iff_lt_add] + exact h₁ + exact absurd hclose (not_lt.mpr (hlt _ ⟨s, ⟨hs.2, hne⟩, rfl⟩).le) + +end Surreal diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/Tests.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/Tests.lean new file mode 100644 index 0000000000..a4e73be1c9 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/Tests.lean @@ -0,0 +1,12 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.Tests.ArchimedeanAssumptions +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.Tests.RealModule + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/Tests/ArchimedeanAssumptions.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/Tests/ArchimedeanAssumptions.lean new file mode 100644 index 0000000000..3bf88d9149 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/Tests/ArchimedeanAssumptions.lean @@ -0,0 +1,89 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.ArchimedeanAssumptions + +/-! +# API checks for LM24 assumptions `(A1)_σ` and `(A2)_σ` on surreal strata + +This separately compiled client consumes the arbitrary-stratum and fixed-strata forms without +unfolding the standard-part or cofinality constructions. It exercises both assumptions at a +nonzero class and at the zero class. +-/ + +public noncomputable section + +namespace Tests + +theorem surreal_stratum_orderAddMonoidIso_real + (u : HahnEmbedding.ArchimedeanStrata ℝ Surreal) + (c : FiniteArchimedeanClass Surreal) : + Nonempty (u.stratum c ≃+o ℝ) := + (LM24.assumptionA1AtFiniteClass_iff u c).mp + (Surreal.assumptionA1AtFiniteClass u c) + +theorem surreal_fixed_strata_assumptionA1_finite + (c : FiniteArchimedeanClass Surreal) : + LM24.AssumptionA1AtFiniteClass Surreal.archimedeanStrata c := + Surreal.assumptionA1AtFiniteClass Surreal.archimedeanStrata c + +theorem surreal_fixed_strata_assumptionA1_zero : + LM24.AssumptionA1 Surreal.archimedeanStrata (⊤ : ArchimedeanClass Surreal) := + Surreal.archimedeanStrata_assumptionA1 ⊤ + +universe u v + +theorem surreal_smallSupportCardinal_uncountable : + Cardinal.aleph0 < Surreal.smallSupportCardinal.{u} := + Surreal.aleph0_lt_smallSupportCardinal + +theorem surreal_smallSupportCardinal_regular : + Surreal.smallSupportCardinal.{u}.IsRegular := + Surreal.smallSupportCardinal_isRegular + +theorem surreal_assumptionA2_finite + {R : Type v} [Field R] (Z : Subring R) + (c : FiniteArchimedeanClass Surreal.{u}) : + LM24.AssumptionA2AtFiniteClass (K := ℝ) Surreal.smallSupportCardinal Z c := + Surreal.assumptionA2AtFiniteClass Z c + +theorem surreal_assumptionA2_zero + {R : Type v} [Field R] (Z : Subring R) : + LM24.AssumptionA2 Surreal.smallSupportCardinal Z + (⊤ : ArchimedeanClass Surreal.{u}) := + Surreal.assumptionA2 Z ⊤ + +/-- The Archimedean class of the surreal number `1`. -/ +def surrealUnitClass : FiniteArchimedeanClass Surreal := + FiniteArchimedeanClass.mk 1 one_ne_zero + +theorem surrealUnitClass_eq : + surrealUnitClass = FiniteArchimedeanClass.mk 1 one_ne_zero := (rfl) + +/-- The monomial `ω⁻¹` lies in the open ball below the class of `1`. -/ +def surrealPositiveInfinitesimal : + ↥(FiniteArchimedeanClass.ball ℝ surrealUnitClass) := + ⟨ω^ (-1 : Surreal), by + rw [FiniteArchimedeanClass.mem_ball_iff] + intro hzero + rw [surrealUnitClass_eq, FiniteArchimedeanClass.mk_lt_mk one_ne_zero hzero] + simpa using Surreal.archimedeanClassMk_wpow_strictAnti + (show (-1 : Surreal) < 0 by norm_num)⟩ + +theorem surrealPositiveInfinitesimal_pos : + 0 < surrealPositiveInfinitesimal := + Surreal.wpow_pos _ + +/-- The open surreal ball below the class of `1` is nondegenerate. This separates the cofinality +branch of `(A2)_σ` from its zero-inner-group branch. -/ +theorem surrealUnitClass_ball_nontrivial : + ¬Subsingleton ↥(FiniteArchimedeanClass.ball ℝ surrealUnitClass) := by + intro h + exact surrealPositiveInfinitesimal_pos.ne' + (Subsingleton.elim surrealPositiveInfinitesimal 0) + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/Tests/RealModule.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/Tests/RealModule.lean new file mode 100644 index 0000000000..c773ae426d --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/Tests/RealModule.lean @@ -0,0 +1,34 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.RealModule +public import LeanPool.ConwayRefinement.CombinatorialGames.Surreal.Pow + +/-! +# API checks for the ordered real module structure on surreal numbers + +The first check identifies scalar multiplication with the standard real embedding. The second +uses the genuinely non-real surreal `ω` and confirms that multiplication by a positive real is +strictly monotone on it. +-/ + +public noncomputable section + +namespace Tests + +theorem surreal_real_smul (r : ℝ) (x : Surreal) : + r • x = (r : Surreal) * x := + Surreal.real_smul_def r x + +theorem surreal_real_smul_omega_strictMono : + StrictMono (fun r : ℝ ↦ r • (ω^ (0 : Surreal))) := by + intro r s hrs + change r • (ω^ (0 : Surreal)) < s • (ω^ (0 : Surreal)) + rw [Surreal.real_smul_def, Surreal.real_smul_def] + exact mul_lt_mul_of_pos_right (Real.toSurreal_lt_iff.mpr hrs) (Surreal.wpow_pos 0) + +end Tests diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/ZFC.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/ZFC.lean new file mode 100644 index 0000000000..b12a5ed797 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/ZFC.lean @@ -0,0 +1,20 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.ZFC.Basic +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.ZFC.Cuts +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.ZFC.Identification +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.ZFC.NormalForm +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.ZFC.OmnificCodes +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.ZFC.OmnificInteger +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.ZFC.Properness +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.ZFC.Reduced +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.ZFC.Refinement +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.ZFC.Tests + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/ZFC/Basic.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/ZFC/Basic.lean new file mode 100644 index 0000000000..f83571aad8 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/ZFC/Basic.lean @@ -0,0 +1,216 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.ZFC.GameOperations +public import LeanPool.ConwayRefinement.CombinatorialGames.Surreal.Division +public import Mathlib.Algebra.Field.TransferInstance +public import Mathlib.Algebra.Order.Hom.Ring +public import Mathlib.Order.Lattice + +import Mathlib.Algebra.Order.Ring.InjSurj + +/-! +# Surreal values of ZFC game codes + +Numeric ZFC game codes are quotiented by Conway equivalence. The resulting ordered field is +identified with the surreal numbers, preserving the value of each set-coded Conway cut. +-/ + +universe u + +public noncomputable section + +namespace ZFSet + +/-- A set-coded game satisfying Conway's numeric condition. -/ +structure NumericGameCode where + /-- The underlying ZFC code for the numeric game. -/ + code : GameCode.{u} + numeric : code.IsNumeric + +namespace NumericGameCode + +/-- The numeric game obtained by decoding a numeric ZFC game code. -/ +def toIGame (x : NumericGameCode.{u}) : IGame.{u} := x.code.toIGame + +instance (x : NumericGameCode.{u}) : IGame.Numeric x.toIGame := by + exact (GameCode.isNumeric_iff x.code).1 x.numeric + +/-- The surreal value of a numeric ZFC game code. -/ +def toSurreal (x : NumericGameCode.{u}) : _root_.Surreal.{u} := _root_.Surreal.mk x.toIGame + +/-- Numerical equality of codes is Conway equivalence, not literal equality of ZFC sets. -/ +def setoid : Setoid NumericGameCode.{u} where + r x y := AntisymmRel (· ≤ ·) x.code y.code + iseqv := ⟨fun _ ↦ .rfl, fun h ↦ h.symm, fun h₁ h₂ ↦ h₁.trans h₂⟩ + +/-- Two numeric codes have the same surreal value exactly when they are Conway equivalent. -/ +theorem toSurreal_eq_iff (x y : NumericGameCode.{u}) : + x.toSurreal = y.toSurreal ↔ AntisymmRel (· ≤ ·) x.code y.code := by + rw [toSurreal, toSurreal, _root_.Surreal.mk_eq_mk] + rfl + +/-- Every surreal value has a numeric ZFC game code. -/ +theorem toSurreal_surjective : Function.Surjective (toSurreal.{u}) := by + intro x + let c : NumericGameCode.{u} := ⟨GameCode.ofIGame x.out, by + rw [GameCode.isNumeric_iff, GameCode.toIGame_ofIGame] + infer_instance⟩ + refine ⟨c, ?_⟩ + let : IGame.Numeric (GameCode.ofIGame x.out).toIGame := + (GameCode.isNumeric_iff _).1 c.numeric + change _root_.Surreal.mk (GameCode.ofIGame x.out).toIGame = x + simp only [GameCode.toIGame_ofIGame, _root_.Surreal.out_eq] + +end NumericGameCode + +/-- The class presentation of surreal values: numeric ZFC game codes modulo Conway equality. -/ +def Surreal : Type (u + 1) := Quotient NumericGameCode.setoid.{u} + +namespace Surreal + +/-- The value represented by a numeric ZFC game code. -/ +def mk (x : GameCode.{u}) (hx : x.IsNumeric) : Surreal.{u} := + Quotient.mk _ (NumericGameCode.mk x hx) + +/-- Evaluate a Conway-equivalence class of numeric ZFC codes in the surreal field. -/ +def toSurreal : Surreal.{u} → _root_.Surreal.{u} := + Quotient.lift NumericGameCode.toSurreal fun x y h ↦ + (NumericGameCode.toSurreal_eq_iff x y).2 h + +@[simp] +theorem toSurreal_mk (x : GameCode.{u}) (hx : x.IsNumeric) : + toSurreal (mk x hx) = @ _root_.Surreal.mk x.toIGame + ((GameCode.isNumeric_iff x).1 hx) := (rfl) + +/-- Equality of class values is precisely Conway equivalence of their numeric codes. -/ +theorem mk_eq_mk (x y : GameCode.{u}) (hx : x.IsNumeric) (hy : y.IsNumeric) : + mk x hx = mk y hy ↔ AntisymmRel (· ≤ ·) x y := Quotient.eq + +/-- Every class value is represented by a numeric ZFC game code. -/ +theorem exists_mk (x : Surreal.{u}) : ∃ (c : GameCode.{u}) (hc : c.IsNumeric), mk c hc = x := by + induction x using Quotient.inductionOn with + | h c => exact ⟨c.code, c.numeric, rfl⟩ + +/-- Evaluation distinguishes all surreal values represented by the code class. -/ +theorem toSurreal_injective : Function.Injective (toSurreal.{u}) := by + intro x y + induction x, y using Quotient.inductionOn₂ with + | h x y => + intro h + exact Quotient.sound ((NumericGameCode.toSurreal_eq_iff x y).1 h) + +/-- The class presentation includes every surreal number. -/ +theorem toSurreal_surjective : Function.Surjective (toSurreal.{u}) := by + intro x + obtain ⟨c, hc⟩ := NumericGameCode.toSurreal_surjective x + exact ⟨mk c.code c.numeric, hc⟩ + +/-- The exact correspondence between class-coded surreal values and the surreal field. -/ +def equiv : Surreal.{u} ≃ _root_.Surreal.{u} := + Equiv.ofBijective toSurreal ⟨toSurreal_injective, toSurreal_surjective⟩ + +@[simp] +theorem equiv_apply (x : Surreal.{u}) : equiv x = toSurreal x := (rfl) + +instance : Field Surreal.{u} := equiv.field + +instance : LinearOrder Surreal.{u} := by + classical + exact equiv.linearOrder + +/-- Evaluation preserves the field operations on class values. -/ +def ringEquiv : Surreal.{u} ≃+* _root_.Surreal.{u} := equiv.ringEquiv + +@[simp] +theorem ringEquiv_apply (x : Surreal.{u}) : ringEquiv x = toSurreal x := (rfl) + +@[simp] +theorem toSurreal_zero : toSurreal (0 : Surreal.{u}) = 0 := map_zero ringEquiv + +@[simp] +theorem toSurreal_one : toSurreal (1 : Surreal.{u}) = 1 := map_one ringEquiv + +@[simp] +theorem toSurreal_add (x y : Surreal.{u}) : + toSurreal (x + y) = toSurreal x + toSurreal y := map_add ringEquiv x y + +@[simp] +theorem toSurreal_mul (x y : Surreal.{u}) : + toSurreal (x * y) = toSurreal x * toSurreal y := map_mul ringEquiv x y + +@[simp] +theorem toSurreal_le_toSurreal (x y : Surreal.{u}) : + toSurreal x ≤ toSurreal y ↔ x ≤ y := (Iff.rfl) + +@[simp] +theorem toSurreal_lt_toSurreal (x y : Surreal.{u}) : + toSurreal x < toSurreal y ↔ x < y := (Iff.rfl) + +instance : IsStrictOrderedRing Surreal.{u} := + Function.Injective.isStrictOrderedRing toSurreal toSurreal_zero toSurreal_one + toSurreal_add toSurreal_mul (toSurreal_le_toSurreal _ _) (toSurreal_lt_toSurreal _ _) + +/-- Evaluation is an ordered ring equivalence between the two presentations of surreals. -/ +def orderRingEquiv : Surreal.{u} ≃+*o _root_.Surreal.{u} where + __ := ringEquiv + map_le_map_iff' := toSurreal_le_toSurreal _ _ + +@[simp] +theorem orderRingEquiv_apply (x : Surreal.{u}) : orderRingEquiv x = toSurreal x := (rfl) + +@[simp] +theorem toSurreal_neg (x : Surreal.{u}) : toSurreal (-x) = -toSurreal x := + map_neg ringEquiv x + +@[simp] +theorem toSurreal_sub (x y : Surreal.{u}) : + toSurreal (x - y) = toSurreal x - toSurreal y := map_sub ringEquiv x y + +@[simp] +theorem mk_zero : mk (0 : GameCode.{u}) GameCode.isNumeric_zero = 0 := by + apply toSurreal_injective + simp only [toSurreal_mk, GameCode.toIGame_zero, _root_.Surreal.mk_zero, toSurreal_zero] + +@[simp] +theorem mk_one : mk (1 : GameCode.{u}) GameCode.isNumeric_one = 1 := by + apply toSurreal_injective + simp only [toSurreal_mk, GameCode.toIGame_one, _root_.Surreal.mk_one, toSurreal_one] + +@[simp] +theorem mk_neg (x : GameCode.{u}) (hx : x.IsNumeric) : + mk (-x) hx.neg = -mk x hx := by + let : IGame.Numeric x.toIGame := (GameCode.isNumeric_iff _).1 hx + apply toSurreal_injective + simp only [toSurreal_mk, GameCode.toIGame_neg, _root_.Surreal.mk_neg, toSurreal_neg] + +@[simp] +theorem mk_add (x y : GameCode.{u}) (hx : x.IsNumeric) (hy : y.IsNumeric) : + mk (x + y) (hx.add hy) = mk x hx + mk y hy := by + let : IGame.Numeric x.toIGame := (GameCode.isNumeric_iff _).1 hx + let : IGame.Numeric y.toIGame := (GameCode.isNumeric_iff _).1 hy + apply toSurreal_injective + simp only [toSurreal_mk, GameCode.toIGame_add, _root_.Surreal.mk_add, toSurreal_add] + +@[simp] +theorem mk_sub (x y : GameCode.{u}) (hx : x.IsNumeric) (hy : y.IsNumeric) : + mk (x - y) (hx.sub hy) = mk x hx - mk y hy := by + let : IGame.Numeric x.toIGame := (GameCode.isNumeric_iff _).1 hx + let : IGame.Numeric y.toIGame := (GameCode.isNumeric_iff _).1 hy + apply toSurreal_injective + simp only [toSurreal_mk, GameCode.toIGame_sub, _root_.Surreal.mk_sub, toSurreal_sub] + +@[simp] +theorem mk_mul (x y : GameCode.{u}) (hx : x.IsNumeric) (hy : y.IsNumeric) : + mk (x * y) (hx.mul hy) = mk x hx * mk y hy := by + let : IGame.Numeric x.toIGame := (GameCode.isNumeric_iff _).1 hx + let : IGame.Numeric y.toIGame := (GameCode.isNumeric_iff _).1 hy + apply toSurreal_injective + simp only [toSurreal_mk, GameCode.toIGame_mul, _root_.Surreal.mk_mul, toSurreal_mul] + +end Surreal +end ZFSet diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/ZFC/Cuts.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/ZFC/Cuts.lean new file mode 100644 index 0000000000..582ea3bc50 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/ZFC/Cuts.lean @@ -0,0 +1,214 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.ZFC.Basic +public import LeanPool.ConwayRefinement.CombinatorialGames.Surreal.Basic +public import Mathlib.Logic.Small.Set + +import LeanPool.ConwayRefinement.CombinatorialGames.Game.Basic +import Mathlib.Data.Set.Image + +/-! +# Small Conway cuts of class-coded surreal values + +A small left set and a small right set of numeric ZFC game codes form a numeric code when every +left value is strictly below every right value. Its quotient value is the Conway cut of the option +values. Choosing numeric representatives therefore constructs cuts on arbitrary small sets of +class-coded surreal values, independently of the representative choices at the level of values. +-/ + +universe u + +public noncomputable section + +open Set + +namespace ZFSet.GameCode + +/-- Small separated sets of numeric codes form a numeric Conway cut. -/ +theorem isNumeric_ofSets (s t : Set GameCode.{u}) [Small.{u} s] [Small.{u} t] + (hs : ∀ x ∈ s, IsNumeric x) (ht : ∀ x ∈ t, IsNumeric x) + (h : ∀ x ∈ s, ∀ y ∈ t, x < y) : IsNumeric (ofSets s t) := by + rw [isNumeric_iff_options] + constructor + · simpa only [moves_ofSets_left, moves_ofSets_right] using h + · intro p x hx + cases p with + | left => exact hs x (by simpa only [moves_ofSets_left] using hx) + | right => exact ht x (by simpa only [moves_ofSets_right] using hx) + +end ZFSet.GameCode + +namespace ZFSet.Surreal + +/-- Quotienting numeric codes preserves their strict Conway comparison. -/ +@[simp] +theorem mk_lt_mk (x y : GameCode.{u}) (hx : x.IsNumeric) (hy : y.IsNumeric) : + mk x hx < mk y hy ↔ x < y := by + let : IGame.Numeric x.toIGame := (GameCode.isNumeric_iff x).1 hx + let : IGame.Numeric y.toIGame := (GameCode.isNumeric_iff y).1 hy + rw [← toSurreal_lt_toSurreal, toSurreal_mk, toSurreal_mk, + _root_.Surreal.mk_lt_mk, GameCode.toIGame_lt_toIGame] + +/-- Quotienting numeric codes preserves their non-strict Conway comparison. -/ +@[simp] +theorem mk_le_mk (x y : GameCode.{u}) (hx : x.IsNumeric) (hy : y.IsNumeric) : + mk x hx ≤ mk y hy ↔ x ≤ y := by + let : IGame.Numeric x.toIGame := (GameCode.isNumeric_iff x).1 hx + let : IGame.Numeric y.toIGame := (GameCode.isNumeric_iff y).1 hy + rw [← toSurreal_le_toSurreal, toSurreal_mk, toSurreal_mk, + _root_.Surreal.mk_le_mk, GameCode.toIGame_le_toIGame] + +/-- The class values represented by a set of numeric game codes. -/ +def codeValues (s : Set GameCode.{u}) (hs : ∀ x ∈ s, x.IsNumeric) : Set Surreal.{u} := + Set.range fun x : s ↦ mk x.1 (hs x.1 x.2) + +instance (s : Set GameCode.{u}) (hs : ∀ x ∈ s, x.IsNumeric) [Small.{u} s] : + Small.{u} (codeValues s hs) := + inferInstanceAs (Small.{u} (Set.range fun x : s ↦ mk x.1 (hs x.1 x.2))) + +@[simp] +theorem mem_codeValues {s : Set GameCode.{u}} {hs : ∀ x ∈ s, x.IsNumeric} + {x : Surreal.{u}} : x ∈ codeValues s hs ↔ ∃ y, ∃ hy : y ∈ s, mk y (hs y hy) = x := by + simp [codeValues] + +/-- Strict separation of numeric code sets descends to their class values. -/ +theorem codeValues_separated (s t : Set GameCode.{u}) + (hs : ∀ x ∈ s, x.IsNumeric) (ht : ∀ x ∈ t, x.IsNumeric) + (h : ∀ x ∈ s, ∀ y ∈ t, x < y) : + ∀ x ∈ codeValues s hs, ∀ y ∈ codeValues t ht, x < y := by + rintro _ ⟨⟨x, hx⟩, rfl⟩ _ ⟨⟨y, hy⟩, rfl⟩ + exact (mk_lt_mk x y (hs x hx) (ht y hy)).2 (h x hx y hy) + +/-- Evaluation preserves separation of left and right sets of class values. -/ +theorem toSurreal_separated (s t : Set Surreal.{u}) + (h : ∀ x ∈ s, ∀ y ∈ t, x < y) : + ∀ x ∈ toSurreal '' s, ∀ y ∈ toSurreal '' t, x < y := by + rintro _ ⟨x, hx, rfl⟩ _ ⟨y, hy, rfl⟩ + exact (toSurreal_lt_toSurreal x y).2 (h x hx y hy) + +/-- The quotient value of the raw Conway cut on separated numeric option codes. -/ +def ofCodeSets (s t : Set GameCode.{u}) [Small.{u} s] [Small.{u} t] + (hs : ∀ x ∈ s, x.IsNumeric) (ht : ∀ x ∈ t, x.IsNumeric) + (h : ∀ x ∈ s, ∀ y ∈ t, x < y) : Surreal.{u} := + mk (GameCode.ofSets s t) (GameCode.isNumeric_ofSets s t hs ht h) + +/-- The class code cut is represented by the literal ZFC cut on its option codes. -/ +theorem ofCodeSets_eq_mk (s t : Set GameCode.{u}) [Small.{u} s] [Small.{u} t] + (hs : ∀ x ∈ s, x.IsNumeric) (ht : ∀ x ∈ t, x.IsNumeric) + (h : ∀ x ∈ s, ∀ y ∈ t, x < y) : + ofCodeSets s t hs ht h = + mk (GameCode.ofSets s t) (GameCode.isNumeric_ofSets s t hs ht h) := (rfl) + +/-- Evaluating a raw numeric code cut gives the Conway cut of its evaluated option values. -/ +theorem toSurreal_ofCodeSets (s t : Set GameCode.{u}) [Small.{u} s] [Small.{u} t] + (hs : ∀ x ∈ s, x.IsNumeric) (ht : ∀ x ∈ t, x.IsNumeric) + (h : ∀ x ∈ s, ∀ y ∈ t, x < y) : + toSurreal (ofCodeSets s t hs ht h) = + !{toSurreal '' codeValues s hs | toSurreal '' codeValues t ht}' + (toSurreal_separated _ _ (codeValues_separated s t hs ht h)) := by + apply _root_.Surreal.toGame_inj.1 + rw [ofCodeSets_eq_mk, toSurreal_mk, _root_.Surreal.toGame_mk, + GameCode.toIGame_ofSets, ConwayGame.mk_ofSets, _root_.Surreal.toGame_ofSets] + congr 1 + simp only [codeValues, Set.image_image, ← Set.range_comp, Function.comp_def, + toSurreal_mk, _root_.Surreal.toGame_mk] + simp only [Set.image_eq_range] + +/-- Choose a numeric ZFC game code representing a class value. -/ +def out (x : Surreal.{u}) : GameCode.{u} := Classical.choose (exists_mk x) + +/-- The chosen representative of a class value is numeric. -/ +theorem isNumeric_out (x : Surreal.{u}) : x.out.IsNumeric := + Classical.choose (Classical.choose_spec (exists_mk x)) + +@[simp] +theorem out_eq (x : Surreal.{u}) : mk x.out (isNumeric_out x) = x := + Classical.choose_spec (Classical.choose_spec (exists_mk x)) + +@[simp] +theorem out_lt_out (x y : Surreal.{u}) : x.out < y.out ↔ x < y := by + rw [← mk_lt_mk x.out y.out (isNumeric_out x) (isNumeric_out y), out_eq, out_eq] + +/-- Every code in the image of a set under the representative selection is numeric. -/ +theorem out_image_numeric (s : Set Surreal.{u}) : ∀ x ∈ out '' s, x.IsNumeric := by + rintro _ ⟨x, _, rfl⟩ + exact isNumeric_out x + +/-- Selecting representatives preserves strict separation of two sets. -/ +theorem out_image_separated (s t : Set Surreal.{u}) + (h : ∀ x ∈ s, ∀ y ∈ t, x < y) : + ∀ x ∈ out '' s, ∀ y ∈ out '' t, x < y := by + rintro _ ⟨x, hx, rfl⟩ _ ⟨y, hy, rfl⟩ + exact (out_lt_out x y).2 (h x hx y hy) + +@[simp] +theorem codeValues_out_image (s : Set Surreal.{u}) : + codeValues (out '' s) (out_image_numeric s) = s := by + ext x + constructor + · intro hx + obtain ⟨c, hc, hcx⟩ := mem_codeValues.1 hx + obtain ⟨y, hy, rfl⟩ := hc + exact ((out_eq y).symm.trans hcx) ▸ hy + · intro hx + exact mem_codeValues.2 ⟨x.out, Set.mem_image_of_mem out hx, out_eq x⟩ + +/-- Construct a class-coded Conway cut using the raw cuts of chosen numeric representatives. -/ +instance : OfSets Surreal.{u} (fun st ↦ ∀ x ∈ st Player.left, + ∀ y ∈ st Player.right, x < y) where + ofSets st h _ _ := ofCodeSets (out '' st Player.left) (out '' st Player.right) + (out_image_numeric _) (out_image_numeric _) + (out_image_separated _ _ h) + +/-- The class cut is the quotient of the raw cut on chosen representative codes. -/ +theorem ofSets_eq_ofCodeSets (s t : Set Surreal.{u}) [Small.{u} s] [Small.{u} t] + (h : ∀ x ∈ s, ∀ y ∈ t, x < y) : + (!{s | t}'h : Surreal.{u}) = ofCodeSets (out '' s) (out '' t) + (out_image_numeric s) (out_image_numeric t) (out_image_separated s t h) := (rfl) + +/-- Evaluating an arbitrary small class cut gives the Conway cut of the evaluation images. -/ +@[simp] +theorem toSurreal_ofSets (s t : Set Surreal.{u}) [Small.{u} s] [Small.{u} t] + (h : ∀ x ∈ s, ∀ y ∈ t, x < y) : + toSurreal (!{s | t}'h) = + !{toSurreal '' s | toSurreal '' t}'(toSurreal_separated s t h) := by + rw [ofSets_eq_ofCodeSets, toSurreal_ofCodeSets] + simp only [codeValues_out_image] + +/-- A raw numeric code cut agrees with the class cut of its option values. -/ +theorem ofCodeSets_eq_ofSets (s t : Set GameCode.{u}) [Small.{u} s] [Small.{u} t] + (hs : ∀ x ∈ s, x.IsNumeric) (ht : ∀ x ∈ t, x.IsNumeric) + (h : ∀ x ∈ s, ∀ y ∈ t, x < y) : + ofCodeSets s t hs ht h = + !{codeValues s hs | codeValues t ht}'(codeValues_separated s t hs ht h) := by + apply toSurreal_injective + rw [toSurreal_ofCodeSets, toSurreal_ofSets] + +/-- Quotienting the literal ZFC cut is the same as cutting its quotient option values. -/ +theorem mk_ofSets (s t : Set GameCode.{u}) [Small.{u} s] [Small.{u} t] + (hs : ∀ x ∈ s, x.IsNumeric) (ht : ∀ x ∈ t, x.IsNumeric) + (h : ∀ x ∈ s, ∀ y ∈ t, x < y) : + mk (GameCode.ofSets s t) (GameCode.isNumeric_ofSets s t hs ht h) = + !{codeValues s hs | codeValues t ht}'(codeValues_separated s t hs ht h) := by + exact (ofCodeSets_eq_mk s t hs ht h).symm.trans (ofCodeSets_eq_ofSets s t hs ht h) + +/-- Every left option value is strictly below the class cut. -/ +theorem lt_ofSets_of_mem_left {s t : Set Surreal.{u}} [Small.{u} s] [Small.{u} t] + {h : ∀ x ∈ s, ∀ y ∈ t, x < y} {x : Surreal.{u}} (hx : x ∈ s) : + x < !{s | t}'h := by + rw [← toSurreal_lt_toSurreal, toSurreal_ofSets] + exact _root_.Surreal.lt_ofSets_of_mem_left (Set.mem_image_of_mem _ hx) + +/-- The class cut is strictly below every right option value. -/ +theorem ofSets_lt_of_mem_right {s t : Set Surreal.{u}} [Small.{u} s] [Small.{u} t] + {h : ∀ x ∈ s, ∀ y ∈ t, x < y} {x : Surreal.{u}} (hx : x ∈ t) : + !{s | t}'h < x := by + rw [← toSurreal_lt_toSurreal, toSurreal_ofSets] + exact _root_.Surreal.ofSets_lt_of_mem_right (Set.mem_image_of_mem _ hx) + +end ZFSet.Surreal diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/ZFC/Identification.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/ZFC/Identification.lean new file mode 100644 index 0000000000..9f76d45045 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/ZFC/Identification.lean @@ -0,0 +1,58 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.ZFC.OmnificInteger +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.ZFC.Cuts +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.ZFC.NormalForm +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.OmnificInteger.NormalForm + +/-! +# Native cut and normal-form criteria for the omnific-integer class + +The class predicate defined using raw ZFC game codes is exactly fixedness under the class-valued +singleton Conway cut. Equivalently, its canonical Conway normal form has nonnegative support and +an integral constant coefficient. These are the cut and normal-form presentations of Conway's +omnific integers recalled in LM24, Section 1.1; the exponent orientation here is unsigned. +-/ + +universe u + +public noncomputable section + +namespace ZFSet.Surreal + +/-- A class value is omnific exactly when it equals its singleton cut at distance one. -/ +theorem isOmnificInteger_iff_cut (x : Surreal.{u}) : + x.IsOmnificInteger ↔ x = !{{x - 1} | {x + 1}}'(by + simp only [Set.mem_singleton_iff] + rintro _ rfl _ rfl + simp [sub_eq_add_neg]) := by + rw [isOmnificInteger_iff, _root_.Surreal.isOmnificInteger_iff, + ← toSurreal_injective.eq_iff, toSurreal_ofSets, _root_.Surreal.omnificIntegerCut_eq] + simp only [Set.image_singleton, toSurreal_sub, toSurreal_add, toSurreal_one] + +/-- Nonnegativity of every Conway support exponent is unchanged by evaluation. -/ +theorem support_subset_Ici_zero_iff_toSurreal (x : Surreal.{u}) : + support x ⊆ Set.Ici 0 ↔ (toSurreal x).support ⊆ Set.Ici 0 := by + rw [← image_support, Set.image_subset_iff] + simp only [Set.subset_def, Set.mem_preimage, Set.mem_Ici, + ← toSurreal_zero, toSurreal_le_toSurreal] + +/-- A class value is omnific exactly when its Conway support is nonnegative and its constant +coefficient is an integer, with the coefficient on the left of the equality. -/ +theorem isOmnificInteger_iff_normalForm (x : Surreal.{u}) : + x.IsOmnificInteger ↔ + support x ⊆ Set.Ici 0 ∧ ∃ z : ℤ, coeff x 0 = (z : ℝ) := by + rw [isOmnificInteger_iff, _root_.Surreal.isOmnificInteger_iff_normalForm, + ← support_subset_Ici_zero_iff_toSurreal, coeff_eq_toSurreal, toSurreal_zero] + constructor + · rintro ⟨hs, z, hz⟩ + exact ⟨hs, z, hz.symm⟩ + · rintro ⟨hs, z, hz⟩ + exact ⟨hs, z, hz.symm⟩ + +end ZFSet.Surreal diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/ZFC/NormalForm.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/ZFC/NormalForm.lean new file mode 100644 index 0000000000..7035836a42 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/ZFC/NormalForm.lean @@ -0,0 +1,186 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.ZFC.Basic +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.HahnSeries.Transfer +public import Mathlib.Algebra.Order.Archimedean.Class +public import Mathlib.Data.Set.Finite.Basic +public import Mathlib.Logic.Small.Basic + +/-! +# Conway normal forms of class-coded surreal values + +The Conway-equivalence classes of numeric ZFC game codes use the existing Conway normal-form +order equivalence. Coefficients and support are indexed by class-coded surreal exponents; support +is set-sized. The finite-support-class and reducedness predicates are stated directly on these +exponents, with exact equivalences to the corresponding formulas in the surreal field. + +Reducedness uses the unsigned Conway-exponent orientation of LM24, Definition 8.2.6. It retains +the zero Archimedean class, which is relevant to constant coefficients other than zero and one. +-/ + +universe u + +public noncomputable section + +namespace ZFSet.Surreal + +/-- The canonical Conway normal-form chart of the class-coded surreal field. -/ +def toHahnSeriesOrderIso : Surreal.{u} ≃o SurrealHahnSeries.{u} := + orderRingEquiv.toOrderIso.trans _root_.Surreal.toHahnSeriesOrderIso + +@[simp] +theorem toHahnSeriesOrderIso_apply (x : Surreal.{u}) : + toHahnSeriesOrderIso x = (toSurreal x).toHahnSeries := by + simp [toHahnSeriesOrderIso] + +/-- The Conway normal form of a class-coded surreal value. -/ +def toHahnSeries (x : Surreal.{u}) : SurrealHahnSeries.{u} := toHahnSeriesOrderIso x + +@[simp] +theorem toHahnSeries_eq_toSurreal (x : Surreal.{u}) : + toHahnSeries x = (toSurreal x).toHahnSeries := toHahnSeriesOrderIso_apply x + +/-- A class value has a given normal form exactly when that series evaluates to its value. -/ +theorem toHahnSeries_eq_iff (x : Surreal.{u}) (s : SurrealHahnSeries.{u}) : + toHahnSeries x = s ↔ toSurreal x = s.toSurreal := by + constructor + · intro h + have hvalue := congrArg SurrealHahnSeries.toSurreal h + simpa only [toHahnSeries_eq_toSurreal, _root_.Surreal.toSurreal_toHahnSeries] using hvalue + · intro h + rw [toHahnSeries_eq_toSurreal, h, SurrealHahnSeries.toHahnSeries_toSurreal] + +/-- The coefficient at a class-coded Conway exponent. -/ +def coeff (x i : Surreal.{u}) : ℝ := (toHahnSeries x).coeff (toSurreal i) + +@[simp] +theorem coeff_eq_toSurreal (x i : Surreal.{u}) : + coeff x i = (toSurreal x).coeff (toSurreal i) := by + rw [coeff, toHahnSeries_eq_toSurreal, _root_.Surreal.coeff_toHahnSeries] + +/-- The Conway support, indexed by the class-coded surreal exponents. -/ +def support (x : Surreal.{u}) : Set Surreal.{u} := toSurreal ⁻¹' (toSurreal x).support + +/-- Membership in the class-coded support is detected by evaluating the exponent. -/ +theorem mem_support_iff_toSurreal (x i : Surreal.{u}) : + i ∈ support x ↔ toSurreal i ∈ (toSurreal x).support := (Iff.rfl) + +@[simp] +theorem mem_support_iff (x i : Surreal.{u}) : i ∈ support x ↔ coeff x i ≠ 0 := by + rw [mem_support_iff_toSurreal, _root_.Surreal.mem_support_iff, coeff_eq_toSurreal] + +/-- Evaluation maps the class-coded support onto exactly the Conway support. -/ +theorem image_support (x : Surreal.{u}) : + toSurreal '' support x = (toSurreal x).support := + Set.image_preimage_eq _ toSurreal_surjective + +/-- A normal form has only a set-sized collection of class-coded exponents. -/ +instance (x : Surreal.{u}) : Small.{u} (support x) := by + refine small_of_injective (f := fun i : support x ↦ + (⟨toSurreal i, (mem_support_iff_toSurreal x i).1 i.property⟩ : + (toSurreal x).support)) ?_ + intro i j h + apply Subtype.ext + exact toSurreal_injective (congrArg Subtype.val h) + +/-- Evaluation preserves the support intersection used by reducedness. -/ +theorem image_support_inter_support_sub_one (x : Surreal.{u}) : + toSurreal '' (support x ∩ support (x - 1)) = + (toSurreal x).support ∩ (toSurreal x - 1).support := by + rw [Set.image_inter toSurreal_injective, image_support, image_support, + toSurreal_sub, toSurreal_one] + +/-- Evaluation induces an order-preserving map on additive Archimedean classes. -/ +def archimedeanClassMap : + ArchimedeanClass Surreal.{u} →o ArchimedeanClass _root_.Surreal.{u} := + ArchimedeanClass.orderHom orderRingEquiv.toOrderRingHom.toOrderAddMonoidHom + +@[simp] +theorem archimedeanClassMap_mk (i : Surreal.{u}) : + archimedeanClassMap (ArchimedeanClass.mk i) = ArchimedeanClass.mk (toSurreal i) := by + simp [archimedeanClassMap] + +/-- Distinct class-coded Archimedean classes remain distinct after evaluation. -/ +theorem archimedeanClassMap_injective : Function.Injective (archimedeanClassMap.{u}) := + ArchimedeanClass.orderHom_injective orderRingEquiv.injective + +/-- Every surreal Archimedean class is represented by class-coded exponents. -/ +theorem archimedeanClassMap_surjective : Function.Surjective (archimedeanClassMap.{u}) := by + intro c + induction c using ArchimedeanClass.ind with + | mk i => + obtain ⟨j, rfl⟩ := toSurreal_surjective i + exact ⟨ArchimedeanClass.mk j, archimedeanClassMap_mk j⟩ + +/-- Evaluation identifies exactly the Archimedean classes met by the two supports. -/ +theorem image_supportArchimedeanClasses (x : Surreal.{u}) : + archimedeanClassMap '' (ArchimedeanClass.mk '' support x) = + ArchimedeanClass.mk '' (toSurreal x).support := by + calc + _ = (fun i ↦ ArchimedeanClass.mk (toSurreal i)) '' support x := by + simp only [Set.image_image, archimedeanClassMap_mk] + _ = ArchimedeanClass.mk '' (toSurreal '' support x) := by rw [Set.image_image] + _ = _ := by rw [image_support] + +/-- The Conway support meets only finitely many additive Archimedean classes. -/ +def HasFiniteSupportClasses (x : Surreal.{u}) : Prop := + (ArchimedeanClass.mk '' support x).Finite + +/-- The defining set formula for finite support-class number. -/ +theorem hasFiniteSupportClasses_iff (x : Surreal.{u}) : + HasFiniteSupportClasses x ↔ (ArchimedeanClass.mk '' support x).Finite := (Iff.rfl) + +/-- Finite support-class number is unchanged by evaluation in the surreal field. -/ +theorem hasFiniteSupportClasses_iff_toSurreal (x : Surreal.{u}) : + HasFiniteSupportClasses x ↔ (ArchimedeanClass.mk '' (toSurreal x).support).Finite := by + rw [hasFiniteSupportClasses_iff, ← image_supportArchimedeanClasses] + exact (Set.finite_image_iff archimedeanClassMap_injective.injOn).symm + +/-- LM24 reducedness: a nonzero class value whose support and support after subtracting one +intersect in a single Archimedean class, including the possible zero class. -/ +def IsReduced (x : Surreal.{u}) : Prop := + x ≠ 0 ∧ ∃ c : ArchimedeanClass Surreal.{u}, + support x ∩ support (x - 1) ⊆ {i | ArchimedeanClass.mk i = c} + +/-- The defining nonzero and support-intersection conditions for class-coded reducedness. -/ +theorem isReduced_iff (x : Surreal.{u}) : + IsReduced x ↔ x ≠ 0 ∧ ∃ c : ArchimedeanClass Surreal.{u}, + support x ∩ support (x - 1) ⊆ {i | ArchimedeanClass.mk i = c} := (Iff.rfl) + +/-- Class-coded reducedness is exactly the unsigned Conway-support formula after evaluation. -/ +theorem isReduced_iff_toSurreal (x : Surreal.{u}) : + IsReduced x ↔ toSurreal x ≠ 0 ∧ ∃ c : ArchimedeanClass _root_.Surreal.{u}, + (toSurreal x).support ∩ (toSurreal x - 1).support ⊆ + {i | ArchimedeanClass.mk i = c} := by + rw [isReduced_iff] + have hzero : x ≠ 0 ↔ toSurreal x ≠ 0 := by + constructor + · intro hx h + exact hx (toSurreal_injective (h.trans toSurreal_zero.symm)) + · intro hx h + exact hx (h ▸ toSurreal_zero) + constructor + · rintro ⟨hx, c, hc⟩ + refine ⟨hzero.mp hx, archimedeanClassMap c, ?_⟩ + intro i hi + rw [← image_support_inter_support_sub_one] at hi + obtain ⟨j, hj, rfl⟩ := hi + change ArchimedeanClass.mk (toSurreal j) = archimedeanClassMap c + rw [← archimedeanClassMap_mk] + exact congrArg archimedeanClassMap (hc hj) + · rintro ⟨hx, c, hc⟩ + obtain ⟨c, rfl⟩ := archimedeanClassMap_surjective c + refine ⟨hzero.mpr hx, c, ?_⟩ + intro i hi + apply archimedeanClassMap_injective + rw [archimedeanClassMap_mk] + apply hc + rw [← image_support_inter_support_sub_one] + exact ⟨i, hi, rfl⟩ + +end ZFSet.Surreal diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/ZFC/OmnificCodes.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/ZFC/OmnificCodes.lean new file mode 100644 index 0000000000..e3bf08b379 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/ZFC/OmnificCodes.lean @@ -0,0 +1,182 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.ZFC.OmnificInteger +public import Mathlib.Algebra.Group.Irreducible.Defs +public import Mathlib.Algebra.Prime.Defs + +import Mathlib.Algebra.Divisibility.Units + +/-! +# Factorisation predicates quantified over omnific ZFC codes + +All factors and divisibility witnesses below range over the full class of omnific game codes. +Products use Conway's recursive multiplication and equality is Conway equivalence. The +surjectivity of evaluation identifies these formulas with the usual ring predicates. +-/ + +universe u + +public noncomputable section + +namespace ZFSet + +/-- A ZFC game code satisfying Conway's omnific-integer equation. -/ +structure OmnificCode where + /-- The underlying ZFC game code satisfying the omnific-integer condition. -/ + code : GameCode.{u} + omnific : code.IsOmnificInteger + +namespace OmnificCode + +/-- The actual omnific integer represented by a set code. -/ +def value (x : OmnificCode.{u}) : _root_.Surreal.OmnificInteger.{u} := + ⟨Surreal.toSurreal (Surreal.mk x.code x.omnific.isNumeric), + _root_.Surreal.mem_omnificIntegers.2 + ((GameCode.isOmnificInteger_iff_toSurreal _ _).1 x.omnific)⟩ + +@[simp] +theorem coe_value (x : OmnificCode.{u}) : (x.value : _root_.Surreal.{u}) = + Surreal.toSurreal (Surreal.mk x.code x.omnific.isNumeric) := (rfl) + +/-- Every omnific integer, including every possible factor or divisor, has a set code. -/ +theorem value_surjective : Function.Surjective (value.{u}) := by + intro b + let c := GameCode.ofIGame (b : _root_.Surreal.{u}).out + have hc : c.IsNumeric := (GameCode.isNumeric_ofIGame _).2 inferInstance + have hval : Surreal.toSurreal (Surreal.mk c hc) = (b : _root_.Surreal.{u}) := by + rw [Surreal.toSurreal_mk] + simp only [c, GameCode.toIGame_ofIGame, _root_.Surreal.out_eq] + have hb : c.IsOmnificInteger := (GameCode.isOmnificInteger_iff_toSurreal c hc).2 (by + rw [hval] + exact _root_.Surreal.mem_omnificIntegers.1 b.2) + exact ⟨⟨c, hb⟩, Subtype.ext hval⟩ + +/-- Equality of omnific codes means Conway equivalence, not literal code equality. -/ +def Equivalent (x y : OmnificCode.{u}) : Prop := AntisymmRel (· ≤ ·) x.code y.code + +/-- The equality relation on codes agrees exactly with equality of their values. -/ +theorem equivalent_iff (x y : OmnificCode.{u}) : Equivalent x y ↔ x.value = y.value := by + rw [Subtype.ext_iff, coe_value, coe_value] + rw [Surreal.toSurreal_injective.eq_iff, Surreal.mk_eq_mk] + rfl + +instance : Zero OmnificCode.{u} := ⟨⟨0, + (GameCode.isOmnificInteger_iff_toSurreal 0 GameCode.isNumeric_zero).2 (by + rw [Surreal.mk_zero, Surreal.toSurreal_zero] + exact _root_.Surreal.isOmnificInteger_zero)⟩⟩ + +instance : One OmnificCode.{u} := ⟨⟨1, + (GameCode.isOmnificInteger_iff_toSurreal 1 GameCode.isNumeric_one).2 (by + rw [Surreal.mk_one, Surreal.toSurreal_one] + exact _root_.Surreal.isOmnificInteger_one)⟩⟩ + +instance : Mul OmnificCode.{u} := ⟨fun x y ↦ ⟨x.code * y.code, + (GameCode.isOmnificInteger_iff_toSurreal _ + (x.omnific.isNumeric.mul y.omnific.isNumeric)).2 (by + rw [Surreal.mk_mul _ _ x.omnific.isNumeric y.omnific.isNumeric, Surreal.toSurreal_mul] + exact ((GameCode.isOmnificInteger_iff_toSurreal _ _).1 x.omnific).mul + ((GameCode.isOmnificInteger_iff_toSurreal _ _).1 y.omnific))⟩⟩ + +@[simp] +theorem code_zero : (0 : OmnificCode.{u}).code = 0 := (rfl) + +@[simp] +theorem code_one : (1 : OmnificCode.{u}).code = 1 := (rfl) + +@[simp] +theorem code_mul (x y : OmnificCode.{u}) : (x * y).code = x.code * y.code := (rfl) + +@[simp] +theorem value_zero : (0 : OmnificCode.{u}).value = 0 := by + apply Subtype.ext + simp only [coe_value, code_zero, Surreal.mk_zero, Surreal.toSurreal_zero] + rfl + +@[simp] +theorem value_one : (1 : OmnificCode.{u}).value = 1 := by + apply Subtype.ext + simp only [coe_value, code_one, Surreal.mk_one, Surreal.toSurreal_one] + rfl + +@[simp] +theorem value_mul (x y : OmnificCode.{u}) : (x * y).value = x.value * y.value := by + apply Subtype.ext + change Surreal.toSurreal (Surreal.mk (x.code * y.code) + (x.omnific.isNumeric.mul y.omnific.isNumeric)) = + Surreal.toSurreal (Surreal.mk x.code x.omnific.isNumeric) * + Surreal.toSurreal (Surreal.mk y.code y.omnific.isNumeric) + rw [Surreal.mk_mul _ _ x.omnific.isNumeric y.omnific.isNumeric, Surreal.toSurreal_mul] + +/-- Divisibility with an omnific set-code witness and Conway equality. -/ +def Divides (x y : OmnificCode.{u}) : Prop := ∃ z, Equivalent y (x * z) + +/-- Units are codes with an omnific multiplicative inverse. -/ +def IsUnit (x : OmnificCode.{u}) : Prop := Divides x 1 + +/-- Irreducibility tested against every pair of omnific codes. -/ +def IsIrreducible (x : OmnificCode.{u}) : Prop := + ¬x.IsUnit ∧ ∀ a b, Equivalent x (a * b) → a.IsUnit ∨ b.IsUnit + +/-- Primality tested against every pair of omnific codes and every divisibility witness. -/ +def IsPrime (x : OmnificCode.{u}) : Prop := + ¬Equivalent x 0 ∧ ¬x.IsUnit ∧ + ∀ a b, Divides x (a * b) → Divides x a ∨ Divides x b + +/-- Code divisibility is exactly divisibility in the omnific-integer ring. -/ +theorem divides_iff (x y : OmnificCode.{u}) : Divides x y ↔ x.value ∣ y.value := by + constructor + · rintro ⟨z, hz⟩ + exact ⟨z.value, by simpa only [value_mul] using (equivalent_iff _ _).1 hz⟩ + · rintro ⟨z, hz⟩ + obtain ⟨c, rfl⟩ := value_surjective z + exact ⟨c, (equivalent_iff _ _).2 (by simpa only [value_mul] using hz)⟩ + +/-- Code units are exactly units in the omnific-integer ring. -/ +theorem isUnit_iff (x : OmnificCode.{u}) : x.IsUnit ↔ _root_.IsUnit x.value := by + rw [IsUnit, divides_iff, value_one, isUnit_iff_dvd_one] + +/-- Code irreducibility is the unrestricted ring-theoretic predicate. -/ +theorem isIrreducible_iff (x : OmnificCode.{u}) : + x.IsIrreducible ↔ Irreducible x.value := by + constructor + · rintro ⟨hu, h⟩ + refine ⟨fun hv ↦ hu ((isUnit_iff x).2 hv), ?_⟩ + intro a b hab + obtain ⟨ca, rfl⟩ := value_surjective a + obtain ⟨cb, rfl⟩ := value_surjective b + have hc := h ca cb ((equivalent_iff _ _).2 (by simpa only [value_mul] using hab)) + exact hc.imp (isUnit_iff _).1 (isUnit_iff _).1 + · intro h + refine ⟨fun hu ↦ h.not_isUnit ((isUnit_iff _).1 hu), ?_⟩ + intro a b hab + have hv : x.value = a.value * b.value := by + simpa only [value_mul] using (equivalent_iff _ _).1 hab + exact (h.isUnit_or_isUnit hv).imp (isUnit_iff _).2 (isUnit_iff _).2 + +/-- Code primality is the unrestricted ring-theoretic predicate. -/ +theorem isPrime_iff (x : OmnificCode.{u}) : x.IsPrime ↔ Prime x.value := by + constructor + · rintro ⟨hz, hu, h⟩ + refine ⟨fun hv ↦ hz ((equivalent_iff _ _).2 (by simpa only [value_zero] using hv)), + fun hv ↦ hu ((isUnit_iff _).2 hv), ?_⟩ + intro a b hab + obtain ⟨ca, rfl⟩ := value_surjective a + obtain ⟨cb, rfl⟩ := value_surjective b + have hc := h ca cb ((divides_iff _ _).2 (by simpa only [value_mul] using hab)) + exact hc.imp (divides_iff _ _).1 (divides_iff _ _).1 + · intro h + refine ⟨fun hz ↦ h.ne_zero (by + simpa only [value_zero] using (equivalent_iff _ _).1 hz), + fun hu ↦ h.not_isUnit ((isUnit_iff _).1 hu), ?_⟩ + intro a b hab + have hv : x.value ∣ a.value * b.value := by + simpa only [value_mul] using (divides_iff _ _).1 hab + exact (h.dvd_or_dvd hv).imp (divides_iff _ _).2 (divides_iff _ _).2 + +end OmnificCode +end ZFSet diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/ZFC/OmnificInteger.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/ZFC/OmnificInteger.lean new file mode 100644 index 0000000000..7b4ce6ec48 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/ZFC/OmnificInteger.lean @@ -0,0 +1,140 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.ZFC.Basic +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.OmnificInteger.Basic + +/-! +# The omnific-integer class + +An omnific code is numeric and Conway equivalent to the singleton cut `{x - 1 | x + 1}`. +The corresponding class values form a subring, identified exactly with the cut-defined omnific +integers. Equality here is equality of numeric values, not equality of their codes. +-/ + +universe u + +public noncomputable section + +namespace ZFSet +namespace GameCode + +/-- Conway's omnific-integer condition on a numeric set-coded game. -/ +def IsOmnificInteger (x : GameCode.{u}) : Prop := + x.IsNumeric ∧ AntisymmRel (· ≤ ·) x (ofSets {x - 1} {x + 1}) + +/-- An omnific game code is numeric. -/ +theorem IsOmnificInteger.isNumeric {x : GameCode.{u}} (h : x.IsOmnificInteger) : x.IsNumeric := + h.1 + +/-- The code condition is precisely fixedness under Conway's defining singleton cut. -/ +theorem isOmnificInteger_iff (x : GameCode.{u}) : x.IsOmnificInteger ↔ + x.IsNumeric ∧ AntisymmRel (· ≤ ·) x (ofSets {x - 1} {x + 1}) := (Iff.rfl) + +/-- The set-code condition agrees with the actual omnific-integer predicate. -/ +theorem isOmnificInteger_iff_toSurreal (x : GameCode.{u}) (hx : x.IsNumeric) : + x.IsOmnificInteger ↔ _root_.Surreal.IsOmnificInteger (Surreal.toSurreal (Surreal.mk x hx)) := by + let : IGame.Numeric x.toIGame := (isNumeric_iff _).1 hx + rw [isOmnificInteger_iff, and_iff_right hx, Surreal.toSurreal_mk, + _root_.Surreal.isOmnificInteger_mk_iff] + rw [← toIGame_equiv_toIGame] + simp only [toIGame_ofSets, Set.image_singleton, toIGame_sub, toIGame_add, toIGame_one] + +end GameCode + +namespace Surreal + +/-- A class value is omnific when a numeric code satisfies Conway's singleton-cut equation. -/ +def IsOmnificInteger (x : Surreal.{u}) : Prop := + ∃ (c : GameCode.{u}) (hc : c.IsNumeric), mk c hc = x ∧ c.IsOmnificInteger + +/-- The class and library predicates select exactly the same omnific integers. -/ +theorem isOmnificInteger_iff (x : Surreal.{u}) : + x.IsOmnificInteger ↔ _root_.Surreal.IsOmnificInteger x.toSurreal := by + constructor + · rintro ⟨c, hc, rfl, h⟩ + exact (GameCode.isOmnificInteger_iff_toSurreal c hc).1 h + · intro h + obtain ⟨c, hc, rfl⟩ := exists_mk x + exact ⟨c, hc, rfl, (GameCode.isOmnificInteger_iff_toSurreal c hc).2 h⟩ + +/-- The subring of class values satisfying Conway's omnific-integer equation. -/ +def omnificIntegers : Subring Surreal.{u} where + carrier := {x | x.IsOmnificInteger} + zero_mem' := (isOmnificInteger_iff _).2 (by + rw [toSurreal_zero] + exact _root_.Surreal.isOmnificInteger_zero) + one_mem' := (isOmnificInteger_iff _).2 (by + rw [toSurreal_one] + exact _root_.Surreal.isOmnificInteger_one) + add_mem' hx hy := (isOmnificInteger_iff _).2 (by + rw [toSurreal_add] + exact ((isOmnificInteger_iff _).1 hx).add ((isOmnificInteger_iff _).1 hy)) + neg_mem' hx := (isOmnificInteger_iff _).2 (by + rw [toSurreal_neg] + exact ((isOmnificInteger_iff _).1 hx).neg) + mul_mem' hx hy := (isOmnificInteger_iff _).2 (by + rw [toSurreal_mul] + exact ((isOmnificInteger_iff _).1 hx).mul ((isOmnificInteger_iff _).1 hy)) + +@[simp] +theorem mem_omnificIntegers (x : Surreal.{u}) : + x ∈ omnificIntegers ↔ x.IsOmnificInteger := (Iff.rfl) + +/-- The class presentation of Conway's omnific-integer ring. -/ +abbrev OmnificInteger := ↥(omnificIntegers : Subring Surreal.{u}) + +namespace OmnificInteger + +/-- Evaluate an omnific class value in the library's omnific-integer ring. -/ +def toOmnificInteger (x : OmnificInteger.{u}) : _root_.Surreal.OmnificInteger.{u} := + ⟨toSurreal x, _root_.Surreal.mem_omnificIntegers.2 + ((isOmnificInteger_iff _).1 ((mem_omnificIntegers _).1 x.2))⟩ + +@[simp] +theorem coe_toOmnificInteger (x : OmnificInteger.{u}) : + (toOmnificInteger x : _root_.Surreal.{u}) = toSurreal (x : Surreal.{u}) := (rfl) + +/-- An exact equivalence of omnific-integer rings, covering all elements and witnesses. -/ +def ringEquiv : OmnificInteger.{u} ≃+* _root_.Surreal.OmnificInteger.{u} where + toFun := toOmnificInteger + invFun x := ⟨equiv.symm x, (mem_omnificIntegers _).2 ((isOmnificInteger_iff _).2 (by + simpa only [← equiv_apply, equiv.apply_symm_apply] using + (_root_.Surreal.mem_omnificIntegers.1 x.2)))⟩ + left_inv x := by + apply Subtype.ext + change equiv.symm (toSurreal (x : Surreal.{u})) = (x : Surreal.{u}) + rw [← equiv_apply, equiv.symm_apply_apply] + right_inv x := by + apply Subtype.ext + change toSurreal (equiv.symm (x : _root_.Surreal.{u})) = (x : _root_.Surreal.{u}) + rw [← equiv_apply, equiv.apply_symm_apply] + map_add' x y := Subtype.ext (toSurreal_add x y) + map_mul' x y := Subtype.ext (toSurreal_mul x y) + +@[simp] +theorem ringEquiv_apply (x : OmnificInteger.{u}) : ringEquiv x = toOmnificInteger x := (rfl) + +@[simp] +theorem toSurreal_coe_ringEquiv_symm (x : _root_.Surreal.OmnificInteger.{u}) : + toSurreal (ringEquiv.symm x : Surreal.{u}) = (x : _root_.Surreal.{u}) := by + simpa only [ringEquiv_apply, coe_toOmnificInteger] using + congrArg (fun y : _root_.Surreal.OmnificInteger.{u} ↦ (y : _root_.Surreal.{u})) + (ringEquiv.apply_symm_apply x) + +/-- The omnific-ring comparison also preserves order. -/ +def orderRingEquiv : OmnificInteger.{u} ≃+*o _root_.Surreal.OmnificInteger.{u} where + __ := ringEquiv + map_le_map_iff' := toSurreal_le_toSurreal _ _ + +@[simp] +theorem orderRingEquiv_apply (x : OmnificInteger.{u}) : + orderRingEquiv x = toOmnificInteger x := (rfl) + +end OmnificInteger +end Surreal +end ZFSet diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/ZFC/Properness.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/ZFC/Properness.lean new file mode 100644 index 0000000000..655753d2c8 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/ZFC/Properness.lean @@ -0,0 +1,216 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.ZFC.OmnificCodes +public import Mathlib.SetTheory.ZFC.Class +public import Mathlib.Logic.Small.Defs + +import Mathlib.Logic.Small.Basic +import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.Cardinal +import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.OmnificInteger.Ordinal + +/-! +# Proper ZFC classes of numeric and omnific game codes + +The intrinsic predicates on ZFC sets select numeric game codes and omnific-integer game codes. +Neither class is represented by a ZFC set. This is witnessed by the size of the distinct values: +evaluation covers every surreal number or omnific integer, and neither value type is small in +the universe of option sets. The quotient presentations of those values are likewise not small. +-/ + +universe u + +public noncomputable section + +namespace Surreal.OmnificInteger + +/-- Omnific integers with option sets in universe `u` are not `u`-small. -/ +theorem not_small : ¬Small.{u} OmnificInteger.{u} := by + intro h + let : Small.{u} OmnificInteger.{u} := h + let f : Ordinal.{u} → OmnificInteger.{u} := fun o ↦ + ⟨(NatOrdinal.of o).toSurreal, NatOrdinal.toSurreal_mem_omnificIntegers (NatOrdinal.of o)⟩ + apply not_injective_of_ordinal f + intro a b hab + exact NatOrdinal.of.injective (NatOrdinal.toSurreal.injective (congrArg Subtype.val hab)) + +end Surreal.OmnificInteger + +namespace ZFSet + +/-- The ZFC class of sets satisfying the game-code grammar and Conway's numeric condition. -/ +def numericGameCodes : Class.{u} := + fun z ↦ ∃ h : IsGameCode z, (GameCode.mk z h).IsNumeric + +/-- Membership in the numeric-code class is the intrinsic numeric predicate on a game code. -/ +theorem numericGameCodes_iff (z : ZFSet.{u}) : + numericGameCodes z ↔ ∃ h : IsGameCode z, (GameCode.mk z h).IsNumeric := (Iff.rfl) + +/-- The ZFC class of game codes satisfying Conway's omnific-integer condition. -/ +def omnificGameCodes : Class.{u} := + fun z ↦ ∃ h : IsGameCode z, (GameCode.mk z h).IsOmnificInteger + +/-- Membership in the omnific-code class is Conway's omnific-integer predicate on a game code. -/ +theorem omnificGameCodes_iff (z : ZFSet.{u}) : + omnificGameCodes z ↔ ∃ h : IsGameCode z, (GameCode.mk z h).IsOmnificInteger := (Iff.rfl) + +/-- Every omnific code is numeric. -/ +theorem omnificGameCodes_subset_numericGameCodes : + omnificGameCodes.{u} ⊆ numericGameCodes.{u} := by + intro z hz + obtain ⟨h, hm⟩ := (omnificGameCodes_iff z).1 hz + exact (numericGameCodes_iff z).2 ⟨h, hm.isNumeric⟩ + +namespace GameCode + +/-- A game code belongs to the numeric class exactly when it is numeric. -/ +theorem mem_numericGameCodes (x : GameCode.{u}) : numericGameCodes (x : ZFSet.{u}) ↔ + x.IsNumeric := by + rw [numericGameCodes_iff] + constructor + · rintro ⟨h, hx⟩ + simpa only [mk_coe] using hx + · intro hx + exact ⟨x.isGameCode, by simpa only [mk_coe] using hx⟩ + +/-- A game code belongs to the omnific class exactly when it is an omnific code. -/ +theorem mem_omnificGameCodes (x : GameCode.{u}) : omnificGameCodes (x : ZFSet.{u}) ↔ + x.IsOmnificInteger := by + rw [omnificGameCodes_iff] + constructor + · rintro ⟨h, hx⟩ + simpa only [mk_coe] using hx + · intro hx + exact ⟨x.isGameCode, by simpa only [mk_coe] using hx⟩ + +end GameCode + +namespace NumericGameCode + +/-- Numeric codes with the same underlying game code are equal. -/ +@[ext] +theorem ext {x y : NumericGameCode.{u}} (h : x.code = y.code) : x = y := by + cases x + cases y + cases h + rfl + +/-- The underlying ZFC set distinguishes literal numeric codes. -/ +theorem coe_code_injective : + Function.Injective (fun x : NumericGameCode.{u} ↦ (x.code : ZFSet.{u})) := + fun _ _ h ↦ ext (GameCode.ext h) + +/-- Every typed numeric code belongs to the intrinsic ZFC class. -/ +theorem mem_numericGameCodes (x : NumericGameCode.{u}) : + numericGameCodes (x.code : ZFSet.{u}) := (GameCode.mem_numericGameCodes _).2 x.numeric + +/-- Numeric game codes are not small, because their values cover all surreal numbers. -/ +theorem not_small : ¬Small.{u} NumericGameCode.{u} := by + intro h + let : Small.{u} NumericGameCode.{u} := h + exact _root_.Surreal.not_small (small_of_surjective toSurreal_surjective) + +end NumericGameCode + +/-- The intrinsic numeric-code class consists exactly of the underlying sets of numeric codes. -/ +theorem numericGameCodes_iff_exists (z : ZFSet.{u}) : + numericGameCodes z ↔ ∃ c : NumericGameCode.{u}, (c.code : ZFSet.{u}) = z := by + constructor + · intro hz + obtain ⟨h, hn⟩ := (numericGameCodes_iff z).1 hz + exact ⟨⟨GameCode.mk z h, hn⟩, GameCode.coe_mk z h⟩ + · rintro ⟨c, rfl⟩ + exact c.mem_numericGameCodes + +namespace OmnificCode + +/-- Omnific codes with the same underlying game code are equal. -/ +@[ext] +theorem ext {x y : OmnificCode.{u}} (h : x.code = y.code) : x = y := by + cases x + cases y + cases h + rfl + +/-- The underlying ZFC set distinguishes literal omnific codes. -/ +theorem coe_code_injective : + Function.Injective (fun x : OmnificCode.{u} ↦ (x.code : ZFSet.{u})) := + fun _ _ h ↦ ext (GameCode.ext h) + +/-- Every typed omnific code belongs to the intrinsic ZFC class. -/ +theorem mem_omnificGameCodes (x : OmnificCode.{u}) : + omnificGameCodes (x.code : ZFSet.{u}) := (GameCode.mem_omnificGameCodes _).2 x.omnific + +/-- Omnific game codes are not small, because their values cover all omnific integers. -/ +theorem not_small : ¬Small.{u} OmnificCode.{u} := by + intro h + let : Small.{u} OmnificCode.{u} := h + exact _root_.Surreal.OmnificInteger.not_small (small_of_surjective value_surjective) + +end OmnificCode + +/-- The intrinsic omnific-code class consists exactly of the underlying sets of omnific codes. -/ +theorem omnificGameCodes_iff_exists (z : ZFSet.{u}) : + omnificGameCodes z ↔ ∃ c : OmnificCode.{u}, (c.code : ZFSet.{u}) = z := by + constructor + · intro hz + obtain ⟨h, hn⟩ := (omnificGameCodes_iff z).1 hz + exact ⟨⟨GameCode.mk z h, hn⟩, GameCode.coe_mk z h⟩ + · rintro ⟨c, rfl⟩ + exact c.mem_omnificGameCodes + +private theorem class_ne_ofSet_of_not_small {α : Type (u + 1)} (f : α → ZFSet.{u}) + (hf : Function.Injective f) (C : Class.{u}) (hC : ∀ x, C (f x)) + (hα : ¬Small.{u} α) (s : ZFSet.{u}) : C ≠ Class.ofSet s := by + intro h + let g : α → s := fun x ↦ ⟨f x, by + apply Class.coe_apply.1 + rw [← h] + exact hC x⟩ + exact hα (small_of_injective (f := g) (fun _ _ hab ↦ hf (congrArg Subtype.val hab))) + +/-- No ZFC set has exactly the numeric game codes as its elements. -/ +theorem numericGameCodes_ne_ofSet (s : ZFSet.{u}) : numericGameCodes ≠ Class.ofSet s := + class_ne_ofSet_of_not_small _ NumericGameCode.coe_code_injective _ + NumericGameCode.mem_numericGameCodes NumericGameCode.not_small s + +/-- Numeric game codes form a proper ZFC class, with a proper class of distinct surreal values. -/ +theorem numericGameCodes_notMem_univ : numericGameCodes ∉ Class.univ.{u} := by + intro h + obtain ⟨s, hs⟩ := Class.mem_univ.1 h + exact numericGameCodes_ne_ofSet s hs.symm + +/-- No ZFC set has exactly the omnific game codes as its elements. -/ +theorem omnificGameCodes_ne_ofSet (s : ZFSet.{u}) : omnificGameCodes ≠ Class.ofSet s := + class_ne_ofSet_of_not_small _ OmnificCode.coe_code_injective _ + OmnificCode.mem_omnificGameCodes OmnificCode.not_small s + +/-- Omnific codes form a proper ZFC class, with a proper class of distinct omnific values. -/ +theorem omnificGameCodes_notMem_univ : omnificGameCodes ∉ Class.univ.{u} := by + intro h + obtain ⟨s, hs⟩ := Class.mem_univ.1 h + exact omnificGameCodes_ne_ofSet s hs.symm + +namespace Surreal + +/-- Distinct Conway-equivalence classes of numeric ZFC game codes do not form a small type. -/ +theorem not_small : ¬Small.{u} Surreal.{u} := by + intro h + let : Small.{u} Surreal.{u} := h + exact _root_.Surreal.not_small (small_of_surjective toSurreal_surjective) + +namespace OmnificInteger + +/-- Distinct omnific values in the class presentation do not form a small type. -/ +theorem not_small : ¬Small.{u} OmnificInteger.{u} := by + intro h + let : Small.{u} OmnificInteger.{u} := h + exact _root_.Surreal.OmnificInteger.not_small (small_of_surjective ringEquiv.surjective) + +end OmnificInteger +end Surreal +end ZFSet diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/ZFC/Reduced.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/ZFC/Reduced.lean new file mode 100644 index 0000000000..56089ef7a7 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/ZFC/Reduced.lean @@ -0,0 +1,99 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.ZFC.NormalForm +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.ZFC.OmnificInteger +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Reduced +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.HahnSeries.CardinalIntegerPart +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.HahnSeries.SignedFull + +/-! +# Class-coded reducedness and the signed Hahn orientation + +The unsigned Conway support formula is equivalent to LM24 reducedness of the signed nonpositive +Hahn series. Negating an exponent preserves its additive Archimedean class, including the zero +class. Consequently the native reducedness predicate on class-coded omnific integers is exactly +the reducedness hypothesis used by the signed Hahn-series theorems. +-/ + +universe u + +public noncomputable section + +namespace Surreal.OmnificInteger + +/-- LM24 reducedness in the signed orientation is exactly the unsigned Conway-support formula. -/ +theorem isReduced_toSignedNonpositiveHahn_iff_support (x : OmnificInteger.{u}) : + HahnSeries.Nonpositive.IsReduced x.toSignedNonpositiveHahn ↔ + (x : Surreal.{u}) ≠ 0 ∧ ∃ c : ArchimedeanClass Surreal.{u}, + (x : Surreal.{u}).support ∩ ((x : Surreal.{u}) - 1).support ⊆ + {i | ArchimedeanClass.mk i = c} := by + have hsub : ((x.toSignedNonpositiveHahn - 1 : HahnSeries.Nonpositive Surreal ℝ) : + HahnSeries Surreal ℝ) = ((x : Surreal) - 1).toSignedFullHahnSeries := by + calc + _ = (x.toSignedNonpositiveHahn : HahnSeries Surreal ℝ) - 1 := rfl + _ = (x : Surreal).toSignedFullHahnSeries - 1 := by + rw [coe_toSignedNonpositiveHahn] + _ = ((x : Surreal) - 1).toSignedFullHahnSeries := by + rw [Surreal.toSignedFullHahnSeries_sub] + congr 1 + simpa using (Surreal.toSignedFullHahnSeries_realCast (1 : ℝ)).symm + have hmem (i : Surreal.{u}) : + i ∈ (x.toSignedNonpositiveHahn : HahnSeries Surreal ℝ).support ↔ + -i ∈ (x : Surreal).support := by + rw [coe_toSignedNonpositiveHahn, Surreal.mem_support_toSignedFullHahnSeries] + have hmemSub (i : Surreal.{u}) : + i ∈ ((x.toSignedNonpositiveHahn - 1 : HahnSeries.Nonpositive Surreal ℝ) : + HahnSeries Surreal ℝ).support ↔ -i ∈ ((x : Surreal) - 1).support := by + rw [hsub, Surreal.mem_support_toSignedFullHahnSeries] + have hzero : x.toSignedNonpositiveHahn ≠ 0 ↔ (x : Surreal) ≠ 0 := by + constructor + · intro hx h + apply hx + apply Subtype.ext + rw [coe_toSignedNonpositiveHahn, h, Surreal.toSignedFullHahnSeries_zero] + rfl + · intro hx h + apply hx + apply Surreal.toSignedFullHahnSeries_injective + have hraw := congrArg (fun q : HahnSeries.Nonpositive Surreal ℝ ↦ + (q : HahnSeries Surreal ℝ)) h + rw [coe_toSignedNonpositiveHahn] at hraw + exact hraw.trans Surreal.toSignedFullHahnSeries_zero.symm + constructor + · intro hx + obtain ⟨hx0, c, hc⟩ := hx.elim + refine ⟨hzero.mp hx0, c, ?_⟩ + intro i hi + have hsigned : -i ∈ (x.toSignedNonpositiveHahn : HahnSeries Surreal ℝ).support ∩ + ((x.toSignedNonpositiveHahn - 1 : HahnSeries.Nonpositive Surreal ℝ) : + HahnSeries Surreal ℝ).support := by + constructor + · exact (hmem (-i)).2 (by simpa only [neg_neg] using hi.1) + · exact (hmemSub (-i)).2 (by simpa only [neg_neg] using hi.2) + simpa only [Set.mem_ofPred_eq, ArchimedeanClass.mk_neg] using hc hsigned + · rintro ⟨hx0, c, hc⟩ + refine HahnSeries.Nonpositive.isReduced_of_support_inter_support_sub_one_subset + (hzero.mpr hx0) c ?_ + intro i hi + have hunsigned : -i ∈ (x : Surreal).support ∩ ((x : Surreal) - 1).support := + ⟨(hmem i).1 hi.1, (hmemSub i).1 hi.2⟩ + simpa only [Set.mem_ofPred_eq, ArchimedeanClass.mk_neg] using hc hunsigned + +end Surreal.OmnificInteger + +namespace ZFSet.Surreal.OmnificInteger + +/-- Native class-coded reducedness is equivalent to the signed Hahn reducedness hypothesis. -/ +theorem isReduced_iff_toSignedNonpositiveHahn (x : OmnificInteger.{u}) : + ZFSet.Surreal.IsReduced (x : ZFSet.Surreal.{u}) ↔ + HahnSeries.Nonpositive.IsReduced (ringEquiv x).toSignedNonpositiveHahn := by + rw [ZFSet.Surreal.isReduced_iff_toSurreal, + _root_.Surreal.OmnificInteger.isReduced_toSignedNonpositiveHahn_iff_support] + simp only [ringEquiv_apply, coe_toOmnificInteger] + +end ZFSet.Surreal.OmnificInteger diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/ZFC/Refinement.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/ZFC/Refinement.lean new file mode 100644 index 0000000000..310ad89958 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/ZFC/Refinement.lean @@ -0,0 +1,42 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.ZFC.OmnificInteger +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.OmnificInteger.RefinementConjecture +public import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Divisibility.Refinement + +import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Divisibility.PrimalPreimage + +/-! +# Conway's refinement conjecture for class-coded omnific integers + +The cut-preserving ring equivalence identifies the four-factor formula on class-coded omnific +values with the formula on the surreal omnific-integer ring. All four inputs and all four factors +are unrestricted, including zero. This states the class presentation of LM24, +Conjecture 1.1.1(2); it does not assert the conjecture. +-/ + +universe u + +public noncomputable section + +namespace ZFSet.Surreal.OmnificInteger + +/-- Conway's four-factor conjecture in the class presentation; no nonzero hypotheses are imposed. -/ +def RefinementConjecture : Prop := HasFourFactorRefinement OmnificInteger.{u} + +/-- The class formulation is equivalent to the existing refinement conjecture, not a weakening. -/ +theorem refinementConjecture_iff : RefinementConjecture.{u} ↔ ConwayRefinementConjecture.{u} := by + rw [RefinementConjecture, hasFourFactorRefinement_iff_forall_isPrimal] + have htarget : ConwayRefinementConjecture.{u} ↔ + ∀ b : _root_.Surreal.OmnificInteger.{u}, IsPrimal b := by + rw [conwayRefinementConjecture_def, ← hasFourFactorRefinement_def, + hasFourFactorRefinement_iff_forall_isPrimal] + rw [htarget, ringEquiv.surjective.forall] + exact forall_congr' fun x ↦ (RingEquiv.isPrimal_iff ringEquiv x).symm + +end ZFSet.Surreal.OmnificInteger diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/ZFC/Tests.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/ZFC/Tests.lean new file mode 100644 index 0000000000..dcc3e7e77f --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/ZFC/Tests.lean @@ -0,0 +1,14 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.ZFC.Tests.Cuts +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.ZFC.Tests.Identification +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.ZFC.Tests.NormalForm +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.ZFC.Tests.Properness + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/ZFC/Tests/Cuts.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/ZFC/Tests/Cuts.lean new file mode 100644 index 0000000000..d2c934a808 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/ZFC/Tests/Cuts.lean @@ -0,0 +1,103 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.ZFC.Cuts + +/-! +# Imported checks for class-coded Conway cuts + +The infinite left set of all natural numbers excludes a construction restricted to finite cuts +or collapsing a cut to one of its options. A nonempty right-option code representing zero separates +literal ZFC code equality from numerical Conway equivalence. The ordinary empty and singleton cuts +are interface smoke tests, not substitutes for these semantic separators. +-/ + +universe u + +public noncomputable section + +open Set + +namespace Tests.ClassSurrealCuts + +example (s t : Set ZFSet.Surreal.{u}) [Small.{u} s] [Small.{u} t] + (h : ∀ x ∈ s, ∀ y ∈ t, x < y) : + ZFSet.Surreal.toSurreal (!{s | t}'h) = + !{ZFSet.Surreal.toSurreal '' s | ZFSet.Surreal.toSurreal '' t}' + (ZFSet.Surreal.toSurreal_separated s t h) := + ZFSet.Surreal.toSurreal_ofSets s t h + +example (s t : Set ZFSet.GameCode.{u}) [Small.{u} s] [Small.{u} t] + (hs : ∀ x ∈ s, x.IsNumeric) (ht : ∀ x ∈ t, x.IsNumeric) + (h : ∀ x ∈ s, ∀ y ∈ t, x < y) : + ZFSet.Surreal.mk (ZFSet.GameCode.ofSets s t) + (ZFSet.GameCode.isNumeric_ofSets s t hs ht h) = + !{ZFSet.Surreal.codeValues s hs | ZFSet.Surreal.codeValues t ht}' + (ZFSet.Surreal.codeValues_separated s t hs ht h) := + ZFSet.Surreal.mk_ofSets s t hs ht h + +example (s t : Set ZFSet.GameCode.{u}) [Small.{u} s] [Small.{u} t] : + (ZFSet.GameCode.ofSets s t : ZFSet.{u}) = ZFSet.pair + (ZFSet.range fun x : s ↦ (x.1 : ZFSet.{u})) + (ZFSet.range fun x : t ↦ (x.1 : ZFSet.{u})) := + ZFSet.GameCode.coe_ofSets s t + +example : (!{∅ | ∅} : ZFSet.Surreal.{u}) = 0 := by + apply ZFSet.Surreal.toSurreal_injective + simp only [ZFSet.Surreal.toSurreal_ofSets, Set.image_empty, ZFSet.Surreal.toSurreal_zero] + rw [Surreal.zero_def] + congr 1 + funext p + cases p <;> rfl + +example : (!{{0} | ∅} : ZFSet.Surreal.{u}) = 1 := by + apply ZFSet.Surreal.toSurreal_injective + simpa only [ZFSet.Surreal.toSurreal_ofSets, Set.image_singleton, Set.image_empty, + ZFSet.Surreal.toSurreal_zero, ZFSet.Surreal.toSurreal_one] using Surreal.one_def.symm + +example : (0 : ZFSet.Surreal.{u}) < !{{0} | {1}} ∧ + (!{{0} | {1}} : ZFSet.Surreal.{u}) < 1 := by + exact ⟨ZFSet.Surreal.lt_ofSets_of_mem_left (Set.mem_singleton _), + ZFSet.Surreal.ofSets_lt_of_mem_right (Set.mem_singleton _)⟩ + +/-- A class cut whose left set is infinite, with every natural number as a left option. -/ +def aboveNaturals : ZFSet.Surreal.{u} := !{Set.range (fun n : ℕ ↦ (n : ZFSet.Surreal.{u})) | ∅} + +/-- The infinite cut is strictly above every natural number, not merely a finite option bound. -/ +theorem nat_lt_aboveNaturals (n : ℕ) : (n : ZFSet.Surreal.{u}) < aboveNaturals := + ZFSet.Surreal.lt_ofSets_of_mem_left (Set.mem_range_self n) + +/-- The infinite cut is not any finite natural number. -/ +theorem aboveNaturals_ne_nat (n : ℕ) : aboveNaturals.{u} ≠ (n : ZFSet.Surreal.{u}) := + (nat_lt_aboveNaturals n).ne' + +/-- The raw code with no left options and the single right option one. -/ +def noncanonicalZero : ZFSet.GameCode.{u} := ZFSet.GameCode.ofSets ∅ {1} + +/-- The noncanonical zero code is numeric because all its options are numeric and separated. -/ +theorem noncanonicalZero_numeric : noncanonicalZero.{u}.IsNumeric := + ZFSet.GameCode.isNumeric_ofSets ∅ {1} (by simp) (by simp) (by simp) + +/-- The noncanonical zero code is not literally the empty-option zero code. -/ +theorem noncanonicalZero_ne_zero : noncanonicalZero.{u} ≠ 0 := by + intro h + have hm := congrArg (fun x : ZFSet.GameCode.{u} ↦ x.toIGame.moves Player.right) h + simp [noncanonicalZero] at hm + +/-- The noncanonical zero code nevertheless represents precisely the zero class value. -/ +theorem mk_noncanonicalZero : + ZFSet.Surreal.mk noncanonicalZero.{u} noncanonicalZero_numeric = 0 := by + apply ZFSet.Surreal.toSurreal_injective + apply Surreal.toGame_inj.1 + rw [ZFSet.Surreal.toSurreal_mk, Surreal.toGame_mk, + ZFSet.Surreal.toSurreal_zero, Surreal.toGame_zero] + apply ConwayGame.mk_eq + rw [noncanonicalZero, ZFSet.GameCode.toIGame_ofSets] + apply IGame.fits_zero_iff_equiv.1 + simp [IGame.Fits] + +end Tests.ClassSurrealCuts diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/ZFC/Tests/Identification.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/ZFC/Tests/Identification.lean new file mode 100644 index 0000000000..fc61cf9aee --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/ZFC/Tests/Identification.lean @@ -0,0 +1,65 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.ZFC.Identification + +/-! +# Imported checks of native class omnific criteria + +The positive monomial `ω` excludes a definition restricted to ordinary integers. The reciprocal +of two excludes unrestricted constant coefficients, while a negative support exponent violates +the unsigned Conway-support criterion. The native singleton-cut and coefficient formulas below +exercise their exported interfaces without unfolding project definitions. +-/ + +universe u + +public noncomputable section + +namespace Tests.ClassOmnificIdentification + +example (x : ZFSet.Surreal.{u}) : + x.IsOmnificInteger ↔ x = !{{x - 1} | {x + 1}}'(by + simp only [Set.mem_singleton_iff] + rintro _ rfl _ rfl + simp [sub_eq_add_neg]) := + ZFSet.Surreal.isOmnificInteger_iff_cut x + +example (x : ZFSet.Surreal.{u}) : + x.IsOmnificInteger ↔ + ZFSet.Surreal.support x ⊆ Set.Ici 0 ∧ + ∃ z : ℤ, ZFSet.Surreal.coeff x 0 = (z : ℝ) := + ZFSet.Surreal.isOmnificInteger_iff_normalForm x + +/-- A negative Conway support exponent rules out the class omnific predicate. -/ +theorem not_isOmnificInteger_of_negative_support (x i : ZFSet.Surreal.{u}) + (hi : i ∈ ZFSet.Surreal.support x) (hneg : i < 0) : ¬ x.IsOmnificInteger := by + intro hx + exact (not_le_of_gt hneg) (((ZFSet.Surreal.isOmnificInteger_iff_normalForm x).1 hx).1 hi) + +/-- The class value with normal form `ω` is an omnific integer. -/ +theorem omega_isOmnificInteger : + (ZFSet.Surreal.equiv.symm (ω^ (1 : Surreal.{u}))).IsOmnificInteger := by + rw [ZFSet.Surreal.isOmnificInteger_iff_normalForm] + constructor + · rw [ZFSet.Surreal.support_subset_Ici_zero_iff_toSurreal, + ← ZFSet.Surreal.equiv_apply, ZFSet.Surreal.equiv.apply_symm_apply] + simp + · refine ⟨0, ?_⟩ + rw [ZFSet.Surreal.coeff_eq_toSurreal, ZFSet.Surreal.toSurreal_zero, + ← ZFSet.Surreal.equiv_apply, ZFSet.Surreal.equiv.apply_symm_apply] + simp + +/-- The class reciprocal of two is not an omnific integer. -/ +theorem two_inv_not_isOmnificInteger : + ¬ ((2 : ZFSet.Surreal.{u})⁻¹).IsOmnificInteger := by + rw [ZFSet.Surreal.isOmnificInteger_iff] + have h := Surreal.two_inv_not_mem_omnificIntegers.{u} + rw [Surreal.mem_omnificIntegers] at h + simpa only [← ZFSet.Surreal.ringEquiv_apply, map_inv₀, map_ofNat] using h + +end Tests.ClassOmnificIdentification diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/ZFC/Tests/NormalForm.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/ZFC/Tests/NormalForm.lean new file mode 100644 index 0000000000..3795a39003 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/ZFC/Tests/NormalForm.lean @@ -0,0 +1,152 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.ZFC.Reduced +public import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.HahnSeries.NormalFormAdd + +/-! +# A separate client of class-coded Conway normal forms + +The chart and support-class predicates are used only through their public interfaces. The +normal form `ω + 2` separates reducedness from the incorrect variant that deletes exponent zero: +both its constant and its nonconstant term survive subtraction of one, in distinct Archimedean +classes. Zero is also tested separately, since nonzeroness is part of reducedness. +-/ + +universe u + +public noncomputable section + +namespace ZFSet.Surreal.Tests.NormalForm + +/-- An arbitrary small Conway series is recovered from its class-coded value. -/ +theorem chart_inverse (s : SurrealHahnSeries.{u}) : + toHahnSeries (toHahnSeriesOrderIso.symm s) = s := by + rw [toHahnSeries_eq_toSurreal, ← toHahnSeriesOrderIso_apply, OrderIso.apply_symm_apply] + +/-- The native support remains set-sized after separately compiling the producer. -/ +theorem support_small (x : Surreal.{u}) : Small.{u} (support x) := inferInstance + +/-- Zero has finite support-class number. -/ +theorem zero_hasFiniteSupportClasses : HasFiniteSupportClasses (0 : Surreal.{u}) := by + rw [hasFiniteSupportClasses_iff_toSurreal, toSurreal_zero, _root_.Surreal.support_zero, + Set.image_empty] + exact Set.finite_empty + +/-- Zero is not reduced, even though its support intersection is empty. -/ +theorem zero_not_isReduced : ¬ IsReduced (0 : Surreal.{u}) := by + simp only [isReduced_iff, ne_eq, not_true_eq_false, false_and, not_false_eq_true] + +/-- The class-coded value with Conway normal form `ω + 2`. -/ +def twoTerm : Surreal.{u} := + toHahnSeriesOrderIso.symm (SurrealHahnSeries.single 1 1 + SurrealHahnSeries.single 0 2) + +/-- The two displayed terms are exactly the normal form of the class-coded example. -/ +theorem toHahnSeries_twoTerm : + toHahnSeries twoTerm.{u} = SurrealHahnSeries.single 1 1 + SurrealHahnSeries.single 0 2 := + chart_inverse _ + +private theorem coeff_eq_normalForm (x i : Surreal.{u}) : + coeff x i = (toHahnSeries x).coeff (toSurreal i) := by + rw [coeff_eq_toSurreal, toHahnSeries_eq_toSurreal, _root_.Surreal.coeff_toHahnSeries] + +/-- The example has a nonzero constant coefficient distinct from one. -/ +theorem twoTerm_coeff_zero : coeff twoTerm.{u} 0 = 2 := by + rw [coeff_eq_normalForm, toHahnSeries_twoTerm, toSurreal_zero] + simp [SurrealHahnSeries.coeff_add_apply, SurrealHahnSeries.coeff_single_of_ne] + +/-- The example also has a nonzero coefficient at the nonzero exponent one. -/ +theorem twoTerm_coeff_one : coeff twoTerm.{u} 1 = 1 := by + rw [coeff_eq_normalForm, toHahnSeries_twoTerm, toSurreal_one] + simp [SurrealHahnSeries.coeff_add_apply, SurrealHahnSeries.coeff_single_of_ne] + +/-- The example is nonzero, as witnessed by its coefficient at exponent one. -/ +theorem twoTerm_ne_zero : twoTerm.{u} ≠ 0 := by + intro h + have hcoeff := twoTerm_coeff_one.{u} + rw [h, coeff_eq_toSurreal, toSurreal_zero, _root_.Surreal.coeff_zero] at hcoeff + exact zero_ne_one hcoeff + +private theorem coeff_sub_one (x i : Surreal.{u}) : + coeff (x - 1) i = coeff x i - (Pi.single 0 1 : _root_.Surreal.{u} → ℝ) (toSurreal i) := by + rw [coeff_eq_toSurreal, toSurreal_sub, toSurreal_one, coeff_eq_toSurreal] + simp only [sub_eq_add_neg, + _root_.Surreal.coeff_add, _root_.Surreal.coeff_neg, _root_.Surreal.coeff_one, + Pi.add_apply, Pi.neg_apply] + +/-- Both relevant coefficients remain nonzero after subtraction of one. -/ +theorem twoTerm_sub_one_coeffs : + coeff (twoTerm.{u} - 1) 0 = 1 ∧ coeff (twoTerm.{u} - 1) 1 = 1 := by + rw [coeff_sub_one, coeff_sub_one, twoTerm_coeff_zero, twoTerm_coeff_one, + toSurreal_zero, toSurreal_one] + norm_num [Pi.single_apply] + +/-- Exactly the exponents zero and one occur in the example. -/ +theorem twoTerm_support : support twoTerm.{u} = {0, 1} := by + ext i + constructor + · intro hi + have h := (mem_support_iff_toSurreal twoTerm i).1 hi + rw [← _root_.Surreal.support_toHahnSeries, ← toHahnSeries_eq_toSurreal, + toHahnSeries_twoTerm] at h + rcases SurrealHahnSeries.support_add_subset h with h | h + · have he : toSurreal i = 1 := SurrealHahnSeries.support_single_subset h + have hi1 : i = 1 := toSurreal_injective (he.trans toSurreal_one.symm) + simp only [Set.mem_insert_iff, Set.mem_singleton_iff, hi1, or_true] + · have he : toSurreal i = 0 := SurrealHahnSeries.support_single_subset h + have hi0 : i = 0 := toSurreal_injective (he.trans toSurreal_zero.symm) + simp only [Set.mem_insert_iff, Set.mem_singleton_iff, hi0, true_or] + · simp only [Set.mem_insert_iff, Set.mem_singleton_iff] + rintro (rfl | rfl) + · rw [mem_support_iff, twoTerm_coeff_zero] + norm_num + · rw [mem_support_iff, twoTerm_coeff_one] + exact one_ne_zero + +/-- The nonconstant example meets finitely many support classes. -/ +theorem twoTerm_hasFiniteSupportClasses : HasFiniteSupportClasses twoTerm.{u} := by + rw [hasFiniteSupportClasses_iff, twoTerm_support] + exact ((Set.finite_singleton 1).insert 0).image _ + +/-- The zero exponent and nonzero exponent make the example genuinely non-reduced. -/ +theorem twoTerm_not_isReduced : ¬ IsReduced twoTerm.{u} := by + intro h + obtain ⟨_, c, hc⟩ := (isReduced_iff twoTerm).1 h + have hzero : ArchimedeanClass.mk (0 : Surreal.{u}) = c := hc ⟨by + rw [mem_support_iff, twoTerm_coeff_zero] + norm_num, by + rw [mem_support_iff, twoTerm_sub_one_coeffs.1] + exact one_ne_zero⟩ + have hone : ArchimedeanClass.mk (1 : Surreal.{u}) = c := hc ⟨by + rw [mem_support_iff, twoTerm_coeff_one] + exact one_ne_zero, by + rw [mem_support_iff, twoTerm_sub_one_coeffs.2] + exact one_ne_zero⟩ + have htop : ArchimedeanClass.mk (1 : Surreal.{u}) = ⊤ := + hone.trans (hzero.symm.trans ArchimedeanClass.mk_zero) + exact one_ne_zero (ArchimedeanClass.mk_eq_top_iff.mp htop) + +/-- Deleting zero would incorrectly satisfy a nonzero-only version of reducedness. -/ +theorem twoTerm_nonzero_intersection_one_class : + twoTerm.{u} ≠ 0 ∧ ∃ c : ArchimedeanClass Surreal.{u}, + (support twoTerm ∩ support (twoTerm - 1)) \ {0} ⊆ + {i | ArchimedeanClass.mk i = c} := by + refine ⟨twoTerm_ne_zero, ArchimedeanClass.mk 1, ?_⟩ + intro i hi + have hiSupport := hi.1.1 + rw [twoTerm_support, Set.mem_insert_iff, Set.mem_singleton_iff] at hiSupport + rcases hiSupport with rfl | rfl + · exact False.elim (hi.2 (Set.mem_singleton 0)) + · rfl + +/-- The signed bridge can be used after separately compiling its producer. -/ +theorem signed_reduced_iff (x : OmnificInteger.{u}) : + IsReduced (x : Surreal.{u}) ↔ + HahnSeries.Nonpositive.IsReduced (OmnificInteger.ringEquiv x).toSignedNonpositiveHahn := + OmnificInteger.isReduced_iff_toSignedNonpositiveHahn x + +end ZFSet.Surreal.Tests.NormalForm diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/ZFC/Tests/Properness.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/ZFC/Tests/Properness.lean new file mode 100644 index 0000000000..1e1b8b9b3a --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Surreal/ZFC/Tests/Properness.lean @@ -0,0 +1,91 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.ZFC.Properness +import LeanPool.ConwayRefinement.CombinatorialGames.Game.Special + +/-! +# Public checks for the intrinsic proper classes + +The empty ZFC set is not a game code, the star game is not numeric, and one half is numeric but +not omnific. These distinguish the intrinsic classes from all ZFC sets, all game codes, and the +incorrect identification of omnific and numeric codes. The remaining examples check coverage of +arbitrary values and properness through the exported interface. +-/ + +universe u + +noncomputable section + +open ZFSet + +example : numericGameCodes ((0 : GameCode.{u}) : ZFSet.{u}) := + (GameCode.mem_numericGameCodes _).2 GameCode.isNumeric_zero + +example : numericGameCodes ((1 : GameCode.{u}) : ZFSet.{u}) := + (GameCode.mem_numericGameCodes _).2 GameCode.isNumeric_one + +example : omnificGameCodes ((0 : GameCode.{u}) : ZFSet.{u}) := by + simpa only [OmnificCode.code_zero] using (0 : OmnificCode.{u}).mem_omnificGameCodes + +example : omnificGameCodes ((1 : GameCode.{u}) : ZFSet.{u}) := by + simpa only [OmnificCode.code_one] using (1 : OmnificCode.{u}).mem_omnificGameCodes + +example : ¬numericGameCodes (∅ : ZFSet.{u}) := by + intro h + obtain ⟨hg, _⟩ := (numericGameCodes_iff _).1 h + obtain ⟨L, R, heq, _, _⟩ := hg.exists_eq_pair + have hm : ({L} : ZFSet.{u}) ∈ (∅ : ZFSet.{u}) := by rw [heq]; simp [ZFSet.pair] + exact ZFSet.notMem_empty _ hm + +example : ¬numericGameCodes + ((GameCode.ofSets ({0} : Set GameCode.{u}) {0}) : ZFSet.{u}) := by + rw [GameCode.mem_numericGameCodes, GameCode.isNumeric_iff_options] + simp + +example : numericGameCodes ((GameCode.ofIGame (IGame.half : IGame.{u})) : ZFSet.{u}) := + (GameCode.mem_numericGameCodes _).2 ((GameCode.isNumeric_ofIGame _).2 inferInstance) + +example : ¬omnificGameCodes ((GameCode.ofIGame (IGame.half : IGame.{u})) : ZFSet.{u}) := by + intro h + have hn : (GameCode.ofIGame (IGame.half : IGame.{u})).IsNumeric := + (GameCode.isNumeric_ofIGame _).2 inferInstance + have ho := (GameCode.isOmnificInteger_iff_toSurreal _ hn).1 + ((GameCode.mem_omnificGameCodes _).1 h) + apply _root_.Surreal.two_inv_not_mem_omnificIntegers + apply _root_.Surreal.mem_omnificIntegers.2 + simpa only [ZFSet.Surreal.toSurreal_mk, GameCode.toIGame_ofIGame, IGame.mk_half] using ho + +example (x : _root_.Surreal.{u}) : + ∃ c : NumericGameCode.{u}, numericGameCodes (c.code : ZFSet.{u}) ∧ c.toSurreal = x := by + obtain ⟨c, hc⟩ := NumericGameCode.toSurreal_surjective x + exact ⟨c, c.mem_numericGameCodes, hc⟩ + +example (x : _root_.Surreal.OmnificInteger.{u}) : + ∃ c : OmnificCode.{u}, omnificGameCodes (c.code : ZFSet.{u}) ∧ c.value = x := by + obtain ⟨c, hc⟩ := OmnificCode.value_surjective x + exact ⟨c, c.mem_omnificGameCodes, hc⟩ + +example (z : ZFSet.{u}) (hz : numericGameCodes z) : + ∃ c : NumericGameCode.{u}, (c.code : ZFSet.{u}) = z := + (numericGameCodes_iff_exists z).1 hz + +example (z : ZFSet.{u}) (hz : omnificGameCodes z) : + ∃ c : OmnificCode.{u}, (c.code : ZFSet.{u}) = z := + (omnificGameCodes_iff_exists z).1 hz + +example (s : ZFSet.{u}) : numericGameCodes ≠ Class.ofSet s := numericGameCodes_ne_ofSet s + +example (s : ZFSet.{u}) : omnificGameCodes ≠ Class.ofSet s := omnificGameCodes_ne_ofSet s + +example : numericGameCodes ∉ Class.univ.{u} := numericGameCodes_notMem_univ + +example : omnificGameCodes ∉ Class.univ.{u} := omnificGameCodes_notMem_univ + +example : ¬Small.{u} ZFSet.Surreal.{u} := ZFSet.Surreal.not_small + +example : ¬Small.{u} ZFSet.Surreal.OmnificInteger.{u} := ZFSet.Surreal.OmnificInteger.not_small diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Tests.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Tests.lean new file mode 100644 index 0000000000..04b4ffec62 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Tests.lean @@ -0,0 +1,12 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Tests.SourceIndex +public import LeanPool.ConwayRefinement.ConwayRefinement.Tests.UpstreamReuse + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Tests/SourceIndex.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Tests/SourceIndex.lean new file mode 100644 index 0000000000..1f815736ca --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Tests/SourceIndex.lean @@ -0,0 +1,1444 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + + +import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Divisibility.PrimalPreimage +import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.AssociatedGradedValuation +import LeanPool.ConwayRefinement.ConwayRefinement.Algebra.Valuation.ResidueMathlib +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Tests.AlmostIrreducible +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Tests.AlmostIrreducibleFactorization +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Tests.GermLikeFactorization +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Tests.FiniteSupportGCD +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Tests.InfiniteSupportFactorization +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Tests.Multiplicativity +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Tests.NormalizedHPart +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Tests.NormalizedHPartMultiplicativity +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Tests.CardinalProposition922 +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Tests.FiniteClassReduction +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.Tests.Reduced +import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.Tests.ArchimedeanAssumptions +import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.HahnSeries.Tests.CardinalIntegerPart +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Tests.OrdinalValueSubmultiplicative +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Tests.CriticalPoint +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.Irreducibility +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OneRow +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Tests.DegreeTwo.TranslatedTruncationSpan +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.DegreeTwo.Factorization +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Tests.DegreeTwo.FactorizationClassification +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Tests.DegreeTwo.TranslatedSpanFactorization +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.DegreeTwo.DegreeTwoExample +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Tests.SectionSixFour +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.Tests.SeriesMaximalFiniteSupportDivisor +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Degree.Tests.SupportSupremumMultiplicativity +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.OrderTypeMultiplicativity +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.OrdinalValue.PrincipalSubringTensor +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.GradedDivisibility +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Factorization.NormalizedHPartSeries +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.FiniteSupportGCDProof +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.FiniteSupportUnit +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.PrincipalAddition +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Degree.PrincipalMultiplicativity +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.IntegerPart.IrreducibilityTransfer +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Degree.SupportSupremumMultiplicativity +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.SourceStatements +import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.OmnificInteger.RefinementConjecture +import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.HahnSeries.DegreeTransfer +import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.OmnificInteger.NormalForm +import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.ZFC.Identification +import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.ZFC.Properness +import LeanPool.ConwayRefinement.ConwayRefinement.Surreal.ZFC.Refinement + +/-! +# Compiled signatures of the source results + +Exact type ascriptions for the published results used in the proof and for the structures on which +they rest. A change in hypotheses, quantifier order, endpoints, or ordinal operations fails +elaboration here. Semantic boundary examples distinguish the intended definitions from nearby +incorrect ones. + +The refinement theorem has two isolated statements. `ConwayRefinement/Standalone/Mathlib/` fixes +its Hahn-series form against Mathlib alone, while +`ConwayRefinement/Standalone/CombinatorialGames/` fixes its concrete omnific-integer form against +Mathlib and CombinatorialGames alone. + +Anonymous examples retain every checked signature without adding a named mathematical API. +-/ + +noncomputable section + +universe u v + +open scoped DirectSum HahnSeries NatOrdinal Topology + +section + +section ExactSignatures + +/- LM24's unsigned normal-form criterion on the class presentation of Conway cuts. -/ +example := (@ZFSet.Surreal.isOmnificInteger_iff_normalForm : + ∀ x : ZFSet.Surreal.{u}, x.IsOmnificInteger ↔ + ZFSet.Surreal.support x ⊆ Set.Ici 0 ∧ + ∃ z : ℤ, ZFSet.Surreal.coeff x 0 = (z : ℝ)) + +/- Every possible omnific factor or divisibility witness has a code. -/ +example := (@ZFSet.OmnificCode.value_surjective : + Function.Surjective (ZFSet.OmnificCode.value.{u})) + +/- Properness of the code class and of its distinct numerical values. -/ +example := (@ZFSet.omnificGameCodes_ne_ofSet : + ∀ s : ZFSet.{u}, ZFSet.omnificGameCodes ≠ Class.ofSet s) +example := (@ZFSet.Surreal.OmnificInteger.not_small : + ¬Small.{u} ZFSet.Surreal.OmnificInteger.{u}) + +/- The class comparison preserves the complete refinement conjecture, not a restricted case. -/ +example := (@ZFSet.Surreal.OmnificInteger.refinementConjecture_iff : + ZFSet.Surreal.OmnificInteger.RefinementConjecture.{u} ↔ ConwayRefinementConjecture.{u}) + +/- LM17, Definition 4.1: the two support-order alternatives in the germ-like predicate. -/ +example := (@LM17.IsGermLike.elim : + ∀ {K : Type u} [Field K] {a : Berarducci.Series K}, LM17.IsGermLike a → + (a : K⟦ℝ⟧).supportOrderType = (Berarducci.ordinalValue a).val ∨ + (1 < Berarducci.ordinalValue a ∧ + (a : K⟦ℝ⟧).supportOrderType = (Berarducci.ordinalValue a).val + 1)) + +/- LM17, Theorem 4.8: every nonzero germ-like series factors into irreducibles. -/ +example := (@LM17.IsGermLike.exists_factorization : + ∀ {K : Type u} [Field K] [CharZero K] {a : Berarducci.Series K}, + LM17.IsGermLike a → a ≠ 0 → + ∃ f : Multiset (Berarducci.Series K), + (∀ b ∈ f, Irreducible b) ∧ Associated f.prod a) + +/- The degree-two-plus-one example exercises the second, nondegenerate germ-like branch. -/ +example := (Tests.LM17.degreeTwoWithConstant_isGermLike (K := ℚ) : + LM17.IsGermLike (PommersheimShahriari.DegreeTwoExample.degreeTwoWithConstant (K := ℚ))) + +section ResidueStructures + +variable {R : Type u} {M : Type v} [CommRing R] [AddCommMonoid M] + [LinearOrder M] [IsOrderedCancelAddMonoid M] + (ν : MaxAddDegree R M) (m : M) + +example : CommRing ν.ResidueRing := inferInstance + +example : Module ν.ResidueRing (ν.Component m) := inferInstance + +end ResidueStructures + +/- LM24, Fact 2.5.2: units and pairwise gcds in the nonpositive finite-support ring. -/ +example := (@HahnSeries.Nonpositive.isUnit_finiteSupport_iff_exists_scalar : + ∀ {G : Type u} {K : Type v} [LinearOrder G] [AddCommGroup G] + [IsOrderedAddMonoid G] [Field K] + (p : (HahnSeries.Nonpositive.finiteSupportSubring : + Subring (HahnSeries.Nonpositive G K))), + IsUnit p ↔ + ∃ k : K, k ≠ 0 ∧ + p = HahnSeries.Nonpositive.finiteSupportScalarHom (G := G) k) + +example := (@HahnSeries.Nonpositive.finiteSupport_pairwise_gcd_exists : + ∀ {G : Type u} {K : Type v} [LinearOrder G] [AddCommGroup G] + [IsOrderedAddMonoid G] [Field K] + (p q : (HahnSeries.Nonpositive.finiteSupportSubring : + Subring (HahnSeries.Nonpositive G K))), + ∃ d : (HahnSeries.Nonpositive.finiteSupportSubring : + Subring (HahnSeries.Nonpositive G K)), + ∀ e : (HahnSeries.Nonpositive.finiteSupportSubring : + Subring (HahnSeries.Nonpositive G K)), + e ∣ p ∧ e ∣ q ↔ e ∣ d) + +/- The same underlying `t⁻¹` distinguishes the nonpositive ring from the full group ring. -/ +example := (Tests.nonpositiveNegativeMonomial_not_isUnit : + ¬ IsUnit Tests.nonpositiveNegativeMonomial) + +example := (Tests.fullNegativeMonomial_isUnit : + IsUnit Tests.fullNegativeMonomial) + +/- The zero-boundary gcd certificate retains both association and the defining orientation. -/ +example := (Tests.finiteSupportGCD_zero_left : + ∃ d : Tests.IntegerNonpositiveFiniteSupportRing, + (d ∣ Tests.nonpositiveNegativeMonomial ∧ + Tests.nonpositiveNegativeMonomial ∣ d) ∧ + ∀ e : Tests.IntegerNonpositiveFiniteSupportRing, + e ∣ 0 ∧ e ∣ Tests.nonpositiveNegativeMonomial ↔ e ∣ d) + +example := (@MaxAddDegree.rvRel_iff : + ∀ {R : Type u} {M : Type v} [CommRing R] [AddCommMonoid M] [LinearOrder M] + (ν : MaxAddDegree R M) (x y : R), + ν.RVRel x y ↔ + (ν x = ⊥ ∧ ν y = ⊥) ∨ + (ν x ≠ ⊥ ∧ ν (x - y) < ν x)) + +example := (@MaxAddDegree.rvEquivHomogeneous : + ∀ {R : Type u} {M : Type v} [CommRing R] [AddCommMonoid M] + [LinearOrder M] [IsOrderedCancelAddMonoid M] + (ν : MaxAddDegree R M) [ν.IsMultiplicative], ν.RV ≃* ν.HomogeneousClasses) + +example := (@MaxAddDegree.associatedGradedValuation : + ∀ {R : Type u} {M : Type v} [CommRing R] [AddCommMonoid M] + [LinearOrder M] [IsOrderedCancelAddMonoid M] + (ν : MaxAddDegree R M), MaxAddDegree ν.AssociatedGraded M) + +example := (@MaxAddDegree.associatedGradedValue_eq_coe_iff : + ∀ {R : Type u} {M : Type v} [CommRing R] [AddCommMonoid M] [LinearOrder M] + (ν : MaxAddDegree R M) (x : ν.AssociatedGraded) (m : M), + ν.associatedGradedValue x = (m : WithBot M) ↔ + x m ≠ 0 ∧ ∀ i, x i ≠ 0 → i ≤ m) + +example := (@MaxAddDegree.associatedGradedValuation_isSeparated : + ∀ {R : Type u} {M : Type v} [CommRing R] [AddCommMonoid M] + [LinearOrder M] [IsOrderedCancelAddMonoid M] + (ν : MaxAddDegree R M), ν.associatedGradedValuation.IsSeparated) + +example := (@MaxAddDegree.associatedGradedValuation_initialForm : + ∀ {R : Type u} {M : Type v} [CommRing R] [AddCommMonoid M] + [LinearOrder M] [IsOrderedCancelAddMonoid M] + (ν : MaxAddDegree R M) (x : R), + ν.associatedGradedValuation (ν.initialForm x) = ν x) + +example := (@Berarducci.ordinalValue_add_le_max : + ∀ {K : Type v} [Field K] (b c : Berarducci.Series K), + Berarducci.ordinalValue (b + c) ≤ + max (Berarducci.ordinalValue b) (Berarducci.ordinalValue c)) + +/- Berarducci, Theorem 9.7 and Corollary 9.8. -/ +example := (@Berarducci.ordinalValue_mul : + ∀ {K : Type v} [Field K] [CharZero K] (b c : Berarducci.Series K), + Berarducci.ordinalValue (b * c) = + Berarducci.ordinalValue b * Berarducci.ordinalValue c) + +/- Berarducci, Lemma 10.1 and Definition 10.2. -/ +example := ((fun {_} [_] [_] ↦ @Berarducci.exists_isCriticalPoint _ _) : + ∀ {K : Type v} [Field K] [CharZero K] {b : Berarducci.Series K}, b ≠ 0 → + ∃ x : ℝ, Berarducci.IsCriticalPoint b x) + +/- Berarducci, Lemma 10.4. -/ +example := (@Berarducci.criticalPoint_product_value : + ∀ {K : Type v} [Field K] [CharZero K] + {b c : Berarducci.Series K} {x y : ℝ}, + Berarducci.IsCriticalPoint b x → Berarducci.IsCriticalPoint c y → + Berarducci.ordinalValue + (Berarducci.translatedTruncation + (((b * c : Berarducci.Series K) : K⟦ℝ⟧)) (x + y)) = + Berarducci.ordinalValue + (Berarducci.translatedTruncation (b : K⟦ℝ⟧) x) * + Berarducci.ordinalValue + (Berarducci.translatedTruncation (c : K⟦ℝ⟧) y)) + +/- Berarducci, Theorem 10.5: both alternatives for the support order type, the prohibition on +strictly negative monomial divisors, and both irreducibility conclusions. -/ +example := (@Berarducci.irreducible_and_add_one_of_supportOrderType : + ∀ {K : Type v} [Field K] [CharZero K] {a : Berarducci.Series K}, + (∀ (gamma : ℝ) (hgamma : gamma < 0), + ¬ HahnSeries.Nonpositive.single gamma (1 : K) hgamma.le ∣ a) → + ((a : K⟦ℝ⟧).supportOrderType = Ordinal.omega0 ∨ + ∃ beta : Ordinal, (a : K⟦ℝ⟧).supportOrderType = + Ordinal.omega0 ^ Ordinal.omega0 ^ beta) → + Irreducible a ∧ Irreducible (a + 1)) + +/- Berarducci, Theorem 10.5, specialized to the coefficient-one row underlying LM24, +Example 9.2.8. -/ +example := (@Berarducci.OneRow.withConstant_supportOrderType : + ∀ {K : Type v} [Field K], + (Berarducci.OneRow.withConstant (K := K) : K⟦ℝ⟧).supportOrderType = + Ordinal.omega0 + 1) + +example := (@Berarducci.OneRow.irreducible_withoutConstant_and_withConstant : + ∀ {K : Type v} [Field K] [CharZero K], + Irreducible (Berarducci.OneRow.withoutConstant (K := K)) ∧ + Irreducible (Berarducci.OneRow.withConstant (K := K))) + +/- PS06's quotient is by `J + K`, not Berarducci's ideal `J`. -/ +example := (@PommersheimShahriari.mem_nearConstantSubmodule_iff : + ∀ {K : Type v} [Field K] {b : Berarducci.Series K}, + b ∈ PommersheimShahriari.nearConstantSubmodule K ↔ + b ∈ Berarducci.nearConstantSubgroup K) + +example := (Tests.constant_one_eq_zero_modulo_constants : + PommersheimShahriari.toSeriesQuotientByJAddConstants + (HahnSeries.Nonpositive.C (1 : ℚ)) = 0) + +example := (Tests.constant_one_ne_zero_in_berarducci_germ : + Berarducci.toGerm (HahnSeries.Nonpositive.C (1 : ℚ)) ≠ 0) + +/- PS06, Lemma 3.1: ordinal factorisation and the critical-point obstruction. -/ +example := (@PommersheimShahriari.ordinalValue_factors_of_mul_eq_wpow_two : + ∀ {K : Type v} [Field K] {b c : Berarducci.Series K}, + Berarducci.ordinalValue b * Berarducci.ordinalValue c = + ω^ (2 : NatOrdinal) → + Berarducci.ordinalValue b ≤ Berarducci.ordinalValue c → + (Berarducci.ordinalValue b = 1 ∧ + Berarducci.ordinalValue c = ω^ (2 : NatOrdinal)) ∨ + (Berarducci.ordinalValue b = ω^ (1 : NatOrdinal) ∧ + Berarducci.ordinalValue c = ω^ (1 : NatOrdinal))) + +example := (@PommersheimShahriari.criticalPoints_eq_zero_of_product_wpow_two : + ∀ {K : Type v} [Field K] [CharZero K] + {a b c : Berarducci.Series K} {x y : ℝ}, + a = b * c → Berarducci.ordinalValue a = ω^ (2 : NatOrdinal) → + (∀ u : ℝ, u < 0 → + Berarducci.ordinalValue (Berarducci.translatedTruncation (a : K⟦ℝ⟧) u) < + ω^ (2 : NatOrdinal)) → + Berarducci.IsCriticalPoint b x → Berarducci.IsCriticalPoint c y → + x = 0 ∧ y = 0) + +/- PS06, Lemma 3.1, complete support-order classification. -/ +example := (@PommersheimShahriari.factorization_cases_of_supportOrderType_wpow_two : + ∀ {K : Type v} [Field K] [CharZero K] + {a b c : Berarducci.Series K}, + a ∉ Berarducci.nearConstantSubgroup K → + ((a : K⟦ℝ⟧).supportOrderType = Ordinal.omega0 ^ (2 : Ordinal) ∨ + (a : K⟦ℝ⟧).supportOrderType = Ordinal.omega0 ^ (2 : Ordinal) + 1) → + a = b * c → Berarducci.ordinalValue b ≤ Berarducci.ordinalValue c → + (∃ k : K, k ≠ 0 ∧ b = HahnSeries.Nonpositive.C k ∧ + c = HahnSeries.Nonpositive.C k⁻¹ * a ∧ + (c : K⟦ℝ⟧).supportOrderType = (a : K⟦ℝ⟧).supportOrderType) ∨ + (((b : K⟦ℝ⟧).supportOrderType = Ordinal.omega0 ∨ + (b : K⟦ℝ⟧).supportOrderType = Ordinal.omega0 + 1) ∧ + ((c : K⟦ℝ⟧).supportOrderType = Ordinal.omega0 ∨ + (c : K⟦ℝ⟧).supportOrderType = Ordinal.omega0 + 1) ∧ + Berarducci.ordinalValue b = ω^ (1 : NatOrdinal) ∧ + Berarducci.ordinalValue c = ω^ (1 : NatOrdinal))) + +example := (@Tests.ps06_degreeTwo_factorization_client : + ∀ {K : Type v} [Field K] [CharZero K] + {a b c : Berarducci.Series K}, + a ∉ Berarducci.nearConstantSubgroup K → + ((a : K⟦ℝ⟧).supportOrderType = Ordinal.omega0 ^ (2 : Ordinal) ∨ + (a : K⟦ℝ⟧).supportOrderType = Ordinal.omega0 ^ (2 : Ordinal) + 1) → + a = b * c → Berarducci.ordinalValue b ≤ Berarducci.ordinalValue c → + (∃ k : K, k ≠ 0 ∧ b = HahnSeries.Nonpositive.C k ∧ + c = HahnSeries.Nonpositive.C k⁻¹ * a ∧ + (c : K⟦ℝ⟧).supportOrderType = (a : K⟦ℝ⟧).supportOrderType) ∨ + (((b : K⟦ℝ⟧).supportOrderType = Ordinal.omega0 ∨ + (b : K⟦ℝ⟧).supportOrderType = Ordinal.omega0 + 1) ∧ + ((c : K⟦ℝ⟧).supportOrderType = Ordinal.omega0 ∨ + (c : K⟦ℝ⟧).supportOrderType = Ordinal.omega0 + 1) ∧ + Berarducci.ordinalValue b = ω^ (1 : NatOrdinal) ∧ + Berarducci.ordinalValue c = ω^ (1 : NatOrdinal))) + +/- PS06, Proposition 3.2(2) and (5), upper-bound direction. -/ +example := (@PommersheimShahriari.finrank_translatedTruncationSpan_mul_le_two : + ∀ {K : Type v} [Field K] {b c : Berarducci.Series K}, + Berarducci.ordinalValue b = ω^ (1 : NatOrdinal) → + Berarducci.ordinalValue c = ω^ (1 : NatOrdinal) → + Berarducci.IsCriticalPoint b 0 → Berarducci.IsCriticalPoint c 0 → + Module.finrank K (PommersheimShahriari.translatedTruncationSpan (b * c)) ≤ 2) + +/- PS06, Proposition 3.2(5), without a finite-dimensionality assumption. -/ +example := (@PommersheimShahriari.rank_translatedTruncationSpan_mul_le_two : + ∀ {K : Type v} [Field K] {b c : Berarducci.Series K}, + Berarducci.ordinalValue b = ω^ (1 : NatOrdinal) → + Berarducci.ordinalValue c = ω^ (1 : NatOrdinal) → + Berarducci.IsCriticalPoint b 0 → Berarducci.IsCriticalPoint c 0 → + Module.rank K (PommersheimShahriari.translatedTruncationSpan (b * c)) ≤ 2) + +/- PS06, Corollary 3.3. -/ +example := (@PommersheimShahriari.irreducible_of_two_lt_finrank_translatedTruncationSpan : + ∀ {K : Type v} [Field K] [CharZero K] {a : Berarducci.Series K}, + a ∉ Berarducci.nearConstantSubgroup K → + ((a : K⟦ℝ⟧).supportOrderType = Ordinal.omega0 ^ (2 : Ordinal) ∨ + (a : K⟦ℝ⟧).supportOrderType = Ordinal.omega0 ^ (2 : Ordinal) + 1) → + 2 < Module.finrank K (PommersheimShahriari.translatedTruncationSpan a) → Irreducible a) + +/- PS06, Corollary 3.3, in cardinal-rank form. -/ +example := (@PommersheimShahriari.irreducible_of_two_lt_rank_translatedTruncationSpan : + ∀ {K : Type v} [Field K] [CharZero K] {a : Berarducci.Series K}, + a ∉ Berarducci.nearConstantSubgroup K → + ((a : K⟦ℝ⟧).supportOrderType = Ordinal.omega0 ^ (2 : Ordinal) ∨ + (a : K⟦ℝ⟧).supportOrderType = Ordinal.omega0 ^ (2 : Ordinal) + 1) → + (2 : Cardinal) < + Module.rank K (PommersheimShahriari.translatedTruncationSpan a) → Irreducible a) + +/- The explicit coefficient-one `ω² + 1` series supplied by the PS06 criterion. -/ +example := (@PommersheimShahriari.DegreeTwoExample.degreeTwoWithConstant_supportOrderType : + ∀ {K : Type v} [Field K], + ((PommersheimShahriari.DegreeTwoExample.degreeTwoWithConstant (K := K) : + Berarducci.Series K) : K⟦ℝ⟧).supportOrderType = + Ordinal.omega0 ^ (2 : Ordinal) + 1) + +example := (@PommersheimShahriari.DegreeTwoExample.degreeTwoWithConstant_irreducible : + ∀ {K : Type v} [Field K] [CharZero K], + Irreducible + (PommersheimShahriari.DegreeTwoExample.degreeTwoWithConstant (K := K))) + +example := (@Tests.ps06_degreeTwo_irreducibility_client : + ∀ {K : Type v} [Field K] [CharZero K] {a : Berarducci.Series K}, + a ∉ Berarducci.nearConstantSubgroup K → + ((a : K⟦ℝ⟧).supportOrderType = Ordinal.omega0 ^ (2 : Ordinal) ∨ + (a : K⟦ℝ⟧).supportOrderType = Ordinal.omega0 ^ (2 : Ordinal) + 1) → + 2 < Module.finrank K (PommersheimShahriari.translatedTruncationSpan a) → Irreducible a) + +example := (@Berarducci.negativeMonomialIdeal_isPrime : + ∀ {K : Type v} [Field K] [CharZero K], + (HahnSeries.Nonpositive.negativeMonomialIdeal K).IsPrime) + +/- Berarducci, Corollary 9.9, imported by LM24 as Fact 3.4.1. -/ +example := (@HahnSeries.Nonpositive.orderTypeMultiplicativeOnWeaklyPrincipal : + ∀ {K : Type v} [Field K] [CharZero K], + HahnSeries.Nonpositive.OrderTypeMultiplicativeOnWeaklyPrincipal K) + +/- LM24, Propositions 3.5.1(2) and 3.6.1. -/ +example := (@HahnSeries.Nonpositive.supportSup_mul : + ∀ {K : Type v} [Field K] [CharZero K] + (b c : HahnSeries.Nonpositive ℝ K), + HahnSeries.Nonpositive.supportSup (b * c) = + HahnSeries.Nonpositive.supportSup b + HahnSeries.Nonpositive.supportSup c) + +example := (@HahnSeries.Nonpositive.IsPrincipal.mul : + ∀ {K : Type v} [Field K] [CharZero K] + {b c : HahnSeries.Nonpositive ℝ K}, + HahnSeries.Nonpositive.IsPrincipal b → + HahnSeries.Nonpositive.IsPrincipal c → + HahnSeries.Nonpositive.IsPrincipal (b * c)) + +/- Boundary certificates exercise the proved characteristic-zero theorems on nonconstant +inputs. -/ +example := (Tests.ordinalValue_mul_approachZero : + Berarducci.ordinalValue + (Tests.approachZeroNonpositive * + Tests.approachZeroNonpositive) = + Berarducci.ordinalValue Tests.approachZeroNonpositive * + Berarducci.ordinalValue Tests.approachZeroNonpositive) + +example := (Tests.twoTermNonprincipal_square_degree : + ((Tests.twoTermNonprincipal * Tests.twoTermNonprincipal : + HahnSeries.Nonpositive ℝ ℚ) : ℚ⟦ℝ⟧).degree = + (Tests.twoTermNonprincipal : ℚ⟦ℝ⟧).degree + + (Tests.twoTermNonprincipal : ℚ⟦ℝ⟧).degree) + +example := (Tests.exists_unattained_zeroSup_square : + ∃ b : HahnSeries.Nonpositive ℝ ℚ, + HahnSeries.Nonpositive.supportSup b = 0 ∧ + 0 ∉ (b : ℚ⟦ℝ⟧).support ∧ + HahnSeries.Nonpositive.supportSup (b * b) = 0) + +example := (@Berarducci.ordinalValueDegree_eq_bot_iff : + ∀ {K : Type v} [Field K] {b : Berarducci.Series K}, + Berarducci.ordinalValueDegree b = ⊥ ↔ + b ∈ HahnSeries.Nonpositive.negativeMonomialIdeal K) + +example := (@Berarducci.ordinalValueDegreeValuation_eq_bot_iff : + ∀ {K : Type v} [Field K] (b : Berarducci.Series K), + Berarducci.ordinalValueDegreeValuation K b = ⊥ ↔ + b ∈ HahnSeries.Nonpositive.negativeMonomialIdeal K) + +example := (@Berarducci.principalComponentMk_eq_iff : + ∀ {K : Type v} [Field K] + (α : NatOrdinal) (b c : Berarducci.Series K) + (hb : Berarducci.ordinalValue b < ω^ (α + 1)) + (hc : Berarducci.ordinalValue c < ω^ (α + 1)), + Berarducci.principalComponentMk α b hb = + Berarducci.principalComponentMk α c hc ↔ + Berarducci.ordinalValue (b - c) < ω^ α) + +example := (@Berarducci.exists_principal_representative_of_ne_zero : + ∀ {K : Type v} [Field K] (α : NatOrdinal) + (x : Berarducci.PrincipalComponent K α), x ≠ 0 → + ∃ (p : Berarducci.Series K) + (hpBound : Berarducci.ordinalValue p < ω^ (α + 1)), + HahnSeries.Nonpositive.IsPrincipal p ∧ + (p : K⟦ℝ⟧).degree = (α : WithBot NatOrdinal) ∧ + Berarducci.principalComponentMk α p hpBound = x) + +/- The equal-degree specialization of LM24, Proposition 3.6.2 used in Lemma 7.2.3. The +unrestricted printed proposition is false. -/ +example := (@HahnSeries.Nonpositive.IsPrincipal.add_of_degree_eq : + ∀ {K : Type v} [Field K] {b c : HahnSeries.Nonpositive ℝ K}, + HahnSeries.Nonpositive.IsPrincipal b → + HahnSeries.Nonpositive.IsPrincipal c → + (c : K⟦ℝ⟧).degree = (b : K⟦ℝ⟧).degree → + ((b + c : HahnSeries.Nonpositive ℝ K) : K⟦ℝ⟧).degree = + (b : K⟦ℝ⟧).degree → + HahnSeries.Nonpositive.IsPrincipal (b + c)) + +example := (@Berarducci.ordinalValue_eq_wpow_of_isPrincipal : + ∀ {K : Type v} [Field K] {p : Berarducci.Series K} + (_hp : HahnSeries.Nonpositive.IsPrincipal p) {α : NatOrdinal}, + (p : K⟦ℝ⟧).degree = (α : WithBot NatOrdinal) → + Berarducci.ordinalValue p = ω^ α) + +example := (@Berarducci.degreeLayerMk_eq_iff_ordinalValue_sub_lt : + ∀ {K : Type v} [Field K] + (α : NatOrdinal) {b c : Berarducci.Series K} + (_hb : HahnSeries.Nonpositive.IsPrincipal b) + (_hc : HahnSeries.Nonpositive.IsPrincipal c) + (hbDegree : (b : K⟦ℝ⟧).degree = (α : WithBot NatOrdinal)) + (hcDegree : (c : K⟦ℝ⟧).degree = (α : WithBot NatOrdinal)), + Berarducci.degreeLayerMk α b hbDegree.le = + Berarducci.degreeLayerMk α c hcDegree.le ↔ + Berarducci.ordinalValue (b - c) < ω^ α) + +example := (@Berarducci.principalDegreeClassesEquivPrincipalComponent : + ∀ (K : Type v) [Field K] + (α : NatOrdinal), + Berarducci.principalDegreeClasses K α ≃ₗ[K] + Berarducci.PrincipalComponent K α) + +/- LM24, Proposition 5.3.1. -/ +example := ((fun (K : Type v) [Field K] [CharZero K] ↦ + Berarducci.principalComponentTensorEquiv K) : + ∀ (K : Type v) [Field K] [CharZero K] + (α : NatOrdinal), + TensorProduct K (Berarducci.PrincipalComponent K α) + Berarducci.FiniteSupportRing ≃ₗ[K] + (HahnSeries.Nonpositive.degreeValuation K).Component α) + +/- LM24, Proposition 6.1.2, under the paper's blanket characteristic-zero hypothesis. -/ +example := (fun {K : Type v} [Field K] [CharZero K] ↦ + (Berarducci.principalSubringTensorEquiv K : + TensorProduct K (Berarducci.PrincipalSubring K) + Berarducci.FiniteSupportRing ≃ₐ[K] + Berarducci.DegreeGraded K)) + +example := (@Berarducci.principalSubringTensorEquiv_tmul_apply : + ∀ {K : Type v} [Field K] [CharZero K] + (x : Berarducci.PrincipalSubring K) + (p : Berarducci.FiniteSupportRing) (α : NatOrdinal), + Berarducci.principalSubringTensorEquiv K (x ⊗ₜ p) α = + Berarducci.principalComponentTensorEquiv K α (x α ⊗ₜ p)) + +example := (@Berarducci.principalSubringTensorEquiv_component : + ∀ {K : Type v} [Field K] [CharZero K] + (z : TensorProduct K (Berarducci.PrincipalSubring K) + Berarducci.FiniteSupportRing) (α : NatOrdinal), + Berarducci.principalSubringTensorEquiv K z α = + Berarducci.principalComponentTensorEquiv K α + (Berarducci.principalSubringTensorComponent K α z)) + +/- LM24, Proposition 5.4.3. -/ +example := (@Berarducci.rv_maximal_finite_support_divisor : + ∀ {K : Type v} [Field K] [CharZero K] + (B : Berarducci.HahnDegreeRV K), + ∃ p : Berarducci.FiniteSupportRing, + (∀ q : Berarducci.FiniteSupportRing, + Berarducci.finiteSupportRVEmbedding K q ∣ B ↔ q ∣ p) ∧ + (∀ p' : Berarducci.FiniteSupportRing, + (∀ q : Berarducci.FiniteSupportRing, + Berarducci.finiteSupportRVEmbedding K q ∣ B ↔ q ∣ p') → + ∃ k : K, k ≠ 0 ∧ + p' = HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℝ) k * p) ∧ + (Berarducci.IsPrincipalRV B → + ∃ k : K, + p = HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℝ) k)) + +/- LM24, Corollary 5.4.4. -/ +example := (@Berarducci.graded_maximal_finite_support_divisor : + ∀ {K : Type v} [Field K] [CharZero K] + (B : Berarducci.DegreeGraded K), + ∃ p : Berarducci.FiniteSupportRing, + (∀ q : Berarducci.FiniteSupportRing, + Berarducci.finiteSupportGradedEmbedding K q ∣ B ↔ q ∣ p) ∧ + ∀ p' : Berarducci.FiniteSupportRing, + (∀ q : Berarducci.FiniteSupportRing, + Berarducci.finiteSupportGradedEmbedding K q ∣ B ↔ q ∣ p') → + ∃ k : K, k ≠ 0 ∧ + p' = HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℝ) k * p) + +/- LM24, Notation 5.4.5. -/ +example := (@Berarducci.existsUnique_normalized_maximal_finite_support_divisor : + ∀ {K : Type v} [Field K] [CharZero K] + (B : Berarducci.DegreeGraded K), + ∃! p : Berarducci.FiniteSupportRing, + Berarducci.IsNormalizedGradedMaximalFiniteSupportDivisor B p) + +/- LM24, Remark 5.4.6. -/ +example := (@Berarducci.maximalFiniteSupportDivisor_dvd : + ∀ {K : Type v} [Field K] [CharZero K] + (B : Berarducci.DegreeGraded K), + Berarducci.finiteSupportGradedEmbedding K + (Berarducci.gradedNormalizedMaximalFiniteSupportDivisor B) ∣ B) + +/- LM24, Proposition 5.4.8. -/ +example := (@Berarducci.maximalFiniteSupportDivisor_mul_dvd : + ∀ {K : Type v} [Field K] [CharZero K] + (B C : Berarducci.DegreeGraded K), + Berarducci.gradedNormalizedMaximalFiniteSupportDivisor B * + Berarducci.gradedNormalizedMaximalFiniteSupportDivisor C ∣ + Berarducci.gradedNormalizedMaximalFiniteSupportDivisor (B * C)) + +/- LM24, Proposition 5.5.1. -/ +example := (@Berarducci.series_maximal_finite_support_divisor : + ∀ {K : Type v} [Field K] [CharZero K] + (b : Berarducci.Series K), + ∃ p : Berarducci.FiniteSupportRing, + (∀ q : Berarducci.FiniteSupportRing, + (q : Berarducci.Series K) ∣ b ↔ q ∣ p) ∧ + ∀ p' : Berarducci.FiniteSupportRing, + (∀ q : Berarducci.FiniteSupportRing, + (q : Berarducci.Series K) ∣ b ↔ q ∣ p') → + ∃ k : K, k ≠ 0 ∧ + p' = HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℝ) k * p) + +/- LM24, Notation 5.5.2. -/ +example := (@Berarducci.existsUnique_normalized_series_maximal_finite_support_divisor : + ∀ {K : Type v} [Field K] [CharZero K] + (b : Berarducci.Series K), + ∃! p : Berarducci.FiniteSupportRing, + Berarducci.IsNormalizedSeriesMaximalFiniteSupportDivisor b p) + +example := (@Berarducci.seriesNormalizedMaximalFiniteSupportDivisor_is : + ∀ {K : Type v} [Field K] [CharZero K] + (b : Berarducci.Series K), + Berarducci.IsNormalizedSeriesMaximalFiniteSupportDivisor b + (Berarducci.seriesNormalizedMaximalFiniteSupportDivisor b)) + +/- LM24, Remark 5.5.3. -/ +example := (@Berarducci.seriesMaximalFiniteSupportDivisor_dvd : + ∀ {K : Type v} [Field K] [CharZero K] + (b : Berarducci.Series K), + (Berarducci.seriesNormalizedMaximalFiniteSupportDivisor b : + Berarducci.Series K) ∣ b) + +example := (@Berarducci.seriesMaximalFiniteSupportDivisor_zero : + ∀ (K : Type v) [Field K] [CharZero K], + Berarducci.seriesNormalizedMaximalFiniteSupportDivisor + (0 : Berarducci.Series K) = 0) + +example := (@Berarducci.exists_scalar_seriesMaximalFiniteSupportDivisor_coe : + ∀ {K : Type v} [Field K] [CharZero K] + (p : Berarducci.FiniteSupportRing), + ∃ k : K, k ≠ 0 ∧ + Berarducci.seriesNormalizedMaximalFiniteSupportDivisor + (p : Berarducci.Series K) = + HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℝ) k * p) + +example := (@Berarducci.seriesMaximalFiniteSupportDivisor_coe_eq_graded : + ∀ {K : Type v} [Field K] [CharZero K] + (p : Berarducci.FiniteSupportRing), + Berarducci.seriesNormalizedMaximalFiniteSupportDivisor + (p : Berarducci.Series K) = + Berarducci.gradedNormalizedMaximalFiniteSupportDivisor + (Berarducci.finiteSupportGradedEmbedding K p)) + +example := (@Berarducci.seriesMaximalFiniteSupportDivisor_principal_eq_one : + ∀ {K : Type v} [Field K] [CharZero K] + {b : Berarducci.Series K}, + HahnSeries.Nonpositive.IsPrincipal b → + Berarducci.seriesNormalizedMaximalFiniteSupportDivisor b = 1) + +/- LM24, Proposition 5.5.5. -/ +example := (@Berarducci.seriesMaximalFiniteSupportDivisor_mul_dvd : + ∀ {K : Type v} [Field K] [CharZero K] + (b c : Berarducci.Series K), + Berarducci.seriesNormalizedMaximalFiniteSupportDivisor b * + Berarducci.seriesNormalizedMaximalFiniteSupportDivisor c ∣ + Berarducci.seriesNormalizedMaximalFiniteSupportDivisor (b * c)) + +/- LM24, Example 5.5.4. -/ +example := (Tests.seriesMaximalExample_isRVMaximalFiniteSupportDivisor : + Berarducci.IsRVMaximalFiniteSupportDivisor + ((HahnSeries.Nonpositive.degreeValuation ℚ).rv Tests.seriesMaximalExample) + (Associates.mk Tests.seriesMaximalExampleRVDivisor)) + +example := (@Tests.seriesMaximalExample_normalized_eq : + ∀ (_hgcd : ∀ p q : Berarducci.FiniteSupportRing, + ∃ d : Berarducci.FiniteSupportRing, + ∀ e : Berarducci.FiniteSupportRing, e ∣ p ∧ e ∣ q ↔ e ∣ d) + (_hunits : ∀ u : Berarducci.FiniteSupportRing, + IsUnit u ↔ ∃ k : ℚ, k ≠ 0 ∧ + u = HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℝ) k), + Berarducci.seriesNormalizedMaximalFiniteSupportDivisor + Tests.seriesMaximalExample = + Tests.seriesMaximalExampleDivisor) + +example := (@Tests.seriesMaximalExample_gradedNormalized_eq : + ∀ (_hgcd : ∀ p q : Berarducci.FiniteSupportRing, + ∃ d : Berarducci.FiniteSupportRing, + ∀ e : Berarducci.FiniteSupportRing, e ∣ p ∧ e ∣ q ↔ e ∣ d) + (_hunits : ∀ u : Berarducci.FiniteSupportRing, + IsUnit u ↔ ∃ k : ℚ, k ≠ 0 ∧ + u = HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℝ) k), + Berarducci.gradedNormalizedMaximalFiniteSupportDivisor + Tests.seriesMaximalExampleLeadingGraded = + Tests.seriesMaximalExampleRVDivisor) + +example := (Tests.seriesMaximalExample_divisors_ne : + Tests.seriesMaximalExampleRVDivisor ≠ + Tests.seriesMaximalExampleDivisor) + +/- LM24, Proposition 5.6.1. The list is the finite sequence `c₁, …, cₙ`, and its length +is `n`. -/ +example := (@Berarducci.series_infinite_support_factorization : + ∀ {K : Type v} [Field K] [CharZero K] + {b : Berarducci.Series K}, b ≠ 0 → + ∃ (factors : List (Berarducci.Series K)) (k : K), + b = HahnSeries.Nonpositive.C k * + (Berarducci.seriesNormalizedMaximalFiniteSupportDivisor b : + Berarducci.Series K) * factors.prod ∧ + (∀ c ∈ factors, + Irreducible c ∧ (c : K⟦ℝ⟧).support.Infinite) ∧ + factors.length ≤ + HahnSeries.degreeCantorTermCount (b : K⟦ℝ⟧)) + +example := (@Berarducci.series_infinite_support_factorization_with_nonzero_scalar : + ∀ {K : Type v} [Field K] [CharZero K] + {b : Berarducci.Series K}, b ≠ 0 → + ∃ (factors : List (Berarducci.Series K)) (k : K), + k ≠ 0 ∧ + b = HahnSeries.Nonpositive.C k * + (Berarducci.seriesNormalizedMaximalFiniteSupportDivisor b : + Berarducci.Series K) * factors.prod ∧ + (∀ c ∈ factors, + Irreducible c ∧ (c : K⟦ℝ⟧).support.Infinite) ∧ + factors.length ≤ + HahnSeries.degreeCantorTermCount (b : K⟦ℝ⟧)) + +example := (Tests.zero_not_hasOnlyUnitFiniteSupportDivisors : + ¬Berarducci.HasOnlyUnitFiniteSupportDivisors + (0 : Berarducci.Series ℚ)) + +/- LM24, Proposition 6.2.1. -/ +example := (@Berarducci.hahnDegreeRV_factors_of_mul_mem : + ∀ {K : Type v} [Field K] + [CharZero K] + {B C : Berarducci.DegreeGraded K}, + B ≠ 0 → C ≠ 0 → + B * C ∈ + (HahnSeries.Nonpositive.degreeValuation K).homogeneousClasses → + B ∈ + (HahnSeries.Nonpositive.degreeValuation K).homogeneousClasses ∧ + C ∈ + (HahnSeries.Nonpositive.degreeValuation K).homogeneousClasses) + +/- The exact graded-image model of `P` used in LM24, Corollary 6.2.2. -/ +example := (@Berarducci.isPrincipalRVImage_iff_exists : + ∀ {K : Type v} [Field K] [CharZero K] + (x : Berarducci.DegreeGraded K), + Berarducci.IsPrincipalRVImage x ↔ + ∃ B : Berarducci.HahnDegreeRV K, + Berarducci.IsPrincipalRV B ∧ + (HahnSeries.Nonpositive.degreeValuation K).rvInitialFormHom B = x) + +/- The intrinsic characterization of the exact graded-image model of `P`. -/ +example := (@Berarducci.isPrincipalRVImage_iff : + ∀ {K : Type v} [Field K] [CharZero K] + (x : Berarducci.DegreeGraded K), + Berarducci.IsPrincipalRVImage x ↔ + x ≠ 0 ∧ + x ∈ + (HahnSeries.Nonpositive.degreeValuation K).homogeneousClasses ∧ + Berarducci.IsPrincipalGraded x) + +/- LM24, Corollary 6.2.2, `P̂` clause. -/ +example := (@Berarducci.hahnDegreePrincipalGraded_factors_of_mul_mem : + ∀ {K : Type v} [Field K] + [CharZero K] + {B C : Berarducci.DegreeGraded K}, + B ≠ 0 → C ≠ 0 → Berarducci.IsPrincipalGraded (B * C) → + Berarducci.IsPrincipalGraded B ∧ + Berarducci.IsPrincipalGraded C) + +/- LM24, Corollary 6.2.2, `P` clause. -/ +example := (@Berarducci.hahnDegreePrincipalRVImage_factors_of_mul_mem : + ∀ {K : Type v} [Field K] + [CharZero K] + {B C : Berarducci.DegreeGraded K}, + B ≠ 0 → C ≠ 0 → Berarducci.IsPrincipalRVImage (B * C) → + Berarducci.IsPrincipalRVImage B ∧ + Berarducci.IsPrincipalRVImage C) + +/- LM24, Corollary 6.2.3, RV clause. -/ +example := (@Berarducci.hahnDegreeRV_dvd_iff_associatedGraded_dvd : + ∀ {K : Type v} [Field K] + [CharZero K] + (B C : Berarducci.HahnDegreeRV K), + B ∣ C ↔ + (HahnSeries.Nonpositive.degreeValuation K).rvInitialFormHom B ∣ + (HahnSeries.Nonpositive.degreeValuation K).rvInitialFormHom C) + +/- LM24, Corollary 6.2.3, finite-support clause. -/ +example := (@Berarducci.finiteSupportGradedEmbedding_dvd_iff : + ∀ {K : Type v} [Field K] + [CharZero K] + (p q : Berarducci.FiniteSupportRing), + Berarducci.finiteSupportGradedEmbedding K p ∣ + Berarducci.finiteSupportGradedEmbedding K q ↔ + p ∣ q) + +/- LM24, Proposition 6.2.4. -/ +example := (@Berarducci.hahnDegreeRV_dvd_iff_dvd_components : + ∀ {K : Type v} [Field K] + [CharZero K] + (B : Berarducci.HahnDegreeRV K) + (C : Berarducci.DegreeGraded K), + (HahnSeries.Nonpositive.degreeValuation K).rvInitialFormHom B ∣ C ↔ + ∀ α, + (HahnSeries.Nonpositive.degreeValuation K).rvInitialFormHom B ∣ + DirectSum.of + (HahnSeries.Nonpositive.degreeValuation K).Component + α (C α)) + +/- LM24, Lemma 6.3.1. -/ +example := (@Berarducci.maximalFiniteSupportDivisor_rv_mul_principal : + ∀ {K : Type v} [Field K] [CharZero K] + (B C : Berarducci.HahnDegreeRV K), + Berarducci.IsPrincipalRV C → C ≠ 0 → + Berarducci.gradedNormalizedMaximalFiniteSupportDivisor + ((HahnSeries.Nonpositive.degreeValuation K).rvInitialFormHom (B * C)) = + Berarducci.gradedNormalizedMaximalFiniteSupportDivisor + ((HahnSeries.Nonpositive.degreeValuation K).rvInitialFormHom B)) + +/- LM24, Lemma 6.3.2. -/ +example := (@Berarducci.maximalFiniteSupportDivisor_mul_principal : + ∀ {K : Type v} [Field K] [CharZero K] + (B C : Berarducci.DegreeGraded K), + Berarducci.IsPrincipalGraded C → C ≠ 0 → + Berarducci.gradedNormalizedMaximalFiniteSupportDivisor (B * C) = + Berarducci.gradedNormalizedMaximalFiniteSupportDivisor B) + +/- LM24, Lemma 6.3.3. -/ +example := (@Berarducci.isRelativelyAlgebraicallyClosed_principalGradedFractionField : + ∀ (K : Type v) [Field K] [CharZero K], + @Algebra.IsRelativelyAlgebraicallyClosed K + (Berarducci.PrincipalSubringFractionField K) _ _ + (Berarducci.principalSubringFractionAlgebra K)) + +/- LM24, Lemma 6.3.4. The nonzeroness of the inverted coefficient is made explicit because +Lean's inverse is total. -/ +example := (@Berarducci.principalSubringFraction_exists_scalarRedistribution : + ∀ {K : Type v} [Field K] [CharZero K] + {p₁ p₂ : Berarducci.PrincipalSubringFractionFiniteSupportRing K}, + p₁ ≠ 0 → p₂ ≠ 0 → + p₁ * p₂ ∈ Berarducci.principalSubringFractionCoefficientSubring K → + ∃ B : Berarducci.PrincipalSubringFractionField K, + B ≠ 0 ∧ + p₁ * HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℝ) B ∈ + Berarducci.principalSubringFractionCoefficientSubring K ∧ + p₂ * HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℝ) B⁻¹ ∈ + Berarducci.principalSubringFractionCoefficientSubring K) + +/- Guardrail: omitting the preceding `B ≠ 0` lets `B = 0` satisfy both membership clauses for +arbitrary factors under Lean's total inverse. -/ +example := (@Berarducci.principalSubringFraction_exists_literalTotalInverseScalarRedistribution : + ∀ {K : Type v} [Field K] [CharZero K] + (p₁ p₂ : Berarducci.PrincipalSubringFractionFiniteSupportRing K), + ∃ B : Berarducci.PrincipalSubringFractionField K, + p₁ * HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℝ) B ∈ + Berarducci.principalSubringFractionCoefficientSubring K ∧ + p₂ * HahnSeries.Nonpositive.finiteSupportScalarHom (G := ℝ) B⁻¹ ∈ + Berarducci.principalSubringFractionCoefficientSubring K) + +/- LM24, Remark 6.3.5. Under the identification of Remark 6.1.3, coefficient extension +reflects divisibility. -/ +example := (@Berarducci.principalSubringFractionScalarExtension_dvd_iff : + ∀ {K : Type v} [Field K] [CharZero K] + (p q : HahnSeries.Nonpositive.FiniteSupportRing (G := ℝ) (K := K)), + Berarducci.principalSubringFractionScalarExtension K p ∣ + Berarducci.principalSubringFractionScalarExtension K q ↔ + p ∣ q) + +/- LM24, Corollary 6.3.6, in the stronger factor-witness form used in its proof. The +finite-support factors remain elements of `K(ℝ^{≤ 0})`. -/ +example := (@Berarducci.finiteSupportGradedEmbedding_exists_factor_dvd : + ∀ {K : Type v} [Field K] [CharZero K] + (p : Berarducci.FiniteSupportRing) + (B C : Berarducci.DegreeGraded K), + Berarducci.finiteSupportGradedEmbedding K p ∣ B * C → + ∃ p₁ p₂ : Berarducci.FiniteSupportRing, + p = p₁ * p₂ ∧ + Berarducci.finiteSupportGradedEmbedding K p₁ ∣ B ∧ + Berarducci.finiteSupportGradedEmbedding K p₂ ∣ C) + +/- LM24, Corollary 6.3.6. -/ +example := (@Berarducci.finiteSupportGradedEmbedding_isPrimal : + ∀ {K : Type v} [Field K] [CharZero K] + (p : Berarducci.FiniteSupportRing), + IsPrimal (Berarducci.finiteSupportGradedEmbedding K p)) + +/- LM24, Corollary 6.3.7. -/ +example := (@Berarducci.maximalFiniteSupportDivisor_mul : + ∀ {K : Type v} [Field K] [CharZero K] + (B C : Berarducci.DegreeGraded K), + Berarducci.gradedNormalizedMaximalFiniteSupportDivisor (B * C) = + Berarducci.gradedNormalizedMaximalFiniteSupportDivisor B * + Berarducci.gradedNormalizedMaximalFiniteSupportDivisor C) + +/- LM24, Proposition 6.3.8. -/ +example := (@Berarducci.seriesMaximalFiniteSupportDivisor_mul : + ∀ {K : Type v} [Field K] [CharZero K] + (b c : Berarducci.Series K), + Berarducci.seriesNormalizedMaximalFiniteSupportDivisor (b * c) = + Berarducci.seriesNormalizedMaximalFiniteSupportDivisor b * + Berarducci.seriesNormalizedMaximalFiniteSupportDivisor c) + +/- LM24, Corollary 6.3.9, in the stronger factor-witness form used in its proof. The factors +remain in the finite-support subring, and their equality is asserted in the ambient series ring. -/ +example := (@Berarducci.finiteSupportSeries_exists_factor_dvd : + ∀ {K : Type v} [Field K] [CharZero K] + (p : Berarducci.FiniteSupportRing (K := K)) (b c : Berarducci.Series K), + (p : Berarducci.Series K) ∣ b * c → + ∃ p₁ p₂ : Berarducci.FiniteSupportRing (K := K), + (p : Berarducci.Series K) = + (p₁ : Berarducci.Series K) * (p₂ : Berarducci.Series K) ∧ + (p₁ : Berarducci.Series K) ∣ b ∧ + (p₂ : Berarducci.Series K) ∣ c) + +/- LM24, Theorem 6.4.1. The list is the sequence `c₁, …, cₙ`, its length is `n`, and +only the finite-support factor is asserted to be unique. -/ +example := (@Berarducci.series_factorization_with_unique_finiteSupportFactor : + ∀ {K : Type v} [Field K] [CharZero K] + {b : Berarducci.Series K}, b ≠ 0 → + ∃ (p : Berarducci.FiniteSupportRing (K := K)) + (factors : List (Berarducci.Series K)), + Berarducci.IsInfiniteSupportIrreducibleFactorization b p factors ∧ + factors.length ≤ + HahnSeries.degreeCantorTermCount (b : K⟦ℝ⟧) ∧ + Berarducci.IsUniqueFiniteSupportFactorUpToScalar b p) + +/- Pending exact target for LM24, Corollary 6.4.2. `DecompositionMonoid` is the +pre-Schreier condition, while `GCDMonoid` contains data and is therefore asserted through +`Nonempty`. This anonymous fixture freezes the proposition without introducing a theorem stub. -/ +example := (fun {K : Type v} [Field K] [CharZero K] ↦ + ((DecompositionMonoid (Berarducci.Series K) ↔ + Nonempty (GCDMonoid (Berarducci.Series K))) ∧ + (Nonempty (GCDMonoid (Berarducci.Series K)) ↔ + ∀ c : Berarducci.Series K, + Irreducible c → (c : K⟦ℝ⟧).support.Infinite → Prime c))) + +/- Boundary guardrail for Theorem 6.4.1: the source permits `n = 0`. -/ +example := (Tests.one_empty_infiniteSupportIrreducibleFactorization : + Berarducci.IsInfiniteSupportIrreducibleFactorization + (1 : Berarducci.Series ℚ) + (1 : Berarducci.FiniteSupportRing (K := ℚ)) []) + +/- Scalar-uniqueness guardrail: literal equality of finite-support factors is false. -/ +example := (Tests.neg_one_finiteSupportFactor_ne_one : + (-1 : Berarducci.FiniteSupportRing (K := ℚ)) ≠ 1) + +/- LM24, Section 6.5, definition of almost irreducibility. The factorisation form makes the +quotient in the printed wording explicit without choosing a division operation. -/ +example := (@HahnSeries.Nonpositive.isAlmostIrreducible_iff : + ∀ {H : AddSubgroup ℝ} {K : Type v} [Field K] + {b : HahnSeries.Nonpositive H K}, + HahnSeries.Nonpositive.IsAlmostIrreducible b ↔ + ∀ c d : HahnSeries.Nonpositive H K, b = c * d → + ¬HahnSeries.Nonpositive.IsMonomial c → + HahnSeries.Nonpositive.IsMonomial d) + +/- LM24, Remark 6.5.1, first assertion. -/ +example := (@HahnSeries.Nonpositive.Irreducible.isAlmostIrreducible : + ∀ {H : AddSubgroup ℝ} {K : Type v} [Field K] + {b : HahnSeries.Nonpositive H K}, Irreducible b → + HahnSeries.Nonpositive.IsAlmostIrreducible b) + +/- Corrected second assertion of LM24, Remark 6.5.1. The printed statement omits the +necessary hypothesis that `b` is not a unit. -/ +open HahnSeries.Nonpositive in +example := (@IsAlmostIrreducible.irreducible_of_not_isUnit_of_realSupportSup_eq_zero : + ∀ {H : AddSubgroup ℝ} {K : Type v} [Field K] + {b : HahnSeries.Nonpositive H K}, + HahnSeries.Nonpositive.IsAlmostIrreducible b → ¬IsUnit b → + HahnSeries.Nonpositive.realSupportSup H b = 0 → Irreducible b) + +/- Counterexample to the printed second assertion of LM24, Remark 6.5.1. -/ +example := (Tests.one_almostIrreducible_counterexample : + HahnSeries.Nonpositive.IsAlmostIrreducible + (1 : Tests.RealExponentSeries) ∧ + HahnSeries.Nonpositive.realSupportSup Tests.RealExponentSubgroup + (1 : Tests.RealExponentSeries) = 0 ∧ + ¬Irreducible (1 : Tests.RealExponentSeries)) + +/- LM24, Remark 6.5.1, final assertion. -/ +example := (@HahnSeries.Nonpositive.not_irreducible_of_realSupportSup_lt_zero : + ∀ {H : AddSubgroup ℝ} {K : Type v} [Field K] [DivisibleBy H ℤ] + {b : HahnSeries.Nonpositive H K}, + HahnSeries.Nonpositive.realSupportSup H b < 0 → ¬Irreducible b) + +/- Corrected exact target for LM24, Lemma 6.5.2. The printed universal quantifier includes +`p = 0`, although the proof and the notation `p_H` require `p ≠ 0`. This proposition remains +uninhabited until the Ritt-factorisation prerequisites are available. -/ +example := (fun {H : AddSubgroup ℝ} {K : Type v} [Field K] [CharZero K] + [DivisibleBy H ℤ] + (p : HahnSeries.Nonpositive.FiniteSupportRing (G := ℝ) (K := K)) ↦ + p ≠ 0 → + ∃! q : HahnSeries.Nonpositive.ConstantTermOneFiniteSupport + (G := H) (K := K), + HahnSeries.Nonpositive.IsNormalizedHPart H p q) + +/- Semantic boundary for the normalized `H`-part predicate: the identity has the identity as +its unique normalized part. -/ +example := (@HahnSeries.Nonpositive.existsUnique_normalizedHPart_one : + ∀ (H : AddSubgroup ℝ) {K : Type v} [Field K], + ∃! q : HahnSeries.Nonpositive.ConstantTermOneFiniteSupport + (G := H) (K := K), + HahnSeries.Nonpositive.IsNormalizedHPart H + (1 : HahnSeries.Nonpositive.FiniteSupportRing (G := ℝ) (K := K)) q) + +/- The uniqueness part of LM24, Lemma 6.5.2 is proved without the Ritt existence input. -/ +example := (@HahnSeries.Nonpositive.IsNormalizedHPart.eq : + ∀ {H : AddSubgroup ℝ} {K : Type v} [Field K] + {p : HahnSeries.Nonpositive.FiniteSupportRing (G := ℝ) (K := K)} + {q q' : HahnSeries.Nonpositive.ConstantTermOneFiniteSupport + (G := H) (K := K)}, + HahnSeries.Nonpositive.IsNormalizedHPart H p q → + HahnSeries.Nonpositive.IsNormalizedHPart H p q' → q = q') + +/- Corrected exact target for LM24, Corollary 6.5.3. The nonzero hypothesis ensures that the +normalized `H`-part of `p(b)` is defined. This relational statement avoids choosing it before +Lemma 6.5.2 is proved. -/ +example := (fun {H : AddSubgroup ℝ} {K : Type v} [Field K] [CharZero K] + [DivisibleBy H ℤ] (b : HahnSeries.Nonpositive ℝ K) ↦ + b ≠ 0 → + ∀ pH : HahnSeries.Nonpositive.ConstantTermOneFiniteSupport (G := H) (K := K), + HahnSeries.Nonpositive.IsNormalizedHPart H + (Berarducci.seriesNormalizedMaximalFiniteSupportDivisor b) pH → + ∀ q : HahnSeries.Nonpositive.ConstantTermOneFiniteSupport (G := H) (K := K), + HahnSeries.Nonpositive.mapDomainToReal H + ((q : HahnSeries.Nonpositive.FiniteSupportRing (G := H) (K := K)) : + HahnSeries.Nonpositive H K) ∣ b ↔ + (q : HahnSeries.Nonpositive.FiniteSupportRing (G := H) (K := K)) ∣ + (pH : HahnSeries.Nonpositive.FiniteSupportRing (G := H) (K := K))) + +/- The proved, prerequisite-explicit reduction underlying Corollary 6.5.3. -/ +example := (@HahnSeries.Nonpositive.normalizedHPart_dvd_iff_dvd_series : + ∀ (H : AddSubgroup ℝ) {K : Type v} [Field K] + {b : HahnSeries.Nonpositive ℝ K} + {p : HahnSeries.Nonpositive.FiniteSupportRing (G := ℝ) (K := K)} + {pH : HahnSeries.Nonpositive.ConstantTermOneFiniteSupport (G := H) (K := K)}, + Berarducci.IsNormalizedSeriesMaximalFiniteSupportDivisor b p → + HahnSeries.Nonpositive.IsNormalizedHPart H p pH → + ∀ q : HahnSeries.Nonpositive.ConstantTermOneFiniteSupport (G := H) (K := K), + HahnSeries.Nonpositive.mapDomainToReal H + ((q : HahnSeries.Nonpositive.FiniteSupportRing (G := H) (K := K)) : + HahnSeries.Nonpositive H K) ∣ b ↔ + (q : HahnSeries.Nonpositive.FiniteSupportRing (G := H) (K := K)) ∣ + (pH : HahnSeries.Nonpositive.FiniteSupportRing (G := H) (K := K))) + +/- Corrected relational target for LM24, Corollary 6.5.4. Both inputs are nonzero because the +normalized `H`-part is a partial operation with codomain `1 + K(H^{<0})`. -/ +example := (fun {H : AddSubgroup ℝ} {K : Type v} [Field K] [CharZero K] + [DivisibleBy H ℤ] + (p q : HahnSeries.Nonpositive.FiniteSupportRing (G := ℝ) (K := K)) ↦ + p ≠ 0 → q ≠ 0 → + ∀ pH qH pqH : HahnSeries.Nonpositive.ConstantTermOneFiniteSupport + (G := H) (K := K), + HahnSeries.Nonpositive.IsNormalizedHPart H p pH → + HahnSeries.Nonpositive.IsNormalizedHPart H q qH → + HahnSeries.Nonpositive.IsNormalizedHPart H (p * q) pqH → + pqH = pH * qH) + +/- The proved reduction underlying Corollary 6.5.4 isolates exactly the factor-refinement input +used in the printed proof. -/ +example := (@HahnSeries.Nonpositive.normalizedHPart_mul_eq : + ∀ (H : AddSubgroup ℝ) {K : Type v} [Field K], + HahnSeries.Nonpositive.HasNormalizedHDivisorRefinement H (K := K) → + ∀ {p q : HahnSeries.Nonpositive.FiniteSupportRing (G := ℝ) (K := K)} + {pH qH pqH : HahnSeries.Nonpositive.ConstantTermOneFiniteSupport + (G := H) (K := K)}, + HahnSeries.Nonpositive.IsNormalizedHPart H p pH → + HahnSeries.Nonpositive.IsNormalizedHPart H q qH → + HahnSeries.Nonpositive.IsNormalizedHPart H (p * q) pqH → + pqH = pH * qH) + +/- Nonconstant semantic certificate for the multiplication reduction: for the trivial exponent +subgroup, the normalized part of `(1 + t⁻¹)²` is `1`, although `1 + t⁻¹` is not its embedded +normalized part. -/ +example := (Tests.normalizedPartNonconstantSeries_ne_embeddedPart : + Tests.normalizedPartNonconstantSeries ≠ + HahnSeries.Nonpositive.finiteSupportToReal Tests.TrivialExponentSubgroup + (1 : HahnSeries.Nonpositive.FiniteSupportRing + (G := Tests.TrivialExponentSubgroup) (K := ℚ))) + +example := (Tests.normalizedPartNonconstantSeries_mul_isNormalizedPart : + HahnSeries.Nonpositive.IsNormalizedHPart Tests.TrivialExponentSubgroup + (Tests.normalizedPartNonconstantSeries * + Tests.normalizedPartNonconstantSeries) 1) + +/- Corrected relational target for LM24, Corollary 6.5.5. -/ +example := (fun {H : AddSubgroup ℝ} {K : Type v} [Field K] [CharZero K] + [DivisibleBy H ℤ] (b c : HahnSeries.Nonpositive ℝ K) ↦ + b ≠ 0 → c ≠ 0 → + ∀ bH cH bcH : HahnSeries.Nonpositive.ConstantTermOneFiniteSupport + (G := H) (K := K), + HahnSeries.Nonpositive.IsNormalizedHPart H + (Berarducci.seriesNormalizedMaximalFiniteSupportDivisor b) bH → + HahnSeries.Nonpositive.IsNormalizedHPart H + (Berarducci.seriesNormalizedMaximalFiniteSupportDivisor c) cH → + HahnSeries.Nonpositive.IsNormalizedHPart H + (Berarducci.seriesNormalizedMaximalFiniteSupportDivisor (b * c)) bcH → + bcH = bH * cH) + +/- The proved reduction underlying Corollary 6.5.5 keeps both mathematical prerequisites +explicit: normalized-divisor refinement and multiplicativity of the real maximal finite-support +divisor. -/ +example := (@HahnSeries.Nonpositive.normalizedHPart_seriesMaximal_mul_eq : + ∀ (H : AddSubgroup ℝ) {K : Type v} [Field K], + HahnSeries.Nonpositive.HasNormalizedHDivisorRefinement H (K := K) → + ∀ {b c : HahnSeries.Nonpositive ℝ K} + {bH cH bcH : HahnSeries.Nonpositive.ConstantTermOneFiniteSupport + (G := H) (K := K)}, + HahnSeries.Nonpositive.IsNormalizedHPart H + (Berarducci.seriesNormalizedMaximalFiniteSupportDivisor b) bH → + HahnSeries.Nonpositive.IsNormalizedHPart H + (Berarducci.seriesNormalizedMaximalFiniteSupportDivisor c) cH → + HahnSeries.Nonpositive.IsNormalizedHPart H + (Berarducci.seriesNormalizedMaximalFiniteSupportDivisor (b * c)) bcH → + Berarducci.seriesNormalizedMaximalFiniteSupportDivisor (b * c) = + Berarducci.seriesNormalizedMaximalFiniteSupportDivisor b * + Berarducci.seriesNormalizedMaximalFiniteSupportDivisor c → + bcH = bH * cH) + +/- Exact target for LM24, Corollary 6.5.6. -/ +example := (fun {H : AddSubgroup ℝ} {K : Type v} [Field K] [CharZero K] + [DivisibleBy H ℤ] ↦ + ∀ p : HahnSeries.Nonpositive.ConstantTermOneFiniteSupport (G := H) (K := K), + IsPrimal + (((p : HahnSeries.Nonpositive.FiniteSupportRing (G := H) (K := K)) : + HahnSeries.Nonpositive H K))) + +/- Corrected exact target for LM24, Theorem 6.5.7. The coefficient unit is indispensable. The +first clause gives existence and global uniqueness of the normalized finite-support factor. When +the real support supremum lies in `H`, the second clause gives an irreducible factorisation whose +monomial exponent equals that supremum and is globally unique among such factorisations. -/ +example := (fun {H : AddSubgroup ℝ} {K : Type v} [Field K] [CharZero K] + [DivisibleBy H ℤ] (b : HahnSeries.Nonpositive H K) ↦ + b ≠ 0 → + ∃ (k : Kˣ) + (p : HahnSeries.Nonpositive.ConstantTermOneFiniteSupport (G := H) (K := K)) + (x : HahnSeries.Nonpositive.exponentMonoid H) + (factors : List (HahnSeries.Nonpositive H K)), + HahnSeries.Nonpositive.IsAlmostIrreducibleFactorization b k p x factors ∧ + HahnSeries.Nonpositive.IsUniqueNormalizedHFactor b p ∧ + ((∃ s : H, HahnSeries.Nonpositive.realSupportSup H b = ((s : ℝ) : WithBot ℝ)) → + ∃ (k' : Kˣ) (x' : HahnSeries.Nonpositive.exponentMonoid H) + (factors' : List (HahnSeries.Nonpositive H K)), + HahnSeries.Nonpositive.IsIrreducibleSubgroupFactorization + b k' p x' factors' ∧ + HahnSeries.Nonpositive.realSupportSup H b = + ((((x' : H) : ℝ) : WithBot ℝ)) ∧ + HahnSeries.Nonpositive.IsUniqueIrreducibleFactorizationExponent b x')) + +/- Scalar boundary for Theorem 6.5.7: the corrected factorisation represents `2`, whereas the +same normalized factor, zero exponent, and empty residual list without a scalar do not. -/ +example := (Tests.scalarTwo_almostIrreducibleFactorization : + HahnSeries.Nonpositive.IsAlmostIrreducibleFactorization + (HahnSeries.Nonpositive.C 2 : Tests.FactorizationSeries) + (Units.mk0 2 (by norm_num)) + (1 : HahnSeries.Nonpositive.ConstantTermOneFiniteSupport + (G := Tests.FactorizationExponentSubgroup) (K := ℚ)) + Tests.factorizationZeroExponent []) + +example := (Tests.scalarTwo_ne_unscaled_empty_factorization : + (HahnSeries.Nonpositive.C 2 : Tests.FactorizationSeries) ≠ + (((1 : HahnSeries.Nonpositive.ConstantTermOneFiniteSupport + (G := Tests.FactorizationExponentSubgroup) (K := ℚ)) : + HahnSeries.Nonpositive.FiniteSupportRing + (G := Tests.FactorizationExponentSubgroup) (K := ℚ)) : + Tests.FactorizationSeries) * + (HahnSeries.Nonpositive.finiteSupportMonomial (K := ℚ) + Tests.factorizationZeroExponent : + Tests.FactorizationSeries) * + ([] : List Tests.FactorizationSeries).prod) + +example := (@Berarducci.principalDegreeClassesToPrincipalComponent_smul : + ∀ {K : Type v} [Field K] + (α : NatOrdinal) (k : K) + (x : Berarducci.principalDegreeClasses K α), + Berarducci.principalDegreeClassesToPrincipalComponent K α (k • x) = + k • Berarducci.principalDegreeClassesToPrincipalComponent K α x) + +example := (@Berarducci.principalDegreeClassesEquivPrincipalComponent_mul : + ∀ {K : Type v} [Field K] [CharZero K] + {α β : NatOrdinal} + (x : Berarducci.principalDegreeClasses K α) + (y : Berarducci.principalDegreeClasses K β), + Berarducci.principalDegreeClassesEquivPrincipalComponent K (α + β) + (Berarducci.principalDegreeClassesMul x y) = + Berarducci.principalComponentMul + (Berarducci.principalDegreeClassesEquivPrincipalComponent K α x) + (Berarducci.principalDegreeClassesEquivPrincipalComponent K β y)) + +example := (@Berarducci.PrincipalSubring : + ∀ (K : Type v) [Field K], + Type (max v 1)) + +example := (@Berarducci.principalSubringEmbedding : + ∀ (K : Type v) [Field K] [CharZero K], + Berarducci.PrincipalSubring K →ₐ[K] + Berarducci.DegreeGraded K) + +example := (@Berarducci.principalSubringEmbedding_apply : + ∀ {K : Type v} [Field K] [CharZero K] + (x : Berarducci.PrincipalSubring K) (α : NatOrdinal), + Berarducci.principalSubringEmbedding K x α = + Berarducci.principalComponentToHahnDegreeLayer K α (x α)) + +example := (@Berarducci.mem_principalGradedSubalgebra_iff : + ∀ {K : Type v} [Field K] [CharZero K] + (x : Berarducci.DegreeGraded K), + x ∈ Berarducci.principalSubringSubalgebra K ↔ + Berarducci.IsPrincipalGraded x) + +example := (@MaxAddDegree.residueMap : + ∀ {R : Type u} {M : Type v} [CommRing R] [AddCommMonoid M] + [LinearOrder M] [IsOrderedCancelAddMonoid M] + (ν : MaxAddDegree R M), ν.nonpositiveSubring →+* ν.ResidueRing) + +example := (@MaxAddDegree.residueMap_surjective : + ∀ {R : Type u} {M : Type v} [CommRing R] [AddCommMonoid M] + [LinearOrder M] [IsOrderedCancelAddMonoid M] + (ν : MaxAddDegree R M), Function.Surjective ν.residueMap) + +example := (@MaxAddDegree.residueMap_ker : + ∀ {R : Type u} {M : Type v} [CommRing R] [AddCommMonoid M] + [LinearOrder M] [IsOrderedCancelAddMonoid M] + (ν : MaxAddDegree R M), + RingHom.ker ν.residueMap = ν.negativeIdeal) + +example := (@MaxAddDegree.residueQuotientEquiv : + ∀ {R : Type u} {M : Type v} [CommRing R] [AddCommMonoid M] + [LinearOrder M] [IsOrderedCancelAddMonoid M] + (ν : MaxAddDegree R M), + ν.nonpositiveSubring ⧸ ν.negativeIdeal ≃+* ν.ResidueRing) + +example := (@MaxAddDegree.nonpositiveSubring_ofValuation_eq_integer : + ∀ {R : Type u} {M : Type v} [CommRing R] [AddCommGroup M] + [LinearOrder M] [IsOrderedAddMonoid M] + (w : Valuation R (WithZero (Multiplicative M))), + (MaxAddDegree.ofValuation w).nonpositiveSubring = w.integer) + +example := (@MaxAddDegree.negativeIdeal_ofValuation_eq_comap_ltIdeal : + ∀ {R : Type u} {M : Type v} [CommRing R] [AddCommGroup M] + [LinearOrder M] [IsOrderedAddMonoid M] + (w : Valuation R (WithZero (Multiplicative M))), + (MaxAddDegree.ofValuation w).negativeIdeal = + (w.ltIdeal 1).comap (MaxAddDegree.nonpositiveEquivInteger w).toRingHom) + +example := (@HahnSeries.Nonpositive.real_hahn_series_finite_support_residue : + ∀ {K : Type v} [Field K] [CharZero K], + ∃ w : MaxAddDegree (HahnSeries.Nonpositive ℝ K) NatOrdinal, w.IsMultiplicative ∧ + (∀ b, w b = (b : K⟦ℝ⟧).degree) ∧ + w.nonpositiveSubring = HahnSeries.Nonpositive.finiteSupportSubring ∧ + w.negativeIdeal = ⊥ ∧ Function.Bijective w.residueMap) + +example := (@HahnSeries.Nonpositive.real_hahn_series_degree_valuation : + ∀ {K : Type v} [Field K] [CharZero K] + (b c : HahnSeries.Nonpositive ℝ K), b ≠ 0 → c ≠ 0 → + ((b + c : HahnSeries.Nonpositive ℝ K) : K⟦ℝ⟧).degree ≤ + max (b : K⟦ℝ⟧).degree (c : K⟦ℝ⟧).degree ∧ + ((b * c : HahnSeries.Nonpositive ℝ K) : K⟦ℝ⟧).degree = + (b : K⟦ℝ⟧).degree + (c : K⟦ℝ⟧).degree ∧ + ((b : K⟦ℝ⟧).degree = ⊥ ↔ b = 0)) + +example := (@HahnSeries.Nonpositive.exists_finiteSupport_split_of_dvd_mul : + ∀ {K : Type v} [Field K] [CharZero K] + {p b c : HahnSeries.Nonpositive ℝ K}, + p ∈ HahnSeries.Nonpositive.finiteSupportSubring → p ∣ b * c → + ∃ p₁ p₂ : HahnSeries.Nonpositive ℝ K, + p₁ ∈ HahnSeries.Nonpositive.finiteSupportSubring ∧ + p₂ ∈ HahnSeries.Nonpositive.finiteSupportSubring ∧ + p = p₁ * p₂ ∧ p₁ ∣ b ∧ p₂ ∣ c) + +/- LM24, Corollary 6.3.9. -/ +example := (@HahnSeries.Nonpositive.isPrimal_of_mem_finiteSupportSubring : + ∀ {K : Type v} [Field K] [CharZero K] + {p : HahnSeries.Nonpositive ℝ K}, + p ∈ HahnSeries.Nonpositive.finiteSupportSubring → IsPrimal p) + +/- Berarducci, Definition 6.6. The residual point is strictly negative, and the translated closed +truncation has exactly the residual value. -/ +example := (@Berarducci.mem_residualPointSet_iff : + ∀ {K : Type v} [Field K] + {b : Berarducci.SeriesWithOrdinalValueAboveOne K} {γ : ℝ}, + γ ∈ Berarducci.residualPointSet b ↔ + γ < 0 ∧ + Berarducci.ordinalValue + (Berarducci.translatedTruncation (b.1 : K⟦ℝ⟧) γ) = b.residualValue) + +example := (@Berarducci.residualPointTail_eq_inter_Ioo : + ∀ {K : Type v} [Field K] + (b : Berarducci.SeriesWithOrdinalValueAboveOne K) (η : ℝ), + Berarducci.residualPointTail b η = + Berarducci.residualPointSet b ∩ Set.Ioo η 0) + +/- Berarducci, Lemma 6.8. The statement is unchanged; the proof treats residual value one by +isolated support points rather than by the failing limit-index construction in the printed proof. -/ +example := ((fun {_} [_] [_] b ↦ Berarducci.residualPointTail_eventually b) : + ∀ {K : Type v} [Field K] [CharZero K] + (b : Berarducci.SeriesWithOrdinalValueAboveOne K), + ∀ᶠ η in nhdsWithin (0 : ℝ) (Set.Iio 0), + (Berarducci.residualPointTail b η).Nonempty ∧ + ∃ htail : (Berarducci.residualPointTail b η).IsPWO, + htail.orderType = b.principalValue.val ∧ + IsLUB (Berarducci.residualPointTail b η) 0) + +/- Berarducci, Lemma 6.9, with the domain of `X(b)` and `v_J^p(b)` made explicit. -/ +example := ((fun {_} [_] [_] ↦ + @Berarducci.ordinalValue_ge_of_eventually_ordinalValue_translatedTruncation_ge _ _) : + ∀ {K : Type v} [Field K] [CharZero K] + (b : Berarducci.SeriesWithOrdinalValueAboveOne K) (c : Berarducci.Series K) + {ρ : Ordinal}, Ordinal.IsPrincipal (fun α β ↦ α + β) ρ → + (∀ᶠ γ in nhdsWithin (0 : ℝ) (Set.Iio 0), + γ ∈ Berarducci.residualPointSet b → + NatOrdinal.of ρ ≤ + Berarducci.ordinalValue (Berarducci.translatedTruncation (c : K⟦ℝ⟧) γ)) → + NatOrdinal.of (ρ * b.principalValue.val) ≤ Berarducci.ordinalValue c) + +example := (@conwayRefinementConjecture_def : + ConwayRefinementConjecture.{u} ↔ + ∀ a b c d : Surreal.OmnificInteger.{u}, a * b = c * d → + ∃ e f g h : Surreal.OmnificInteger.{u}, + a = e * f ∧ b = g * h ∧ c = e * g ∧ d = f * h) + +/- *On Numbers and Games*, Theorem 31, as recalled in LM24, Section 1.1. -/ +example := (@Surreal.isOmnificInteger_iff_normalForm : + ∀ {x : Surreal.{u}}, + Surreal.IsOmnificInteger x ↔ + x.support ⊆ Set.Ici 0 ∧ + x.coeff 0 ∈ Set.range ((↑) : ℤ → ℝ)) + +/- LM24, Sections 1.1 and 1.5, after the change of variable `t = ω⁻¹`. -/ +example := (@Surreal.supportOrderType_toFullHahnSeries : + ∀ (x : Surreal.{u}), + x.toFullHahnSeries.supportOrderType = Ordinal.lift.{u + 1, u} x.length) + +example := (@Surreal.supportDegree_toFullHahnSeries : + ∀ (x : Surreal.{u}), x.toFullHahnSeries.degree = x.supportDegree) + +/- LM24, Proposition 2.4.3: every nonzero surreal Archimedean stratum is order-additively +isomorphic to the reals. -/ +example := (@Surreal.stratumOrderAddMonoidIsoReal : + ∀ (s : HahnEmbedding.ArchimedeanStrata ℝ Surreal.{u}) + (c : FiniteArchimedeanClass Surreal.{u}), s.stratum c ≃+o ℝ) + +/- Universe-bounded LM24, Proposition 2.4.4: every nonzero surreal Archimedean ball has +cofinality at least the cardinal bounding small Conway normal forms. -/ +example := (@Surreal.smallSupportCardinal_le_ball_cof : + ∀ (c : FiniteArchimedeanClass Surreal.{u}), + Surreal.smallSupportCardinal.{u} ≤ + Order.cof ↥(FiniteArchimedeanClass.ball ℝ c)) + +/- LM24, Definition 8.2.6. Reducedness is defined only for a nonzero series, and the witnessing +Archimedean class may be the zero class. -/ +example := (@HahnSeries.Nonpositive.IsReduced.elim : + ∀ {G : Type u} {R : Type v} + [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] [Ring R] + {b : HahnSeries.Nonpositive G R}, HahnSeries.Nonpositive.IsReduced b → + b ≠ 0 ∧ ∃ c : ArchimedeanClass G, + (b : R⟦G⟧).support ∩ + ((b - 1 : HahnSeries.Nonpositive G R) : R⟦G⟧).support ⊆ + {x | ArchimedeanClass.mk x = c}) + +/- The zero Archimedean class is a genuine witness, while mixing zero with a nonzero class is +not reduced. -/ +example := (Tests.reducedConstant_isReduced : + HahnSeries.Nonpositive.IsReduced Tests.reducedConstant) + +example := (Tests.nonreducedTwoClass_not_isReduced : + ¬HahnSeries.Nonpositive.IsReduced Tests.nonreducedTwoClass) + +/- The finite calculation before LM24, Definition 8.4.2 uses the classes met by the support, +including the zero class. These are not the individual support exponents. -/ +example := (@HahnSeries.Nonpositive.mem_supportArchimedeanClasses : + ∀ {G : Type u} {R : Type v} + [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] [Ring R] + (b : HahnSeries.Nonpositive G R) (c : ArchimedeanClass G), + c ∈ HahnSeries.Nonpositive.supportArchimedeanClasses b ↔ + ∃ g ∈ (b : R⟦G⟧).support, ArchimedeanClass.mk g = c) + +/- LM24's finite calculation removes the leading class at each open truncation. The Mathlib +order on classes is opposite to LM24's. This signature checks strict support-class descent. -/ +example := (@HahnSeries.Nonpositive.supportArchimedeanClasses_tau_ssubset : + ∀ {K : Type u} {G : Type u} {R : Type v} + [DivisionRing K] [LinearOrder K] [IsOrderedRing K] [Archimedean K] + [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [Module K G] [IsOrderedModule K G] [Ring R] + (b : HahnSeries.Nonpositive G R) (_hb0 : b ≠ 0) + (horder : (b : R⟦G⟧).order ≠ 0), + HahnSeries.Nonpositive.supportArchimedeanClasses + (HahnSeries.Nonpositive.tau (K := K) + (HahnSeries.Nonpositive.leadingClass b horder) b) ⊂ + HahnSeries.Nonpositive.supportArchimedeanClasses b) + +/- The leading reduction in LM24, Proposition 8.2.5 is reduced. This one-step certificate, +together with strict descent, does not assert the closed finite-product formula in Section 8.4. -/ +example := (@HahnSeries.Nonpositive.isReduced_rho_leadingClass_of_tau_ne_zero : + ∀ {K : Type u} {G : Type u} {R : Type v} + [DivisionRing K] [LinearOrder K] [IsOrderedRing K] [Archimedean K] + [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [Module K G] [IsOrderedModule K G] [Field R] + (s : HahnEmbedding.ArchimedeanStrata K G) + (b : HahnSeries.Nonpositive G R) (_hb0 : b ≠ 0) + (horder : (b : R⟦G⟧).order ≠ 0) + (_htau : HahnSeries.Nonpositive.tau (K := K) + (HahnSeries.Nonpositive.leadingClass b horder) b ≠ 0), + HahnSeries.Nonpositive.IsReduced + (HahnSeries.Nonpositive.rho s (HahnSeries.Nonpositive.leadingClass b horder) b)) + +/- Nondegenerate separators: the first support contains both zero and a nonzero exponent; +the second support is infinite but meets only one class. -/ +example := (Tests.FiniteClassReduction.twoClass_support_classes : + HahnSeries.Nonpositive.supportArchimedeanClasses + Tests.FiniteClassReduction.twoClassSeries = + {ArchimedeanClass.mk (-1 : ℝ), ⊤}) + +example := (Tests.FiniteClassReduction.oneRow_support_infinite : + (Berarducci.OneRow.withoutConstant (K := ℝ) : ℝ⟦ℝ⟧).support.Infinite) + +example := (Tests.FiniteClassReduction.oneRow_support_classes : + HahnSeries.Nonpositive.supportArchimedeanClasses + (Berarducci.OneRow.withoutConstant (K := ℝ)) = + {ArchimedeanClass.mk (-1 : ℝ)}) + +/- LM24, Proposition 8.3.6(5), residue-one irreducibility transfer. -/ +example := (@HahnSeries.Nonpositive.irreducible_of_irreducible_splitTruncation_of_tau_eq_one : + ∀ {K : Type u} {G : Type u} {R : Type v} + [DivisionRing K] [LinearOrder K] [IsOrderedRing K] [Archimedean K] + [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [Module K G] [IsOrderedModule K G] [Field R] + (s : HahnEmbedding.ArchimedeanStrata K G) (Z : Subring R) + (b : HahnSeries.truncationIntegerPart G Z) + (_hb0 : (b : HahnSeries.Nonpositive G R) ≠ 0) + (horder : ((b : HahnSeries.Nonpositive G R) : R⟦G⟧).order ≠ 0) + (_htau : HahnSeries.Nonpositive.tauBall (K := K) + (HahnSeries.Nonpositive.leadingClass + (b : HahnSeries.Nonpositive G R) horder) + (b : HahnSeries.Nonpositive G R) = 1) + (_hirr : Irreducible + (HahnSeries.Nonpositive.splitTruncation s + (HahnSeries.Nonpositive.leadingClass + (b : HahnSeries.Nonpositive G R) horder) + (b : HahnSeries.Nonpositive G R))), + Irreducible b) + +/- LM24, Proposition 9.2.2 in the cardinal-bounded model used for surreal normal forms. Its +underlying preimage lemma is used with a domain ambient ring and clears scalar denominators before +applying primality in the residue subring. -/ +example := (@Subring.isPrimal_residueSubring_iff : + ∀ {L : Type u} {A : Type v} [Field L] [CommRing A] [Algebra L A] + {π : A →ₐ[L] L} {S : Subring L} [IsDomain A] {b : A} (hb : π b ∈ S), + IsPrimal (⟨b, hb⟩ : Subring.residueSubring π S) ↔ + (π b ≠ 0 ∧ IsPrimal (⟨π b, hb⟩ : S) ∧ IsPrimal b) ∨ + (π b = 0 ∧ + IsPrimal + (⟨b, Subring.le_fracSubring hb⟩ : + Subring.residueSubring π (Subring.fracSubring S)))) + +example := (@Tests.cardinalProposition922 : + ∀ {K : Type u} {G : Type u} {R : Type v} {κ : Cardinal.{u}} + [DivisionRing K] [LinearOrder K] [IsOrderedRing K] [Archimedean K] + [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [Module K G] [IsOrderedModule K G] [Field R] + [Fact (Cardinal.aleph0 < κ)] [Fact κ.IsRegular] + (s : HahnEmbedding.ArchimedeanStrata K G) (Z : Subring R) + (b : HahnSeries.cardSuppLTTruncationIntegerPart + (G := G) (R := R) (κ := κ) Z) + (_hb0 : HahnSeries.CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b ≠ 0) + (horder : ((HahnSeries.CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b : + HahnSeries.Nonpositive G R) : R⟦G⟧).order ≠ 0) + (_hbReduced : HahnSeries.Nonpositive.IsReduced + (HahnSeries.CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b)) + (_hA2 : LM24.AssumptionA2AtFiniteClass (K := K) κ Z + (HahnSeries.Nonpositive.leadingClass + (HahnSeries.CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b) horder)), + IsPrimal b ↔ + IsPrimal (HahnSeries.Nonpositive.splitTruncationCardSuppLT s + (HahnSeries.Nonpositive.leadingClass + (HahnSeries.CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b) horder) + (HahnSeries.CardSuppLTTruncationIntegerPart.toNonpositiveRingHom Z b) + (HahnSeries.CardSuppLTTruncationIntegerPart.cardSupp_toNonpositiveRingHom_lt Z b))) + +end ExactSignatures diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Tests/UpstreamReuse.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Tests/UpstreamReuse.lean new file mode 100644 index 0000000000..66a1684a13 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Tests/UpstreamReuse.lean @@ -0,0 +1,160 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +import Mathlib.Algebra.Divisibility.Basic +import Mathlib.Algebra.DirectSum.Ring +import Mathlib.Algebra.Group.Subgroup.Lattice +import Mathlib.Algebra.MonoidAlgebra.ToDirectSum +import Mathlib.Algebra.MvPolynomial.Eval +import Mathlib.Algebra.Order.Archimedean.Real.Basic +import Mathlib.FieldTheory.AlgebraicClosure +import Mathlib.LinearAlgebra.Basis.VectorSpace +import Mathlib.LinearAlgebra.DirectSum.TensorProduct +import Mathlib.LinearAlgebra.Dual.Lemmas +import Mathlib.LinearAlgebra.Projection +import Mathlib.RingTheory.Derivation.Basic +import Mathlib.RingTheory.HahnSeries.Cardinal +import Mathlib.RingTheory.Ideal.Prime +import Mathlib.RingTheory.Ideal.Quotient.Operations +import Mathlib.RingTheory.Ideal.Span +import Mathlib.RingTheory.Localization.Basic +import Mathlib.RingTheory.Localization.BaseChange +import Mathlib.RingTheory.Localization.FractionRing +import Mathlib.RingTheory.Valuation.Basic +import Mathlib.RingTheory.Valuation.ExtendToLocalization +import Mathlib.RingTheory.Valuation.Integers +import Mathlib.RingTheory.TensorProduct.Maps +import Mathlib.RingTheory.TensorProduct.MonoidAlgebra +import Mathlib.Order.Bounds.OrderIso +import Mathlib.Order.Filter.Germ.Basic +import Mathlib.Order.Hom.Set +import Mathlib.SetTheory.Ordinal.Arithmetic +import Mathlib.SetTheory.Ordinal.Principal +import Mathlib.SetTheory.Cardinal.Cofinality.Basic +import Mathlib.SetTheory.ZFC.Class +import Mathlib.SetTheory.Ordinal.Family +import LeanPool.ConwayRefinement.CombinatorialGames.NatOrdinal.Pow +import LeanPool.ConwayRefinement.CombinatorialGames.Surreal.HahnSeries.Basic +import LeanPool.ConwayRefinement.CombinatorialGames.Surreal.Ordinal + +/-! +# Upstream reuse checks + +This module pins the availability and compiler-visible signatures of selected upstream interfaces. +The anonymous examples retain these signature checks without adding a mathematical API. +-/ +noncomputable section + +universe u v w + +example : + {o : Ordinal.{u}} → + Ordinal.IsPrincipal (· + ·) o ↔ + o = 0 ∨ o ∈ Set.range fun e : Ordinal.{u} ↦ Ordinal.omega0 ^ e := + @Ordinal.isPrincipal_add_iff_zero_or_omega0_opow + +example : + {o : Ordinal.{u}} → + o ≠ 0 → o - Ordinal.omega0 ^ Ordinal.log Ordinal.omega0 o < o := + @Ordinal.sub_omega0_opow_log_lt + +example : + (Γ : Type u) → + (R : Type v) → + (κ : Cardinal.{u}) → + [PartialOrder Γ] → + [AddCommMonoid Γ] → + [IsOrderedCancelAddMonoid Γ] → + [Ring R] → [Fact (Cardinal.aleph0 ≤ κ)] → Subring (HahnSeries Γ R) := + @HahnSeries.cardSuppLTSubring + +example : + (Γ : Type u) → + (R : Type v) → + (κ : Cardinal.{u}) → + [LinearOrder Γ] → + [AddCommGroup Γ] → + [IsOrderedAddMonoid Γ] → + [Field R] → [Fact (Cardinal.aleph0 < κ)] → Subfield (HahnSeries Γ R) := + @HahnSeries.cardSuppLTSubfield + +example : + ∀ {α : Type u} [Preorder α] {c : Cardinal.{u}}, + c ≤ Order.cof α ↔ ∀ s : Set α, IsCofinal s → c ≤ Cardinal.mk ↥s := + @Order.le_cof_iff + +example : + ∀ {α : Type u} [LinearOrder α] {s : Set α}, + ¬ IsCofinal s ↔ ∃ x, ∀ y ∈ s, y < x := + @not_isCofinal_iff + +example : + ∀ {Γ : Type u} {R : Type v} [PartialOrder Γ] [AddCommMonoid Γ] + [IsOrderedCancelAddMonoid Γ] [NonUnitalNonAssocSemiring R] + (x : HahnSeries Γ R) (a : Γ) (r : R), + (HahnSeries.single a r * x).cardSupp ≤ x.cardSupp := + @HahnSeries.cardSupp_single_mul_le + +example : + {Γ : Type u} → + {Γ' : Type v} → + {R : Type w} → + [PartialOrder Γ] → + [Zero R] → + [PartialOrder Γ'] → + HahnSeries Γ (HahnSeries Γ' R) ≃ HahnSeries (Lex (Γ × Γ')) R := + @HahnSeries.iterateEquiv + +example : + {Γ : Type u} → + {R : Type v} → + [Zero R] → + [PartialOrder Γ] → + [DecidableLT Γ] → Γ → ZeroHom (HahnSeries Γ R) (HahnSeries Γ R) := + @HahnSeries.truncLT + +example : + {Γ : Type u} → + {Γ' : Type v} → + {R : Type w} → + [PartialOrder Γ] → + [Zero R] → + [PartialOrder Γ'] → + (Γ ↪o Γ') → HahnSeries Γ R → HahnSeries Γ' R := + @HahnSeries.embDomain + +example : + {Γ : Type u} → + {Γ' : Type v} → + {R : Type w} → + [PartialOrder Γ] → + [Zero R] → + [PartialOrder Γ'] → + {f : Γ ↪o Γ'} → + {x : HahnSeries Γ R} → + (HahnSeries.embDomain f x).support ⊆ f '' x.support := + @HahnSeries.support_embDomain_subset + +example : + {α : Type u} → + [Preorder α] → + [SupSet α] → + {s : Set α} → + s.Nonempty → + BddAbove s → + ((sSup s : α) : WithBot α) = + sSup ((fun a : α ↦ (a : WithBot α)) '' s) := + @WithBot.coe_sSup' + +example : + ∀ x : SurrealHahnSeries.{u}, + Ordinal.type (α := x.support) (· > ·) = Ordinal.lift.{u + 1} x.length := + @SurrealHahnSeries.type_support + +example : + ∀ {α : Type v} [Small.{u} α] (f : Ordinal.{u} → α), ¬Function.Injective f := + @not_injective_of_ordinal diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Topology.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Topology.lean new file mode 100644 index 0000000000..8f7f634056 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Topology.lean @@ -0,0 +1,16 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Topology.CantorBendixson +public import LeanPool.ConwayRefinement.ConwayRefinement.Topology.CantorBendixsonProduct +public import LeanPool.ConwayRefinement.ConwayRefinement.Topology.CantorBendixsonRank +public import LeanPool.ConwayRefinement.ConwayRefinement.Topology.CantorBendixsonReconstruction +public import LeanPool.ConwayRefinement.ConwayRefinement.Topology.Order +public import LeanPool.ConwayRefinement.ConwayRefinement.Topology.Tests + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Topology/CantorBendixson.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Topology/CantorBendixson.lean new file mode 100644 index 0000000000..5ac8d66bef --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Topology/CantorBendixson.lean @@ -0,0 +1,190 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import Mathlib.Topology.DerivedSet +public import Mathlib.Topology.Sets.Closeds +public import Mathlib.SetTheory.Ordinal.Arithmetic +import Mathlib.Order.TransfiniteIteration +public import Mathlib.Topology.Maps.Basic +import Mathlib.Topology.Compactness.Compact + +/-! +# Transfinite Cantor–Bendixson derivatives + +The derivative is taken in the given ambient topology. Its transfinite iteration on a closed +set takes intersections at limit ordinals. Closed maps with finite fibers lift membership in +every derivative of the image. No countability or scatteredness assumption is imposed. +-/ + +public noncomputable section + +open Set Topology Order + +universe u v w + +namespace TopologicalSpace.Closeds + +variable {X : Type u} [TopologicalSpace X] [T1Space X] + +/-- The set of accumulation points of a closed set, in the ambient topology. -/ +def derived (s : Closeds X) : Closeds X := ⟨derivedSet (s : Set X), isClosed_derivedSet _⟩ + +@[simp] +theorem coe_derived (s : Closeds X) : (s.derived : Set X) = derivedSet (s : Set X) := (rfl) + +theorem derived_le (s : Closeds X) : s.derived ≤ s := + (isClosed_iff_derivedSet_subset _).mp s.isClosed + +/-- The transfinite Cantor–Bendixson derivative, with the original closed set at stage zero. -/ +def cantorBendixson (s : Closeds X) (o : Ordinal.{w}) : Closeds X := + transfiniteIterate (I := (Closeds X)ᵒᵈ) derived o s + +@[simp] +theorem cantorBendixson_zero (s : Closeds X) : s.cantorBendixson (0 : Ordinal.{w}) = s := by + exact transfiniteIterate_bot (I := (Closeds X)ᵒᵈ) derived s + +@[simp] +theorem cantorBendixson_add_one (s : Closeds X) (o : Ordinal.{w}) : + s.cantorBendixson (o + 1) = (s.cantorBendixson o).derived := by + exact transfiniteIterate_succ (I := (Closeds X)ᵒᵈ) derived s o (not_isMax o) + +theorem cantorBendixson_limit (s : Closeds X) (o : Ordinal.{w}) (ho : IsSuccLimit o) : + s.cantorBendixson o = ⨅ i : Iio o, s.cantorBendixson i.1 := by + exact transfiniteIterate_limit (I := (Closeds X)ᵒᵈ) derived s o ho + +theorem cantorBendixson_mono {s t : Closeds X} (hst : s ≤ t) (o : Ordinal.{w}) : + s.cantorBendixson o ≤ t.cantorBendixson o := by + induction o using Ordinal.limitRecOn with + | zero => simpa using hst + | add_one o ih => + rw [cantorBendixson_add_one, cantorBendixson_add_one] + exact derivedSet_mono _ _ ih + | limit o ho ih => + rw [cantorBendixson_limit _ _ ho, cantorBendixson_limit _ _ ho] + exact iInf_mono fun i ↦ ih i.1 i.2 + +theorem cantorBendixson_antitone (s : Closeds X) : + Antitone (s.cantorBendixson : Ordinal.{w} → Closeds X) := + monotone_transfiniteIterate (I := (Closeds X)ᵒᵈ) derived s derived_le + +theorem cantorBendixson_le (s : Closeds X) (o : Ordinal.{w}) : s.cantorBendixson o ≤ s := by + simpa using s.cantorBendixson_antitone (show 0 ≤ o from zero_le) + +end TopologicalSpace.Closeds + +variable {X : Type u} {Y : Type v} [TopologicalSpace X] [TopologicalSpace Y] + +/-- Every accumulation point of the image under a closed map lifts to an accumulation point. +Continuity and finiteness of the fibers are not required for this single derivative. -/ +theorem IsClosedMap.derivedSet_image_subset {f : X → Y} (hf : IsClosedMap f) (s : Set X) : + derivedSet (f '' s) ⊆ f '' derivedSet s := by + intro y hy + have hfreq := accPt_iff_frequently.mp (mem_derivedSet.mp hy) + obtain ⟨x, hx, h⟩ := hf.frequently_nhds_fiber (p := fun x ↦ f x ≠ y ∧ x ∈ s) y + (hfreq.mono fun z hz ↦ by + obtain ⟨a, ha, rfl⟩ := hz.2 + exact ⟨a, rfl, hz.1, ha⟩) + refine ⟨x, mem_derivedSet.mpr (accPt_iff_frequently.mpr ?_), hx⟩ + exact h.mono fun z hz ↦ ⟨fun hzx ↦ hz.1 (hzx ▸ hx), hz.2⟩ + +/-- A closed map with finite fibers lifts every transfinite derivative of the image. +The statement holds for arbitrary ordinals, including limits of uncountable cofinality. -/ +theorem IsClosedMap.cantorBendixson_image_subset [T1Space X] [T1Space Y] + {f : X → Y} (hf : IsClosedMap f) (hfin : ∀ y, (f ⁻¹' {y}).Finite) + (s : TopologicalSpace.Closeds X) (o : Ordinal.{w}) : + ((⟨f '' (s : Set X), hf _ s.isClosed⟩ : TopologicalSpace.Closeds Y).cantorBendixson o : + Set Y) ⊆ f '' (s.cantorBendixson o : Set X) := by + induction o using Ordinal.limitRecOn with + | zero => simp + | add_one o ih => + simp only [TopologicalSpace.Closeds.cantorBendixson_add_one, + TopologicalSpace.Closeds.coe_derived] + exact (derivedSet_mono _ _ ih).trans (hf.derivedSet_image_subset _) + | limit o ho ih => + intro y hy + rw [TopologicalSpace.Closeds.cantorBendixson_limit _ _ ho] at hy ⊢ + have hymem : ∀ i : Iio o, y ∈ f '' (s.cantorBendixson i.1 : Set X) := + fun i ↦ ih i.1 i.2 ((TopologicalSpace.Closeds.mem_iInf.mp hy) i) + let t (i : Iio o) : Set X := (f ⁻¹' {y}) ∩ (s.cantorBendixson i.1 : Set X) + have htn (i : Iio o) : (t i).Nonempty := by + obtain ⟨x, hx, hxy⟩ := hymem i + exact ⟨x, hxy, hx⟩ + have htd : Directed (· ⊇ ·) t := by + intro i j + refine ⟨max i j, ?_, ?_⟩ + · exact inter_subset_inter_right _ (s.cantorBendixson_antitone (le_max_left i j)) + · exact inter_subset_inter_right _ (s.cantorBendixson_antitone (le_max_right i j)) + have htf (i : Iio o) : (t i).Finite := (hfin y).subset inter_subset_left + let : Nonempty (Iio o) := ⟨⟨0, ho.bot_lt⟩⟩ + obtain ⟨x, hx⟩ := IsCompact.nonempty_iInter_of_directed_nonempty_isCompact_isClosed + t htd htn (fun i ↦ (htf i).isCompact) (fun i ↦ (htf i).isClosed) + have hxi := mem_iInter.mp hx + exact ⟨x, TopologicalSpace.Closeds.mem_iInf.mpr (fun i ↦ (hxi i).2), + (hxi ⟨0, ho.bot_lt⟩).1⟩ + +namespace TopologicalSpace.Closeds + +variable [T1Space X] + +/-- A locally strictly decreasing ordinal label bounds every Cantor–Bendixson stage. +Only other points of the original closed set are required to have smaller nearby labels. -/ +theorem cantorBendixson_subset_of_locally_lt (s : Closeds X) (r : X → Ordinal.{w}) + (hr : ∀ x ∈ s, ∀ᶠ y in 𝓝 x, y ∈ s → y ≠ x → r y < r x) (o : Ordinal.{w}) : + (s.cantorBendixson o : Set X) ⊆ {x | o ≤ r x} := by + induction o using Ordinal.limitRecOn with + | zero => exact fun _ _ ↦ (show (0 : Ordinal) ≤ _ from zero_le) + | add_one o ih => + intro x hx + rw [cantorBendixson_add_one] at hx + have hacc := accPt_iff_frequently.mp (mem_derivedSet.mp hx) + have hxs : x ∈ s := s.cantorBendixson_le (o + 1) (by + rw [cantorBendixson_add_one]; exact hx) + change o + 1 ≤ r x + apply Order.succ_le_iff.mpr + by_contra! hle + obtain ⟨y, hy, hnear⟩ := (hacc.and_eventually (hr x hxs)).exists + exact (not_lt_of_ge (ih hy.2)) + ((hnear (s.cantorBendixson_le o hy.2) hy.1).trans_le hle) + | limit o ho ih => + intro x hx + rw [cantorBendixson_limit _ _ ho] at hx + exact ho.le_iff_forall_le.mpr fun a ha ↦ ih a ha (mem_iInf.mp hx ⟨a, ha⟩) + +/-- Transfinite derivatives commute with binary unions of closed sets. -/ +theorem cantorBendixson_sup (s t : Closeds X) (o : Ordinal.{w}) : + (s ⊔ t).cantorBendixson o = s.cantorBendixson o ⊔ t.cantorBendixson o := by + apply le_antisymm + · induction o using Ordinal.limitRecOn with + | zero => simp + | add_one o ih => + rw [cantorBendixson_add_one, cantorBendixson_add_one, cantorBendixson_add_one] + change (((s ⊔ t).cantorBendixson o).derived : Set X) ⊆ + ((s.cantorBendixson o).derived : Set X) ∪ ((t.cantorBendixson o).derived : Set X) + simp only [coe_derived] + rw [← derivedSet_union] + exact derivedSet_mono _ _ ih + | limit o ho ih => + intro x hx + change x ∈ (s.cantorBendixson o : Set X) ∪ (t.cantorBendixson o : Set X) + by_contra hnot + have hs : x ∉ s.cantorBendixson o := fun hh ↦ hnot (Or.inl hh) + have ht : x ∉ t.cantorBendixson o := fun hh ↦ hnot (Or.inr hh) + rw [cantorBendixson_limit _ _ ho] at hs ht + obtain ⟨i, hi⟩ : ∃ i : Iio o, x ∉ s.cantorBendixson i.1 := by + by_contra! hn + exact hs (mem_iInf.mpr hn) + obtain ⟨j, hj⟩ : ∃ j : Iio o, x ∉ t.cantorBendixson j.1 := by + by_contra! hn + exact ht (mem_iInf.mpr hn) + have hm := ih (max i.1 j.1) (max_lt i.2 j.2) + ((s ⊔ t).cantorBendixson_antitone (max_lt i.2 j.2).le hx) + rcases hm with hm | hm + · exact hi (s.cantorBendixson_antitone (le_max_left _ _) hm) + · exact hj (t.cantorBendixson_antitone (le_max_right _ _) hm) + · exact sup_le (cantorBendixson_mono le_sup_left o) (cantorBendixson_mono le_sup_right o) + +end TopologicalSpace.Closeds diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Topology/CantorBendixsonProduct.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Topology/CantorBendixsonProduct.lean new file mode 100644 index 0000000000..4a06fd60d0 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Topology/CantorBendixsonProduct.lean @@ -0,0 +1,56 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Topology.CantorBendixson +public import LeanPool.ConwayRefinement.CombinatorialGames.NatOrdinal.Basic +public import Mathlib.Topology.Constructions.SumProd + +/-! +# Natural-sum bounds for Cantor–Bendixson derivatives of products + +Locally strictly decreasing ordinal labels on two closed sets give their natural sum as a +bound on the Cantor–Bendixson stages of the product. The addition is Hessenberg addition on +`NatOrdinal`, not ordinary ordinal addition. No countability or compactness is required. +-/ + +public noncomputable section + +open Set Filter Topology TopologicalSpace + +universe u v w + +namespace TopologicalSpace.Closeds + +variable {X : Type u} {Y : Type v} [TopologicalSpace X] [TopologicalSpace Y] + [T1Space X] [T1Space Y] + +/-- Natural addition of locally strictly decreasing ordinal labels bounds product derivatives. -/ +theorem cantorBendixson_prod_subset_of_locally_lt (s : Closeds X) (t : Closeds Y) + (r : X → NatOrdinal.{w}) (q : Y → NatOrdinal.{w}) + (hr : ∀ x ∈ s, ∀ᶠ z in 𝓝 x, z ∈ s → z ≠ x → r z < r x) + (hq : ∀ y ∈ t, ∀ᶠ z in 𝓝 y, z ∈ t → z ≠ y → q z < q y) (o : Ordinal.{w}) : + ((s ×ˢ t).cantorBendixson o : Set (X × Y)) ⊆ {p | o ≤ (r p.1 + q p.2).val} := by + apply cantorBendixson_subset_of_locally_lt + rintro ⟨x, y⟩ hxy + obtain ⟨hx, hy⟩ := mem_prod.mp hxy + rw [nhds_prod_eq] + apply eventually_prod_iff.mpr + refine ⟨_, hr x hx, _, hq y hy, ?_⟩ + intro z hz w hw hzw hne + obtain ⟨hzs, hwt⟩ := mem_prod.mp hzw + apply NatOrdinal.val.lt_iff_lt.mpr + by_cases hzx : z = x + · subst z + have hwy : w ≠ y := fun heq ↦ hne (Prod.ext rfl heq) + exact add_lt_add_right (hw hwt hwy) _ + · have hwle : q w ≤ q y := by + by_cases hwy : w = y + · exact hwy ▸ le_rfl + · exact (hw hwt hwy).le + exact add_lt_add_of_lt_of_le (hz hzs hzx) hwle + +end TopologicalSpace.Closeds diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Topology/CantorBendixsonRank.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Topology/CantorBendixsonRank.lean new file mode 100644 index 0000000000..c462569513 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Topology/CantorBendixsonRank.lean @@ -0,0 +1,144 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Topology.CantorBendixson +public import LeanPool.ConwayRefinement.ConwayRefinement.Topology.Order.PWOAddition +public import Mathlib.SetTheory.Ordinal.Basic +import Mathlib.Topology.DiscreteSubset + +/-! +# Cantor–Bendixson point ranks of well-ordered supports + +For a closed well-ordered subset of a linearly ordered space, each point disappears at a +successor derivative stage. The ordinal index of the point in the well-ordered support gives +a bound, because a sufficiently small neighborhood contains no larger support point. + +The point rank is the least ordinal whose successor derivative omits the point. On the support, +membership in stage `o` is equivalent to `o` being at most the point rank. Points outside the +support have rank zero. All derivatives use the given ambient topology. +-/ + +public noncomputable section + +open Set Filter Topology TopologicalSpace + +universe u + +variable {X : Type u} [LinearOrder X] [TopologicalSpace X] [OrderTopology X] + +/-- A well-ordered support has no points immediately to the right of any given ambient point. -/ +theorem Set.IsPWO.eventually_le {s : Set X} (hs : s.IsPWO) (x : X) : + ∀ᶠ y in 𝓝 x, y ∈ s → y ≤ x := by + let v := s ∩ Ioi x + by_cases hn : v.Nonempty + · have hv : v.IsWF := hs.isWF.mono inter_subset_left + let m := hv.min hn + have hm : m ∈ v := hv.min_mem hn + filter_upwards [Iio_mem_nhds hm.2] with y hy hys + exact le_of_not_gt fun hxy ↦ (not_lt_of_ge (hv.min_le hn ⟨hys, hxy⟩)) hy + · apply Filter.Eventually.of_forall + intro y hy + exact le_of_not_gt fun hxy ↦ hn ⟨y, hy, hxy⟩ + +namespace TopologicalSpace.Closeds + +/-- Every ambient point is absent from some successor derivative of a closed well-ordered set. -/ +theorem exists_notMem_cantorBendixson_succ (s : Closeds X) (hs : (s : Set X).IsPWO) (x : X) : + ∃ o : Ordinal.{u}, x ∉ (s.cantorBendixson (o + 1) : Set X) := by + classical + let : WellFoundedLT (s : Set X) := hs.isWF + let r (y : X) : Ordinal.{u} := + if h : y ∈ s then Ordinal.typein (α := (s : Set X)) (· < ·) ⟨y, h⟩ else 0 + have hr : ∀ y ∈ s, ∀ᶠ z in 𝓝 y, z ∈ s → z ≠ y → r z < r y := by + intro y hy + filter_upwards [hs.eventually_le y] with z hz hzs hzy + simp only [r, dite_eq_left hzs, dite_eq_left hy, Ordinal.typein_lt_typein] + exact (lt_of_le_of_ne (hz hzs) hzy : z < y) + refine ⟨r x, fun hx ↦ ?_⟩ + exact (not_le_of_gt (Order.lt_succ (r x))) + (s.cantorBendixson_subset_of_locally_lt r hr (r x + 1) hx) + +/-- The least ordinal whose successor derivative omits the point; zero outside the set. -/ +def cantorBendixsonRank (s : Closeds X) (hs : (s : Set X).IsPWO) (x : X) : Ordinal.{u} := + wellFounded_lt.min {o : Ordinal.{u} | x ∉ (s.cantorBendixson (o + 1) : Set X)} + (s.exists_notMem_cantorBendixson_succ hs x) + +/-- The successor of the point rank removes that point. -/ +theorem notMem_cantorBendixson_rank_add_one (s : Closeds X) + (hs : (s : Set X).IsPWO) (x : X) : + x ∉ (s.cantorBendixson (s.cantorBendixsonRank hs x + 1) : Set X) := by + exact wellFounded_lt.min_mem + {o : Ordinal.{u} | x ∉ (s.cantorBendixson (o + 1) : Set X)} + (s.exists_notMem_cantorBendixson_succ hs x) + +/-- Any successor stage omitting a point gives an upper bound on its rank. -/ +theorem cantorBendixsonRank_le_of_notMem (s : Closeds X) (hs : (s : Set X).IsPWO) + (x : X) {o : Ordinal.{u}} (ho : x ∉ (s.cantorBendixson (o + 1) : Set X)) : + s.cantorBendixsonRank hs x ≤ o := by + exact WellFoundedLT.min_le ho + +/-- A point belongs to a derivative exactly when it lies in the set and its rank is high enough. -/ +theorem mem_cantorBendixson_iff (s : Closeds X) (hs : (s : Set X).IsPWO) + (x : X) (o : Ordinal.{u}) : + x ∈ (s.cantorBendixson o : Set X) ↔ x ∈ s ∧ o ≤ s.cantorBendixsonRank hs x := by + constructor + · intro hx + refine ⟨s.cantorBendixson_le o hx, ?_⟩ + by_contra! ho + exact s.notMem_cantorBendixson_rank_add_one hs x + (s.cantorBendixson_antitone (Order.succ_le_of_lt ho) hx) + · rintro ⟨hx, ho⟩ + induction o using Ordinal.limitRecOn with + | zero => simpa using hx + | add_one o ih => + by_contra hn + exact (not_le_of_gt ((Order.lt_succ o).trans_le ho)) + (s.cantorBendixsonRank_le_of_notMem hs x hn) + | limit o hlo ih => + rw [cantorBendixson_limit _ _ hlo] + exact mem_iInf.mpr fun i ↦ ih i.1 i.2 (i.2.le.trans ho) + +/-- A support point has rank `o` exactly when it survives stage `o` but not its successor. -/ +theorem cantorBendixsonRank_eq_iff (s : Closeds X) (hs : (s : Set X).IsPWO) + {x : X} (hx : x ∈ s) (o : Ordinal.{u}) : + s.cantorBendixsonRank hs x = o ↔ + x ∈ (s.cantorBendixson o : Set X) ∧ x ∉ (s.cantorBendixson (o + 1) : Set X) := by + constructor + · intro he + exact ⟨(s.mem_cantorBendixson_iff hs x o).mpr ⟨hx, he.ge⟩, + he ▸ s.notMem_cantorBendixson_rank_add_one hs x⟩ + · rintro ⟨hm, hn⟩ + exact le_antisymm (s.cantorBendixsonRank_le_of_notMem hs x hn) + ((s.mem_cantorBendixson_iff hs x o).mp hm).2 + +/-- The rank convention assigns zero to points outside the original closed set. -/ +theorem cantorBendixsonRank_of_notMem (s : Closeds X) (hs : (s : Set X).IsPWO) + {x : X} (hx : x ∉ s) : s.cantorBendixsonRank hs x = 0 := by + apply le_antisymm _ zero_le + apply s.cantorBendixsonRank_le_of_notMem hs x + exact fun h ↦ hx (s.cantorBendixson_le _ h) + +/-- Every point has rank zero relative to a finite closed set. -/ +theorem cantorBendixsonRank_of_finite (s : Closeds X) (hs : (s : Set X).IsPWO) + (hfin : (s : Set X).Finite) (x : X) : s.cantorBendixsonRank hs x = 0 := by + apply le_antisymm _ zero_le + apply s.cantorBendixsonRank_le_of_notMem hs x + rw [cantorBendixson_add_one, cantorBendixson_zero, coe_derived, mem_derivedSet] + exact fun h ↦ hfin.not_infinite (Set.Infinite.of_accPt h) + +/-- All other sufficiently nearby support points have strictly smaller rank. -/ +theorem cantorBendixsonRank_locally_lt (s : Closeds X) (hs : (s : Set X).IsPWO) + (x : X) : ∀ᶠ y in 𝓝 x, y ∈ s → y ≠ x → + s.cantorBendixsonRank hs y < s.cantorBendixsonRank hs x := by + have hn := s.notMem_cantorBendixson_rank_add_one hs x + rw [cantorBendixson_add_one, coe_derived, mem_derivedSet, accPt_iff_frequently, + Filter.not_frequently] at hn + filter_upwards [hn] with y hy hys hyx + by_contra! hle + exact hy ⟨hyx, (s.mem_cantorBendixson_iff hs y _).mpr ⟨hys, hle⟩⟩ + +end TopologicalSpace.Closeds diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Topology/CantorBendixsonReconstruction.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Topology/CantorBendixsonReconstruction.lean new file mode 100644 index 0000000000..c26348b809 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Topology/CantorBendixsonReconstruction.lean @@ -0,0 +1,507 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Topology.CantorBendixsonRank +public import Mathlib.Topology.Homeomorph.Defs +public import Mathlib.Topology.DiscreteSubset + +import Mathlib.Topology.Maps.Basic + +/-! +# Local reconstruction of Cantor–Bendixson stages + +Transfinite derivatives compose by ordinary ordinal addition and agree locally whenever the +original closed sets agree on an open set. For a closed well-ordered support, the points of +exact rank `a` are dense in its `a`-th derivative. These facts give the reconstruction inequality: +if its rank-`a` points locally belong to another set's `b`-th derivative, then its `(a + c)`-th +stage locally belongs to that set's `(b + c)`-th stage, for every ordinal `c`. + +The statements use the given ambient topology and hold at arbitrary ordinal cofinalities. +-/ + +public noncomputable section + +open Set Filter Topology TopologicalSpace + +universe u v w + +/-- Homeomorphisms preserve every transfinite derivative stage of a closed set. -/ +theorem Homeomorph.mem_cantorBendixson_iff {X Y : Type*} + [TopologicalSpace X] [TopologicalSpace Y] [T1Space X] [T1Space Y] + (e : X ≃ₜ Y) (s : Closeds X) (t : Closeds Y) (he : e '' (s : Set X) = (t : Set Y)) + (x : X) (o : Ordinal.{v}) : + e x ∈ (t.cantorBendixson o : Set Y) ↔ x ∈ (s.cantorBendixson o : Set X) := by + have hf (y : Y) : (e ⁻¹' {y}).Finite := (finite_singleton y).preimage e.injective.injOn + have hg (x : X) : (e.symm ⁻¹' {x}).Finite := + (finite_singleton x).preimage e.symm.injective.injOn + have ht' : (⟨e '' (s : Set X), e.isClosedMap _ s.isClosed⟩ : Closeds Y) = t := + SetLike.coe_injective he + have he' : e.symm '' (t : Set Y) = (s : Set X) := by + rw [← he, ← Set.image_comp] + simp + have hs' : (⟨e.symm '' (t : Set Y), e.symm.isClosedMap _ t.isClosed⟩ : Closeds X) = s := + SetLike.coe_injective he' + have hst := e.isClosedMap.cantorBendixson_image_subset hf s o + have hts := e.symm.isClosedMap.cantorBendixson_image_subset hg t o + rw [ht'] at hst + rw [hs'] at hts + constructor + · intro hx + obtain ⟨y, hy, hyx⟩ := hst hx + exact e.injective hyx ▸ hy + · intro hx + obtain ⟨y, hy, hyx⟩ := hts hx + have hxy : y = e x := by simpa using congrArg e hyx + exact hxy ▸ hy + +namespace TopologicalSpace.Closeds + +variable {X : Type u} [TopologicalSpace X] [T1Space X] + +/-- Iteration of derivative stages corresponds to ordinary ordinal addition. -/ +theorem cantorBendixson_add (s : Closeds X) (a b : Ordinal.{v}) : + s.cantorBendixson (a + b) = (s.cantorBendixson a).cantorBendixson b := by + induction b using Ordinal.limitRecOn with + | zero => simp + | add_one b ih => + rw [← add_assoc, cantorBendixson_add_one, cantorBendixson_add_one, ih] + | limit b hb ih => + rw [cantorBendixson_limit _ _ (Ordinal.isSuccLimit_add a hb), + cantorBendixson_limit _ _ hb] + apply le_antisymm + · apply le_iInf + intro i + rw [← ih i.1 i.2] + exact iInf_le (fun j : Iio (a + b) ↦ s.cantorBendixson j.1) + ⟨a + i.1, (add_lt_add_iff_left a).mpr i.2⟩ + · apply le_iInf + intro i + obtain ⟨j, hj, hij⟩ := (Ordinal.lt_add_iff hb.ne_bot).mp i.2 + exact (iInf_le (fun k : Iio b ↦ (s.cantorBendixson a).cantorBendixson k.1) + ⟨j, hj⟩).trans + ((ih j hj) ▸ s.cantorBendixson_antitone hij) + +end TopologicalSpace.Closeds + +/-- Restricting a set to an open set preserves its derived set inside that open set. -/ +theorem IsOpen.derivedSet_inter_eq {X : Type*} [TopologicalSpace X] {U s : Set X} + (hU : IsOpen U) : derivedSet (s ∩ U) ∩ U = derivedSet s ∩ U := by + ext x + constructor + · rintro ⟨hx, hxU⟩ + exact ⟨derivedSet_mono _ _ inter_subset_left hx, hxU⟩ + · rintro ⟨hx, hxU⟩ + refine ⟨mem_derivedSet.mpr (accPt_iff_frequently.mpr ?_), hxU⟩ + exact ((accPt_iff_frequently.mp (mem_derivedSet.mp hx)).and_eventually + (hU.mem_nhds hxU)).mono fun y hy ↦ ⟨hy.1.1, hy.1.2, hy.2⟩ + +/-- Sets agreeing on an open set have closures agreeing there. -/ +theorem IsOpen.closure_congr {X : Type*} [TopologicalSpace X] {U s t : Set X} + (hU : IsOpen U) (hst : s ∩ U = t ∩ U) : closure s ∩ U = closure t ∩ U := by + ext x + constructor + · intro hx + have hm := hU.closure_inter hx + rw [hst] at hm + exact ⟨closure_mono inter_subset_left hm, hx.2⟩ + · intro hx + have hm := hU.closure_inter hx + rw [← hst] at hm + exact ⟨closure_mono inter_subset_left hm, hx.2⟩ + +/-- Sets agreeing on an open set have derived sets agreeing there. -/ +theorem IsOpen.derivedSet_congr {X : Type*} [TopologicalSpace X] {U s t : Set X} + (hU : IsOpen U) (hst : s ∩ U = t ∩ U) : derivedSet s ∩ U = derivedSet t ∩ U := by + rw [← hU.derivedSet_inter_eq (s := s), hst, hU.derivedSet_inter_eq] + +namespace TopologicalSpace.Closeds + +variable {X : Type u} [TopologicalSpace X] [T1Space X] + +/-- Closed sets agreeing on an open set have every derivative stage agreeing there. -/ +theorem cantorBendixson_congr_on_open (s t : Closeds X) {U : Set X} (hU : IsOpen U) + (hst : (s : Set X) ∩ U = (t : Set X) ∩ U) (o : Ordinal.{v}) : + (s.cantorBendixson o : Set X) ∩ U = (t.cantorBendixson o : Set X) ∩ U := by + induction o using Ordinal.limitRecOn with + | zero => simpa using hst + | add_one o ih => + simpa only [cantorBendixson_add_one, coe_derived] using hU.derivedSet_congr ih + | limit o ho ih => + rw [cantorBendixson_limit _ _ ho, cantorBendixson_limit _ _ ho] + ext x + constructor + · rintro ⟨hx, hxU⟩ + refine ⟨Closeds.mem_iInf.mpr (fun i ↦ ?_), hxU⟩ + exact ((Set.ext_iff.mp (ih i.1 i.2) x).mp + ⟨Closeds.mem_iInf.mp hx i, hxU⟩).1 + · rintro ⟨hx, hxU⟩ + refine ⟨Closeds.mem_iInf.mpr (fun i ↦ ?_), hxU⟩ + exact ((Set.ext_iff.mp (ih i.1 i.2) x).mpr + ⟨Closeds.mem_iInf.mp hx i, hxU⟩).1 + +/-- Local inclusion of closed sets implies local inclusion at every derivative stage. -/ +theorem cantorBendixson_mono_on_open (s t : Closeds X) {U : Set X} (hU : IsOpen U) + (hst : (s : Set X) ∩ U ⊆ (t : Set X)) (o : Ordinal.{v}) : + (s.cantorBendixson o : Set X) ∩ U ⊆ (t.cantorBendixson o : Set X) := by + have he : (s : Set X) ∩ U = ((s ⊓ t : Closeds X) : Set X) ∩ U := by + ext x + constructor + · intro hx + exact ⟨⟨hx.1, hst hx⟩, hx.2⟩ + · rintro ⟨⟨hx, _⟩, hxU⟩ + exact ⟨hx, hxU⟩ + intro x hx + have hx' := (Set.ext_iff.mp (s.cantorBendixson_congr_on_open (s ⊓ t) hU he o) x).mp hx + exact cantorBendixson_mono inf_le_right o hx'.1 + +variable [LinearOrder X] [OrderTopology X] + +/-- Point rank depends only on the closed set in a neighborhood of the point. -/ +theorem cantorBendixsonRank_congr_on_open (s t : Closeds X) + (hs : (s : Set X).IsPWO) (ht : (t : Set X).IsPWO) + {U : Set X} (hU : IsOpen U) (hst : (s : Set X) ∩ U = (t : Set X) ∩ U) + {x : X} (hx : x ∈ U) : s.cantorBendixsonRank hs x = t.cantorBendixsonRank ht x := by + apply le_antisymm + · apply s.cantorBendixsonRank_le_of_notMem hs x + intro hm + have he := s.cantorBendixson_congr_on_open t hU hst (t.cantorBendixsonRank ht x + 1) + exact t.notMem_cantorBendixson_rank_add_one ht x ((Set.ext_iff.mp he x).mp ⟨hm, hx⟩).1 + · apply t.cantorBendixsonRank_le_of_notMem ht x + intro hm + have he := s.cantorBendixson_congr_on_open t hU hst (s.cantorBendixsonRank hs x + 1) + exact s.notMem_cantorBendixson_rank_add_one hs x ((Set.ext_iff.mp he x).mpr ⟨hm, hx⟩).1 + +omit [T1Space X] in +/-- The isolated points of a closed well-ordered support are dense in that support. -/ +theorem closure_isolated_eq (s : Closeds X) (hs : (s : Set X).IsPWO) : + closure {x | x ∈ s ∧ x ∉ derivedSet (s : Set X)} = (s : Set X) := by + apply Subset.antisymm (closure_minimal (fun _ h ↦ h.1) s.isClosed) + intro x hx + apply mem_closure_iff.mpr + intro U hU hxU + let v : Set X := (s : Set X) ∩ U + have hv : v.IsWF := hs.isWF.mono inter_subset_left + have hn : v.Nonempty := ⟨x, hx, hxU⟩ + let m := hv.min hn + have hm : m ∈ v := hv.min_mem hn + refine ⟨m, hm.2, hm.1, ?_⟩ + rw [mem_derivedSet, accPt_iff_frequently, Filter.not_frequently] + filter_upwards [hs.eventually_le m, hU.mem_nhds hm.2] with y hy hyU hn + exact hn.1 ((hy hn.2).antisymm (hv.min_le ‹v.Nonempty› ⟨hn.2, hyU⟩)) + +/-- The exact rank-`o` points are dense in the `o`-th derivative of a well-ordered support. -/ +theorem closure_rank_level_eq (s : Closeds X) (hs : (s : Set X).IsPWO) (o : Ordinal.{u}) : + closure {x | x ∈ s ∧ s.cantorBendixsonRank hs x = o} = + (s.cantorBendixson o : Set X) := by + have hd := (s.cantorBendixson o).closure_isolated_eq (hs.mono (s.cantorBendixson_le o)) + have he : {x | x ∈ s ∧ s.cantorBendixsonRank hs x = o} = + {x | x ∈ (s.cantorBendixson o : Set X) ∧ + x ∉ derivedSet (s.cantorBendixson o : Set X)} := by + ext x + constructor + · rintro ⟨hx, hr⟩ + have hh := (s.cantorBendixsonRank_eq_iff hs hx o).mp hr + simpa only [cantorBendixson_add_one, coe_derived, Set.mem_ofPred_eq] using hh + · intro hh + have hx := s.cantorBendixson_le o hh.1 + refine ⟨hx, (s.cantorBendixsonRank_eq_iff hs hx o).mpr ?_⟩ + simpa only [cantorBendixson_add_one, coe_derived, Set.mem_ofPred_eq] using hh + rw [he] + exact hd + +/-- Local inclusion of exact-rank points lifts to all further derivative stages. -/ +theorem cantorBendixson_reconstruction (s t : Closeds X) (hs : (s : Set X).IsPWO) + {U : Set X} (hU : IsOpen U) (a b c : Ordinal.{u}) + (hlevel : ∀ y ∈ U, y ∈ s → s.cantorBendixsonRank hs y = a → + y ∈ (t.cantorBendixson b : Set X)) : + (s.cantorBendixson (a + c) : Set X) ∩ U ⊆ + (t.cantorBendixson (b + c) : Set X) := by + have hlocal : (s.cantorBendixson a : Set X) ∩ U ⊆ (t.cantorBendixson b : Set X) := by + intro x hx + have hl : x ∈ closure {y | y ∈ s ∧ s.cantorBendixsonRank hs y = a} := by + rw [s.closure_rank_level_eq hs a] + exact hx.1 + have hf := (mem_closure_iff_frequently.mp hl).and_eventually (hU.mem_nhds hx.2) + exact (t.cantorBendixson b).isClosed.closure_subset + (mem_closure_iff_frequently.mpr (hf.mono fun y hy ↦ hlevel y hy.2 hy.1.1 hy.1.2)) + simpa only [cantorBendixson_add] using + (s.cantorBendixson a).cantorBendixson_mono_on_open (t.cantorBendixson b) hU hlocal c + +/-- If every local exact-rank point of `s` survives to the same stage of `t`, then absence from +the next two stages of `t` bounds the rank in `s` by one successor. -/ +theorem cantorBendixsonRank_le_add_one_of_rankLevel_mapsTo_stage + (s t : Closeds X) (hs : (s : Set X).IsPWO) {U : Set X} (hU : IsOpen U) + {x : X} (hxU : x ∈ U) (a b : Ordinal.{u}) + (hlevel : ∀ y ∈ U, y ∈ s → s.cantorBendixsonRank hs y = a → + y ∈ (t.cantorBendixson b : Set X)) + (ht : x ∉ (t.cantorBendixson ((b + 1) + 1) : Set X)) : + s.cantorBendixsonRank hs x ≤ a + 1 := by + apply s.cantorBendixsonRank_le_of_notMem hs x + intro hx + have hrec := s.cantorBendixson_reconstruction t hs hU a b (1 + 1) hlevel + apply ht + have hm := hrec ⟨by simpa only [add_assoc] using hx, hxU⟩ + simpa only [add_assoc] using hm + +/-- If every local exact-rank point of `s` survives to the same stage of `t`, then absence from +the next two stages of `t` bounds the rank in `s` by one successor. -/ +theorem cantorBendixsonRank_le_add_one_of_rankLevel_mapsTo + (s t : Closeds X) (hs : (s : Set X).IsPWO) {U : Set X} (hU : IsOpen U) + {x : X} (hxU : x ∈ U) (a : Ordinal.{u}) + (hlevel : ∀ y ∈ U, y ∈ s → s.cantorBendixsonRank hs y = a → + y ∈ (t.cantorBendixson a : Set X)) + (ht : x ∉ (t.cantorBendixson ((a + 1) + 1) : Set X)) : + s.cantorBendixsonRank hs x ≤ a + 1 := by + exact s.cantorBendixsonRank_le_add_one_of_rankLevel_mapsTo_stage + t hs hU hxU a a hlevel ht + +/-- The points of one exact Cantor--Bendixson rank in a closed partially well-ordered set form a +discrete subset. -/ +theorem rankLevel_isDiscrete (s : Closeds X) (hs : (s : Set X).IsPWO) (o : Ordinal.{u}) : + IsDiscrete {x | x ∈ s ∧ s.cantorBendixsonRank hs x = o} := by + rw [isDiscrete_iff_nhdsNE] + intro x hx + have hr := (s.cantorBendixsonRank_eq_iff hs hx.1 o).mp hx.2 + have hn : ¬AccPt x (𝓟 (s.cantorBendixson o : Set X)) := by + simpa only [cantorBendixson_add_one, coe_derived, mem_derivedSet] using hr.2 + rw [AccPt, not_neBot] at hn + apply le_antisymm + · calc + 𝓝[≠] x ⊓ 𝓟 {y | y ∈ s ∧ s.cantorBendixsonRank hs y = o} ≤ + 𝓝[≠] x ⊓ 𝓟 (s.cantorBendixson o : Set X) := + inf_le_inf_left _ (Filter.principal_mono.mpr fun y hy ↦ + (s.mem_cantorBendixson_iff hs y o).mpr ⟨hy.1, hy.2.ge⟩) + _ = ⊥ := hn + · exact bot_le + +omit [T1Space X] in +/-- The subtype of one exact rank level inherits partial well-ordering from the closed support. -/ +theorem rankLevel_univ_isPWO (s : Closeds X) (hs : (s : Set X).IsPWO) + (o : Ordinal.{u}) : + (Set.univ : Set {x // x ∈ s ∧ s.cantorBendixsonRank hs x = o}).IsPWO := by + rw [Set.isPWO_iff_exists_monotone_subseq] + intro f _ + obtain ⟨g, hg⟩ := hs.exists_monotone_subseq fun n ↦ (f n).property.1 + refine ⟨g, fun a b hab ↦ ?_⟩ + exact Subtype.coe_le_coe.mp (hg hab) + +variable [NoMinOrder X] + +omit [LinearOrder X] [OrderTopology X] [NoMinOrder X] [T1Space X] in +/-- **A union of two discrete sets is discrete when neither accumulates at the other.** At a point +of one of them, that set's own witness handles it; the other either contains the point, and +supplies its own witness, or stays away from it, leaving room to shrink into. + +Staying away is the hypothesis, in the form each application actually has: it holds when the sets +are closed, and equally when they are only relatively closed on an open set containing both. -/ +theorem isDiscrete_union {L M : Set X} (hL : IsDiscrete L) (hM : IsDiscrete M) + (hLM : ∀ x ∈ M, x ∉ L → Lᶜ ∈ 𝓝 x) (hML : ∀ x ∈ L, x ∉ M → Mᶜ ∈ 𝓝 x) : + IsDiscrete (L ∪ M) := by + rw [isDiscrete_iff_nhdsNE] at hL hM ⊢ + have haway : ∀ {S : Set X} {y : X}, Sᶜ ∈ 𝓝 y → 𝓝[≠] y ⊓ 𝓟 S = ⊥ := by + intro S y hy + refine le_bot_iff.mp (le_trans (inf_le_inf_right _ nhdsWithin_le_nhds) ?_) + rw [le_bot_iff, Filter.inf_principal_eq_bot] + exact hy + intro x hx + rw [← Filter.sup_principal, inf_sup_left] + rcases hx with hx | hx + · rw [hL x hx, bot_sup_eq] + by_cases hxM : x ∈ M + · exact hM x hxM + · exact haway (hML x hx hxM) + · rw [hM x hx, sup_bot_eq] + by_cases hxL : x ∈ L + · exact hL x hxL + · exact haway (hLM x hx hxL) + +omit [LinearOrder X] [OrderTopology X] [NoMinOrder X] [T1Space X] in +/-- **A finite union of discrete sets is discrete when none accumulates at another's points.** -/ +theorem isDiscrete_biUnion {ι' : Type*} (s : Finset ι') (L : ι' → Set X) + (hL : ∀ i ∈ s, IsDiscrete (L i)) + (haway : ∀ i ∈ s, ∀ j ∈ s, ∀ x ∈ L j, x ∉ L i → (L i)ᶜ ∈ 𝓝 x) : + IsDiscrete (⋃ i ∈ s, L i) := by + classical + induction s using Finset.induction_on with + | empty => + simp only [Finset.notMem_empty, Set.iUnion_of_empty, Set.iUnion_empty] + rw [isDiscrete_iff_nhdsNE] + simp + | insert c s hc ih => + have hLs : ∀ i ∈ s, IsDiscrete (L i) := fun i hi ↦ hL i (Finset.mem_insert_of_mem hi) + have hawayS : ∀ i ∈ s, ∀ j ∈ s, ∀ x ∈ L j, x ∉ L i → (L i)ᶜ ∈ 𝓝 x := + fun i hi j hj ↦ haway i (Finset.mem_insert_of_mem hi) j (Finset.mem_insert_of_mem hj) + have hrest := ih hLs hawayS + rw [Finset.set_biUnion_insert] + refine isDiscrete_union (hL c (Finset.mem_insert_self c s)) hrest ?_ ?_ + · intro x hx hxc + rw [Set.mem_iUnion₂] at hx + obtain ⟨j, hj, hxj⟩ := hx + exact haway c (Finset.mem_insert_self c s) j (Finset.mem_insert_of_mem hj) x hxj hxc + · intro x hx hxrest + have hcompl : (⋃ i ∈ s, L i)ᶜ = ⋂ i ∈ s, (L i)ᶜ := by + simp only [Set.compl_iUnion] + rw [hcompl] + refine (Filter.biInter_finset_mem s).mpr fun i hi ↦ ?_ + refine haway i (Finset.mem_insert_of_mem hi) c (Finset.mem_insert_self c s) x hx ?_ + intro hxi + exact hxrest (Set.mem_iUnion₂.mpr ⟨i, hi, hxi⟩) + +omit [T1Space X] in +/-- **Ordered disjoint left cuts for a discrete set.** Each point of a discrete set in a linear +order has an interval below it meeting the set only at that point, and those intervals may be taken +so that a smaller point never reaches into a larger point's interval. -/ +theorem exists_leftCuts_of_isDiscrete (L : Set X) (hL : IsDiscrete L) : + ∃ z : ↥L → X, (∀ x : ↥L, z x < (x : X)) ∧ + (∀ x : ↥L, Ioc (z x) (x : X) ∩ L = {(x : X)}) ∧ + ∀ x y : ↥L, (x : X) < (y : X) → (x : X) ≤ z y := by + have hcuts : ∀ x : ↥L, ∃ z < (x : X), Ioc z (x : X) ∩ L = {(x : X)} := by + intro x + obtain ⟨U, hUn, hUint⟩ := nhds_inter_eq_singleton_of_mem_discrete hL x.property + obtain ⟨z, hzx, hzU⟩ := exists_Ioc_subset_of_mem_nhds hUn (exists_lt (x : X)) + refine ⟨z, hzx, Set.Subset.antisymm ?_ ?_⟩ + · intro y hy + rw [← hUint] + exact ⟨hzU hy.1, hy.2⟩ + · intro y hy + rw [mem_singleton_iff] at hy + subst y + exact ⟨⟨hzx, le_rfl⟩, x.property⟩ + choose z hzlt hzlevel using hcuts + refine ⟨z, hzlt, hzlevel, fun x y hxy ↦ ?_⟩ + by_contra hle + have hxmem : (x : X) ∈ Ioc (z y) (y : X) ∩ L := ⟨⟨lt_of_not_ge hle, hxy.le⟩, x.property⟩ + rw [hzlevel y, mem_singleton_iff] at hxmem + exact hxy.ne hxmem + +/-- Exact-rank points admit left neighborhoods that are ordered by their centers. This is the +arbitrary-cofinality replacement for choosing successive disjoint intervals along a sequence. -/ +theorem exists_rankLevel_leftCuts (s : Closeds X) (hs : (s : Set X).IsPWO) + (o : Ordinal.{u}) : + ∃ z : {x // x ∈ s ∧ s.cantorBendixsonRank hs x = o} → X, + (∀ x, z x < x) ∧ + (∀ x, Ioc (z x) x ∩ {y | y ∈ s ∧ s.cantorBendixsonRank hs y = o} = + {(x : X)}) ∧ + ∀ x y : {x // x ∈ s ∧ s.cantorBendixsonRank hs x = o}, + (x : X) < y → (x : X) ≤ z y := by + let level : Set X := {x | x ∈ s ∧ s.cantorBendixsonRank hs x = o} + have hdisc : IsDiscrete level := s.rankLevel_isDiscrete hs o + have hcuts : ∀ x : level, ∃ z < (x : X), Ioc z x ∩ level = {(x : X)} := by + intro x + obtain ⟨U, hUn, hUint⟩ := nhds_inter_eq_singleton_of_mem_discrete hdisc x.property + obtain ⟨z, hzx, hzU⟩ := exists_Ioc_subset_of_mem_nhds hUn (exists_lt (x : X)) + refine ⟨z, hzx, Set.Subset.antisymm ?_ ?_⟩ + · intro y hy + rw [← hUint] + exact ⟨hzU hy.1, hy.2⟩ + · intro y hy + rw [mem_singleton_iff] at hy + subst y + exact ⟨⟨hzx, le_rfl⟩, x.property⟩ + choose z hzlt hzlevel using hcuts + refine ⟨z, hzlt, hzlevel, fun x y hxy ↦ ?_⟩ + by_contra hle + have hxmem : (x : X) ∈ Ioc (z y) y ∩ level := + ⟨⟨lt_of_not_ge hle, hxy.le⟩, x.property⟩ + rw [hzlevel y, mem_singleton_iff] at hxmem + exact hxy.ne hxmem + +end TopologicalSpace.Closeds + +/-- Homeomorphisms carrying one closed well-ordered support onto another preserve point ranks. -/ +theorem Homeomorph.cantorBendixsonRank_eq {X Y : Type u} + [LinearOrder X] [LinearOrder Y] [TopologicalSpace X] [TopologicalSpace Y] + [OrderTopology X] [OrderTopology Y] (e : X ≃ₜ Y) + (s : Closeds X) (t : Closeds Y) (hs : (s : Set X).IsPWO) (ht : (t : Set Y).IsPWO) + (he : e '' (s : Set X) = (t : Set Y)) (x : X) : + t.cantorBendixsonRank ht (e x) = s.cantorBendixsonRank hs x := by + apply le_antisymm + · apply t.cantorBendixsonRank_le_of_notMem ht (e x) + intro hx + exact s.notMem_cantorBendixson_rank_add_one hs x + ((e.mem_cantorBendixson_iff s t he x _).mp hx) + · apply s.cantorBendixsonRank_le_of_notMem hs x + intro hx + exact t.notMem_cantorBendixson_rank_add_one ht (e x) + ((e.mem_cantorBendixson_iff s t he x _).mpr hx) + +namespace Topology.IsClosedEmbedding + +variable {X : Type u} {Y : Type v} [TopologicalSpace X] [TopologicalSpace Y] + [T1Space X] [T1Space Y] {f : X → Y} + +/-- A closed embedding carries every Cantor–Bendixson derivative onto the corresponding +derivative of its closed image. -/ +theorem image_cantorBendixson_eq (hf : IsClosedEmbedding f) (s : Closeds X) + (o : Ordinal.{w}) : + f '' (s.cantorBendixson o : Set X) = + ((⟨f '' (s : Set X), hf.isClosedMap _ s.isClosed⟩ : Closeds Y).cantorBendixson o : + Set Y) := by + apply Set.Subset.antisymm + · induction o using Ordinal.limitRecOn with + | zero => simp + | add_one o ih => + simp only [Closeds.cantorBendixson_add_one, Closeds.coe_derived] + exact (hf.continuous.image_derivedSet hf.injective).trans + (derivedSet_mono _ _ ih) + | limit o ho ih => + rw [Closeds.cantorBendixson_limit _ _ ho, + Closeds.cantorBendixson_limit _ _ ho] + rintro _ ⟨x, hx, rfl⟩ + apply Closeds.mem_iInf.mpr + intro i + exact ih i.1 i.2 ⟨x, Closeds.mem_iInf.mp hx i, rfl⟩ + · exact hf.isClosedMap.cantorBendixson_image_subset + (fun y ↦ (Set.finite_singleton y).preimage hf.injective.injOn) s o + +end Topology.IsClosedEmbedding + +namespace Topology.IsOpenEmbedding + +variable {X : Type u} {Y : Type v} [TopologicalSpace X] [TopologicalSpace Y] + [T1Space X] [T1Space Y] {f : X → Y} + +omit [T1Space X] [T1Space Y] in +private theorem image_derivedSet_eq_inter_range (hf : IsOpenEmbedding f) (s : Set X) : + f '' derivedSet s = derivedSet (f '' s) ∩ range f := by + apply Set.Subset.antisymm + · rintro _ ⟨x, hx, rfl⟩ + exact ⟨hf.continuous.image_derivedSet hf.injective ⟨x, hx, rfl⟩, + mem_range_self x⟩ + · rintro y ⟨hy, x, rfl⟩ + refine ⟨x, mem_derivedSet.mpr ?_, rfl⟩ + have hy' : AccPt (f x) (Filter.principal (f '' s)) := mem_derivedSet.mp hy + rw [← hf.accPt_comap_iff] at hy' + simpa only [comap_principal, preimage_image_eq _ hf.injective] using hy' + +/-- Derivatives in an open subspace are the ambient derivatives restricted to that subspace. -/ +theorem image_cantorBendixson_top_eq (hf : IsOpenEmbedding f) (o : Ordinal.{w}) : + f '' (((⊤ : Closeds X).cantorBendixson o : Set X)) = + ((⊤ : Closeds Y).cantorBendixson o : Set Y) ∩ range f := by + induction o using Ordinal.limitRecOn with + | zero => simp + | add_one o ih => + simp only [Closeds.cantorBendixson_add_one, Closeds.coe_derived] + rw [hf.image_derivedSet_eq_inter_range, ih] + exact hf.isOpen_range.derivedSet_inter_eq + | limit o ho ih => + rw [Closeds.cantorBendixson_limit _ _ ho, + Closeds.cantorBendixson_limit _ _ ho] + ext y + constructor + · rintro ⟨x, hx, rfl⟩ + refine ⟨Closeds.mem_iInf.mpr fun i ↦ ?_, mem_range_self x⟩ + exact (Set.ext_iff.mp (ih i.1 i.2) (f x)).mp + ⟨x, Closeds.mem_iInf.mp hx i, rfl⟩ |>.1 + · rintro ⟨hy, x, rfl⟩ + refine ⟨x, Closeds.mem_iInf.mpr fun i ↦ ?_, rfl⟩ + have hi := (Set.ext_iff.mp (ih i.1 i.2) (f x)).mpr + ⟨Closeds.mem_iInf.mp hy i, mem_range_self x⟩ + obtain ⟨z, hz, hzx⟩ := hi + exact hf.injective hzx ▸ hz + +end Topology.IsOpenEmbedding diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Topology/Order.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Topology/Order.lean new file mode 100644 index 0000000000..1ede3f6368 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Topology/Order.lean @@ -0,0 +1,24 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Topology.Order.ArchimedeanBallBase +public import LeanPool.ConwayRefinement.ConwayRefinement.Topology.Order.CantorBendixsonAddition +public import LeanPool.ConwayRefinement.ConwayRefinement.Topology.Order.CantorBendixsonConvexCover +public import LeanPool.ConwayRefinement.ConwayRefinement.Topology.Order.ClosedPWO +public import LeanPool.ConwayRefinement.ConwayRefinement.Topology.Order.CoinitialComplete +public import LeanPool.ConwayRefinement.ConwayRefinement.Topology.Order.LeftNeighborhood +public import LeanPool.ConwayRefinement.ConwayRefinement.Topology.Order.OrderedAddGroup +public import LeanPool.ConwayRefinement.ConwayRefinement.Topology.Order.OrderedIntervalFamily +public import LeanPool.ConwayRefinement.ConwayRefinement.Topology.Order.PWOAddition +public import LeanPool.ConwayRefinement.ConwayRefinement.Topology.Order.PWOAdditionFiber +public import LeanPool.ConwayRefinement.ConwayRefinement.Topology.Order.PWOSumset +public import LeanPool.ConwayRefinement.ConwayRefinement.Topology.Order.SeparatedPieceFamily +public import LeanPool.ConwayRefinement.ConwayRefinement.Topology.Order.SmallClosedSubspace +public import LeanPool.ConwayRefinement.ConwayRefinement.Topology.Order.Tests + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Topology/Order/ArchimedeanBallBase.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Topology/Order/ArchimedeanBallBase.lean new file mode 100644 index 0000000000..f2bbec4b3c --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Topology/Order/ArchimedeanBallBase.lean @@ -0,0 +1,218 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import Mathlib.Algebra.Order.Archimedean.Class +public import Mathlib.Topology.Algebra.OpenSubgroup +public import Mathlib.SetTheory.Cardinal.Order +public import Mathlib.Order.Cofinal +public import Mathlib.Topology.Order.Basic + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint + +/-! +# A well-founded base of open Archimedean balls + +In an ordered abelian group whose nonzero Archimedean classes have no smallest magnitude, the +open Archimedean balls form a neighborhood base at zero. Mathlib orders Archimedean classes in +the reverse of magnitude, so the hypothesis is that `FiniteArchimedeanClass G` has no maximum. + +The full class order need not be well-founded. To obtain a well-founded nested base, fix an +arbitrary well-order of the finite classes and retain its record elements: a class belongs to +`CofinalIndex G` when it is larger in the ambient class order than every earlier class in the +well-order. Record elements are cofinal, while their ambient order is a subrelation of the fixed +well-order. Their open balls therefore give the required base without any countability +assumption or separately chosen cofinal chain. +-/ + +open Set + +universe u + +public noncomputable section + +namespace ArchimedeanClass + +variable {G : Type u} [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + +/-- The record finite Archimedean classes for an arbitrary fixed well-order. Their inherited +Archimedean-class order is well-founded and their values are cofinal among finite classes. -/ +def CofinalIndex (G : Type u) [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] := + {c : FiniteArchimedeanClass G // ∀ d, WellOrderingRel d c → d < c} + +namespace CofinalIndex + +noncomputable instance : LinearOrder (CofinalIndex G) := inferInstanceAs (LinearOrder + {c : FiniteArchimedeanClass G // ∀ d, WellOrderingRel d c → d < c}) + +/-- The finite Archimedean class represented by an index in the cofinal family. -/ +def archimedeanClass (i : CofinalIndex G) : FiniteArchimedeanClass G := i.1 + +/-- A representative of the Archimedean class indexed by `i`. -/ +def representative (i : CofinalIndex G) : G := + ArchimedeanClass.out (archimedeanClass i).1 + +/-- The representative of a cofinal index is nonzero. -/ +theorem representative_ne_zero (i : CofinalIndex G) : representative i ≠ 0 := by + change ArchimedeanClass.out (archimedeanClass i).1 ≠ 0 + intro h + have hout := ArchimedeanClass.mk_out (archimedeanClass i).1 + rw [h, ArchimedeanClass.mk_eq_top_iff.mpr rfl] at hout + exact (archimedeanClass i).2 hout.symm + +/-- The class of the chosen representative is the indexed Archimedean class. -/ +theorem mk_representative (i : CofinalIndex G) : + ArchimedeanClass.mk (representative i) = (archimedeanClass i).1 := + ArchimedeanClass.mk_out (archimedeanClass i).1 + +/-- The map from the cofinal index set to finite Archimedean classes is strictly monotone. -/ +theorem archimedeanClass_lt_of_lt {i j : CofinalIndex G} (hij : i < j) : + archimedeanClass i < archimedeanClass j := + hij + +/-- The index order is the order induced from finite Archimedean classes. -/ +theorem lt_iff_archimedeanClass_lt {i j : CofinalIndex G} : + i < j ↔ archimedeanClass i < archimedeanClass j := + Iff.rfl + +/-- Increasing cofinal indices give increasing underlying Archimedean classes. -/ +theorem underlyingClass_lt_of_lt {i j : CofinalIndex G} (hij : i < j) : + (archimedeanClass i).1 < (archimedeanClass j).1 := + hij + +private theorem wellOrderingRel_of_lt {a b : CofinalIndex G} (hab : a < b) : + WellOrderingRel a.1 b.1 := by + rcases trichotomous_of WellOrderingRel a.1 b.1 with h | h | h + · exact h + · exact False.elim (hab.ne (Subtype.ext h)) + · exact False.elim ((a.property b.1 h).asymm hab) + +noncomputable instance : WellFoundedLT (CofinalIndex G) := + (InvImage.wf (fun c : CofinalIndex G ↦ c.1) WellOrderingRel.isWellOrder.wf).mono + (fun _ _ h ↦ wellOrderingRel_of_lt h) + +/-- The indexed Archimedean classes are cofinal in the finite class order. -/ +theorem isCofinal_range_archimedeanClass : IsCofinal + (Set.range (archimedeanClass (G := G))) := by + change IsCofinal (Set.range (fun c : + {c : FiniteArchimedeanClass G // ∀ d, WellOrderingRel d c → d < c} => c.1)) + simpa using + (isCofinal_setOfPred_imp_lt + (WellOrderingRel : FiniteArchimedeanClass G → FiniteArchimedeanClass G → Prop)) + +end CofinalIndex + +/-- Every open Archimedean ball is order-convex. -/ +theorem ballAddSubgroup_ordConnected (c : ArchimedeanClass G) : + ((ballAddSubgroup c : AddSubgroup G) : Set G).OrdConnected := by + by_cases hc : c = ⊤ + · rw [hc, ballAddSubgroup_top] + exact ordConnected_singleton + constructor + intro a ha b hb x hx + apply (mem_ballAddSubgroup_iff hc).mpr + have ha' := (mem_ballAddSubgroup_iff hc).mp ha + have hb' := (mem_ballAddSubgroup_iff hc).mp hb + exact (lt_min ha' hb').trans_le (min_le_mk_of_le_of_le hx.1 hx.2) + +variable [TopologicalSpace G] [OrderTopology G] [IsTopologicalAddGroup G] + +/-- An Archimedean ball is open when there is a strictly smaller nonzero magnitude. -/ +theorem ballAddSubgroup_isOpen_of_exists_gt + {c : ArchimedeanClass G} (hc : ∃ d ≠ ⊤, c < d) : + IsOpen ((ballAddSubgroup c : AddSubgroup G) : Set G) := by + obtain ⟨d, hdtop, hcd⟩ := hc + induction d using ArchimedeanClass.ind with + | mk a => + have ha0 : a ≠ 0 := mk_eq_top_iff.not.mp hdtop + have habs : 0 < |a| := abs_pos.mpr ha0 + apply AddSubgroup.isOpen_of_mem_nhds + apply Filter.mem_of_superset (Ioo_mem_nhds (neg_lt_zero.mpr habs) habs) + intro x hx + apply (mem_ballAddSubgroup_iff hcd.ne_top).mpr + exact hcd.trans_le ((mk_le_mk).mpr ⟨1, by simpa using (abs_lt.mpr hx).le⟩) + +/-- The canonical open Archimedean ball at a record class. -/ +def cofinalBallBase (i : CofinalIndex G) : AddSubgroup G := + ballAddSubgroup (CofinalIndex.archimedeanClass i).1 + +omit [TopologicalSpace G] [OrderTopology G] [IsTopologicalAddGroup G] in +/-- Membership in a canonical Archimedean ball. -/ +theorem mem_cofinalBallBase_iff (i : CofinalIndex G) (x : G) : + x ∈ cofinalBallBase i ↔ + (CofinalIndex.archimedeanClass i).1 < ArchimedeanClass.mk x := + mem_ballAddSubgroup_iff (CofinalIndex.archimedeanClass i).2 + +omit [TopologicalSpace G] [OrderTopology G] [IsTopologicalAddGroup G] in +/-- The canonical Archimedean balls decrease along their index order. -/ +theorem cofinalBallBase_antitone : Antitone (cofinalBallBase (G := G)) := by + intro i j hij + exact ballAddSubgroup_antitone (show i.1.1 ≤ j.1.1 from hij) + +/-- If finite Archimedean classes have no maximum, every canonical ball is open. -/ +theorem cofinalBallBase_isOpen [NoMaxOrder (FiniteArchimedeanClass G)] (i : CofinalIndex G) : + IsOpen ((cofinalBallBase i : AddSubgroup G) : Set G) := by + obtain ⟨d, hid⟩ := exists_gt (CofinalIndex.archimedeanClass i) + exact ballAddSubgroup_isOpen_of_exists_gt ⟨d.1, d.2, hid⟩ + +omit [TopologicalSpace G] [OrderTopology G] [IsTopologicalAddGroup G] in +/-- Every canonical Archimedean ball is order-convex. -/ +theorem cofinalBallBase_ordConnected (i : CofinalIndex G) : + ((cofinalBallBase i : AddSubgroup G) : Set G).OrdConnected := + ballAddSubgroup_ordConnected (CofinalIndex.archimedeanClass i).1 + +omit [TopologicalSpace G] [OrderTopology G] [IsTopologicalAddGroup G] in +/-- The canonical Archimedean balls are coinitial among symmetric neighborhoods of zero. -/ +theorem exists_cofinalBallBase_subset_Ioo (ε : G) (hε : 0 < ε) : + ∃ i : CofinalIndex G, ((cofinalBallBase i : AddSubgroup G) : Set G) ⊆ Ioo (-ε) ε := by + obtain ⟨d, ⟨i, rfl⟩, hi⟩ := + CofinalIndex.isCofinal_range_archimedeanClass (G := G) + ⟨ArchimedeanClass.mk ε, ArchimedeanClass.mk_eq_top_iff.not.mpr hε.ne'⟩ + refine ⟨i, fun x hx ↦ ?_⟩ + have hix : (CofinalIndex.archimedeanClass i).1 < mk x := + (mem_cofinalBallBase_iff i x).mp hx + have hi' : mk ε ≤ (CofinalIndex.archimedeanClass i).1 := hi + have hxabs : |x| < ε := by + simpa [abs_of_pos hε] using (mk_lt_mk.mp (hi'.trans_lt hix) 1) + exact abs_lt.mp hxabs + +/-- Open Archimedean balls admit a well-founded decreasing neighbourhood basis when the nonzero +Archimedean classes have no smallest magnitude. -/ +@[blueprint "lem:well-founded-archimedean-ball-basis" + (phase := "Algebraic independence in graded rings") + (title := "Well-founded Archimedean-ball bases") + (statement := /-- + Let $G$ be an ordered topological abelian group. Suppose that the nonzero + Archimedean classes of $G$ have no least element in the magnitude order. + Then there are a well-founded linear order $I$ and a decreasing family + $(U_i)_{i\in I}$ of open order-convex additive subgroups of $G$ such that + every symmetric open interval about $0$ contains some $U_i$. + -/) + (proof := /-- + Well-order the finite Archimedean classes arbitrarily and retain each + class that is larger in the Archimedean-class order than every earlier + class. These record classes are cofinal, while their inherited order is + a subrelation of the chosen well-order and is therefore well-founded. + Associate to each record class its Archimedean ball. The balls decrease + with the record classes and are order-convex. The absence of a least + nonzero magnitude makes every ball open, and cofinality of the record + classes puts one inside every symmetric interval about $0$. + -/)] +theorem exists_wellFounded_archimedeanBall_basis + [NoMaxOrder (FiniteArchimedeanClass G)] : + ∃ (ι : Type u) (_ : LinearOrder ι) (_ : WellFoundedLT ι) + (U : ι → AddSubgroup G), + Antitone U ∧ + (∀ i, IsOpen ((U i : AddSubgroup G) : Set G)) ∧ + (∀ i, ((U i : AddSubgroup G) : Set G).OrdConnected) ∧ + ∀ ε : G, 0 < ε → ∃ i, ((U i : AddSubgroup G) : Set G) ⊆ Ioo (-ε) ε := by + exact ⟨CofinalIndex G, inferInstance, inferInstance, cofinalBallBase, + cofinalBallBase_antitone, cofinalBallBase_isOpen, cofinalBallBase_ordConnected, + exists_cofinalBallBase_subset_Ioo⟩ + +end ArchimedeanClass + +end diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Topology/Order/CantorBendixsonAddition.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Topology/Order/CantorBendixsonAddition.lean new file mode 100644 index 0000000000..6d1cb6dd1d --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Topology/Order/CantorBendixsonAddition.lean @@ -0,0 +1,113 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Topology.CantorBendixsonProduct +public import LeanPool.ConwayRefinement.ConwayRefinement.Topology.CantorBendixsonRank + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint + +/-! +# Cantor–Bendixson bounds for addition of supports + +Addition on two closed well-ordered supports is a closed map with finite fibers in an ordered +uniform group that is Cauchy complete. A point in any derivative of their sum therefore comes +from a pair whose natural sum of point ranks bounds that stage. This applies at arbitrary +ordinals and does not require addition on the supports to be injective. +-/ + +public noncomputable section + +open Set Filter Topology TopologicalSpace +open scoped Pointwise + +universe u + +namespace TopologicalSpace.Closeds + +variable {G : Type u} [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [UniformSpace G] [IsUniformAddGroup G] [OrderTopology G] [Nontrivial G] [CompleteSpace G] + +/-- A point in a derivative of a sum lifts to summands with a sufficient natural sum of ranks. -/ +@[blueprint "lem:cantor-bendixson-derivative-of-sum" + (phase := "Cantor–Bendixson ranks of supports") + (title := "Cantor--Bendixson derivatives of sums of well-ordered sets") + (statement := /-- + Let $S,T$ be closed well-ordered subsets of a nontrivial ordered abelian + group $G$, equipped with a compatible additive uniformity and its order + topology, and assume that $G$ is Cauchy complete. For every ordinal $\alpha$, + \[ + (S+T)^{(\alpha)}\subseteq + \left\{z:\begin{array}{l} + z=x+y\text{ for some }x\in S, y\in T,\\ + \alpha\le + \operatorname{rk}_S(x)\oplus\operatorname{rk}_T(y) + \end{array}\right\}. + \] + -/) + (proof := /-- + On $S\times T$, the natural sum of the two point ranks strictly decreases + in a punctured neighbourhood of each point. Transfinite + Cantor--Bendixson induction therefore bounds the derivative rank on the + product. Addition $S\times T\to S+T$ is closed and has finite fibers; + lifting derivatives through this map gives the stated summands and rank + bound. + -/)] +theorem cantorBendixson_add_subset (s t : Closeds G) + (hs : (s : Set G).IsPWO) (ht : (t : Set G).IsPWO) (o : Ordinal.{u}) : + ((⟨(s : Set G) + (t : Set G), + hs.isClosed_add ht s.isClosed t.isClosed⟩ : Closeds G).cantorBendixson o : Set G) ⊆ + {z | ∃ x ∈ s, ∃ y ∈ t, x + y = z ∧ + o ≤ (NatOrdinal.of (s.cantorBendixsonRank hs x) + + NatOrdinal.of (t.cantorBendixsonRank ht y)).val} := by + let f : (s : Set G) ×ˢ t → G := fun p ↦ p.1.1 + p.1.2 + have hf : IsClosedMap f := hs.isClosedMap_add ht s.isClosed t.isClosed + have himage : f '' (univ : Set ((s : Set G) ×ˢ t)) = (s : Set G) + (t : Set G) := by + ext z + constructor + · rintro ⟨p, _, rfl⟩ + exact add_mem_add p.2.1 p.2.2 + · rintro ⟨x, hx, y, hy, rfl⟩ + exact ⟨⟨(x, y), hx, hy⟩, mem_univ _, rfl⟩ + have he : (⟨f '' (univ : Set ((s : Set G) ×ˢ t)), hf _ isClosed_univ⟩ : Closeds G) = + ⟨(s : Set G) + (t : Set G), hs.isClosed_add ht s.isClosed t.isClosed⟩ := + Closeds.ext himage + let r (p : (s : Set G) ×ˢ t) : NatOrdinal := + NatOrdinal.of (s.cantorBendixsonRank hs p.1.1) + + NatOrdinal.of (t.cantorBendixsonRank ht p.1.2) + have hr (p : (s : Set G) ×ˢ t) (_hp : p ∈ (⊤ : Closeds ((s : Set G) ×ˢ t))) : + ∀ᶠ q in 𝓝 p, q ∈ (⊤ : Closeds ((s : Set G) ×ˢ t)) → q ≠ p → r q < r p := by + have hfst : Continuous (fun q : (s : Set G) ×ˢ t ↦ q.1.1) := by fun_prop + have hsnd : Continuous (fun q : (s : Set G) ×ˢ t ↦ q.1.2) := by fun_prop + filter_upwards + [hfst.continuousAt.tendsto.eventually (s.cantorBendixsonRank_locally_lt hs p.1.1), + hsnd.continuousAt.tendsto.eventually (t.cantorBendixsonRank_locally_lt ht p.1.2)] + with q hq1 hq2 _ hne + change NatOrdinal.of _ + NatOrdinal.of _ < NatOrdinal.of _ + NatOrdinal.of _ + by_cases h1 : q.1.1 = p.1.1 + · have h2 : q.1.2 ≠ p.1.2 := fun h2 ↦ hne (Subtype.ext (Prod.ext h1 h2)) + rw [h1] + apply add_lt_add_right + exact hq2 q.2.2 h2 + · have h2 : NatOrdinal.of (t.cantorBendixsonRank ht q.1.2) ≤ + NatOrdinal.of (t.cantorBendixsonRank ht p.1.2) := by + by_cases he2 : q.1.2 = p.1.2 + · rw [he2] + · exact (hq2 q.2.2 he2).le + exact add_lt_add_of_lt_of_le (hq1 q.2.1 h1) h2 + have hb := (⊤ : Closeds ((s : Set G) ×ˢ t)).cantorBendixson_subset_of_locally_lt + (fun p ↦ (r p).val) (fun p hp ↦ (hr p hp).mono fun q hq hqt hne ↦ hq hqt hne) o + have hlift := hf.cantorBendixson_image_subset (hs.finite_subtype_add_fiber ht) ⊤ o + rw [show (⊤ : Closeds ((s : Set G) ×ˢ t)) = + ⟨univ, isClosed_univ⟩ from rfl] at hlift + change ((⟨f '' univ, hf _ isClosed_univ⟩ : Closeds G).cantorBendixson o : Set G) ⊆ _ + at hlift + rw [he] at hlift + intro z hz + obtain ⟨p, hp, hpz⟩ := hlift hz + exact ⟨p.1.1, p.2.1, p.1.2, p.2.2, hpz, hb hp⟩ + +end TopologicalSpace.Closeds diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Topology/Order/CantorBendixsonConvexCover.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Topology/Order/CantorBendixsonConvexCover.lean new file mode 100644 index 0000000000..103c5d3e12 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Topology/Order/CantorBendixsonConvexCover.lean @@ -0,0 +1,271 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Topology.CantorBendixsonRank +import Mathlib.Order.WellFounded +import Mathlib.Topology.Order.MonotoneContinuity + +/-! +# A disjoint convex cover controlled by Cantor–Bendixson rank + +Fix a nested well-ordered family of open order-convex additive subgroups forming a neighborhood +base at zero. Every point of a closed partially well-ordered set has cosets in which it is the +largest point of the set and its unique point of maximal Cantor--Bendixson rank; along the nested +base each point has a least such level. The cosets of least level through each point are maximal +in the whole chosen family, so the maximal members cover the set, are pairwise disjoint and order +separated, and carry one center each. The centers accumulate nowhere, including at zero, because +every center owns an open coset meeting no other center. + +The output forgets the subgroups: it consists of open order-convex pairwise disjoint ordered +pieces, each containing its center as the largest point of the set inside it, with every other +point of the set inside of strictly smaller rank. This is the localization used by the +well-founded cofactor construction, at arbitrary cofinality and with no countability hypothesis. +-/ + +open Set Filter Topology TopologicalSpace + +universe u v + +public noncomputable section + +variable {G : Type u} {κ : Type v} + [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [TopologicalSpace G] [OrderTopology G] [NoMinOrder G] [NoMaxOrder G] + [LinearOrder κ] [WellFoundedLT κ] + +omit [AddCommGroup G] [IsOrderedAddMonoid G] [TopologicalSpace G] [OrderTopology G] + [NoMinOrder G] [NoMaxOrder G] [LinearOrder κ] [WellFoundedLT κ] in +/-- Two disjoint order-convex sets crossed by one ordered pair are fully order separated. -/ +theorem Set.OrdConnected.forall_lt_of_disjoint {D E : Set G} + (hD : D.OrdConnected) (hE : E.OrdConnected) (hDE : Disjoint D E) + {d e : G} (hd : d ∈ D) (he : e ∈ E) (hde : d < e) : + ∀ a ∈ D, ∀ b ∈ E, a < b := by + intro a ha b hb + by_contra hba + have hba' : b ≤ a := not_lt.mp hba + rcases lt_or_ge a e with hae | hea + · exact Set.disjoint_left.mp hDE ha (hE.out hb he ⟨hba', hae.le⟩) + · exact Set.disjoint_left.mp hDE (hD.out hd ha ⟨hde.le, hea⟩) he + +namespace TopologicalSpace.Closeds + +/-- A closed partially well-ordered set in a group with a nested well-ordered convex open subgroup +base has a pairwise disjoint ordered open convex cover. Each piece contains its center as the +largest member of the set inside it and as its unique member of maximal Cantor--Bendixson rank; +the centers accumulate nowhere. -/ +theorem exists_disjoint_convex_cover_with_rank_lt_center_within + (s : Closeds G) (hs : (s : Set G).IsPWO) + (W : Set G) (hWopen : IsOpen W) + (U : κ → AddSubgroup G) + (hUmono : ∀ {i j : κ}, i ≤ j → (U j : Set G) ⊆ (U i : Set G)) + (hUopen : ∀ i, IsOpen (U i : Set G)) + (hUconv : ∀ i, (U i : Set G).OrdConnected) + (hUbase : ∀ ε : G, 0 < ε → ∃ i, (U i : Set G) ⊆ Ioo (-ε) ε) : + ∃ (X : Set G) (C : X → Set G), + X ⊆ (s : Set G) ∩ W ∧ + (∀ x : X, (x : G) ∈ C x) ∧ + (∀ x : X, IsOpen (C x)) ∧ + (∀ x : X, (C x).OrdConnected) ∧ + (∀ x : X, C x ⊆ W) ∧ + (∀ x y : X, x ≠ y → Disjoint (C x) (C y)) ∧ + (∀ x y : X, (x : G) < (y : G) → ∀ a ∈ C x, ∀ b ∈ C y, a < b) ∧ + ((s : Set G) ∩ W ⊆ ⋃ x : X, C x) ∧ + (∀ x : X, ∀ z ∈ (s : Set G) ∩ C x, z ≤ (x : G)) ∧ + (∀ x : X, ∀ z ∈ (s : Set G) ∩ C x, z ≠ (x : G) → + s.cantorBendixsonRank hs z < s.cantorBendixsonRank hs (x : G)) ∧ + (∀ z ∈ W, ¬ AccPt z (𝓟 X)) := by + classical + let T := {z : G // z ∈ (s : Set G) ∩ W} + let coset : G → κ → Set G := fun z i ↦ (fun g ↦ z + g) '' (U i : Set G) + have hcoset_mem : ∀ (z : G) (i : κ), z ∈ coset z i := fun z i ↦ + ⟨0, (U i).zero_mem, add_zero z⟩ + have hcoset_open : ∀ (z : G) (i : κ), IsOpen (coset z i) := by + intro z i + have hset : coset z i = (fun y ↦ y + -z) ⁻¹' (U i : Set G) := by + ext y + constructor + · rintro ⟨u, hu, rfl⟩ + have he : (fun g ↦ z + g) u + -z = u := by + change z + u + -z = u + abel + simpa only [Set.mem_preimage, he] using hu + · intro hy + exact ⟨y + -z, hy, by change z + (y + -z) = y; abel⟩ + rw [hset] + exact (OrderIso.continuous (OrderIso.addRight (-z))).isOpen_preimage _ (hUopen i) + have hcoset_conv : ∀ (z : G) (i : κ), (coset z i).OrdConnected := by + intro z i + constructor + rintro a ⟨u, hu, rfl⟩ b ⟨v, hv, rfl⟩ w ⟨hwl, hwr⟩ + have hwl' : z + u ≤ w := hwl + have hwr' : w ≤ z + v := hwr + refine ⟨w - z, (hUconv i).out hu hv ⟨?_, ?_⟩, by change z + (w - z) = w; abel⟩ + · rwa [le_sub_iff_add_le, add_comm] + · rwa [sub_le_iff_le_add, add_comm] + -- Step 1: every point of the set has a valid level. + have hlevel : ∀ z : T, ∃ i : κ, coset (z : G) i ⊆ W ∧ + (∀ w ∈ (s : Set G), w ∈ coset (z : G) i → w ≤ (z : G)) ∧ + (∀ w ∈ (s : Set G), w ∈ coset (z : G) i → w ≠ (z : G) → + s.cantorBendixsonRank hs w < s.cantorBendixsonRank hs (z : G)) := by + rintro ⟨z, hz⟩ + have hnearW := (hs.eventually_le z).and (s.cantorBendixsonRank_locally_lt hs z) + have hnear : {y : G | (y ∈ (s : Set G) → y ≤ z) ∧ + (y ∈ s → y ≠ z → s.cantorBendixsonRank hs y < s.cantorBendixsonRank hs z)} ∩ W ∈ + 𝓝 z := Filter.inter_mem hnearW (hWopen.mem_nhds hz.2) + obtain ⟨a, b, ⟨haz, hzb⟩, hab⟩ := mem_nhds_iff_exists_Ioo_subset.mp hnear + obtain ⟨i, hi⟩ := hUbase (min (z - a) (b - z)) + (lt_min (sub_pos.mpr haz) (sub_pos.mpr hzb)) + have hmem : ∀ w ∈ coset z i, w ∈ Ioo a b := by + rintro w ⟨u, hu, rfl⟩ + have hu' := hi hu + constructor + · have h1 : -(z - a) < u := (neg_le_neg (min_le_left _ _)).trans_lt hu'.1 + have h2 := add_lt_add_left h1 z + have e1 : -(z - a) + z = a := by abel + rw [e1, add_comm u z] at h2 + exact h2 + · have h1 : u < b - z := hu'.2.trans_le (min_le_right _ _) + have h2 := add_lt_add_left h1 z + have e1 : b - z + z = b := by abel + rw [e1, add_comm u z] at h2 + exact h2 + exact ⟨i, fun w hwm ↦ (hab (hmem w hwm)).2, + fun w hw hwm ↦ (hab (hmem w hwm)).1.1 hw, + fun w hw hwm ↦ (hab (hmem w hwm)).1.2 hw⟩ + -- Step 2: the least valid level and its coset. + let good : T → Set κ := fun z ↦ {i : κ | coset (z : G) i ⊆ W ∧ + (∀ w ∈ (s : Set G), w ∈ coset (z : G) i → w ≤ (z : G)) ∧ + (∀ w ∈ (s : Set G), w ∈ coset (z : G) i → w ≠ (z : G) → + s.cantorBendixsonRank hs w < s.cantorBendixsonRank hs (z : G))} + have hne : ∀ z : T, (good z).Nonempty := fun z ↦ hlevel z + let idx : T → κ := fun z ↦ wellFounded_lt.min (good z) (hne z) + have hidx : ∀ z : T, idx z ∈ good z := fun z ↦ wellFounded_lt.min_mem (good z) (hne z) + let B : T → Set G := fun z ↦ coset (z : G) (idx z) + have hBmem : ∀ z : T, (z : G) ∈ B z := fun z ↦ hcoset_mem (z : G) (idx z) + -- Cosets of comparable levels through a common point are nested. + have hnest : ∀ z w : T, idx w ≤ idx z → ∀ y, y ∈ B z → y ∈ B w → B z ⊆ B w := by + rintro z w hij y ⟨u, hu, hyu⟩ ⟨v, hv, hyv⟩ p ⟨q, hq, hpq⟩ + have hyu' : (z : G) + u = y := hyu + have hyv' : (w : G) + v = y := hyv + have hpq' : (z : G) + q = p := hpq + refine ⟨v - u + q, (U (idx w)).add_mem ((U (idx w)).sub_mem hv (hUmono hij hu)) + (hUmono hij hq), ?_⟩ + change (w : G) + (v - u + q) = p + have hzw : (z : G) = (w : G) + v - u := by + rw [eq_sub_iff_add_eq, hyu', hyv'] + rw [← hpq', hzw] + abel + -- Equal cosets share their largest set point. + have hcenter_eq : ∀ z w : T, B z = B w → (z : G) = (w : G) := by + intro z w he + have h1 : (z : G) ∈ B w := by rw [← he]; exact hBmem z + have h2 : (w : G) ∈ B z := by rw [he]; exact hBmem w + exact le_antisymm ((hidx w).2.1 z z.2.1 h1) ((hidx z).2.1 w w.2.1 h2) + -- Step 3: the maximal cosets. + let X : Set G := {p : G | ∃ hp : p ∈ (s : Set G) ∩ W, + ∀ v : T, B ⟨p, hp⟩ ⊆ B v → B v = B ⟨p, hp⟩} + have hXs : X ⊆ (s : Set G) ∩ W := fun p hp ↦ hp.choose + let C : X → Set G := fun x ↦ B ⟨(x : G), hXs x.2⟩ + have hCmax : ∀ x : X, ∀ v : T, C x ⊆ B v → B v = C x := fun x ↦ x.2.choose_spec + have hCmem : ∀ x : X, (x : G) ∈ C x := fun x ↦ hBmem _ + -- Disjointness of distinct maximal cosets. + have hdisj : ∀ x y : X, x ≠ y → Disjoint (C x) (C y) := by + intro x y hxy + rw [Set.disjoint_left] + intro q hqx hqy + have hxyG : (x : G) ≠ (y : G) := fun h ↦ hxy (Subtype.ext h) + rcases le_total (idx ⟨(x : G), hXs x.2⟩) (idx ⟨(y : G), hXs y.2⟩) with h | h + · have hsub := hnest ⟨(y : G), hXs y.2⟩ ⟨(x : G), hXs x.2⟩ h q hqy hqx + have heq := hCmax y ⟨(x : G), hXs x.2⟩ hsub + exact hxyG (hcenter_eq ⟨(x : G), hXs x.2⟩ ⟨(y : G), hXs y.2⟩ heq) + · have hsub := hnest ⟨(x : G), hXs x.2⟩ ⟨(y : G), hXs y.2⟩ h q hqx hqy + have heq := hCmax x ⟨(y : G), hXs y.2⟩ hsub + exact hxyG (hcenter_eq ⟨(y : G), hXs y.2⟩ ⟨(x : G), hXs x.2⟩ heq).symm + -- Coverage: the least-level coset through a point is maximal. + have hcov : (s : Set G) ∩ W ⊆ ⋃ x : X, C x := by + intro p hp + let covIdx : Set κ := {j : κ | ∃ w : T, idx w = j ∧ p ∈ B w} + have hcovne : covIdx.Nonempty := ⟨idx ⟨p, hp⟩, ⟨p, hp⟩, rfl, hBmem ⟨p, hp⟩⟩ + obtain ⟨w, hwidx, hpw⟩ := wellFounded_lt.min_mem covIdx hcovne + have hwmax : ∀ v : T, B w ⊆ B v → B v = B w := by + intro v hsub + have hpv : p ∈ B v := hsub hpw + have hmv : idx w ≤ idx v := by + rw [hwidx] + exact WellFoundedLT.min_le (s := covIdx) (x := idx v) ⟨v, rfl, hpv⟩ + exact le_antisymm (hnest v w hmv p hpv hpw) hsub + have hwX : (w : G) ∈ X := ⟨w.2, hwmax⟩ + exact Set.mem_iUnion.mpr ⟨⟨(w : G), hwX⟩, hpw⟩ + -- Order separation from disjointness and convexity. + have hconv : ∀ x : X, (C x).OrdConnected := fun x ↦ hcoset_conv _ _ + have hord : ∀ x y : X, (x : G) < (y : G) → ∀ a ∈ C x, ∀ b ∈ C y, a < b := by + intro x y hxy + exact Set.OrdConnected.forall_lt_of_disjoint (hconv x) (hconv y) + (hdisj x y fun h ↦ absurd (congrArg Subtype.val h) hxy.ne) + (hCmem x) (hCmem y) hxy + -- The centers accumulate nowhere. + have hdiscrete : ∀ z ∈ W, ¬ AccPt z (𝓟 X) := by + intro z hzW hacc + rw [accPt_iff_nhds] at hacc + by_cases hzs : z ∈ (s : Set G) ∩ W + · obtain ⟨x₀, hx₀⟩ := Set.mem_iUnion.mp (hcov hzs) + have hXC : ∀ y ∈ X, y ∈ C x₀ → y = (x₀ : G) := by + intro y hy hyC + by_contra hne + exact Set.disjoint_left.mp + (hdisj ⟨y, hy⟩ x₀ fun h ↦ hne (congrArg Subtype.val h)) + (hCmem ⟨y, hy⟩) hyC + rcases eq_or_ne (x₀ : G) z with hx0z | hx0z + · obtain ⟨y, ⟨hyC, hyX⟩, hyz⟩ := hacc (C x₀) ((hcoset_open _ _).mem_nhds hx₀) + exact hyz (by rw [hXC y hyX hyC, hx0z]) + · rcases lt_or_gt_of_ne hx0z with hlt | hgt + · obtain ⟨b, hzb⟩ := exists_gt z + obtain ⟨y, ⟨⟨hyC, hy1, _⟩, hyX⟩, hyz⟩ := hacc (C x₀ ∩ Ioo (x₀ : G) b) + ((((hcoset_open _ _).inter isOpen_Ioo)).mem_nhds ⟨hx₀, hlt, hzb⟩) + exact absurd (hXC y hyX hyC) (ne_of_gt hy1) + · obtain ⟨a, haz⟩ := exists_lt z + obtain ⟨y, ⟨⟨hyC, _, hy2⟩, hyX⟩, hyz⟩ := hacc (C x₀ ∩ Ioo a (x₀ : G)) + ((((hcoset_open _ _).inter isOpen_Ioo)).mem_nhds ⟨hx₀, haz, hgt⟩) + exact absurd (hXC y hyX hyC) (ne_of_lt hy2) + · have hzsc : z ∉ (s : Set G) := fun h ↦ hzs ⟨h, hzW⟩ + obtain ⟨y, ⟨hyc, hyX⟩, -⟩ := hacc ((s : Set G)ᶜ) + (s.isClosed.isOpen_compl.mem_nhds hzsc) + exact hyc (hXs hyX).1 + exact ⟨X, C, hXs, hCmem, fun x ↦ hcoset_open _ _, hconv, + fun x ↦ (hidx ⟨(x : G), hXs x.2⟩).1, hdisj, hord, hcov, + fun x z hz ↦ (hidx ⟨(x : G), hXs x.2⟩).2.1 z hz.1 hz.2, + fun x z hz hne ↦ (hidx ⟨(x : G), hXs x.2⟩).2.2 z hz.1 hz.2 hne, hdiscrete⟩ + +/-- The disjoint convex cover of the whole closed set, obtained by taking the open region to be +`univ`. -/ +theorem exists_disjoint_convex_cover_with_rank_lt_center (s : Closeds G) (hs : (s : Set G).IsPWO) + (U : κ → AddSubgroup G) + (hUmono : ∀ {i j : κ}, i ≤ j → (U j : Set G) ⊆ (U i : Set G)) + (hUopen : ∀ i, IsOpen (U i : Set G)) + (hUconv : ∀ i, (U i : Set G).OrdConnected) + (hUbase : ∀ ε : G, 0 < ε → ∃ i, (U i : Set G) ⊆ Ioo (-ε) ε) : + ∃ (X : Set G) (C : X → Set G), + X ⊆ (s : Set G) ∧ + (∀ x : X, (x : G) ∈ C x) ∧ + (∀ x : X, IsOpen (C x)) ∧ + (∀ x : X, (C x).OrdConnected) ∧ + (∀ x y : X, x ≠ y → Disjoint (C x) (C y)) ∧ + (∀ x y : X, (x : G) < (y : G) → ∀ a ∈ C x, ∀ b ∈ C y, a < b) ∧ + ((s : Set G) ⊆ ⋃ x : X, C x) ∧ + (∀ x : X, ∀ z ∈ (s : Set G) ∩ C x, z ≤ (x : G)) ∧ + (∀ x : X, ∀ z ∈ (s : Set G) ∩ C x, z ≠ (x : G) → + s.cantorBendixsonRank hs z < s.cantorBendixsonRank hs (x : G)) ∧ + (∀ z : G, ¬ AccPt z (𝓟 X)) := by + obtain ⟨X, C, hXs, hCmem, hCopen, hCconv, -, hCdisj, hCord, hCcov, hCmax, hCrank, hXdisc⟩ := + exists_disjoint_convex_cover_with_rank_lt_center_within s hs Set.univ isOpen_univ U + hUmono hUopen hUconv hUbase + refine ⟨X, C, fun p hp ↦ (hXs hp).1, hCmem, hCopen, hCconv, hCdisj, hCord, ?_, hCmax, hCrank, + fun z ↦ hXdisc z (Set.mem_univ z)⟩ + intro p hp + exact hCcov ⟨hp, Set.mem_univ p⟩ + +end TopologicalSpace.Closeds diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Topology/Order/ClosedPWO.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Topology/Order/ClosedPWO.lean new file mode 100644 index 0000000000..6e0d2a1885 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Topology/Order/ClosedPWO.lean @@ -0,0 +1,466 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.CantorBendixson +public import LeanPool.ConwayRefinement.ConwayRefinement.SetTheory.Ordinal.SetOrderType +public import LeanPool.ConwayRefinement.ConwayRefinement.Topology.CantorBendixsonReconstruction +public import LeanPool.ConwayRefinement.ConwayRefinement.Topology.Order.PWOAddition +public import Mathlib.Topology.Instances.Real.Lemmas + +import Mathlib.SetTheory.Ordinal.FixedPoint +import Mathlib.Topology.Order.Monotone +import Mathlib.Topology.Order.MonotoneContinuity +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint + +/-! +# Closed real well-orders + +A closed well-ordered subset of the reals is canonically homeomorphic to its ordinal index +space. Closing a well-order below a strict supremum inserts at most one limit point before each +original point; in particular it preserves a nonzero additively principal order type. +-/ + +open Filter Order Set Topology +open Ordinal + +public noncomputable section + +namespace Set.IsPWO + +variable {s : Set ℝ} (hs : s.IsPWO) + +private def enumReal (s : Set ℝ) [WellFoundedLT s] : + Iio (Ordinal.type (· < · : s → s → Prop)) → ℝ := + fun i ↦ (Ordinal.enum (· < · : s → s → Prop) i).1 + +private theorem enumReal_strictMono (s : Set ℝ) [WellFoundedLT s] : StrictMono (enumReal s) := by + intro i j hij + exact (Ordinal.enum_lt_enum (r := (· < · : s → s → Prop))).mpr hij + +private theorem exists_enumReal_ge_of_isSuccLimit [WellFoundedLT s] (hc : IsClosed s) + {i : Iio (Ordinal.type (· < · : s → s → Prop))} (hi : IsSuccLimit i.1) + {b : ℝ} (hb : b < enumReal s i) : + ∃ j < i, b ≤ enumReal s j := by + let A : Set ℝ := enumReal s '' Iio i + have hAne : A.Nonempty := by + let j : Iio (Ordinal.type (· < · : s → s → Prop)) := + ⟨0, hi.bot_lt.trans i.2⟩ + exact ⟨enumReal s j, ⟨j, hi.bot_lt, rfl⟩⟩ + have hAbdd : BddAbove A := by + refine ⟨enumReal s i, ?_⟩ + rintro _ ⟨j, hji, rfl⟩ + exact (enumReal_strictMono s hji).le + have hAs : A ⊆ s := by + rintro _ ⟨j, _, rfl⟩ + exact (Ordinal.enum (· < · : s → s → Prop) j).2 + have hsupmem : sSup A ∈ s := hc.closure_subset + (closure_mono hAs (csSup_mem_closure hAne hAbdd)) + have hsup_le : sSup A ≤ enumReal s i := csSup_le hAne fun _ hx ↦ by + obtain ⟨j, hji, rfl⟩ := hx + exact (enumReal_strictMono s hji).le + have hsup_eq : sSup A = enumReal s i := by + apply le_antisymm hsup_le + by_contra hnot + have hlt : sSup A < enumReal s i := lt_of_not_ge hnot + let k : Iio (Ordinal.type (· < · : s → s → Prop)) := + ⟨Ordinal.typein (· < · : s → s → Prop) ⟨sSup A, hsupmem⟩, + Ordinal.typein_lt_type _ _⟩ + have hki : k < i := by + apply (Ordinal.enum_lt_enum (r := (· < · : s → s → Prop))).mp + have hk : Ordinal.enum (· < · : s → s → Prop) k = ⟨sSup A, hsupmem⟩ := by + simp [k] + rw [hk] + exact hlt + have hsucc : k.1 + 1 < i.1 := hi.succ_lt hki + let j : Iio (Ordinal.type (· < · : s → s → Prop)) := + ⟨k.1 + 1, hsucc.trans i.2⟩ + have hjA : enumReal s j ∈ A := ⟨j, hsucc, rfl⟩ + have hkj : k < j := Order.lt_succ k.1 + have hsup_lt : sSup A < enumReal s j := by + have := enumReal_strictMono s hkj + simpa [k, enumReal] using this + exact (not_lt_of_ge (le_csSup hAbdd hjA)) hsup_lt + by_contra! hnone + have hub : b ∈ upperBounds A := by + rintro _ ⟨j, hji, rfl⟩ + exact (hnone j hji).le + have hle : enumReal s i ≤ b := by + rw [← hsup_eq] + exact (isLUB_csSup hAne hAbdd).2 hub + exact (not_lt_of_ge hle) hb + +private theorem nhdsWithin_Ici_eq_pure + {T : Ordinal} (i : Iio T) : 𝓝[Set.Ici i] i = pure i := by + apply le_antisymm + · rw [le_pure_iff] + have hopen : IsOpen {j : Iio T | j.1 < i.1 + 1} := + isOpen_Iio.preimage continuous_subtype_val + have hmem : {j : Iio T | j.1 < i.1 + 1} ∈ 𝓝 i := + hopen.mem_nhds (Order.lt_succ i.1) + rw [mem_nhdsWithin_iff_exists_mem_nhds_inter] + refine ⟨_, hmem, ?_⟩ + intro j hj + apply mem_singleton_iff.mpr + apply Subtype.ext + exact le_antisymm (Order.lt_succ_iff.mp hj.1) hj.2 + · exact pure_le_nhdsWithin (mem_Ici.mpr le_rfl) + +private theorem continuousAt_enumReal_of_not_isSuccLimit [WellFoundedLT s] + {i : Iio (Ordinal.type (· < · : s → s → Prop))} (hi : ¬IsSuccLimit i.1) : + ContinuousAt (enumReal s) i := by + have hopenOrdinal : IsOpen ({i.1} : Set Ordinal) := + SuccOrder.isOpen_singleton_iff.mpr hi + have hopen : IsOpen ({i} : Set (Iio (Ordinal.type (· < · : s → s → Prop)))) := by + rw [show ({i} : Set (Iio (Ordinal.type (· < · : s → s → Prop)))) = + (fun j : Iio (Ordinal.type (· < · : s → s → Prop)) ↦ j.1) ⁻¹' {i.1} by + ext j + exact Subtype.ext_iff] + exact hopenOrdinal.preimage continuous_subtype_val + change Tendsto (enumReal s) (𝓝 i) (𝓝 (enumReal s i)) + rw [(isOpen_singleton_iff_nhds_eq_pure i).mp hopen] + exact pure_le_nhds _ + +private theorem continuous_enumReal [WellFoundedLT s] (hc : IsClosed s) : + Continuous (enumReal s) := by + rw [continuous_iff_continuousAt] + intro i + by_cases hi : IsSuccLimit i.1 + · apply continuousAt_iff_continuous_left_right.mpr + constructor + · apply StrictMonoOn.continuousWithinAt_left_of_exists_between + (s := Set.univ) ((enumReal_strictMono s).strictMonoOn Set.univ) univ_mem + intro b hb + obtain ⟨j, hji, hbj⟩ := exists_enumReal_ge_of_isSuccLimit hc hi hb + exact ⟨j, mem_univ _, hbj, enumReal_strictMono s hji⟩ + · change Tendsto (enumReal s) (𝓝[Set.Ici i] i) (𝓝 (enumReal s i)) + rw [nhdsWithin_Ici_eq_pure] + exact pure_le_nhds _ + · exact continuousAt_enumReal_of_not_isSuccLimit hi + +private def enumRealOrderIso (s : Set ℝ) [WellFoundedLT s] : + Iio (Ordinal.type (· < · : s → s → Prop)) ≃o s := + OrderIso.ofRelIsoLT (Ordinal.enum (· < · : s → s → Prop)) + +private theorem continuous_typeinReal [WellFoundedLT s] : + Continuous (enumRealOrderIso s).symm := by + let t : TopologicalSpace (Iio (Ordinal.type (· < · : s → s → Prop))) := inferInstance + have ht : t = Preorder.topology (Iio (Ordinal.type (· < · : s → s → Prop))) := + OrderTopology.topology_eq_generate_intervals + change @Continuous s (Iio (Ordinal.type (· < · : s → s → Prop))) _ t + (enumRealOrderIso s).symm + rw [ht, continuous_generateFrom_iff] + rintro u ⟨a, rfl | rfl⟩ + · rw [show (enumRealOrderIso s).symm ⁻¹' Ioi a = + Subtype.val ⁻¹' Ioi ((enumRealOrderIso s) a).1 by + ext x + change a < (enumRealOrderIso s).symm x ↔ (enumRealOrderIso s) a < x + constructor + · intro h + have h' := (enumRealOrderIso s).strictMono h + rw [(enumRealOrderIso s).apply_symm_apply] at h' + exact h' + · intro h + have h' := (enumRealOrderIso s).symm.strictMono h + rw [(enumRealOrderIso s).symm_apply_apply] at h' + exact h'] + exact isOpen_Ioi.preimage continuous_subtype_val + · rw [show (enumRealOrderIso s).symm ⁻¹' Iio a = + Subtype.val ⁻¹' Iio ((enumRealOrderIso s) a).1 by + ext x + change (enumRealOrderIso s).symm x < a ↔ x < (enumRealOrderIso s) a + constructor + · intro h + have h' := (enumRealOrderIso s).strictMono h + rw [(enumRealOrderIso s).apply_symm_apply] at h' + exact h' + · intro h + have h' := (enumRealOrderIso s).symm.strictMono h + rw [(enumRealOrderIso s).symm_apply_apply] at h' + exact h'] + exact isOpen_Iio.preimage continuous_subtype_val + +/-- The canonical enumeration of a closed real well-order is a homeomorphism from its ordinal +index space. -/ +def homeomorphIioType [WellFoundedLT s] (hc : IsClosed s) : + Iio (Ordinal.type (· < · : s → s → Prop)) ≃ₜ s := + Homeomorph.mk (enumRealOrderIso s).toEquiv + (Continuous.subtype_mk (continuous_enumReal hc) _) + continuous_typeinReal + +end Set.IsPWO +universe u + +namespace Set + +variable {s : Set ℝ} + +private theorem exists_mem_Ioc_of_mem_closure' (hs : s.IsPWO) {x y : ℝ} + (hx : x ∈ closure s) (hy : y < x) : + ∃ b ∈ s, y < b ∧ b ≤ x := by + by_contra! hn + have habove : ∀ b ∈ s, y < b → x < b := fun b hb hyb ↦ hn b hb hyb + let v := s ∩ Ioi x + have hv : v.IsWF := hs.isWF.mono inter_subset_left + have hne : v.Nonempty := by + obtain ⟨b, hby, hbs⟩ := mem_closure_iff_nhds.mp hx (Ioi y) (Ioi_mem_nhds hy) + exact ⟨b, hbs, habove b hbs hby⟩ + let m := hv.min hne + have hm : m ∈ v := hv.min_mem hne + obtain ⟨b, hb, hbs⟩ := mem_closure_iff_nhds.mp hx (Ioo y m) (Ioo_mem_nhds hy hm.2) + exact (not_lt_of_ge (hv.min_le hne ⟨hbs, habove b hbs hb.1⟩)) hb.2 + +variable {z : ℝ} + +private def strictClosure : Set ℝ := closure s ∩ Iio z + +private theorem exists_support_above (hz : IsLUB s z) + (x : strictClosure (s := s) (z := z)) : + ∃ y ∈ s, x.1 < y := by + obtain ⟨y, hy, hxy, -⟩ := hz.exists_between x.2.2 + exact ⟨y, hy, hxy⟩ + +private def upperSupport (x : strictClosure (s := s) (z := z)) : Set ℝ := s ∩ Ici x.1 + +private theorem upperSupport_nonempty (hz : IsLUB s z) + (x : strictClosure (s := s) (z := z)) : + (upperSupport (s := s) (z := z) x).Nonempty := by + obtain ⟨y, hy, hxy⟩ := exists_support_above hz x + exact ⟨y, hy, hxy.le⟩ + +private noncomputable def ceiling (hs : s.IsPWO) (hz : IsLUB s z) + (x : strictClosure (s := s) (z := z)) : ℝ := + (hs.isWF.mono (s := upperSupport (s := s) (z := z) x) inter_subset_left).min + (upperSupport_nonempty hz x) + +private theorem ceiling_mem (hs : s.IsPWO) (hz : IsLUB s z) + (x : strictClosure (s := s) (z := z)) : + ceiling hs hz x ∈ s ∩ Ici x.1 := + (hs.isWF.mono (s := upperSupport (s := s) (z := z) x) inter_subset_left).min_mem + (upperSupport_nonempty hz x) + +private theorem ceiling_le_of_mem (hs : s.IsPWO) (hz : IsLUB s z) + (x : strictClosure (s := s) (z := z)) {y : ℝ} + (hy : y ∈ s) (hxy : x.1 ≤ y) : + ceiling hs hz x ≤ y := + (hs.isWF.mono (s := upperSupport (s := s) (z := z) x) inter_subset_left).min_le + (upperSupport_nonempty hz x) ⟨hy, hxy⟩ + +private theorem ceiling_eq_self_of_mem (hs : s.IsPWO) (hz : IsLUB s z) + (x : strictClosure (s := s) (z := z)) + (hx : x.1 ∈ s) : + ceiling hs hz x = x.1 := + le_antisymm (ceiling_le_of_mem hs hz x hx le_rfl) (ceiling_mem hs hz x).2 + +private noncomputable def closureEmbedding (hs : s.IsPWO) (hz : IsLUB s z) : + strictClosure (s := s) (z := z) → s ×ₗ Fin 2 := by + classical + exact fun x ↦ + ⟨⟨ceiling hs hz x, (ceiling_mem hs hz x).1⟩, + if x.1 ∈ s then (1 : Fin 2) else 0⟩ + +private theorem closureEmbedding_strictMono (hs : s.IsPWO) (hz : IsLUB s z) : + StrictMono (closureEmbedding hs hz) := by + intro x y hxy + have hceil : ceiling hs hz x ≤ ceiling hs hz y := + ceiling_le_of_mem hs hz x (ceiling_mem hs hz y).1 + ((show x.1 ≤ y.1 from hxy.le).trans (ceiling_mem hs hz y).2) + by_cases hlt : ceiling hs hz x < ceiling hs hz y + · rw [Prod.Lex.lt_iff] + exact Or.inl hlt + · have heq : ceiling hs hz x = ceiling hs hz y := le_antisymm hceil (not_lt.mp hlt) + have hxnot : x.1 ∉ s := by + intro hxs + have hxceil := ceiling_eq_self_of_mem hs hz x hxs + have hy_le : y.1 ≤ ceiling hs hz y := (ceiling_mem hs hz y).2 + have hyx : y.1 ≤ x.1 := by + rw [← hxceil, heq] + exact hy_le + exact (not_le_of_gt hxy) hyx + have hys : y.1 ∈ s := by + by_contra hynot + obtain ⟨b, hbs, hxb, hby⟩ := + exists_mem_Ioc_of_mem_closure' hs y.2.1 hxy + have hb_lt : b < y.1 := lt_of_le_of_ne hby fun h ↦ hynot (h ▸ hbs) + have hceilb : ceiling hs hz x ≤ b := ceiling_le_of_mem hs hz x hbs hxb.le + have hyceil : y.1 ≤ ceiling hs hz y := (ceiling_mem hs hz y).2 + have : ceiling hs hz y < ceiling hs hz y := + heq.symm.le.trans_lt (hceilb.trans_lt (hb_lt.trans_le hyceil)) + exact (lt_irrefl _ this) + rw [Prod.Lex.lt_iff] + refine Or.inr ⟨Subtype.ext heq, ?_⟩ + simp only [closureEmbedding, hxnot, hys, ↓reduceIte] + change (0 : Fin 2) < 1 + simp + +private theorem strictClosure_orderType_le_two_mul (hs : s.IsPWO) (hz : IsLUB s z) : + ((hs.closure.mono (s := strictClosure (s := s) (z := z)) + inter_subset_left).orderType) ≤ + 2 * hs.orderType := by + let ht := hs.closure.mono (s := strictClosure (s := s) (z := z)) inter_subset_left + let : WellFoundedLT (strictClosure (s := s) (z := z)) := ht.isWF + let : WellFoundedLT s := hs.isWF + let e : strictClosure (s := s) (z := z) ↪o s ×ₗ Fin 2 := + OrderEmbedding.ofStrictMono (closureEmbedding hs hz) + (closureEmbedding_strictMono hs hz) + calc + ht.orderType = typeLT (strictClosure (s := s) (z := z)) := + ht.orderType_eq_typeLT_of_orderIso (OrderIso.refl _) + _ ≤ typeLT (s ×ₗ Fin 2) := e.ltEmbedding.ordinal_type_le + _ = 2 * hs.orderType := by + change Ordinal.type (Prod.Lex (fun a b : s ↦ a < b) + (fun a b : Fin 2 ↦ a < b)) = _ + rw [Ordinal.type_prod_lex, Ordinal.type_fin] + exact congrArg (2 * ·) (hs.orderType_eq_typeLT_of_orderIso (OrderIso.refl s)).symm + +private theorem strictClosure_orderType_eq_of_two_mul (hs : s.IsPWO) (hz : IsLUB s z) + (hzn : z ∉ s) (habsorb : 2 * hs.orderType = hs.orderType) : + (hs.closure.mono (s := strictClosure (s := s) (z := z)) + inter_subset_left).orderType = hs.orderType := by + let ht := hs.closure.mono (s := strictClosure (s := s) (z := z)) inter_subset_left + apply le_antisymm + · simpa only [habsorb] using strictClosure_orderType_le_two_mul hs hz + · apply hs.orderType_mono ht + intro x hx + refine ⟨subset_closure hx, ?_⟩ + exact lt_of_le_of_ne (hz.1 hx) fun h ↦ hzn (h ▸ hx) + +private theorem strictClosure_orderType_eq_opow (hs : s.IsPWO) (hz : IsLUB s z) + (hzn : z ∉ s) {a : Ordinal} (ha : a ≠ 0) + (htype : hs.orderType = omega0 ^ a) : + (hs.closure.mono (s := strictClosure (s := s) (z := z)) + inter_subset_left).orderType = omega0 ^ a := by + have habsorb : 2 * hs.orderType = hs.orderType := by + rw [htype, mul_eq_right_iff_opow_omega0_dvd] + have h2 : (2 : Ordinal) ^ omega0 = omega0 := natCast_opow_omega0 (by norm_num) + rw [h2] + have hle : (1 : Ordinal) ≤ a := by + simpa using Order.succ_le_of_lt (pos_iff_ne_zero.mpr ha) + simpa only [opow_one] using opow_dvd_opow omega0 hle + exact (strictClosure_orderType_eq_of_two_mul hs hz hzn habsorb).trans htype + +private theorem mem_cantorBendixson_top_Iio_iff {T : Ordinal.{0}} (i : Iio T) + (a : Ordinal.{0}) : + i ∈ ((⊤ : TopologicalSpace.Closeds (Iio T)).cantorBendixson a : Set (Iio T)) ↔ + i.1 ∈ ((⊤ : TopologicalSpace.Closeds Ordinal).cantorBendixson a : Set Ordinal) := by + let f : Iio T → Ordinal := Subtype.val + have hf : Topology.IsOpenEmbedding f := isOpen_Iio.isOpenEmbedding_subtypeVal + have himage := hf.image_cantorBendixson_top_eq a + constructor + · intro hi + have hm : f i ∈ f '' + ((⊤ : TopologicalSpace.Closeds (Iio T)).cantorBendixson a : Set (Iio T)) := + ⟨i, hi, rfl⟩ + exact ((Set.ext_iff.mp himage (f i)).mp hm).1 + · intro hi + have hm : f i ∈ + ((⊤ : TopologicalSpace.Closeds Ordinal).cantorBendixson a : Set Ordinal) ∩ + range f := ⟨hi, mem_range_self i⟩ + obtain ⟨j, hj, hji⟩ := (Set.ext_iff.mp himage (f i)).mpr hm + exact hf.injective hji ▸ hj + +/-- If a real well-order has order type `ω ^ a` and a strict supremum, that supremum has +Cantor–Bendixson rank `a` in the closure. -/ +@[blueprint "lem:cantor-bendixson-rank-of-strict-supremum" + (phase := "Cantor–Bendixson ranks of supports") + (title := "Cantor--Bendixson rank at a strict supremum") + (statement := /-- + Let $S\subseteq\mathbb R$ be well ordered and let $z$ be its least upper + bound, with $z\notin S$. If $\alpha\ne0$ and + $\operatorname{ot}(S)=\omega^\alpha$, then + \[ + \operatorname{rk}_{\mathrm{CB},\mathrm{cl}(S)}(z)=\alpha. + \] + -/) + (proof := /-- + The closure of $S$ is again well ordered. Its increasing enumeration is a + homeomorphism from an ordinal interval, and the strict initial segment below + $z$ still has order type $\omega^\alpha$. In an ordinal interval, the + $\alpha$-th Cantor--Bendixson derivative contains the point indexed by + $\omega^\alpha$, while the $(\alpha+1)$-st derivative does not. Transport + these two statements through the homeomorphism to the closure of $S$. + -/)] +theorem IsPWO.cantorBendixsonRank_closure_eq_of_orderType_eq_opow + (hs : s.IsPWO) (hz : IsLUB s z) (hzn : z ∉ s) {a : Ordinal} (ha : a ≠ 0) + (htype : hs.orderType = omega0 ^ a) : + TopologicalSpace.Closeds.cantorBendixsonRank + (⟨(_root_.closure s), isClosed_closure⟩ : TopologicalSpace.Closeds ℝ) + (Set.IsPWO.closure hs) z = a := by + obtain ⟨y, hy, -, -⟩ := hz.exists_between (sub_lt_self z one_pos) + have hzc : z ∈ _root_.closure s := hz.mem_closure ⟨y, hy⟩ + let S : TopologicalSpace.Closeds ℝ := ⟨(_root_.closure s), isClosed_closure⟩ + let C : Set ℝ := _root_.closure s + let hc : C.IsPWO := hs.closure + let : WellFoundedLT C := hc.isWF + let T : Ordinal := Ordinal.type (· < · : C → C → Prop) + let i : Iio T := + ⟨Ordinal.typein (· < · : C → C → Prop) ⟨z, hzc⟩, + Ordinal.typein_lt_type _ _⟩ + have hi : i.1 = omega0 ^ a := by + rw [← strictClosure_orderType_eq_opow hs hz hzn ha htype] + exact (hc.orderType_inter_Iio_eq_typein hzc).symm + let e := Set.IsPWO.homeomorphIioType (s := C) isClosed_closure + have hei : e i = ⟨z, hzc⟩ := by + apply Subtype.ext + simp [e, Set.IsPWO.homeomorphIioType, Set.IsPWO.enumRealOrderIso, + i] + have hsource : + i ∈ ((⊤ : TopologicalSpace.Closeds (Iio T)).cantorBendixson a : Set (Iio T)) := by + rw [mem_cantorBendixson_top_Iio_iff, Ordinal.cantorBendixson_top_eq, + ite_eq_right ha, hi, Ordinal.mem_positivePrincipalMultiples] + exact ⟨1, zero_lt_one, by simp⟩ + have hsourceSucc : + i ∉ ((⊤ : TopologicalSpace.Closeds (Iio T)).cantorBendixson (a + 1) : + Set (Iio T)) := by + have hsucc : a + 1 ≠ 0 := (add_pos_of_right zero_lt_one a).ne' + rw [mem_cantorBendixson_top_Iio_iff, Ordinal.cantorBendixson_top_eq, + ite_eq_right hsucc, hi, Ordinal.mem_positivePrincipalMultiples] + rintro ⟨q, hq, heq⟩ + have hle : omega0 ^ (a + 1) ≤ omega0 ^ (a + 1) * q := + by simpa using mul_le_mul_right (one_le_iff_pos.mpr hq) (omega0 ^ (a + 1)) + have hlt : omega0 ^ a < omega0 ^ (a + 1) := + (opow_lt_opow_iff_right one_lt_omega0).mpr (Order.lt_succ a) + exact (not_le_of_gt hlt) (hle.trans_eq heq) + have heTop : e '' (Set.univ : Set (Iio T)) = (Set.univ : Set C) := by + ext x + simp + have hsub : ⟨z, hzc⟩ ∈ + ((⊤ : TopologicalSpace.Closeds C).cantorBendixson a : Set C) := by + rw [← hei] + exact (e.mem_cantorBendixson_iff ⊤ ⊤ heTop i a).mpr hsource + have hsubSucc : ⟨z, hzc⟩ ∉ + ((⊤ : TopologicalSpace.Closeds C).cantorBendixson (a + 1) : Set C) := by + rw [← hei] + exact fun h ↦ hsourceSucc ((e.mem_cantorBendixson_iff ⊤ ⊤ heTop i (a + 1)).mp h) + let j : C → ℝ := Subtype.val + have hj : Topology.IsClosedEmbedding j := isClosed_closure.isClosedEmbedding_subtypeVal + let J : TopologicalSpace.Closeds ℝ := + ⟨j '' ((⊤ : TopologicalSpace.Closeds C) : Set C), + hj.isClosedMap _ (TopologicalSpace.Closeds.isClosed ⊤)⟩ + have hJS : J = S := by + apply SetLike.coe_injective + ext x + simp [J, S, j, C] + have hambient : z ∈ (S.cantorBendixson a : Set ℝ) := by + have hstage := hj.image_cantorBendixson_eq ⊤ a + have hzJ : z ∈ (J.cantorBendixson a : Set ℝ) := by + rw [← hstage] + exact ⟨⟨z, hzc⟩, hsub, rfl⟩ + rwa [hJS] at hzJ + have hambientSucc : z ∉ (S.cantorBendixson (a + 1) : Set ℝ) := by + have hstage := hj.image_cantorBendixson_eq ⊤ (a + 1) + intro hzS + have hzJ : z ∈ (J.cantorBendixson (a + 1) : Set ℝ) := by + rwa [hJS] + rw [← hstage] at hzJ + obtain ⟨x, hx, hxz⟩ := hzJ + change x.1 = z at hxz + have hxeq : x = ⟨z, hzc⟩ := Subtype.ext hxz + exact hsubSucc (hxeq ▸ hx) + exact (S.cantorBendixsonRank_eq_iff (Set.IsPWO.closure hs) hzc a).mpr + ⟨hambient, hambientSucc⟩ + +end Set diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Topology/Order/CoinitialComplete.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Topology/Order/CoinitialComplete.lean new file mode 100644 index 0000000000..6f56ebd629 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Topology/Order/CoinitialComplete.lean @@ -0,0 +1,238 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import Mathlib.Topology.Algebra.IsUniformGroup.Defs +public import Mathlib.Topology.Order.Basic +public import Mathlib.Topology.UniformSpace.Cauchy + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint + +/-! +# Completeness from a coinitial family and fillable cuts + +An ordered abelian group need not be Cauchy complete, and the group of exponents of a Conway +normal form is a case in point: the partial sums of `∑_a ω^(-a)` over all ordinals `a` form a +Cauchy family with no limit, because a limit would need a support that is not a set. What rescues +the situation is passing to a quotient by a convex subgroup, where the positive elements acquire a +*set-indexed* coinitial family. This file records what that buys. + +Suppose the positive elements of `G` admit a family `ε : ι → G` that is coinitial with room to +spare — below every positive element sits some `ε i` together with a second copy of itself — and +suppose every cut cut out by two `ι`-indexed families can be filled. Then `G` is Cauchy complete +(`completeSpace_of_coinitial_of_forall_exists_mem_cut`). + +The proof is the usual centre-and-radius argument, carried out at the fixed index type `ι` so that +only cuts between two `ι`-indexed families are ever needed. Pick for each `i` a set `A i` in the +Cauchy filter of diameter below `ε i` and a point `a i` of it. Any two of these sets meet, so +`a i - ε i < a j + ε j` for all `i` and `j`; filling that cut gives a point `z` within `ε i` of +every `a i`, and then `A i` sits inside any interval around `z` of radius at least `ε i + ε i`. + +For the intended application `ι` indexes a coinitial family of the quotient, the cuts are filled by +choosing representatives and taking a single surreal cut between the two resulting sets, and the +second copy of `ε i` is available because the quotient is divisible. +-/ + +universe u w + +open Filter Set Topology Uniformity + +public section + +/-- Filling cuts between two `ι`-indexed families. Stated as a predicate so that the hypothesis +can be transported along a quotient before being fed to the completeness criterion. -/ +def FillsCuts (ι : Type w) (G : Type u) [Preorder G] : Prop := + ∀ L R : ι → G, (∀ i j, L i < R j) → ∃ z, (∀ i, L i ≤ z) ∧ ∀ j, z ≤ R j + +theorem fillsCuts_iff (ι : Type w) (G : Type u) [Preorder G] : + FillsCuts ι G ↔ + ∀ L R : ι → G, (∀ i j, L i < R j) → ∃ z, (∀ i, L i ≤ z) ∧ ∀ j, z ≤ R j := + Iff.rfl + +/-- A conditionally complete order fills every cut between nonempty families: the supremum of the +lower family is bounded above by the upper one, and lies below all of it. -/ +theorem fillsCuts_of_conditionallyCompleteLinearOrder {ι : Type w} [Nonempty ι] + {G : Type u} [ConditionallyCompleteLinearOrder G] : FillsCuts ι G := by + intro L R hLR + have hbdd : BddAbove (Set.range L) := + ⟨R (Classical.arbitrary ι), by rintro _ ⟨i, rfl⟩; exact (hLR i _).le⟩ + refine ⟨sSup (Set.range L), fun i ↦ le_csSup hbdd ⟨i, rfl⟩, fun j ↦ ?_⟩ + exact csSup_le (Set.range_nonempty L) (by rintro _ ⟨i, rfl⟩; exact (hLR i j).le) + +/-- **Cut filling passes to a quotient.** A surjection that preserves `≤` and reflects `<` carries +the property of filling `ι`-indexed cuts along with it: lift the two families to representatives, +which the reflected order still separates, fill the cut upstairs, and push the filler down. + +For a quotient of an ordered group by a convex subgroup the hypotheses hold, so the quotient fills +cuts as soon as the group does — which for the surreals is the simplicity theorem at sets. -/ +@[blueprint "lem:cut-filling-order-reflecting-surjection" + (phase := "A cut criterion for Cauchy completeness") + (title := "Cut filling under monotone order-reflecting surjections") + (statement := /-- + Let $f\colon G\twoheadrightarrow C$ be a monotone surjection of preordered + sets that reflects strict inequalities. If every cut between two + $I$-indexed families in $G$ can be filled, then the same is true in $C$. + -/) + (proof := /-- + Choose preimages in $G$ of the two families in $C$. Reflection of strict + inequalities keeps the lifted families separated. Fill their cut in + $G$, then apply $f$; monotonicity places the image between the two original + families. + -/)] +theorem FillsCuts.of_surjective {ι : Type w} {G : Type u} {C : Type*} [Preorder G] [Preorder C] + {f : G → C} (hsurj : Function.Surjective f) (hmono : Monotone f) + (hreflect : ∀ a b : G, f a < f b → a < b) (hG : FillsCuts ι G) : FillsCuts ι C := by + intro L R hLR + choose l hl using fun i ↦ hsurj (L i) + choose r hr using fun j ↦ hsurj (R j) + obtain ⟨z, hzl, hzr⟩ := hG l r fun i j ↦ hreflect _ _ (by rw [hl, hr]; exact hLR i j) + exact ⟨f z, fun i ↦ hl i ▸ hmono (hzl i), fun j ↦ hr j ▸ hmono (hzr j)⟩ + +variable {G : Type u} [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [UniformSpace G] [IsUniformAddGroup G] [OrderTopology G] + +/-- The symmetric interval of a positive radius is an entourage. -/ +theorem mem_uniformity_Ioo_of_pos {c : G} (hc : 0 < c) : + {p : G × G | p.2 - p.1 ∈ Ioo (-c) c} ∈ 𝓤 G := by + rw [uniformity_eq_comap_nhds_zero G] + exact ⟨Ioo (-c) c, Ioo_mem_nhds (neg_neg_iff_pos.mpr hc) hc, subset_rfl⟩ + +/-- Conversely every entourage contains a symmetric interval of positive radius. -/ +theorem exists_pos_Ioo_subset_of_mem_uniformity [Nontrivial G] {s : Set (G × G)} + (hs : s ∈ 𝓤 G) : ∃ c : G, 0 < c ∧ {p : G × G | p.2 - p.1 ∈ Ioo (-c) c} ⊆ s := by + rw [uniformity_eq_comap_nhds_zero G] at hs + obtain ⟨W, hW, hWs⟩ := hs + obtain ⟨x, hx⟩ := exists_ne (0 : G) + have hpos : (0 : G) < |x| := abs_pos.mpr hx + obtain ⟨l, u, hlu, hsub⟩ := + (mem_nhds_iff_exists_Ioo_subset' ⟨-|x|, neg_neg_iff_pos.mpr hpos⟩ ⟨|x|, hpos⟩).mp hW + refine ⟨min (-l) u, lt_min (neg_pos.mpr hlu.1) hlu.2, fun p hp ↦ hWs ?_⟩ + refine hsub ⟨?_, ?_⟩ + · refine lt_of_le_of_lt ?_ hp.1 + rw [le_neg] + exact min_le_left (-l) u + · exact hp.2.trans_le (min_le_right (-l) u) + +/-- **Completeness from a coinitial family and fillable cuts.** If the positive elements of `G` +admit a coinitial family `ε : ι → G` whose members each fit twice below any prescribed positive +element, and every cut between two `ι`-indexed families of `G` is filled, then `G` is Cauchy +complete. + +Only cuts indexed by the same `ι` as the coinitial family are used, so for a quotient of the +surreals by a convex subgroup this asks for the simplicity theorem at sets, not at classes. -/ +@[blueprint "lem:complete-of-coinitial-scales-and-cut-filling" + (phase := "A cut criterion for Cauchy completeness") + (title := "A cut criterion for Cauchy completeness") + (statement := /-- + Let $G$ be an ordered abelian group whose order topology is induced by a + compatible additive uniformity, and let $I$ be nonempty. Suppose there + are elements $\varepsilon_i>0$ such that, for every $c>0$, some $i\in I$ + satisfies + \[ + \varepsilon_i+\varepsilon_i\le c. + \] + Suppose also that whenever $L_i.trans hqb⟩ + exact (hab hc) (subset_closure ⟨i, rfl⟩) + · obtain ⟨p, ⟨hcutp, _⟩, ⟨_, hpb⟩⟩ := hi + obtain ⟨q, ⟨_, hqcenter⟩, ⟨haq, _⟩⟩ := hj + have hc : center j ∈ Ioo a b := + ⟨haq.trans_le hqcenter, (hord j i hji).trans_lt hcutp |>.trans hpb⟩ + exact (hab hc) (subset_closure ⟨j, rfl⟩) + +/-- Away from the closure of the interval centers, the closure of an ordered union agrees locally +with the closure of one member. -/ +theorem exists_local_closure_eq_ordered_iUnion + (f : ι → Set X) (cut center : ι → X) + (hsupp : ∀ i, f i ⊆ Ioc (cut i) (center i)) + (hord : ∀ i j, i < j → center i ≤ cut j) + {x : X} (hxcenter : x ∉ closure (Set.range center)) + (hx : x ∈ closure (⋃ i, f i)) : + ∃ i t, IsOpen t ∧ x ∈ t ∧ + closure (⋃ i, f i) ∩ t = closure (f i) ∩ t := by + obtain ⟨t, htx, hsub⟩ := exists_nhds_subsingleton_ordered_Ioc cut center hord hxcenter + let u := interior t + have hxu : x ∈ u := mem_interior_iff_mem_nhds.mpr htx + have huopen : IsOpen u := isOpen_interior + obtain ⟨p, hpu, hp⟩ := mem_closure_iff.mp hx u huopen hxu + rw [Set.mem_iUnion] at hp + obtain ⟨i, hpi⟩ := hp + have hi : i ∈ {j | (Ioc (cut j) (center j) ∩ t).Nonempty} := + ⟨p, hsupp i hpi, interior_subset hpu⟩ + refine ⟨i, u, huopen, hxu, huopen.closure_congr ?_⟩ + ext y + constructor + · rintro ⟨hy, hyu⟩ + rw [Set.mem_iUnion] at hy + obtain ⟨j, hyj⟩ := hy + have hj : j ∈ {k | (Ioc (cut k) (center k) ∩ t).Nonempty} := + ⟨y, hsupp j hyj, interior_subset hyu⟩ + exact ⟨hsub hj hi ▸ hyj, hyu⟩ + · rintro ⟨hyi, hyu⟩ + exact ⟨Set.mem_iUnion_of_mem i hyi, hyu⟩ + +/-- If a derivative stage of every component is supported at its interval center, the +corresponding stage of the ordered union is supported on the closure of those centers. -/ +theorem cantorBendixson_ordered_iUnion_subset_closure_range + (f : ι → Set X) (cut center : ι → X) + (hsupp : ∀ i, f i ⊆ Ioc (cut i) (center i)) + (hord : ∀ i j, i < j → center i ≤ cut j) (o : Ordinal.{u}) + (hstage : ∀ i, ((⟨closure (f i), isClosed_closure⟩ : Closeds X).cantorBendixson o : + Set X) ⊆ {center i}) : + ((⟨closure (⋃ i, f i), isClosed_closure⟩ : Closeds X).cantorBendixson o : Set X) ⊆ + closure (Set.range center) := by + intro x hx + by_contra hxcenter + have hxunion : x ∈ closure (⋃ i, f i) := + (⟨closure (⋃ i, f i), isClosed_closure⟩ : Closeds X).cantorBendixson_le o hx + obtain ⟨i, t, htopen, hxt, heq⟩ := + exists_local_closure_eq_ordered_iUnion f cut center hsupp hord hxcenter hxunion + let s : Closeds X := ⟨closure (⋃ i, f i), isClosed_closure⟩ + let q : Closeds X := ⟨closure (f i), isClosed_closure⟩ + have hcongr := TopologicalSpace.Closeds.cantorBendixson_congr_on_open + s q htopen heq o + have hm := (Set.ext_iff.mp hcongr x).mp ⟨hx, hxt⟩ + have hxc : x = center i := Set.mem_singleton_iff.mp (hstage i hm.1) + exact hxcenter (subset_closure ⟨i, hxc.symm⟩) diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Topology/Order/PWOAddition.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Topology/Order/PWOAddition.lean new file mode 100644 index 0000000000..31a1d7735b --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Topology/Order/PWOAddition.lean @@ -0,0 +1,211 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import Mathlib.Order.WellFoundedSet +public import Mathlib.Topology.Algebra.IsUniformGroup.Basic +public import Mathlib.Topology.Order.LeftRightNhds +public import Mathlib.Topology.Maps.Proper.Basic +public import Mathlib.Topology.UniformSpace.UniformEmbedding +public import Mathlib.Topology.Algebra.Group.Pointwise + +/-! +# Addition on well-ordered supports + +In a complete linearly ordered uniform additive group, addition restricted to two closed +well-ordered subsets is proper and has finite fibers. Closure therefore commutes with their +pointwise sum. Well-ordering here refers to the increasing order on the exponent group. + +The proof uses the finite set of minimal elements in a partially well-ordered set: an ultrafilter +containing that set concentrates above one of its minimal elements. If the sums are Cauchy, +nonnegative increments in either coordinate are bounded by increments of the sum. Completeness +then supplies a limit in the closed product. No Archimedean or countable cofinality hypothesis +is used, and no order completion is substituted for the given ambient group. +-/ + +public section + +open Set Filter Topology +open scoped Pointwise + +/-- An ultrafilter containing a partially well-ordered set concentrates above one of its points. -/ +theorem Set.IsPWO.exists_eventually_le {α : Type*} [PartialOrder α] + {s : Set α} (hs : s.IsPWO) (𝒰 : Ultrafilter α) (hmem : s ∈ 𝒰) : + ∃ a ∈ s, ∀ᶠ b in 𝒰, a ≤ b := by + have hfin : {a | Minimal (· ∈ s) a}.Finite := + (setOfPred_minimal_antichain _).finite_of_partiallyWellOrderedOn + (hs.mono (setOfPred_minimal_subset _)) + have he : ∀ᶠ b in 𝒰, ∃ a ∈ {a | Minimal (· ∈ s) a}, a ≤ b := by + filter_upwards [hmem] with b hb + obtain ⟨a, hab, ha⟩ := hs.exists_le_minimal hb + exact ⟨a, ha, hab⟩ + obtain ⟨a, ha, hab⟩ := (Ultrafilter.eventually_exists_mem_iff hfin).mp he + exact ⟨a, ha.1, hab⟩ + +private theorem Set.IsPWO.exists_mem_Ioc_of_mem_closure {α : Type*} + [LinearOrder α] [TopologicalSpace α] [OrderTopology α] + {s : Set α} (hs : s.IsPWO) {x y : α} (hx : x ∈ closure s) (hy : y < x) : + ∃ b ∈ s, y < b ∧ b ≤ x := by + by_contra! hn + have habove : ∀ b ∈ s, y < b → x < b := fun b hb hyb ↦ hn b hb hyb + let v := s ∩ Ioi x + have hv : v.IsWF := hs.isWF.mono inter_subset_left + have hne : v.Nonempty := by + obtain ⟨b, hby, hbs⟩ := mem_closure_iff_nhds.mp hx (Ioi y) (Ioi_mem_nhds hy) + exact ⟨b, hbs, habove b hbs hby⟩ + let m := hv.min hne + have hm : m ∈ v := hv.min_mem hne + obtain ⟨b, hb, hbs⟩ := mem_closure_iff_nhds.mp hx (Ioo y m) (Ioo_mem_nhds hy hm.2) + exact (not_lt_of_ge (hv.min_le hne ⟨hbs, habove b hbs hb.1⟩)) hb.2 + +/-- The ambient closure of a well-ordered subset of a linearly ordered space is well ordered. -/ +theorem Set.IsPWO.closure {α : Type*} [LinearOrder α] [TopologicalSpace α] + [OrderTopology α] {s : Set α} (hs : s.IsPWO) : (closure s).IsPWO := by + rw [Set.isPWO_iff_isWF, Set.isWF_iff_no_descending_seq] + intro f hf hmem + choose b hbs hb using fun n ↦ + hs.exists_mem_Ioc_of_mem_closure (hmem n) (hf (Nat.lt_succ_self n)) + have hAnti : StrictAnti b := strictAnti_nat_of_succ_lt fun n ↦ + lt_of_le_of_lt (hb (n + 1)).2 (hb n).1 + exact (Set.isWF_iff_no_descending_seq.mp hs.isWF) b hAnti hbs + +section OrderedGroup + +variable {G : Type*} [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [UniformSpace G] [IsUniformAddGroup G] [OrderTopology G] [Nontrivial G] + +omit [UniformSpace G] [IsUniformAddGroup G] [OrderTopology G] [Nontrivial G] in +/-- A line of fixed sum meets a product of well-ordered sets in finitely many points. -/ +theorem Set.IsPWO.finite_add_fiber {s t : Set G} (hs : s.IsPWO) (ht : t.IsPWO) (z : G) : + {p : G × G | p ∈ s ×ˢ t ∧ p.1 + p.2 = z}.Finite := by + apply IsAntichain.finite_of_partiallyWellOrderedOn _ + ((hs.prod ht).mono fun _ h ↦ h.1) + intro p hp q hq hne hpq + apply hne + have hfst : p.1 = q.1 := le_antisymm hpq.1 <| + (add_le_add_iff_right p.2).mp <| calc + q.1 + p.2 ≤ q.1 + q.2 := add_le_add_right hpq.2 _ + _ = p.1 + p.2 := hq.2.trans hp.2.symm + exact Prod.ext hfst (add_left_cancel (hfst ▸ hp.2.trans hq.2.symm)) + +omit [UniformSpace G] [IsUniformAddGroup G] [OrderTopology G] [Nontrivial G] in +private theorem abs_sub_lt_of_lower_bound {a x y : G × G} {ε : G} + (hx : a ≤ x) (hy : a ≤ y) + (hxs : |(x.1 + x.2) - (a.1 + a.2)| < ε) + (hys : |(y.1 + y.2) - (a.1 + a.2)| < ε) : |x.1 - y.1| < ε := by + have hb (z : G × G) (hz : a ≤ z) : + z.1 - a.1 ≤ (z.1 + z.2) - (a.1 + a.2) := by + rw [← sub_add_sub_comm] + exact le_add_of_nonneg_right (sub_nonneg.mpr hz.2) + apply abs_lt.mpr + constructor + · have h : y.1 - x.1 < ε := + (sub_le_sub_left hx.1 _).trans_lt ((hb y hy).trans_lt (abs_lt.mp hys).2) + simpa only [neg_sub] using neg_lt_neg h + · exact (sub_le_sub_left hy.1 _).trans_lt ((hb x hx).trans_lt (abs_lt.mp hxs).2) + +private theorem Ultrafilter.exists_mem_small_coordinates {s t : Set G} + (hs : s.IsPWO) (ht : t.IsPWO) (𝒰 : Ultrafilter (G × G)) + (hmem : s ×ˢ t ∈ 𝒰) + (hc : Cauchy (Filter.map (fun p : G × G ↦ p.1 + p.2) (𝒰 : Filter (G × G)))) + {ε : G} (hε : 0 < ε) : + ∃ v ∈ 𝒰, ∀ x ∈ v, ∀ y ∈ v, |x.1 - y.1| < ε ∧ |x.2 - y.2| < ε := by + obtain ⟨v, hv, hdiam⟩ := + ((nhds_basis_zero_abs_lt G).uniformity_of_nhds_zero_swapped.cauchy_iff.mp hc).2 ε hε + let w : Set (G × G) := (s ×ˢ t) ∩ {p | p.1 + p.2 ∈ v} + have hw : w ∈ 𝒰 := inter_mem hmem hv + obtain ⟨a, ha, hle⟩ := ((hs.prod ht).mono inter_subset_left).exists_eventually_le 𝒰 hw + refine ⟨w ∩ Ici a, inter_mem hw hle, ?_⟩ + intro x hx y hy + have hxa : |(x.1 + x.2) - (a.1 + a.2)| < ε := hdiam _ hx.1.2 _ ha.2 + have hya : |(y.1 + y.2) - (a.1 + a.2)| < ε := hdiam _ hy.1.2 _ ha.2 + refine ⟨abs_sub_lt_of_lower_bound hx.2 hy.2 hxa hya, ?_⟩ + exact abs_sub_lt_of_lower_bound (a := a.swap) (x := x.swap) (y := y.swap) + ⟨hx.2.2, hx.2.1⟩ ⟨hy.2.2, hy.2.1⟩ + (by simpa only [Prod.swap, add_comm] using hxa) + (by simpa only [Prod.swap, add_comm] using hya) + +/-- A Cauchy sum makes an ultrafilter on two well-ordered supports itself Cauchy. -/ +theorem Ultrafilter.cauchy_of_add {s t : Set G} + (hs : s.IsPWO) (ht : t.IsPWO) (𝒰 : Ultrafilter (G × G)) + (hmem : s ×ˢ t ∈ 𝒰) + (hc : Cauchy (Filter.map (fun p : G × G ↦ p.1 + p.2) (𝒰 : Filter (G × G)))) : + Cauchy (𝒰 : Filter (G × G)) := by + rw [cauchy_prod_iff] + constructor + · rw [IsUniformAddGroup.cauchy_map_iff_tendsto] + refine ⟨inferInstance, (nhds_basis_zero_abs_lt G).tendsto_right_iff.mpr ?_⟩ + intro ε hε + obtain ⟨v, hv, hd⟩ := 𝒰.exists_mem_small_coordinates hs ht hmem hc hε + exact mem_of_superset (prod_mem_prod hv hv) fun p hp ↦ (hd _ hp.1 _ hp.2).1 + · rw [IsUniformAddGroup.cauchy_map_iff_tendsto] + refine ⟨inferInstance, (nhds_basis_zero_abs_lt G).tendsto_right_iff.mpr ?_⟩ + intro ε hε + obtain ⟨v, hv, hd⟩ := 𝒰.exists_mem_small_coordinates hs ht hmem hc hε + exact mem_of_superset (prod_mem_prod hv hv) fun p hp ↦ (hd _ hp.1 _ hp.2).2 + +/-- Addition on two closed well-ordered supports is proper in an ordered uniform group that is +Cauchy complete. -/ +theorem Set.IsPWO.isProperMap_add [CompleteSpace G] {s t : Set G} + (hs : s.IsPWO) (ht : t.IsPWO) (hsc : IsClosed s) (htc : IsClosed t) : + IsProperMap (fun p : s ×ˢ t ↦ p.1.1 + p.1.2) := by + let : CompleteSpace (s ×ˢ t) := (hsc.prod htc).isComplete.completeSpace_coe + refine isProperMap_iff_ultrafilter_of_t2.mpr ⟨by fun_prop, ?_⟩ + intro 𝒰 y hy + have hc : Cauchy (Filter.map (fun p : G × G ↦ p.1 + p.2) + (𝒰.map Subtype.val : Filter (G × G))) := by + simpa only [Ultrafilter.coe_map, Filter.map_map, Function.comp_def] using hy.cauchy_map + have hm : s ×ˢ t ∈ 𝒰.map Subtype.val := by + change {p : s ×ˢ t | p.1 ∈ s ×ˢ t} ∈ (𝒰 : Filter (s ×ˢ t)) + exact Filter.Eventually.of_forall fun p ↦ p.2 + have hu := (𝒰.map Subtype.val).cauchy_of_add hs ht hm hc + have hcU : Cauchy (𝒰 : Filter (s ×ˢ t)) := + isUniformEmbedding_subtype_val.isUniformInducing.cauchy_map_iff.mp hu + exact cauchy_iff_exists_le_nhds.mp hcU + +/-- Addition on two closed well-ordered supports is a closed map. -/ +theorem Set.IsPWO.isClosedMap_add [CompleteSpace G] {s t : Set G} + (hs : s.IsPWO) (ht : t.IsPWO) (hsc : IsClosed s) (htc : IsClosed t) : + IsClosedMap (fun p : s ×ˢ t ↦ p.1.1 + p.1.2) := + (hs.isProperMap_add ht hsc htc).isClosedMap + +omit [UniformSpace G] [IsUniformAddGroup G] [OrderTopology G] [Nontrivial G] in +/-- Every fiber of addition on the subtype of two well-ordered supports is finite. -/ +theorem Set.IsPWO.finite_subtype_add_fiber {s t : Set G} + (hs : s.IsPWO) (ht : t.IsPWO) (z : G) : + ((fun p : s ×ˢ t ↦ p.1.1 + p.1.2) ⁻¹' {z}).Finite := by + have hf := (hs.finite_add_fiber ht z).preimage + (f := (Subtype.val : s ×ˢ t → G × G)) Subtype.val_injective.injOn + change {p : s ×ˢ t | p.1.1 + p.1.2 = z}.Finite + simpa only [Set.preimage_ofPred_eq, Subtype.coe_prop, true_and] using hf + +/-- The sum of two closed well-ordered supports is closed. -/ +theorem Set.IsPWO.isClosed_add [CompleteSpace G] {s t : Set G} + (hs : s.IsPWO) (ht : t.IsPWO) (hsc : IsClosed s) (htc : IsClosed t) : + IsClosed (s + t) := by + have he : Set.range (fun p : s ×ˢ t ↦ p.1.1 + p.1.2) = s + t := by + ext z + constructor + · rintro ⟨p, rfl⟩ + exact Set.add_mem_add p.2.1 p.2.2 + · rintro ⟨x, hx, y, hy, rfl⟩ + exact ⟨⟨(x, y), hx, hy⟩, rfl⟩ + rw [← he] + exact (hs.isClosedMap_add ht hsc htc).isClosed_range + +/-- Closure commutes with addition of well-ordered supports when the ambient ordered uniform group +is Cauchy complete. -/ +theorem Set.IsPWO.closure_add_eq [CompleteSpace G] {s t : Set G} + (hs : s.IsPWO) (ht : t.IsPWO) : + _root_.closure (s + t) = _root_.closure s + _root_.closure t := by + apply Subset.antisymm + · exact closure_minimal (Set.add_subset_add subset_closure subset_closure) + (hs.closure.isClosed_add ht.closure isClosed_closure isClosed_closure) + · rw [← Set.image2_add, ← Set.image2_add, ← Set.image_prod, ← Set.image_prod, + ← closure_prod_eq] + exact image_closure_subset_closure_image (by fun_prop) + +end OrderedGroup diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Topology/Order/PWOAdditionFiber.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Topology/Order/PWOAdditionFiber.lean new file mode 100644 index 0000000000..94cf99d8a0 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Topology/Order/PWOAdditionFiber.lean @@ -0,0 +1,77 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Topology.CantorBendixsonRank + +/-! +# Local domination by a finite addition fiber + +Near a fixed sum, each pair from two closed well-ordered supports is coordinatewise bounded +by exactly one pair in the fiber at that sum. Closedness of addition propagates the local +right gaps of the supports to a whole nearby fiber; finite fibers supply uniqueness. +The ambient ordered uniform group is Cauchy complete. No countability or density is assumed. +-/ + +public noncomputable section + +open Set Filter Topology + +universe u + +variable {G : Type u} [AddCommGroup G] [LinearOrder G] [IsOrderedAddMonoid G] + [UniformSpace G] [IsUniformAddGroup G] [OrderTopology G] [Nontrivial G] [CompleteSpace G] + +/-- Every nearby addition pair lies below a pair in the fixed fiber. -/ +theorem Set.IsPWO.eventually_exists_add_dominator {B C : Set G} + (hB : B.IsPWO) (hC : C.IsPWO) (hBc : IsClosed B) (hCc : IsClosed C) (γ : G) : + ∀ᶠ δ in 𝓝 γ, ∀ q : B ×ˢ C, q.1.1 + q.1.2 = δ → + ∃ p : B ×ˢ C, p.1.1 + p.1.2 = γ ∧ q.1 ≤ p.1 := by + apply (hB.isClosedMap_add hC hBc hCc).eventually_nhds_fiber γ + intro p hp + have hfst : Continuous (fun q : B ×ˢ C ↦ q.1.1) := by fun_prop + have hsnd : Continuous (fun q : B ×ˢ C ↦ q.1.2) := by fun_prop + filter_upwards [hfst.continuousAt.tendsto.eventually (hB.eventually_le p.1.1), + hsnd.continuousAt.tendsto.eventually (hC.eventually_le p.1.2)] with q hq1 hq2 + exact ⟨p, hp, hq1 q.2.1, hq2 q.2.2⟩ + +/-- Every nearby addition pair lies below exactly one pair in the fixed fiber. -/ +theorem Set.IsPWO.eventually_existsUnique_add_dominator {B C : Set G} + (hB : B.IsPWO) (hC : C.IsPWO) (hBc : IsClosed B) (hCc : IsClosed C) (γ : G) : + ∀ᶠ δ in 𝓝 γ, ∀ q : B ×ˢ C, q.1.1 + q.1.2 = δ → + ∃! p : B ×ˢ C, p.1.1 + p.1.2 = γ ∧ q.1 ≤ p.1 := by + let f : B ×ˢ C → G := fun p ↦ p.1.1 + p.1.2 + let F := f ⁻¹' {γ} + have hF : F.Finite := hB.finite_subtype_add_fiber hC γ + have hu : ∀ᶠ δ in 𝓝 γ, ∀ p ∈ F, ∀ r ∈ F, ∀ q : B ×ˢ C, + f q = δ → q.1 ≤ p.1 → q.1 ≤ r.1 → p = r := by + apply hF.eventually_all.mpr + intro p hp + apply hF.eventually_all.mpr + intro r hr + by_cases he : p = r + · exact Filter.Eventually.of_forall fun _ _ _ _ _ ↦ he + have hne : p.1.1 ≠ r.1.1 := by + intro he1 + apply he + apply Subtype.ext + apply Prod.ext he1 + have hh : p.1.1 + p.1.2 = r.1.1 + r.1.2 := hp.trans hr.symm + rw [he1] at hh + exact add_left_cancel hh + rcases lt_or_gt_of_ne hne with hlt | hlt + · have hgap : p.1.1 + r.1.2 < γ := + (add_lt_add_left hlt r.1.2).trans_eq hr + filter_upwards [eventually_gt_nhds hgap] with δ hδ q hq hqp hqr + exact False.elim ((not_le_of_gt hδ) (hq ▸ add_le_add hqp.1 hqr.2)) + · have hgap : r.1.1 + p.1.2 < γ := + (add_lt_add_left hlt p.1.2).trans_eq hp + filter_upwards [eventually_gt_nhds hgap] with δ hδ q hq hqp hqr + exact False.elim ((not_le_of_gt hδ) (hq ▸ add_le_add hqr.1 hqp.2)) + filter_upwards [hB.eventually_exists_add_dominator hC hBc hCc γ, hu] + with δ hex huniq q hq + obtain ⟨p, hp, hqp⟩ := hex q hq + exact ⟨p, ⟨hp, hqp⟩, fun r hr ↦ huniq r hr.1 p hp q hq hr.2 hqp⟩ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Topology/Order/PWOSumset.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Topology/Order/PWOSumset.lean new file mode 100644 index 0000000000..41a5f58182 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Topology/Order/PWOSumset.lean @@ -0,0 +1,246 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import Mathlib.Algebra.Group.Pointwise.Set.Basic +public import Mathlib.Order.WellFoundedSet +public import Mathlib.Topology.MetricSpace.Pseudo.Defs + +import Mathlib.Topology.Instances.Real.Lemmas +import Mathlib.Topology.Order.MonotoneConvergence +import Mathlib.Topology.Sequences + +/-! +# Sumsets of well-ordered sets of reals + +The two geometric inputs to Berarducci's convolution formula in Section 7. + +Berarducci, Lemma 7.1: the closure of the pointwise sum of two partially well-ordered subsets of +`ℝ` is the sum of their closures. Berarducci, Lemma 7.4: for `δ ≤ γ` sufficiently close to +`γ`, +every point of `B × C` on the line of sum `δ` is dominated coordinatewise by exactly one point of +`B × C` on the line of sum `γ`. + +Both rest on one construction: a sequence in `B + C` converging to `x` can be replaced by a +subsequence whose two factor sequences are monotone, hence convergent, with limits in the two +closures summing to `x`. Well-ordering supplies the monotone subsequences and completeness of `ℝ` +supplies their limits; Berarducci, Remark 7.3 records that Lemma 7.1 fails over `ℚ`. + +Uniqueness in Lemma 7.4 is separate and uses only well-ordering: the line of sum `γ` meets +`B × C` in finitely many points, so the first coordinates of those points are separated by some +`d > 0`, and two distinct dominating points would force `γ - δ ≥ d`. + +The inclusion `closure B + closure C ⊆ closure (B + C)` holds for arbitrary sets and is stated +separately. Lemma 7.4 is applied to the closed supports of two series, so the module also proves +that the closure of a partially well-ordered set of reals is partially well ordered: a strictly +decreasing sequence in the closure can be pushed down to one in the set itself. +-/ + +public noncomputable section + +open Pointwise Filter Topology + +namespace Set + +private theorem exists_mem_Ioc_of_mem_closure {B : Set ℝ} (hB : B.IsPWO) {x y : ℝ} + (hx : x ∈ closure B) (hy : y < x) : ∃ b ∈ B, y < b ∧ b ≤ x := by + by_contra hcon + push Not at hcon + have habove : ∀ b ∈ B, y < b → x < b := by + intro b hbB hyb + exact lt_of_not_ge fun hbx ↦ absurd hbx (not_le.mpr (hcon b hbB hyb)) + set U := B ∩ Set.Ioi x with hU + have hUwf : U.IsWF := hB.isWF.mono Set.inter_subset_left + have hUne : U.Nonempty := by + obtain ⟨b, hbB, hb⟩ := Metric.mem_closure_iff.mp hx (x - y) (by linarith) + rw [Real.dist_eq, abs_lt] at hb + exact ⟨b, hbB, habove b hbB (by linarith [hb.1])⟩ + set m := hUwf.min hUne with hm + have hmU : m ∈ U := hUwf.min_mem hUne + have hmx : x < m := hmU.2 + obtain ⟨b', hb'B, hb'⟩ := + Metric.mem_closure_iff.mp hx (min (m - x) (x - y)) (lt_min (by linarith) (by linarith)) + rw [Real.dist_eq, abs_lt] at hb' + have hb'y : y < b' := by + have := hb'.1 + have hle : min (m - x) (x - y) ≤ x - y := min_le_right _ _ + linarith + have hb'x : x < b' := habove b' hb'B hb'y + have hb'm : b' < m := by + have := hb'.2 + have hle : min (m - x) (x - y) ≤ m - x := min_le_left _ _ + linarith + exact absurd hb'm (not_lt.mpr (hUwf.min_le hUne ⟨hb'B, hb'x⟩)) + +/-- The closure of a partially well-ordered set of reals is partially well ordered. -/ +theorem isPWO_closure {B : Set ℝ} (hB : B.IsPWO) : (closure B).IsPWO := by + rw [Set.isPWO_iff_isWF, Set.isWF_iff_no_descending_seq] + intro f hf hmem + choose b hbB hb using fun n ↦ + exists_mem_Ioc_of_mem_closure hB (hmem n) (hf (Nat.lt_succ_self n)) + have hAnti : StrictAnti b := by + refine strictAnti_nat_of_succ_lt fun n ↦ ?_ + exact lt_of_le_of_lt (hb (n + 1)).2 (hb n).1 + exact (Set.isWF_iff_no_descending_seq.mp hB.isWF) b hAnti hbB + +private theorem exists_monotone_limits_of_add_tendsto + {B C : Set ℝ} (hB : B.IsPWO) (hC : C.IsPWO) {x : ℝ} + {b c : ℕ → ℝ} (hb : ∀ n, b n ∈ B) (hc : ∀ n, c n ∈ C) + (hlim : Tendsto (fun n ↦ b n + c n) atTop (𝓝 x)) : + ∃ (g : ℕ → ℕ) (β ξ : ℝ), StrictMono g ∧ β ∈ closure B ∧ ξ ∈ closure C ∧ + β + ξ = x ∧ (∀ n, b (g n) ≤ β) ∧ ∀ n, c (g n) ≤ ξ := by + obtain ⟨g₁, hg₁⟩ := hB.exists_monotone_subseq hb + obtain ⟨g₂, hg₂⟩ := + hC.exists_monotone_subseq (f := fun n ↦ c (g₁ n)) fun n ↦ hc (g₁ n) + set g : ℕ → ℕ := fun n ↦ g₁ (g₂ n) with hgDef + have hgMono : StrictMono g := g₁.strictMono.comp g₂.strictMono + set B' : ℕ → ℝ := fun n ↦ b (g n) with hB'Def + set C' : ℕ → ℝ := fun n ↦ c (g n) with hC'Def + have hB'mono : Monotone B' := fun _ _ hmn ↦ hg₁ (g₂.strictMono.monotone hmn) + have hC'mono : Monotone C' := fun _ _ hmn ↦ hg₂ hmn + have hsumLim : Tendsto (fun n ↦ B' n + C' n) atTop (𝓝 x) := + hlim.comp hgMono.tendsto_atTop + have hbound : ∀ n, B' n + C' n ≤ x := (hB'mono.add hC'mono).ge_of_tendsto hsumLim + have hB'bdd : BddAbove (Set.range B') := by + refine ⟨x - C' 0, ?_⟩ + rintro _ ⟨n, rfl⟩ + have h0 := hC'mono (Nat.zero_le n) + have hn := hbound n + linarith + have hC'bdd : BddAbove (Set.range C') := by + refine ⟨x - B' 0, ?_⟩ + rintro _ ⟨n, rfl⟩ + have h0 := hB'mono (Nat.zero_le n) + have hn := hbound n + linarith + have hB'lim : Tendsto B' atTop (𝓝 (⨆ n, B' n)) := tendsto_atTop_ciSup hB'mono hB'bdd + have hC'lim : Tendsto C' atTop (𝓝 (⨆ n, C' n)) := tendsto_atTop_ciSup hC'mono hC'bdd + refine ⟨g, ⨆ n, B' n, ⨆ n, C' n, hgMono, + mem_closure_of_tendsto hB'lim (by filter_upwards with n using hb (g n)), + mem_closure_of_tendsto hC'lim (by filter_upwards with n using hc (g n)), ?_, + fun n ↦ le_ciSup hB'bdd n, fun n ↦ le_ciSup hC'bdd n⟩ + exact tendsto_nhds_unique (hB'lim.add hC'lim) hsumLim + +theorem closure_add_closure_subset (B C : Set ℝ) : + closure B + closure C ⊆ closure (B + C) := by + rw [← Set.image2_add, ← Set.image2_add, ← Set.image_prod, ← Set.image_prod, + ← closure_prod_eq] + exact image_closure_subset_closure_image (by fun_prop) + +theorem IsPWO.closure_add {B C : Set ℝ} (hB : B.IsPWO) (hC : C.IsPWO) : + closure (B + C) = closure B + closure C := by + refine Set.Subset.antisymm ?_ (closure_add_closure_subset B C) + intro x hx + obtain ⟨y, hy, hyx⟩ := mem_closure_iff_seq_limit.mp hx + choose b hb c hc hbc using fun n ↦ Set.mem_add.mp (hy n) + have hlim : Tendsto (fun n ↦ b n + c n) atTop (𝓝 x) := by + simpa only [hbc] using hyx + obtain ⟨_, β, ξ, _, hβ, hξ, hsum, -, -⟩ := + exists_monotone_limits_of_add_tendsto hB hC hb hc hlim + exact hsum ▸ Set.add_mem_add hβ hξ + +/-- Berarducci, Section 7: a line `β + ξ = γ` meets `B × C` in finitely many points. -/ +theorem IsPWO.finite_sub_mem {B C : Set ℝ} (hB : B.IsPWO) (hC : C.IsPWO) (γ : ℝ) : + {β | β ∈ B ∧ γ - β ∈ C}.Finite := by + by_contra hinf + rw [Set.not_finite] at hinf + set e := hinf.natEmbedding with he + set u : ℕ → ℝ := fun n ↦ (e n : ℝ) with hu + have huInj : Function.Injective u := fun m n hmn ↦ e.injective (Subtype.ext hmn) + have huB : ∀ n, u n ∈ B := fun n ↦ (e n).2.1 + have huC : ∀ n, γ - u n ∈ C := fun n ↦ (e n).2.2 + obtain ⟨g, hg⟩ := hB.exists_monotone_subseq huB + set v : ℕ → ℝ := fun n ↦ u (g n) with hv + have hvMono : Monotone v := fun _ _ hmn ↦ hg hmn + have hvInj : Function.Injective v := huInj.comp g.injective + have hvStrict : StrictMono v := hvMono.strictMono_of_injective hvInj + have hwAnti : StrictAnti (fun n ↦ γ - v n) := fun _ _ hmn ↦ + sub_lt_sub_left (hvStrict hmn) γ + exact (Set.isWF_iff_no_descending_seq.mp hC.isWF) _ hwAnti fun n ↦ huC (g n) + +private theorem exists_pos_forall_le_abs_sub {S : Set ℝ} (hS : S.Finite) : + ∃ d > (0 : ℝ), ∀ β₁ ∈ S, ∀ β₂ ∈ S, + β₁ ≠ β₂ → d ≤ |β₁ - β₂| := by + classical + set T := hS.toFinset with hT + set P := (T ×ˢ T).filter fun p ↦ p.1 ≠ p.2 with hP + by_cases hPne : P.Nonempty + · refine ⟨P.inf' hPne fun p ↦ |p.1 - p.2|, ?_, ?_⟩ + · rw [gt_iff_lt, Finset.lt_inf'_iff] + intro p hp + have hne : p.1 ≠ p.2 := (Finset.mem_filter.mp hp).2 + exact abs_pos.mpr (sub_ne_zero.mpr hne) + · intro β₁ h₁ β₂ h₂ hne + have hmem : (β₁, β₂) ∈ P := by + simp only [hP, Finset.mem_filter, Finset.mem_product, hT, + Set.Finite.mem_toFinset] + exact ⟨⟨h₁, h₂⟩, hne⟩ + exact Finset.inf'_le (fun p ↦ |p.1 - p.2|) hmem + · refine ⟨1, one_pos, fun β₁ h₁ β₂ h₂ hne ↦ absurd ⟨(β₁, β₂), ?_⟩ hPne⟩ + simp only [hP, Finset.mem_filter, Finset.mem_product, hT, + Set.Finite.mem_toFinset] + exact ⟨⟨h₁, h₂⟩, hne⟩ + +private theorem eventually_unique_dominating {B C : Set ℝ} + (hB : B.IsPWO) (hC : C.IsPWO) (γ : ℝ) : + ∀ᶠ δ in 𝓝[≤] γ, ∀ β' ξ' : ℝ, β' + ξ' = δ → ∀ β₁ β₂ : ℝ, + (β₁ ∈ B ∧ γ - β₁ ∈ C ∧ β' ≤ β₁ ∧ ξ' ≤ γ - β₁) → + (β₂ ∈ B ∧ γ - β₂ ∈ C ∧ β' ≤ β₂ ∧ + ξ' ≤ γ - β₂) → + β₁ = β₂ := by + obtain ⟨d, hd, hgap⟩ := exists_pos_forall_le_abs_sub (hB.finite_sub_mem hC γ) + have hnear : ∀ᶠ δ in 𝓝[≤] γ, γ - d < δ := + eventually_nhdsWithin_of_eventually_nhds (eventually_gt_nhds (by linarith)) + filter_upwards [hnear] with δ hδ β' ξ' hsum β₁ β₂ h₁ h₂ + by_contra hne + have hd₁₂ : d ≤ |β₁ - β₂| := + hgap β₁ ⟨h₁.1, h₁.2.1⟩ β₂ ⟨h₂.1, h₂.2.1⟩ hne + rcases abs_cases (β₁ - β₂) with ⟨habs, _⟩ | ⟨habs, _⟩ + · have : δ ≤ γ - d := by + have h := h₂.2.2.1 + have h' := h₁.2.2.2 + rw [habs] at hd₁₂ + linarith + linarith + · have : δ ≤ γ - d := by + have h := h₁.2.2.1 + have h' := h₂.2.2.2 + rw [habs] at hd₁₂ + linarith + linarith + +private theorem eventually_exists_dominating {B C : Set ℝ} + (hB : B.IsPWO) (hC : C.IsPWO) (hBc : IsClosed B) (hCc : IsClosed C) (γ : ℝ) : + ∀ᶠ δ in 𝓝[≤] γ, ∀ β' ∈ B, ∀ ξ' ∈ C, β' + ξ' = δ → + ∃ β, β ∈ B ∧ γ - β ∈ C ∧ β' ≤ β ∧ ξ' ≤ γ - β := by + by_contra hcon + rw [not_eventually] at hcon + obtain ⟨δ, hδ, hδp⟩ := Filter.exists_seq_forall_of_frequently hcon + simp only [not_forall, not_exists] at hδp + choose b hb c hc hbc hno using hδp + have hlim : Tendsto (fun n ↦ b n + c n) atTop (𝓝 γ) := by + have hδγ : Tendsto δ atTop (𝓝 γ) := hδ.mono_right nhdsWithin_le_nhds + simpa only [hbc] using hδγ + obtain ⟨g, β, ξ, _, hβ, hξ, hsum, hble, hcle⟩ := + exists_monotone_limits_of_add_tendsto hB hC hb hc hlim + have hβB : β ∈ B := hBc.closure_eq ▸ hβ + have hξC : ξ ∈ C := hCc.closure_eq ▸ hξ + have hγβ : γ - β = ξ := by linarith + exact hno (g 0) β ⟨hβB, by rw [hγβ]; exact hξC, hble 0, by rw [hγβ]; exact hcle 0⟩ + +/-- Berarducci, Lemma 7.4: for `δ ≤ γ` sufficiently close to `γ`, every point of +`B × C` on the line of sum `δ` is dominated by exactly one point of `B × C` on the line of +sum `γ`. -/ +theorem IsPWO.eventually_existsUnique_dominating {B C : Set ℝ} + (hB : B.IsPWO) (hC : C.IsPWO) (hBc : IsClosed B) (hCc : IsClosed C) (γ : ℝ) : + ∀ᶠ δ in 𝓝[≤] γ, ∀ β' ∈ B, ∀ ξ' ∈ C, β' + ξ' = δ → + ∃! β, β ∈ B ∧ γ - β ∈ C ∧ β' ≤ β ∧ ξ' ≤ γ - β := by + filter_upwards [eventually_exists_dominating hB hC hBc hCc γ, + eventually_unique_dominating hB hC γ] with δ hex huniq β' hβ' ξ' hξ' hsum + obtain ⟨β, hβ⟩ := hex β' hβ' ξ' hξ' hsum + exact ⟨β, hβ, fun β₂ h₂ ↦ huniq β' ξ' hsum β₂ β h₂ hβ⟩ + +end Set diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Topology/Order/SeparatedPieceFamily.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Topology/Order/SeparatedPieceFamily.lean new file mode 100644 index 0000000000..fc9ad99e27 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Topology/Order/SeparatedPieceFamily.lean @@ -0,0 +1,193 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Topology.CantorBendixsonReconstruction + +/-! +# Local geometry of separated piece families + +A family of pieces, each carried by an open member of a pairwise ordered disjoint family of open +sets and bounded above by a center inside its own open carrier, is locally a single piece: at a +point of some carrier, that carrier isolates its piece; away from all carriers and from the +closure of the centers, an order interval avoiding the centers meets at most one piece, because a +piece meeting it forces its center inside. This replaces the half-open interval bookkeeping of +ordered interval families and applies to cosets of convex open subgroups at arbitrary +cofinality. +-/ + +open Set Filter Topology TopologicalSpace + +universe u v + +public noncomputable section + +variable {X : Type u} {ι : Type v} + [LinearOrder X] [TopologicalSpace X] [OrderTopology X] [NoMinOrder X] [NoMaxOrder X] + [LinearOrder ι] + +omit [TopologicalSpace X] [OrderTopology X] [NoMinOrder X] [NoMaxOrder X] in +/-- An order interval avoiding the centers meets at most one piece of a separated family. -/ +theorem subsingleton_pieces_of_Ioo_of_notMem_centers + (P : ι → Set X) (C : ι → Set X) (x : ι → X) + (hPC : ∀ i, P i ⊆ C i) (hPx : ∀ i, ∀ p ∈ P i, p ≤ x i) (hxC : ∀ i, x i ∈ C i) + (hord : ∀ i j, i < j → ∀ a ∈ C i, ∀ b ∈ C j, a < b) + {a b : X} (hab : ∀ y ∈ Ioo a b, y ∉ Set.range x) : + {i | (P i ∩ Ioo a b).Nonempty}.Subsingleton := by + intro i hi j hj + by_contra hne + rcases lt_or_gt_of_ne hne with hij | hji + · obtain ⟨p, hpP, hpa, hpb⟩ := hi + obtain ⟨q, hqP, hqa, hqb⟩ := hj + have hpx : p ≤ x i := hPx i p hpP + have hxq : x i < q := hord i j hij (x i) (hxC i) q (hPC j hqP) + exact hab (x i) ⟨hpa.trans_le hpx, hxq.trans hqb⟩ ⟨i, rfl⟩ + · obtain ⟨p, hpP, hpa, hpb⟩ := hi + obtain ⟨q, hqP, hqa, hqb⟩ := hj + have hqx : q ≤ x j := hPx j q hqP + have hxp : x j < p := hord j i hji (x j) (hxC j) p (hPC i hpP) + exact hab (x j) ⟨hqa.trans_le hqx, hxp.trans hpb⟩ ⟨j, rfl⟩ + +/-- Away from the closure of the centers, the closure of a separated piece union agrees locally +with the closure of a single piece. -/ +theorem exists_local_closure_eq_separated_pieces + (P : ι → Set X) (C : ι → Set X) (x : ι → X) + (hPC : ∀ i, P i ⊆ C i) (hPx : ∀ i, ∀ p ∈ P i, p ≤ x i) (hxC : ∀ i, x i ∈ C i) + (hCopen : ∀ i, IsOpen (C i)) + (hdisj : ∀ i j, i ≠ j → Disjoint (C i) (C j)) + (hord : ∀ i j, i < j → ∀ a ∈ C i, ∀ b ∈ C j, a < b) + {z : X} (hzcenter : z ∉ closure (Set.range x)) + (hz : z ∈ closure (⋃ i, P i)) : + ∃ i t, IsOpen t ∧ z ∈ t ∧ + closure (⋃ i, P i) ∩ t = closure (P i) ∩ t := by + classical + by_cases hzC : ∃ i, z ∈ C i + · obtain ⟨i, hzi⟩ := hzC + refine ⟨i, C i, hCopen i, hzi, (hCopen i).closure_congr ?_⟩ + ext y + constructor + · rintro ⟨hy, hyC⟩ + rw [Set.mem_iUnion] at hy + obtain ⟨j, hyj⟩ := hy + rcases eq_or_ne j i with rfl | hji + · exact ⟨hyj, hyC⟩ + · exact absurd hyC (Set.disjoint_left.mp (hdisj j i hji) (hPC j hyj)) + · rintro ⟨hyi, hyC⟩ + exact ⟨Set.mem_iUnion_of_mem i hyi, hyC⟩ + · rw [not_exists] at hzC + have hcompl : (closure (Set.range x))ᶜ ∈ 𝓝 z := + isClosed_closure.isOpen_compl.mem_nhds hzcenter + obtain ⟨a, b, ⟨haz, hzb⟩, hab⟩ := mem_nhds_iff_exists_Ioo_subset.mp hcompl + have habx : ∀ y ∈ Ioo a b, y ∉ Set.range x := fun y hy hyx ↦ + hab hy (subset_closure hyx) + have hsub := subsingleton_pieces_of_Ioo_of_notMem_centers P C x hPC hPx hxC hord habx + obtain ⟨p, hpu, hp⟩ := mem_closure_iff.mp hz (Ioo a b) isOpen_Ioo ⟨haz, hzb⟩ + rw [Set.mem_iUnion] at hp + obtain ⟨i, hpi⟩ := hp + have hi : i ∈ {j | (P j ∩ Ioo a b).Nonempty} := ⟨p, hpi, hpu⟩ + refine ⟨i, Ioo a b, isOpen_Ioo, ⟨haz, hzb⟩, isOpen_Ioo.closure_congr ?_⟩ + ext y + constructor + · rintro ⟨hy, hyu⟩ + rw [Set.mem_iUnion] at hy + obtain ⟨j, hyj⟩ := hy + have hj : j ∈ {k | (P k ∩ Ioo a b).Nonempty} := ⟨y, hyj, hyu⟩ + exact ⟨hsub hj hi ▸ hyj, hyu⟩ + · rintro ⟨hyi, hyu⟩ + exact ⟨Set.mem_iUnion_of_mem i hyi, hyu⟩ + +/-- When every piece closure stays inside its open carrier, the closure of the union is carried +by the carriers together with the closure of the centers. -/ +theorem closure_iUnion_subset_of_closure_piece_subset + (P : ι → Set X) (C : ι → Set X) (x : ι → X) + (hPC : ∀ i, P i ⊆ C i) (hPx : ∀ i, ∀ p ∈ P i, p ≤ x i) (hxC : ∀ i, x i ∈ C i) + (hCopen : ∀ i, IsOpen (C i)) + (hdisj : ∀ i j, i ≠ j → Disjoint (C i) (C j)) + (hord : ∀ i j, i < j → ∀ a ∈ C i, ∀ b ∈ C j, a < b) + (hclP : ∀ i, closure (P i) ⊆ C i) : + closure (⋃ i, P i) ⊆ (⋃ i, C i) ∪ closure (Set.range x) := by + intro z hz + by_cases hzc : z ∈ closure (Set.range x) + · exact Or.inr hzc + · obtain ⟨i, t, -, hzt, heq⟩ := + exists_local_closure_eq_separated_pieces P C x hPC hPx hxC hCopen hdisj hord hzc hz + have hzi : z ∈ closure (P i) := ((Set.ext_iff.mp heq z).mp ⟨hz, hzt⟩).1 + exact Or.inl (Set.mem_iUnion_of_mem i (hclP i hzi)) + +/-- If a derivative stage of every piece is supported at its center, the same stage of the +separated union is supported on the closure of the centers. -/ +theorem cantorBendixson_separated_iUnion_subset_closure_range + (P : ι → Set X) (C : ι → Set X) (x : ι → X) + (hPC : ∀ i, P i ⊆ C i) (hPx : ∀ i, ∀ p ∈ P i, p ≤ x i) (hxC : ∀ i, x i ∈ C i) + (hCopen : ∀ i, IsOpen (C i)) + (hdisj : ∀ i j, i ≠ j → Disjoint (C i) (C j)) + (hord : ∀ i j, i < j → ∀ a ∈ C i, ∀ b ∈ C j, a < b) + (o : Ordinal.{u}) + (hstage : ∀ i, ((⟨closure (P i), isClosed_closure⟩ : Closeds X).cantorBendixson o : + Set X) ⊆ {x i}) : + ((⟨closure (⋃ i, P i), isClosed_closure⟩ : Closeds X).cantorBendixson o : Set X) ⊆ + closure (Set.range x) := by + intro z hz + by_contra hzcenter + have hzunion : z ∈ closure (⋃ i, P i) := + (⟨closure (⋃ i, P i), isClosed_closure⟩ : Closeds X).cantorBendixson_le o hz + obtain ⟨i, t, htopen, hzt, heq⟩ := + exists_local_closure_eq_separated_pieces P C x hPC hPx hxC hCopen hdisj hord hzcenter hzunion + let s : Closeds X := ⟨closure (⋃ i, P i), isClosed_closure⟩ + let q : Closeds X := ⟨closure (P i), isClosed_closure⟩ + have hcongr := TopologicalSpace.Closeds.cantorBendixson_congr_on_open s q htopen heq o + have hm := (Set.ext_iff.mp hcongr z).mp ⟨hz, hzt⟩ + have hzc : z = x i := Set.mem_singleton_iff.mp (hstage i hm.1) + exact hzcenter (subset_closure ⟨i, hzc.symm⟩) + +omit [NoMinOrder X] [NoMaxOrder X] [LinearOrder ι] in +/-- On its own open carrier, a derivative stage of the separated union agrees with that stage of +the single piece carried there. -/ +theorem cantorBendixson_inter_piece_eq + (P : ι → Set X) (C : ι → Set X) + (hPC : ∀ i, P i ⊆ C i) + (hCopen : ∀ i, IsOpen (C i)) + (hdisj : ∀ i j, i ≠ j → Disjoint (C i) (C j)) + (i : ι) (o : Ordinal.{u}) : + ((⟨closure (⋃ j, P j), isClosed_closure⟩ : Closeds X).cantorBendixson o : Set X) ∩ C i = + ((⟨closure (P i), isClosed_closure⟩ : Closeds X).cantorBendixson o : Set X) ∩ C i := by + have hinter : (⋃ j, P j) ∩ C i = P i ∩ C i := by + ext y + constructor + · rintro ⟨hy, hyC⟩ + rw [Set.mem_iUnion] at hy + obtain ⟨j, hyj⟩ := hy + rcases eq_or_ne j i with rfl | hji + · exact ⟨hyj, hyC⟩ + · exact absurd hyC (Set.disjoint_left.mp (hdisj j i hji) (hPC j hyj)) + · rintro ⟨hyi, hyC⟩ + exact ⟨Set.mem_iUnion_of_mem i hyi, hyC⟩ + exact TopologicalSpace.Closeds.cantorBendixson_congr_on_open _ _ (hCopen i) + ((hCopen i).closure_congr hinter) o + +/-- If every piece of a separated family has an empty stage, that stage of the union is carried +by the closure of the centers with the centers themselves removed. -/ +theorem cantorBendixson_separated_iUnion_subset_of_stage_empty + (P : ι → Set X) (C : ι → Set X) (x : ι → X) + (hPC : ∀ i, P i ⊆ C i) (hPx : ∀ i, ∀ p ∈ P i, p ≤ x i) (hxC : ∀ i, x i ∈ C i) + (hCopen : ∀ i, IsOpen (C i)) + (hdisj : ∀ i j, i ≠ j → Disjoint (C i) (C j)) + (hord : ∀ i j, i < j → ∀ a ∈ C i, ∀ b ∈ C j, a < b) + (o : Ordinal.{u}) + (hstage : ∀ i, ((⟨closure (P i), isClosed_closure⟩ : Closeds X).cantorBendixson o : + Set X) = ∅) : + ((⟨closure (⋃ i, P i), isClosed_closure⟩ : Closeds X).cantorBendixson o : Set X) ⊆ + closure (Set.range x) \ Set.range x := by + intro z hz + refine ⟨cantorBendixson_separated_iUnion_subset_closure_range P C x hPC hPx hxC hCopen hdisj + hord o (fun i ↦ by rw [hstage i]; exact Set.empty_subset _) hz, ?_⟩ + rintro ⟨i, rfl⟩ + have hmem : x i ∈ ((⟨closure (P i), isClosed_closure⟩ : Closeds X).cantorBendixson o : + Set X) ∩ C i := by + rw [← cantorBendixson_inter_piece_eq P C hPC hCopen hdisj i o] + exact ⟨hz, hxC i⟩ + rw [hstage i] at hmem + exact absurd hmem.1 (Set.notMem_empty _) diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Topology/Order/SmallClosedSubspace.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Topology/Order/SmallClosedSubspace.lean new file mode 100644 index 0000000000..44ea34a263 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Topology/Order/SmallClosedSubspace.lean @@ -0,0 +1,229 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Topology.Order.OrderedAddGroup +public import Mathlib.Algebra.Order.Module.Rat +public import Mathlib.Algebra.Module.Torsion.Field +public import Mathlib.LinearAlgebra.Finsupp.LinearCombination +public import Mathlib.SetTheory.Cardinal.Finsupp +public import Mathlib.SetTheory.Cardinal.Rat +public import Mathlib.Topology.Algebra.Module.Basic + +import LeanPool.ConwayRefinement.ConwayRefinement.Blueprint +import Mathlib.Tactic.NormNum.Inv +import Mathlib.Tactic.NormNum.Ineq + +/-! +# Supports in closed rational subspaces + +Density of a rational span in its closure bounds every well-ordered subset of the closure by the +cardinality of the original span. This keeps supports produced by Cantor–Bendixson germ refinement +below a prescribed cardinal without bounding the whole closed subspace. +-/ + +open Set +open Cardinal + +universe u + +public noncomputable section + +namespace Submodule + +variable {C : Type u} [AddCommGroup C] [LinearOrder C] [IsOrderedAddMonoid C] + [Module ℚ C] [PosSMulMono ℚ C] + [TopologicalSpace C] [OrderTopology C] [IsTopologicalAddGroup C] + [DenselyOrdered C] + +local instance : PosSMulStrictMono ℚ C := PosSMulMono.toPosSMulStrictMono + +omit [IsOrderedAddMonoid C] in +/-- Rational scalar multiplication is continuous in the order topology of an ordered rational +vector space. -/ +theorem continuous_rat_smul (q : ℚ) : Continuous fun x : C ↦ q • x := by + rcases lt_trichotomy q 0 with hq | hq | hq + · have hpos : 0 < -q := neg_pos.mpr hq + have hcont : Continuous fun x : C ↦ (-q) • x := by + apply Monotone.continuous_of_surjective + · intro x y hxy + exact smul_le_smul_of_nonneg_left hxy hpos.le + · intro y + refine ⟨(-q)⁻¹ • y, ?_⟩ + change (-q) • ((-q)⁻¹ • y) = y + rw [smul_smul, mul_inv_cancel₀ hpos.ne', one_smul] + convert continuous_neg.comp hcont using 1 + funext x + simp + · subst q + simpa using (continuous_const : Continuous fun _ : C ↦ (0 : C)) + · apply Monotone.continuous_of_surjective + · intro x y hxy + exact smul_le_smul_of_nonneg_left hxy hq.le + · intro y + refine ⟨q⁻¹ • y, ?_⟩ + change q • (q⁻¹ • y) = y + rw [smul_smul, mul_inv_cancel₀ hq.ne', one_smul] + +instance instContinuousConstSMulRat : ContinuousConstSMul ℚ C := + ⟨continuous_rat_smul⟩ + +/-- Distinct points in the closed rational span are separated by a point of the original span. -/ +theorem exists_span_between_of_ne (S : Set C) + (x y : (span ℚ S).topologicalClosure) (hxy : x ≠ y) : + ∃ z : span ℚ S, (x : C) < z ∧ (z : C) < y ∨ + (y : C) < z ∧ (z : C) < x := by + let P := span ℚ S + rcases lt_or_gt_of_ne (Subtype.coe_ne_coe.mpr hxy) with hxy' | hyx' + · let m : C := (2 : ℚ)⁻¹ • ((x : C) + (y : C)) + have hm : m ∈ closure (P : Set C) := by + have hm' : m ∈ P.topologicalClosure := by + simpa [m] using P.topologicalClosure.smul_mem ((2 : ℚ)⁻¹) + (P.topologicalClosure.add_mem x.2 y.2) + rw [← topologicalClosure_coe] + exact hm' + have hxm : (x : C) < m := by + dsimp [m] + calc + (x : C) = (2 : ℚ)⁻¹ • ((x : C) + (x : C)) := by + rw [smul_add, ← add_smul] + norm_num + _ < (2 : ℚ)⁻¹ • ((x : C) + (y : C)) := + smul_lt_smul_of_pos_left + (add_lt_add_left hxy' (x : C) |>.trans_eq (add_comm _ _)) (by norm_num) + have hmy : m < (y : C) := by + dsimp [m] + calc + (2 : ℚ)⁻¹ • ((x : C) + (y : C)) < + (2 : ℚ)⁻¹ • ((y : C) + (y : C)) := + smul_lt_smul_of_pos_left + (by simpa [add_comm] using (add_lt_add_left hxy' (y : C))) (by norm_num) + _ = (y : C) := by + rw [smul_add, ← add_smul] + norm_num + obtain ⟨z, hzI, hzP⟩ := + mem_closure_iff.mp hm (Ioo (x : C) (y : C)) isOpen_Ioo ⟨hxm, hmy⟩ + exact ⟨⟨z, hzP⟩, Or.inl hzI⟩ + · let m : C := (2 : ℚ)⁻¹ • ((y : C) + (x : C)) + have hm : m ∈ closure (P : Set C) := by + have hm' : m ∈ P.topologicalClosure := by + simpa [m] using P.topologicalClosure.smul_mem ((2 : ℚ)⁻¹) + (P.topologicalClosure.add_mem y.2 x.2) + rw [← topologicalClosure_coe] + exact hm' + have hym : (y : C) < m := by + dsimp [m] + calc + (y : C) = (2 : ℚ)⁻¹ • ((y : C) + (y : C)) := by + rw [smul_add, ← add_smul] + norm_num + _ < (2 : ℚ)⁻¹ • ((y : C) + (x : C)) := + smul_lt_smul_of_pos_left + (add_lt_add_left hyx' (y : C) |>.trans_eq (add_comm _ _)) (by norm_num) + have hmx : m < (x : C) := by + dsimp [m] + calc + (2 : ℚ)⁻¹ • ((y : C) + (x : C)) < + (2 : ℚ)⁻¹ • ((x : C) + (x : C)) := + smul_lt_smul_of_pos_left + (by simpa [add_comm] using (add_lt_add_left hyx' (x : C))) (by norm_num) + _ = (x : C) := by + rw [smul_add, ← add_smul] + norm_num + obtain ⟨z, hzI, hzP⟩ := + mem_closure_iff.mp hm (Ioo (y : C) (x : C)) isOpen_Ioo ⟨hym, hmx⟩ + exact ⟨⟨z, hzP⟩, Or.inr hzI⟩ + +/-- Every well-ordered subset of the closed rational span of a small nonempty set is small. -/ +@[blueprint "lem:well-ordered-subset-closed-rational-span-cardinality" + (phase := "Refinement over Archimedean classes") + (title := "Well-ordered subsets of closed rational spans") + (statement := /-- + Let $C$ be a densely ordered rational vector space with its order topology, + let $\kappa>\aleph_0$, and let $S\subseteq C$ be nonempty with + $\#S<\kappa$. Every well-ordered subset of the topological closure of + $\operatorname{span}_{\mathbb Q}(S)$ has cardinality less than $\kappa$. + -/) + (proof := /-- + For each nonmaximal point $x$ of the well-ordered subset, let $x^+$ be its + successor and choose a point of $\operatorname{span}_{\mathbb Q}(S)$ + strictly between $x$ and $x^+$. The resulting intervals are disjoint, so + this choice is injective; the possible maximum accounts for one additional + point. Hence the subset has cardinality at most + $\#\operatorname{span}_{\mathbb Q}(S)+1$. Finite rational linear + combinations identify the latter span with a subset of + $S\to_0\mathbb Q$, whose cardinality is + $\max\{\#S,\aleph_0\}<\kappa$. + -/)] +theorem mk_lt_of_isPWO_topologicalClosure_span + {κ : Cardinal.{u}} [Fact (ℵ₀ < κ)] + (S : Set C) (hS : #S < κ) (hSne : S.Nonempty) + (W : Set (span ℚ S).topologicalClosure) (hW : W.IsPWO) : + #W < κ := by + let upper (x : W) : Set (span ℚ S).topologicalClosure := W ∩ Set.Ioi x + have upperWF (x : W) : (upper x).IsWF := hW.isWF.mono Set.inter_subset_left + let next (x : W) (h : (upper x).Nonempty) : W := + ⟨(upperWF x).min h, ((upperWF x).min_mem h).1⟩ + have lt_next (x : W) (h : (upper x).Nonempty) : x < next x h := + ((upperWF x).min_mem h).2 + have exists_between_span (x : W) (h : (upper x).Nonempty) : + ∃ z : span ℚ S, (x : C) < z ∧ (z : C) < next x h := by + have hne : + (x : (span ℚ S).topologicalClosure) ≠ + (next x h : (span ℚ S).topologicalClosure) := by + intro hxy + exact (lt_next x h).ne (Subtype.ext hxy) + obtain ⟨z, hz | hz⟩ := exists_span_between_of_ne S x (next x h) hne + · exact ⟨z, hz⟩ + · exact ((show (x : C) < next x h by exact lt_next x h).asymm + (hz.1.trans hz.2)).elim + let between (x : W) (h : (upper x).Nonempty) : span ℚ S := + Classical.choose (exists_between_span x h) + have between_spec (x : W) (h : (upper x).Nonempty) : + (x : C) < between x h ∧ (between x h : C) < next x h := by + exact Classical.choose_spec (exists_between_span x h) + classical + let f : W → (span ℚ S) ⊕ Unit := fun x ↦ + if h : (upper x).Nonempty then Sum.inl (between x h) else Sum.inr () + have hf : Function.Injective f := by + have f_ne_of_lt {x y : W} (hxy : x < y) : f x ≠ f y := by + have hx : (upper x).Nonempty := ⟨y, y.2, hxy⟩ + by_cases hy : (upper y).Nonempty + · intro heq + have heq' : between x hx = between y hy := by + simpa only [f, dite_eq_left hx, dite_eq_left hy, Sum.inl.injEq] using heq + have hnle : next x hx ≤ y := (upperWF x).min_le hx ⟨y.2, hxy⟩ + have hlt : (between x hx : C) < between y hy := by + calc + (between x hx : C) < next x hx := (between_spec x hx).2 + _ ≤ y := hnle + _ < between y hy := (between_spec y hy).1 + exact hlt.ne (congrArg Subtype.val heq') + · simp [f, hx, hy] + intro x y hxy + by_contra hne + rcases lt_or_gt_of_ne hne with hlt | hgt + · exact f_ne_of_lt hlt hxy + · exact f_ne_of_lt hgt hxy.symm + have hspan : #(span ℚ S) < κ := by + let : Nonempty S := hSne.to_subtype + have hinj : Function.Injective (Span.repr ℚ S) := by + intro x y hxy + apply Subtype.ext + have := congrArg (Finsupp.linearCombination ℚ ((↑) : S → C)) hxy + simpa using this + calc + #(span ℚ S) ≤ #(S →₀ ℚ) := Cardinal.mk_le_of_injective hinj + _ = max #S ℵ₀ := by + simp + _ < κ := max_lt hS Fact.out + calc + #W ≤ #(span ℚ S) + 1 := by + simpa using Cardinal.mk_le_of_injective hf + _ < κ := Cardinal.add_lt_of_lt (Fact.out : ℵ₀ < κ).le hspan + (Cardinal.one_lt_aleph0.trans Fact.out) + +end Submodule diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Topology/Order/Tests.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Topology/Order/Tests.lean new file mode 100644 index 0000000000..726ce8257f --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Topology/Order/Tests.lean @@ -0,0 +1,12 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Topology.Order.Tests.CantorBendixsonConvexCover +public import LeanPool.ConwayRefinement.ConwayRefinement.Topology.Order.Tests.PWOAddition + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Topology/Order/Tests/CantorBendixsonConvexCover.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Topology/Order/Tests/CantorBendixsonConvexCover.lean new file mode 100644 index 0000000000..6f4dfc9d51 --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Topology/Order/Tests/CantorBendixsonConvexCover.lean @@ -0,0 +1,235 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Topology.Order.CantorBendixsonConvexCover +public import Mathlib.Algebra.Order.Group.PiLex +public import Mathlib.Basic.Real.Basic +public import Mathlib.Topology.Instances.Real.Lemmas +import Mathlib.Order.Interval.Set.OrdConnected + +/-! +# The Cantor–Bendixson convex cover has a nondegenerate model + +The partition hypotheses require a nested well-ordered neighborhood base at zero consisting of +open convex subgroups. The real line does not satisfy them: its only convex subgroups are zero +and the whole line, and zero is not open. Any witness is therefore non-Archimedean, and this file +supplies one: real sequences indexed by the naturals under the lexicographic order, with the +subgroups of sequences vanishing below a given index. + +Those subgroups are nested, convex, open, and coinitial, so the hypotheses are consistent and the +geometric part of the cofactor construction is not vacuous. The check also separates the openness +requirement from the trivial family: the zero subgroup alone satisfies every other condition. +-/ + +public noncomputable section + +open Set + +namespace Tests.CantorBendixsonConvexCover + +/-- Real sequences under the lexicographic order: a non-Archimedean ordered abelian group. -/ +abbrev LexSeq := Lex (ℕ → ℝ) + +/-- The entries of a lexicographic sequence. -/ +abbrev entry (x : LexSeq) (k : ℕ) : ℝ := ofLex x k + +theorem entry_add (x y : LexSeq) (k : ℕ) : + entry (x + y) k = entry x k + entry y k := (rfl) + +theorem entry_neg (x : LexSeq) (k : ℕ) : entry (-x) k = -entry x k := (rfl) + +theorem entry_zero (k : ℕ) : entry (0 : LexSeq) k = 0 := (rfl) + +theorem entry_sub (x y : LexSeq) (k : ℕ) : + entry (x - y) k = entry x k - entry y k := (rfl) + +theorem lt_of_forall_eq_of_lt {x y : LexSeq} {m : ℕ} + (h : ∀ j < m, entry x j = entry y j) (hm : entry x m < entry y m) : x < y := + ⟨m, h, hm⟩ + +instance : TopologicalSpace LexSeq := Preorder.topology LexSeq + +instance : OrderTopology LexSeq := ⟨rfl⟩ + +/-- The subgroup of sequences vanishing below a given index. -/ +def vanishingBelow (n : ℕ) : AddSubgroup LexSeq where + carrier := {x : LexSeq | ∀ k < n, entry x k = 0} + zero_mem' := fun _ _ ↦ rfl + add_mem' hx hy := fun k hk ↦ by + rw [entry_add, hx k hk, hy k hk, add_zero] + neg_mem' hx := fun k hk ↦ by + rw [entry_neg, hx k hk, neg_zero] + +@[simp] +theorem mem_vanishingBelow {n : ℕ} {x : LexSeq} : + x ∈ vanishingBelow n ↔ ∀ k < n, entry x k = 0 := (Iff.rfl) + +/-- The witnessing family is nested and decreasing. -/ +theorem vanishingBelow_mono {i j : ℕ} (hij : i ≤ j) : + (vanishingBelow j : Set LexSeq) ⊆ (vanishingBelow i : Set LexSeq) := + fun _ hx k hk ↦ hx k (hk.trans_le hij) + +/-- The least index at which a nonzero sequence does not vanish. -/ +theorem exists_least_ne_zero {c : LexSeq} {k : ℕ} (hne : entry c k ≠ 0) : + ∃ m, entry c m ≠ 0 ∧ ∀ j < m, entry c j = 0 := by + classical + have hex : ∃ m, entry c m ≠ 0 := ⟨k, hne⟩ + exact ⟨Nat.find hex, Nat.find_spec hex, fun j hj ↦ not_not.mp (Nat.find_min hex hj)⟩ + +/-- Each subgroup of the family is convex: a sequence between two vanishing ones has no earlier +nonzero entry, since a positive one would exceed the upper bound and a negative one would fall +below the lower bound. -/ +theorem vanishingBelow_ordConnected (n : ℕ) : + ((vanishingBelow n : AddSubgroup LexSeq) : Set LexSeq).OrdConnected := by + constructor + intro a ha b hb c hc k hk + by_contra hne + obtain ⟨m, hm, hmin⟩ := exists_least_ne_zero hne + have hmn : m < n := by + by_contra hmn + exact hne (hmin k (lt_of_lt_of_le hk (not_lt.mp hmn))) + rcases lt_trichotomy (entry c m) 0 with hneg | hzero | hpos + · have hca : c < a := + lt_of_forall_eq_of_lt (fun j hj ↦ by + rw [hmin j hj, ha j (hj.trans hmn)]) (by rw [ha m hmn]; exact hneg) + exact absurd hc.1 (not_le.mpr hca) + · exact hm hzero + · have hbc : b < c := + lt_of_forall_eq_of_lt (fun j hj ↦ by + rw [hb j (hj.trans hmn), hmin j hj]) (by rw [hb m hmn]; exact hpos) + exact absurd hc.2 (not_le.mpr hbc) + +/-- The indicator sequence with a single unit entry. -/ +def unitAt (n : ℕ) : LexSeq := toLex (fun k ↦ if k = n then (1 : ℝ) else 0) + +theorem entry_unitAt (n k : ℕ) : entry (unitAt n) k = if k = n then (1 : ℝ) else 0 := (rfl) + +theorem unitAt_pos (n : ℕ) : 0 < unitAt n := by + refine lt_of_forall_eq_of_lt (m := n) (fun j hj ↦ ?_) ?_ + · rw [entry_unitAt, ite_eq_right hj.ne] + rfl + · rw [entry_unitAt, ite_eq_left rfl] + exact zero_lt_one + +/-- Every sequence vanishing below an index lies strictly between the negative and positive unit +sequences at that index, so each subgroup of the family contains a neighborhood of zero and is +therefore open. -/ +theorem vanishingBelow_subset_Ioo (n : ℕ) : + ((vanishingBelow (n + 1) : AddSubgroup LexSeq) : Set LexSeq) ⊆ + Ioo (-unitAt n) (unitAt n) := by + intro x hx + constructor + · refine lt_of_forall_eq_of_lt (m := n) (fun j hj ↦ ?_) ?_ + · rw [entry_neg, entry_unitAt, ite_eq_right hj.ne, neg_zero, + hx j (hj.trans (Nat.lt_succ_self n))] + · rw [entry_neg, entry_unitAt, ite_eq_left rfl, hx n (Nat.lt_succ_self n)] + norm_num + · refine lt_of_forall_eq_of_lt (m := n) (fun j hj ↦ ?_) ?_ + · rw [entry_unitAt, ite_eq_right hj.ne, hx j (hj.trans (Nat.lt_succ_self n))] + · rw [entry_unitAt, ite_eq_left rfl, hx n (Nat.lt_succ_self n)] + exact zero_lt_one + +theorem vanishingBelow_isOpen (n : ℕ) : + IsOpen ((vanishingBelow n : AddSubgroup LexSeq) : Set LexSeq) := by + rw [isOpen_iff_mem_nhds] + intro x hx + have hsub : Ioo (x - unitAt n) (x + unitAt n) ⊆ + ((vanishingBelow n : AddSubgroup LexSeq) : Set LexSeq) := by + intro y hy + have hmem : y - x ∈ Ioo (-unitAt n) (unitAt n) := by + constructor + · rw [lt_sub_iff_add_lt] + have h1 := hy.1 + rw [sub_eq_neg_add] at h1 + exact h1 + · rw [sub_lt_iff_lt_add] + have h2 := hy.2 + rw [add_comm] at h2 + exact h2 + -- Convexity of the subgroup transfers membership from `x` to `y`. + have hyx : y = x + (y - x) := by abel + rw [hyx] + refine AddSubgroup.add_mem _ hx ?_ + intro k hk + by_contra hne + obtain ⟨m, hm, hmin⟩ := exists_least_ne_zero hne + have hmn : m < n := by + by_contra hmn + exact hne (hmin k (lt_of_lt_of_le hk (not_lt.mp hmn))) + rcases lt_trichotomy (entry (y - x) m) 0 with hneg | hzero | hpos + · refine absurd hmem.1 (not_lt.mpr (le_of_lt (lt_of_forall_eq_of_lt (m := m) + (fun j hj ↦ ?_) ?_))) + · rw [hmin j hj, entry_neg, entry_unitAt, ite_eq_right (by omega), neg_zero] + · rw [entry_neg, entry_unitAt, ite_eq_right (by omega), neg_zero] + exact hneg + · exact hm hzero + · refine absurd hmem.2 (not_lt.mpr (le_of_lt (lt_of_forall_eq_of_lt (m := m) + (fun j hj ↦ ?_) ?_))) + · rw [entry_unitAt, ite_eq_right (by omega), hmin j hj] + · rw [entry_unitAt, ite_eq_right (by omega)] + exact hpos + exact Filter.mem_of_superset + (Ioo_mem_nhds (sub_lt_self x (unitAt_pos n)) (lt_add_of_pos_right x (unitAt_pos n))) hsub + +/-- The family is coinitial: every strictly positive sequence dominates one of its members. -/ +theorem exists_vanishingBelow_subset_Ioo {ε : LexSeq} (hε : 0 < ε) : + ∃ n : ℕ, ((vanishingBelow n : AddSubgroup LexSeq) : Set LexSeq) ⊆ Ioo (-ε) ε := by + obtain ⟨p, hpz, hpos⟩ := hε + have hpz' : ∀ j < p, entry ε j = 0 := fun j hj ↦ (hpz j hj).symm + have hpos' : (0 : ℝ) < entry ε p := hpos + refine ⟨p + 1, fun x hx ↦ ⟨?_, ?_⟩⟩ + · refine lt_of_forall_eq_of_lt (m := p) (fun j hj ↦ ?_) ?_ + · rw [entry_neg, hpz' j hj, neg_zero, hx j (hj.trans (Nat.lt_succ_self p))] + · rw [entry_neg, hx p (Nat.lt_succ_self p)] + linarith + · refine lt_of_forall_eq_of_lt (m := p) (fun j hj ↦ ?_) ?_ + · rw [hx j (hj.trans (Nat.lt_succ_self p)), hpz' j hj] + · rw [hx p (Nat.lt_succ_self p)] + exact hpos' + +instance : NoMinOrder LexSeq := + ⟨fun x ↦ ⟨x - unitAt 0, sub_lt_self x (unitAt_pos 0)⟩⟩ + +instance : NoMaxOrder LexSeq := + ⟨fun x ↦ ⟨x + unitAt 0, lt_add_of_pos_right x (unitAt_pos 0)⟩⟩ + +/-- **The cover hypotheses are consistent.** Every hypothesis of the disjoint convex cover theorem +holds for the lexicographic sequence group with the vanishing-below family, so the result is not +vacuous. -/ +theorem exists_disjoint_convex_cover_with_rank_lt_center_lexSeq + (s : TopologicalSpace.Closeds LexSeq) (hs : (s : Set LexSeq).IsPWO) : + ∃ (X : Set LexSeq) (C : X → Set LexSeq), + X ⊆ (s : Set LexSeq) ∧ + (∀ x : X, (x : LexSeq) ∈ C x) ∧ + (∀ x : X, IsOpen (C x)) ∧ + (∀ x : X, (C x).OrdConnected) ∧ + (∀ x y : X, x ≠ y → Disjoint (C x) (C y)) ∧ + (∀ x y : X, (x : LexSeq) < (y : LexSeq) → ∀ a ∈ C x, ∀ b ∈ C y, a < b) ∧ + ((s : Set LexSeq) ⊆ ⋃ x : X, C x) ∧ + (∀ x : X, ∀ z ∈ (s : Set LexSeq) ∩ C x, z ≤ (x : LexSeq)) ∧ + (∀ x : X, ∀ z ∈ (s : Set LexSeq) ∩ C x, z ≠ (x : LexSeq) → + s.cantorBendixsonRank hs z < s.cantorBendixsonRank hs (x : LexSeq)) ∧ + (∀ z : LexSeq, ¬ AccPt z (Filter.principal X)) := + TopologicalSpace.Closeds.exists_disjoint_convex_cover_with_rank_lt_center s hs vanishingBelow + (fun hij ↦ vanishingBelow_mono hij) vanishingBelow_isOpen vanishingBelow_ordConnected + (fun _ hε ↦ exists_vanishingBelow_subset_Ioo hε) + +/-- The real line is not a witness: its only convex subgroups are zero and the whole line, and +zero is not open, so no family of open convex subgroups is a neighborhood base at zero. The +openness requirement is therefore doing real work. -/ +theorem not_isOpen_bot_real : ¬ IsOpen ((⊥ : AddSubgroup ℝ) : Set ℝ) := by + intro h + have hmem : (0 : ℝ) ∈ ((⊥ : AddSubgroup ℝ) : Set ℝ) := (⊥ : AddSubgroup ℝ).zero_mem + obtain ⟨ε, hε, hsub⟩ := Metric.isOpen_iff.mp h 0 hmem + have hlt : ε / 2 ∈ Metric.ball (0 : ℝ) ε := by + rw [Metric.mem_ball, Real.dist_eq, sub_zero, abs_of_pos (by linarith)] + linarith + have hb : ε / 2 ∈ (⊥ : AddSubgroup ℝ) := hsub hlt + rw [AddSubgroup.mem_bot] at hb + linarith + +end Tests.CantorBendixsonConvexCover diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Topology/Order/Tests/PWOAddition.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Topology/Order/Tests/PWOAddition.lean new file mode 100644 index 0000000000..84a6240d2b --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Topology/Order/Tests/PWOAddition.lean @@ -0,0 +1,1034 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Topology.Order.PWOAddition +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.Additive +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.Truncation +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.Convolution +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.Multiplication +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.Leibniz +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.Power +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.Cancellation +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.CantorBendixsonValueMultiplicativity +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.Germ +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.Graded +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.Scalar +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.GlobalCofactors +public import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Germ.AlgebraicIndependence.Lifts +import Mathlib.Algebra.MvPolynomial.CommRing +import LeanPool.ConwayRefinement.ConwayRefinement.HahnSeries.Nonpositive +public import Mathlib.Topology.DerivedSet +public import Mathlib.Topology.Instances.Real.Lemmas +import Mathlib.Analysis.SpecificLimits.Basic + +/-! +# Addition on a support with an accumulation point + +The closed support generated by the negative reciprocal sequence has an accumulation point at +zero. Addition on its square is proper and has a finite noninjective fiber. This excludes both +a finite-support substitute for well-ordering and an injectivity substitute for finite fibers. +The empty-support case separately exercises the degenerate domain. +-/ + +public noncomputable section + +open Set Filter Topology HahnSeries + +namespace Tests.PWOAddition + +/-- The increasing negative reciprocal sequence converging to zero. -/ +def negRecip (n : ℕ) : ℝ := -(1 / ((n : ℝ) + 1)) + +@[simp] +theorem negRecip_apply (n : ℕ) : + negRecip n = -(1 / ((n : ℝ) + 1)) := (rfl) + +private theorem negRecip_strictMono : StrictMono negRecip := by + intro m n hmn + simp only [negRecip_apply] + apply neg_lt_neg + exact one_div_lt_one_div_of_lt (by positivity) (by exact_mod_cast Nat.add_lt_add_right hmn 1) + +private theorem negRecip_pwo : (range negRecip).IsPWO := by + simpa only [image_univ] using + (Set.isPWO_of_wellQuasiOrderedLE (univ : Set ℕ)).image_of_monotoneOn + (negRecip_strictMono.monotone.monotoneOn _) + +private theorem negRecip_tendsto : Tendsto negRecip atTop (𝓝 (0 : ℝ)) := by + simpa only [← funext negRecip_apply, neg_zero] using + (tendsto_one_div_add_atTop_nhds_zero_nat (𝕜 := ℝ)).neg + +/-- The test support is not discrete: zero is an accumulation point. -/ +theorem accumulation : (0 : ℝ) ∈ derivedSet (closure (range negRecip)) := by + apply mem_derivedSet.mpr + apply accPt_iff_nhds.mpr + intro U hU + have he : ∀ᶠ n in atTop, negRecip n ∈ U := negRecip_tendsto hU + obtain ⟨n, hn⟩ := he.exists + refine ⟨negRecip n, ⟨hn, subset_closure (mem_range_self n)⟩, ?_⟩ + simp only [negRecip_apply] + exact neg_ne_zero.mpr (one_div_ne_zero (by positivity)) + +/-- The proper-map theorem applies to a support with a genuine accumulation point. -/ +theorem proper_add : + IsProperMap (fun p : closure (range negRecip) ×ˢ closure (range negRecip) ↦ p.1.1 + p.1.2) := + negRecip_pwo.closure.isProperMap_add negRecip_pwo.closure isClosed_closure isClosed_closure + +/-- The addition fiber is finite although addition is not injective on the support square. -/ +theorem finite_noninjective_fiber : + let s := closure (range negRecip) + let f := fun p : s ×ˢ s ↦ p.1.1 + p.1.2 + (f ⁻¹' {negRecip 0 + negRecip 1}).Finite ∧ ¬Function.Injective f := by + dsimp only + refine ⟨negRecip_pwo.closure.finite_subtype_add_fiber negRecip_pwo.closure _, ?_⟩ + intro hinj + let p : closure (range negRecip) ×ˢ closure (range negRecip) := + ⟨(negRecip 0, negRecip 1), subset_closure (mem_range_self 0), subset_closure (mem_range_self 1)⟩ + let q : closure (range negRecip) ×ˢ closure (range negRecip) := + ⟨(negRecip 1, negRecip 0), subset_closure (mem_range_self 1), subset_closure (mem_range_self 0)⟩ + have he : p = q := hinj (by exact add_comm _ _) + have hfst : negRecip 0 = negRecip 1 := congrArg (fun p ↦ p.1.1) he + exact (negRecip_strictMono (by decide : 0 < 1)).ne hfst + +/-- Empty supports are permitted by the proper-map statement. -/ +theorem empty_left : IsProperMap (fun p : (∅ : Set ℝ) ×ˢ closure (range negRecip) ↦ + p.1.1 + p.1.2) := + Set.isPWO_empty.isProperMap_add negRecip_pwo.closure isClosed_empty isClosed_closure + +/-- A Hahn series with coefficient one on the negative reciprocal sequence and zero elsewhere. -/ +def accumulatingSeries : HahnSeries ℝ ℚ := by + classical + exact ⟨fun x ↦ if x ∈ range negRecip then 1 else 0, by + simpa only [Function.support, ne_eq, ite_eq_right_iff, one_ne_zero, imp_false, not_not, + Set.ofPred_mem_eq] + using negRecip_pwo⟩ + +open Classical in +@[simp] +theorem accumulatingSeries_coeff (x : ℝ) : + accumulatingSeries.coeff x = if x ∈ range negRecip then 1 else 0 := by + classical + rfl + +@[simp] +theorem accumulatingSeries_support : accumulatingSeries.support = range negRecip := by + classical + ext x + simp only [HahnSeries.mem_support, accumulatingSeries_coeff, ne_eq, ite_eq_right_iff, + one_ne_zero, imp_false, not_not] + +/-- A genuine infinite Hahn support has positive rank at zero and value at least `omega`. -/ +theorem accumulatingSeries_positive_rank : + 1 ≤ accumulatingSeries.cantorBendixsonRank 0 ∧ + Ordinal.omega0 ≤ accumulatingSeries.cantorBendixsonValue := by + have hm : (0 : ℝ) ∈ + (accumulatingSeries.closedSupport.cantorBendixson (1 : Ordinal) : Set ℝ) := by + rw [show (1 : Ordinal) = 0 + 1 by simp, TopologicalSpace.Closeds.cantorBendixson_add_one, + TopologicalSpace.Closeds.cantorBendixson_zero, TopologicalSpace.Closeds.coe_derived, + HahnSeries.coe_closedSupport, accumulatingSeries_support] + exact accumulation + obtain ⟨hmem, hr⟩ := (accumulatingSeries.mem_support_derivative_iff 0 1).mp hm + refine ⟨hr, ?_⟩ + rw [accumulatingSeries.cantorBendixsonValue_of_mem hmem] + simpa only [Ordinal.opow_one] using + Ordinal.opow_le_opow_right Ordinal.omega0_pos hr + +/-- Zero and strictly negative monomials vanish, but a nonzero constant has value one. -/ +theorem value_boundary_cases : + (0 : HahnSeries ℝ ℚ).cantorBendixsonValue = 0 ∧ + (HahnSeries.single (-1 : ℝ) (1 : ℚ)).cantorBendixsonValue = 0 ∧ + (HahnSeries.single (0 : ℝ) (1 : ℚ)).cantorBendixsonValue = 1 := by + refine ⟨HahnSeries.cantorBendixsonValue_zero, ?_, ?_⟩ + · apply HahnSeries.cantorBendixsonValue_of_finite_of_coeff_eq_zero + · exact (Set.finite_singleton _).subset HahnSeries.support_single_subset + · simp + · apply HahnSeries.cantorBendixsonValue_of_finite_of_coeff_ne_zero + · exact (Set.finite_singleton _).subset HahnSeries.support_single_subset + · simp + +/-- Weak truncation retains the cutoff monomial; strict truncation deletes it. -/ +theorem cutoff_endpoint : + (HahnSeries.translate (1 : ℝ) + (HahnSeries.truncLE (-1) (HahnSeries.single (-1) (1 : ℚ)))).cantorBendixsonValue = 1 ∧ + (HahnSeries.translate (1 : ℝ) + (HahnSeries.truncLT (-1) (HahnSeries.single (-1) (1 : ℚ)))).cantorBendixsonValue = 0 := by + have hle : HahnSeries.translate (1 : ℝ) + (HahnSeries.truncLE (-1) (HahnSeries.single (-1) (1 : ℚ))) = + HahnSeries.single 0 1 := by + ext x + by_cases hx : x = 0 + · subst x + simp [HahnSeries.coeff_truncLE] + · have hn : x - 1 ≠ -1 := by simpa using hx + simp [HahnSeries.coeff_truncLE, hx, hn] + have hlt : HahnSeries.truncLT (-1 : ℝ) (HahnSeries.single (-1) (1 : ℚ)) = 0 := by + ext x + by_cases hx : x = -1 + · subst x + simp [HahnSeries.coeff_truncLT] + · simp [HahnSeries.coeff_truncLT, hx] + rw [hle, hlt, map_zero] + exact ⟨value_boundary_cases.2.2, HahnSeries.cantorBendixsonValue_zero⟩ + +/-- A cutoff at an actual accumulation point preserves its positive rank. -/ +theorem accumulated_cutoff_rank : + (HahnSeries.translate (0 : ℝ) + (HahnSeries.truncLE 0 accumulatingSeries)).cantorBendixsonRank 0 ≥ 1 := by + rw [HahnSeries.translate_zero_apply, HahnSeries.cantorBendixsonRank_truncLE] + exact accumulatingSeries_positive_rank.1 + +/-- The finite convolution fiber contains a limit pair absent from both raw supports. -/ +theorem convolution_limit_index : + ((0, 0) : ℝ × ℝ) ∈ accumulatingSeries.closedSupportAddFiber accumulatingSeries 0 ∧ + (0 : ℝ) ∉ accumulatingSeries.support := by + have hc : (0 : ℝ) ∈ accumulatingSeries.closedSupport := by + rw [mem_closedSupport, accumulatingSeries_support] + exact isClosed_closure.closure_subset (derivedSet_subset_closure _ accumulation) + refine ⟨(mem_closedSupportAddFiber _ _ _ _).mpr ⟨hc, hc, add_zero _⟩, ?_⟩ + rw [accumulatingSeries_support] + rintro ⟨n, hn⟩ + have hne : negRecip n ≠ 0 := by + simp only [negRecip_apply, ne_eq, neg_eq_zero, one_div, inv_eq_zero] + positivity + exact hne hn + +/-- Omitting that limit pair would falsely give value zero for this actual square. -/ +theorem convolution_square_nonzero_value : + (accumulatingSeries * accumulatingSeries).cantorBendixsonValue ≠ 0 := by + apply mt (cantorBendixsonValue_eq_zero_iff _).mp + apply not_not.mpr + have hcoeff (n : ℕ) : + 0 < (accumulatingSeries * accumulatingSeries).coeff (negRecip n + negRecip n) := by + rw [coeff_mul] + apply Finset.sum_pos' + · intro p _ + apply mul_nonneg <;> simp only [accumulatingSeries_coeff] <;> split <;> norm_num + · refine ⟨(negRecip n, negRecip n), ?_, ?_⟩ + · rw [Finset.mem_antidiagonal, accumulatingSeries_support] + exact ⟨mem_range_self n, mem_range_self n, rfl⟩ + · simp only [accumulatingSeries_coeff, mem_range_self, ite_true, one_mul, zero_lt_one] + have ht := negRecip_tendsto + apply mem_closure_of_tendsto (by simpa only [add_zero] using ht.add ht) + exact Filter.Eventually.of_forall fun n ↦ (hcoeff n).ne' + +/-- The finite convolution error has value zero on the accumulating support fixture. -/ +theorem convolution_error_value : + (translate (0 : ℝ) (truncLE 0 (accumulatingSeries * accumulatingSeries)) - + ∑ p ∈ accumulatingSeries.closedSupportAddFiber accumulatingSeries 0, + translate (-p.1) (truncLE p.1 accumulatingSeries) * + translate (-p.2) (truncLE p.2 accumulatingSeries)).cantorBendixsonValue = 0 := by + simpa only [neg_zero] using + accumulatingSeries.cantorBendixsonValue_convolution_error accumulatingSeries 0 + +/-- The natural-product upper bound applies to the nonzero infinite-support square. -/ +theorem square_value_upper_bound : + NatOrdinal.of (accumulatingSeries * accumulatingSeries).cantorBendixsonValue ≤ + NatOrdinal.of accumulatingSeries.cantorBendixsonValue * + NatOrdinal.of accumulatingSeries.cantorBendixsonValue := by + have hs : accumulatingSeries.support ⊆ Iic 0 := by + rw [accumulatingSeries_support] + rintro _ ⟨n, rfl⟩ + simp only [mem_Iic, negRecip_apply] + exact neg_nonpos.mpr (by positivity) + exact accumulatingSeries.cantorBendixsonValue_mul_le accumulatingSeries hs hs + +/-- Equal nonzero values can cancel completely; the unequal-values hypothesis is necessary. -/ +theorem equal_value_cancellation : + (-accumulatingSeries).cantorBendixsonValue = accumulatingSeries.cantorBendixsonValue ∧ + 0 < accumulatingSeries.cantorBendixsonValue ∧ + (accumulatingSeries + -accumulatingSeries).cantorBendixsonValue = 0 := by + refine ⟨cantorBendixsonValue_neg _, + Ordinal.omega0_pos.trans_le accumulatingSeries_positive_rank.2, ?_⟩ + rw [add_neg_cancel, cantorBendixsonValue_zero] + +/-- An ordinary constant cannot cancel the accumulating part of the test series. -/ +theorem constant_does_not_cancel_accumulation : + (accumulatingSeries + single (0 : ℝ) (1 : ℚ)).cantorBendixsonValue = + accumulatingSeries.cantorBendixsonValue := by + have hlt : (single (0 : ℝ) (1 : ℚ)).cantorBendixsonValue < + accumulatingSeries.cantorBendixsonValue := by + rw [value_boundary_cases.2.2] + exact Ordinal.one_lt_omega0.trans_le accumulatingSeries_positive_rank.2 + rw [cantorBendixsonValue_add_eq_max_of_ne _ _ hlt.ne', max_eq_left hlt.le] + +private theorem accumulating_support_nonpositive : accumulatingSeries.support ⊆ Iic 0 := by + rw [accumulatingSeries_support] + rintro _ ⟨n, rfl⟩ + simp only [mem_Iic, negRecip_apply] + exact neg_nonpos.mpr (by positivity) + +/-- Value one permits an actual infinite tail bounded away from zero. -/ +theorem infinite_tail_value_one : + (translate (-1 : ℝ) accumulatingSeries).support.Infinite ∧ + (translate (-1 : ℝ) accumulatingSeries + single 0 (1 : ℚ)).cantorBendixsonValue = 1 := by + have hbound : (translate (-1 : ℝ) accumulatingSeries).support ⊆ Iic (-1 : ℝ) := by + rw [support_translate] + rintro _ ⟨x, hx, rfl⟩ + simpa only [mem_Iic, add_zero] using + add_le_add_right (accumulating_support_nonpositive hx) (-1 : ℝ) + have hnonpos : (translate (-1 : ℝ) accumulatingSeries).support ⊆ Iic 0 := + hbound.trans (Iic_subset_Iic.mpr (by norm_num)) + have hz : (translate (-1 : ℝ) accumulatingSeries).cantorBendixsonValue = 0 := + (cantorBendixsonValue_eq_zero_iff_support_bounded_lt _ hnonpos).mpr + ⟨-1, by norm_num, hbound⟩ + constructor + · intro hf + have hr := accumulatingSeries.cantorBendixsonRank_translate (-1) 0 + rw [cantorBendixsonRank_of_finite _ hf, eq_comm] at hr + have hge := accumulatingSeries_positive_rank.1 + rw [hr] at hge + exact (not_le_of_gt (show (0 : Ordinal) < 1 from zero_lt_one)) hge + · rw [cantorBendixsonValue_add_eq_max_of_ne _ _ (by + rw [hz, value_boundary_cases.2.2]; exact zero_ne_one), hz, value_boundary_cases.2.2] + exact max_eq_right zero_le + +/-- A value-one factor with infinite support preserves the accumulating-series value. -/ +theorem value_one_factor_preserves_infinite_value : + ((translate (-1 : ℝ) accumulatingSeries + single 0 (1 : ℚ)) * + accumulatingSeries).cantorBendixsonValue = accumulatingSeries.cantorBendixsonValue := by + apply cantorBendixsonValue_mul_of_left_eq_one _ _ _ accumulating_support_nonpositive + infinite_tail_value_one.2 + intro x hx + change x ≤ 0 + rcases support_add_subset _ _ hx with hx | hx + · rw [support_translate] at hx + obtain ⟨y, hy, rfl⟩ := hx + exact add_nonpos (by norm_num) (accumulating_support_nonpositive hy) + · exact (support_single_subset hx : x = 0) ▸ le_rfl + +/-- The Leibniz bound is strictly smaller than the predicted square value on an actual +infinite support; this excludes a finite-support or constant-factor substitute. -/ +theorem leibniz_infinite_square : + ∃ ρ : NatOrdinal, 0 < ρ ∧ + ρ < NatOrdinal.of accumulatingSeries.cantorBendixsonValue * + NatOrdinal.of accumulatingSeries.cantorBendixsonValue ∧ + ∀ᶠ γ in 𝓝[<] (0 : ℝ), + NatOrdinal.of (translate (-γ) (truncLE γ (accumulatingSeries * accumulatingSeries)) - + translate (-γ) (truncLE γ accumulatingSeries) * accumulatingSeries - + accumulatingSeries * translate (-γ) (truncLE γ accumulatingSeries)).cantorBendixsonValue < + ρ := by + have hc : 0 ∈ closure accumulatingSeries.support := by + rw [accumulatingSeries_support] + exact isClosed_closure.closure_subset (derivedSet_subset_closure _ accumulation) + let B : Ordinal.AdditivePrincipalAboveOne := + ⟨accumulatingSeries.cantorBendixsonValue, by + rw [accumulatingSeries.cantorBendixsonValue_of_mem hc] + exact Ordinal.isAdditivelyPrincipal_omega0_opow _, + Ordinal.one_lt_omega0.trans_le accumulatingSeries_positive_rank.2⟩ + have hρ : 0 < NatOrdinal.of B.residualFactor := + pos_iff_ne_zero.mpr B.residualFactor_isAdditivelyPrincipal.ne_zero + have hV : 0 < NatOrdinal.of B.val := pos_iff_ne_zero.mpr B.2.1.ne_zero + refine ⟨NatOrdinal.of B.residualFactor * NatOrdinal.of B.val, mul_pos hρ hV, ?_, ?_⟩ + · apply mul_lt_mul_of_pos_right _ hV + change NatOrdinal.of B.residualFactor < NatOrdinal.of B.val + rw [← B.naturalResidual_mul_naturalPrincipal] + simpa only [mul_one] using + mul_lt_mul_of_pos_left + (show (1 : NatOrdinal) < NatOrdinal.of B.principalFactor from B.one_lt_principalFactor) hρ + · exact accumulatingSeries.eventually_cantorBendixsonValue_leibnizRemainder_lt + accumulatingSeries accumulating_support_nonpositive accumulating_support_nonpositive + B B rfl rfl le_rfl + +/-- The eventual qualifier is essential: negative monomials produce a value-one remainder +at an earlier negative cutoff, although both original values are zero. -/ +theorem leibniz_not_all_negative_cutoffs : + let b : HahnSeries ℝ ℚ := single (-1) 1 + (translate (2 : ℝ) (truncLE (-2) (b * b)) - translate 2 (truncLE (-2) b) * b - + b * translate 2 (truncLE (-2) b)).cantorBendixsonValue = 1 := by + dsimp only + have hz : truncLE (-2 : ℝ) (single (-1) (1 : ℚ)) = 0 := by + ext x + by_cases hx : x = -1 + · subst x + norm_num [HahnSeries.coeff_truncLE] + · simp [HahnSeries.coeff_truncLE, hx] + have hprod : (single (-1 : ℝ) (1 : ℚ) * single (-1) 1) = single (-2) 1 := by + rw [single_mul_single] + norm_num + have htr : translate (2 : ℝ) (truncLE (-2) (single (-2) (1 : ℚ))) = single 0 1 := by + ext x + by_cases hx : x = 0 + · subst x + norm_num [HahnSeries.coeff_truncLE] + · have hx' : x - 2 ≠ -2 := by simpa using hx + simp [HahnSeries.coeff_truncLE, hx, hx'] + rw [hz, hprod, htr, map_zero, zero_mul, mul_zero, sub_zero, sub_zero] + exact value_boundary_cases.2.2 + +/-- Zero-input API smoke test; this does not distinguish the multiplicities. -/ +theorem power_remainder_zero_inputs (b : HahnSeries ℝ ℚ) (m : ℕ) (γ : ℝ) : + leibnizPowerRemainder 0 b m γ = 0 ∧ leibnizPowerRemainder b 0 m γ = 0 := by + simp [leibnizPowerRemainder_eq] + +/-- The ordinary coefficient distinguishes the square rule from the wrong coefficient-one rule. -/ +theorem power_remainder_multiplicity : + let b : HahnSeries ℝ ℚ := 1 + single (-1) 1 + (leibnizPowerRemainder b 1 1 (-1)).coeff 0 = 0 ∧ + (translate 1 (truncLE (-1) (b ^ 2)) - + translate 1 (truncLE (-1) b) * b).coeff 0 = 1 := by + let b : HahnSeries ℝ ℚ := 1 + single (-1) 1 + change (leibnizPowerRemainder b 1 1 (-1)).coeff 0 = 0 ∧ _ + have hs : (single (-1 : ℝ) (1 : ℚ)) ^ 2 = single (-2) 1 := by + rw [pow_two, single_mul_single] + norm_num + have hp : b ^ 2 = 1 + 2 * single (-1) 1 + single (-2) 1 := by + dsimp only [b] + rw [add_sq, one_pow, mul_one, hs] + have ht : translate (1 : ℝ) (truncLE (-1) b) = 1 := by + ext x + by_cases hx : x = 0 + · subst x + norm_num [HahnSeries.coeff_truncLE, b] + · have hn : x - 1 ≠ -1 := by simpa using hx + suffices x ≤ 0 → x - 1 ≠ 0 by + simpa [HahnSeries.coeff_truncLE, b, hx, hn] using this + intro hle he + linarith + have h1 : truncLE (-1 : ℝ) (1 : HahnSeries ℝ ℚ) = 0 := by + ext x + by_cases hx : x = 0 + · subst x + norm_num [HahnSeries.coeff_truncLE] + · simp [HahnSeries.coeff_truncLE, hx] + constructor + · rw [leibnizPowerRemainder_eq] + norm_num only [neg_neg, one_add_one_eq_two, pow_one, mul_one, h1, map_zero, + mul_zero, sub_zero, ht, one_mul] + rw [hp] + norm_num [HahnSeries.coeff_truncLE, b, coeff_nsmul, two_mul, + show (2 : HahnSeries ℝ ℚ) = 1 + 1 by norm_num] + have htwo : (2 : HahnSeries ℝ ℚ) = 1 + 1 := by norm_num + rw [htwo, coeff_add] + norm_num + · change (translate (1 : ℝ) (truncLE (-1) (b ^ 2)) - + translate 1 (truncLE (-1) b) * b).coeff 0 = 1 + rw [ht, one_mul, hp] + norm_num [HahnSeries.coeff_truncLE, b, two_mul] + +/-- The power estimate on an actual accumulating support, for every exponent including zero. +The positive Cantor–Bendixson rank excludes a finite-support or ordinary-constant substitute. -/ +theorem power_remainder_infinite_support (m : ℕ) : + ∃ ρ : NatOrdinal, 0 < ρ ∧ + ρ < NatOrdinal.of accumulatingSeries.cantorBendixsonValue ^ (m + 1) ∧ + ∀ᶠ γ in 𝓝[<] (0 : ℝ), + NatOrdinal.of (translate (-γ) (truncLE γ (accumulatingSeries ^ (m + 1))) - + (m + 1) • (translate (-γ) (truncLE γ accumulatingSeries) * + accumulatingSeries ^ m)).cantorBendixsonValue < ρ := by + have hc : 0 ∈ closure accumulatingSeries.support := by + rw [accumulatingSeries_support] + exact isClosed_closure.closure_subset (derivedSet_subset_closure _ accumulation) + let B : Ordinal.AdditivePrincipalAboveOne := + ⟨accumulatingSeries.cantorBendixsonValue, by + rw [accumulatingSeries.cantorBendixsonValue_of_mem hc] + exact Ordinal.isAdditivelyPrincipal_omega0_opow _, + Ordinal.one_lt_omega0.trans_le accumulatingSeries_positive_rank.2⟩ + have hρ : 0 < NatOrdinal.of B.residualFactor := + pos_iff_ne_zero.mpr B.residualFactor_isAdditivelyPrincipal.ne_zero + have hV : 0 < NatOrdinal.of B.val := pos_iff_ne_zero.mpr B.2.1.ne_zero + have hlt : NatOrdinal.of B.residualFactor < NatOrdinal.of B.val := by + rw [← B.naturalResidual_mul_naturalPrincipal] + simpa only [mul_one] using mul_lt_mul_of_pos_left + (show (1 : NatOrdinal) < NatOrdinal.of B.principalFactor from B.one_lt_principalFactor) hρ + refine ⟨NatOrdinal.of B.val ^ m * NatOrdinal.of B.residualFactor, + mul_pos (pow_pos hV m) hρ, ?_, ?_⟩ + · change NatOrdinal.of B.val ^ m * NatOrdinal.of B.residualFactor < + NatOrdinal.of B.val ^ (m + 1) + rw [pow_succ] + exact mul_lt_mul_of_pos_left hlt (pow_pos hV m) + · exact accumulatingSeries.eventually_cantorBendixsonValue_powerRemainder_lt + accumulating_support_nonpositive B rfl m + +private theorem finite_strict_cut {y : ℝ} (hy : y < 0) : + (truncLE y accumulatingSeries).support.Finite := by + obtain ⟨N, hN⟩ := eventually_atTop.mp (negRecip_tendsto (Ioi_mem_nhds hy)) + apply ((Finset.range N).finite_toSet.image negRecip).subset + intro x hx + rw [support_truncLE, accumulatingSeries_support] at hx + obtain ⟨⟨n, rfl⟩, hn⟩ := hx + refine ⟨n, ?_, rfl⟩ + simp only [Finset.mem_coe, Finset.mem_range] + exact lt_of_not_ge fun hge ↦ (not_lt_of_ge hn) (hN n hge) + +/-- The accumulating fixture has rank exactly one in value, not merely a positive lower bound. -/ +theorem accumulatingSeries_value : + accumulatingSeries.cantorBendixsonValue = Ordinal.omega0 := by + have hstage : (accumulatingSeries.closedSupport.cantorBendixson (1 : Ordinal) : Set ℝ) ⊆ {0} := by + intro y hy + obtain ⟨hys, hyr⟩ := (accumulatingSeries.mem_support_derivative_iff y 1).mp hy + have hy0 : y ≤ 0 := closure_minimal accumulating_support_nonpositive isClosed_Iic hys + by_contra hne + have hylt : y < 0 := lt_of_le_of_ne hy0 hne + have hz : accumulatingSeries.cantorBendixsonRank y = 0 := by + rw [← cantorBendixsonRank_truncLE _ y] + exact cantorBendixsonRank_of_finite _ (finite_strict_cut hylt) y + rw [hz] at hyr + exact not_le_of_gt zero_lt_one hyr + have hnot : (0 : ℝ) ∉ (accumulatingSeries.closedSupport.cantorBendixson + ((1 : Ordinal) + 1) : Set ℝ) := by + rw [TopologicalSpace.Closeds.cantorBendixson_add_one, TopologicalSpace.Closeds.coe_derived] + intro h + exact (finite_singleton (0 : ℝ)).not_infinite + (Set.Infinite.of_accPt (mem_derivedSet.mp (derivedSet_mono _ _ hstage h))) + have hr : accumulatingSeries.cantorBendixsonRank 0 ≤ 1 := by + rw [cantorBendixsonRank_eq] + exact accumulatingSeries.closedSupport.cantorBendixsonRank_le_of_notMem + accumulatingSeries.closedSupport_isPWO 0 hnot + have he := hr.antisymm accumulatingSeries_positive_rank.1 + have hm : (0 : ℝ) ∈ closure accumulatingSeries.support := by + rw [accumulatingSeries_support] + exact isClosed_closure.closure_subset (derivedSet_subset_closure _ accumulation) + rw [cantorBendixsonValue_of_mem _ hm, he, Ordinal.opow_one] + +private def omegaValue : Ordinal.AdditivePrincipalAboveOne := + ⟨Ordinal.omega0, Ordinal.isAdditivelyPrincipal_iff.mpr ⟨1, by simp⟩, Ordinal.one_lt_omega0⟩ + +private theorem omegaValue_residual : omegaValue.residualFactor = 1 := by + apply omegaValue.residualFactor_eq_one_of_isInfiniteMultiplicativelyPrincipal + apply Ordinal.isInfiniteMultiplicativelyPrincipal_iff.mpr + exact ⟨0, by simp [omegaValue]⟩ + +/-- The pure-power cancellation theorem proves every power value on an actual infinite support. +Residual cutoffs have value one, so value-one multiplication closes the smaller-product +hypothesis. -/ +theorem accumulatingSeries_pow_value (n : ℕ) : + NatOrdinal.of (accumulatingSeries ^ n).cantorBendixsonValue = + NatOrdinal.of Ordinal.omega0 ^ n := by + induction n with + | zero => + simp only [pow_zero] + apply congrArg NatOrdinal.of + exact cantorBendixsonValue_of_finite_of_coeff_ne_zero _ + (by rw [support_one]; exact finite_singleton _) (by simp) + | succ n ih => + apply cantorBendixsonValue_pow_eq_of_eventually accumulatingSeries + accumulating_support_nonpositive omegaValue accumulatingSeries_value n + apply Filter.Eventually.of_forall + intro γ hγ + have hv : (translate (-γ) (truncLE γ accumulatingSeries)).cantorBendixsonValue = 1 := by + rw [omegaValue_residual] at hγ + exact NatOrdinal.of.injective hγ + rw [cantorBendixsonValue_mul_of_left_eq_one _ _ (support_translated_truncLE _ _) + ((nonpositiveSubring ℝ ℚ).pow_mem accumulating_support_nonpositive _) hv] + rw [omegaValue_residual] + simpa only [NatOrdinal.of_one, mul_one, omegaValue] using ih + + + +/-- The two-factor cancellation theorem also closes on the opposite-sign infinite factors. +Its residual-point hypothesis uses the independently proved pure-square value. -/ +theorem accumulatingSeries_negative_product_value : + NatOrdinal.of (accumulatingSeries * -accumulatingSeries).cantorBendixsonValue = + NatOrdinal.of Ordinal.omega0 ^ 2 := by + have hc : (-accumulatingSeries).support ⊆ Iic 0 := by + simpa only [support_neg] using accumulating_support_nonpositive + have hv : (-accumulatingSeries).cantorBendixsonValue = omegaValue.val := by + rw [cantorBendixsonValue_neg, accumulatingSeries_value] + rfl + have h := cantorBendixsonValue_pow_mul_eq_of_eventually accumulatingSeries + (-accumulatingSeries) accumulating_support_nonpositive hc omegaValue omegaValue + accumulatingSeries_value hv le_rfl 0 (by + apply Filter.Eventually.of_forall + intro γ hγ + have ht : (translate (-γ) (truncLE γ accumulatingSeries)).cantorBendixsonValue = 1 := by + rw [omegaValue_residual] at hγ + exact NatOrdinal.of.injective hγ + rw [pow_zero, one_mul, cantorBendixsonValue_mul_of_left_eq_one _ _ + (support_translated_truncLE _ _) ((nonpositiveSubring ℝ ℚ).pow_mem hc 2) ht, + neg_sq, omegaValue_residual] + simpa only [NatOrdinal.of_one, mul_one, one_mul, omegaValue, pow_two, pow_zero] using + accumulatingSeries_pow_value 2) + simpa only [zero_add, pow_one, omegaValue, pow_two] using h + + +/-- Unequal positive ranks, mixed signs, and a nonzero constant term are all retained. -/ +theorem accumulatingSeries_mixed_rank_product : + NatOrdinal.of (accumulatingSeries ^ 2 * (1 - accumulatingSeries)).cantorBendixsonValue = + NatOrdinal.of Ordinal.omega0 ^ 3 := by + have hb : accumulatingSeries.support ⊆ Iic 0 := by + rw [accumulatingSeries_support] + rintro x ⟨n, rfl⟩ + change negRecip n ≤ 0 + rw [negRecip_apply] + exact neg_nonpos.mpr (by positivity) + have hc : (1 - accumulatingSeries).support ⊆ Iic 0 := + (nonpositiveSubring ℝ ℚ).sub_mem (nonpositiveSubring ℝ ℚ).one_mem hb + have h1 : (1 : HahnSeries ℝ ℚ).cantorBendixsonValue = 1 := + cantorBendixsonValue_of_finite_of_coeff_ne_zero _ + (by rw [support_one]; exact finite_singleton _) (by simp) + have hv : (1 - accumulatingSeries).cantorBendixsonValue = Ordinal.omega0 := by + rw [sub_eq_add_neg, cantorBendixsonValue_add_eq_max_of_ne, cantorBendixsonValue_neg, + accumulatingSeries_value, h1, max_eq_right Ordinal.one_lt_omega0.le] + rw [cantorBendixsonValue_neg, accumulatingSeries_value, h1] + exact Ordinal.one_lt_omega0.ne + rw [cantorBendixsonValue_mul _ _ ((nonpositiveSubring ℝ ℚ).pow_mem hb 2) hc, + accumulatingSeries_pow_value, hv] + rfl + +open HahnSeries.Nonpositive in +/-- The germ quotient is not the ordinary-coefficient quotient: this series has coefficient +zero at zero and still gives a nonzero germ. -/ +theorem accumulatingSeries_survives_germ : + ∃ b : Nonpositive ℝ ℚ, (b : HahnSeries ℝ ℚ) = accumulatingSeries ∧ + (b : HahnSeries ℝ ℚ).coeff 0 = 0 ∧ + Ideal.Quotient.mk (cantorBendixsonValuation (G := ℝ) (R := ℚ)).supp b ≠ 0 := by + have hb : accumulatingSeries.support ⊆ Iic 0 := by + rw [accumulatingSeries_support] + rintro x ⟨n, rfl⟩ + change negRecip n ≤ 0 + rw [negRecip_apply] + exact neg_nonpos.mpr (by positivity) + refine ⟨⟨accumulatingSeries, hb⟩, rfl, ?_, ?_⟩ + · rw [accumulatingSeries_coeff, ite_eq_right] + rintro ⟨n, hn⟩ + rw [negRecip_apply] at hn + exact (neg_ne_zero.mpr (one_div_ne_zero (by positivity))) hn + · rw [ne_eq, Ideal.Quotient.eq_zero_iff_mem, Valuation.mem_supp_iff, + cantorBendixsonValuation_apply] + change NatOrdinal.of accumulatingSeries.cantorBendixsonValue ≠ 0 + rw [accumulatingSeries_value] + exact Ordinal.omega0_ne_zero + + +open HahnSeries.Nonpositive in +/-- A nonzero negative monomial vanishes in the germ quotient, excluding the zero ideal. -/ +theorem negative_monomial_vanishes_germ : + ∃ b : Nonpositive ℝ ℚ, b ≠ 0 ∧ + Ideal.Quotient.mk (cantorBendixsonValuation (G := ℝ) (R := ℚ)).supp b = 0 := by + have hb : (HahnSeries.single (-1 : ℝ) (1 : ℚ)).support ⊆ Iic 0 := by + intro x hx + have hx' : x = -1 := support_single_subset hx + simpa only [mem_Iic, hx'] using (show (-1 : ℝ) ≤ 0 by norm_num) + refine ⟨⟨HahnSeries.single (-1) 1, hb⟩, ?_, ?_⟩ + · intro h + have h' := congrArg (fun x : Nonpositive ℝ ℚ ↦ (x : HahnSeries ℝ ℚ).coeff (-1)) h + simp at h' + · rw [Ideal.Quotient.eq_zero_iff_mem, Valuation.mem_supp_iff, + cantorBendixsonValuation_apply] + exact congrArg NatOrdinal.of value_boundary_cases.2.1 + + +open HahnSeries.Nonpositive in +/-- The accumulating series gives a genuine degree-one class whose square is nonzero. -/ +theorem accumulatingSeries_graded_class : + ∃ b : Nonpositive ℝ ℚ, (b : HahnSeries ℝ ℚ) = accumulatingSeries ∧ + cantorBendixsonDegreeValuation b = (1 : WithBot NatOrdinal) ∧ + (cantorBendixsonDegreeValuation (G := ℝ) (R := ℚ)).initialForm b ^ 2 ≠ 0 := by + obtain ⟨b, hb, -, -⟩ := accumulatingSeries_survives_germ + have hd : cantorBendixsonDegreeValuation b = (1 : WithBot NatOrdinal) := by + rw [cantorBendixsonDegreeValuation_apply, cantorBendixsonValuation_apply, hb, + accumulatingSeries_value] + simp + refine ⟨b, hb, hd, ?_⟩ + let := cantorBendixson_associatedGraded_isDomain (G := ℝ) (R := ℚ) + exact pow_ne_zero 2 + ((cantorBendixsonDegreeValuation (G := ℝ) (R := ℚ)).initialForm_ne_zero_of_ne_bot + (by rw [hd]; exact WithBot.coe_ne_bot)) + +section Derivative + +open HahnSeries.Nonpositive + +local notation "ν" => (cantorBendixsonDegreeValuation (G := ℝ) (R := ℚ)) + +/-- The accumulating degree-one class has nonzero derivative, excluding the zero-map substitute. -/ +theorem accumulatingSeries_derivative_nonzero : + ∃ b : (ν).filtrationLE 1, ((b : Nonpositive ℝ ℚ) : HahnSeries ℝ ℚ) = + accumulatingSeries ∧ + cantorBendixsonGradedDerivation ((ν).homogeneousMk 1 b) ≠ 0 := by + obtain ⟨b, hb, hd, -⟩ := accumulatingSeries_graded_class + let a : (ν).filtrationLE 1 := ⟨b, ((ν).mem_filtrationLE_iff _ _).mpr hd.le⟩ + refine ⟨a, hb, ?_⟩ + have ha : (ν).componentMk 1 a ≠ 0 := by + rw [ne_eq, (ν).componentMk_eq_zero_iff] + change ¬ ν b < (1 : NatOrdinal) + rw [hd] + exact lt_irrefl _ + intro hzero + apply ha + have hi := cantorBendixsonGradedDerivation_injective_on_successor + (G := ℝ) (R := ℚ) 0 + rw [zero_add] at hi + apply hi + simpa only [(ν).homogeneousMk_apply, map_zero] using hzero + +/-- The additive derivative sends zero to zero. -/ +theorem graded_derivative_zero : cantorBendixsonGradedDerivation + (0 : (ν).AssociatedGraded) = 0 := map_zero _ + +/-- Every grade-zero class has zero derivative. -/ +theorem graded_derivative_constant_grade (a : (ν).Component 0) : + cantorBendixsonGradedDerivation (DirectSum.of (ν).Component 0 a) = 0 := by + rw [cantorBendixsonGradedDerivation_of, + cantorBendixsonHomogeneousDerivation_limit 0 NatOrdinal.constantCoeff_zero, + AddMonoidHom.zero_apply] + +/-- The grade-zero scalar map is an actual coefficient-field equivalence. -/ +theorem graded_zero_component_coefficients : + Function.Bijective (cantorBendixsonLayerScalarHom (G := ℝ) (K := ℚ)) := + ⟨cantorBendixsonLayerScalarHom_injective, cantorBendixsonLayerScalarHom_surjective⟩ + +/-- The standard derivation and additive truncation map agree. -/ +theorem graded_derivation_apply + (x : (ν).AssociatedGraded) : + cantorBendixsonDerivation x = cantorBendixsonGradedDerivation x := + cantorBendixsonDerivation_apply x + +/-- The accumulating series exercises both terms of the graded product rule. -/ +theorem accumulatingSeries_graded_square_rule : + ∃ b : (ν).filtrationLE 1, ((b : Nonpositive ℝ ℚ) : HahnSeries ℝ ℚ) = + accumulatingSeries ∧ + cantorBendixsonGradedDerivation ((ν).homogeneousMk 1 b ^ 2) = + 2 • (cantorBendixsonGradedDerivation ((ν).homogeneousMk 1 b) * + ((ν).homogeneousMk 1 b : Filter.Germ (𝓝[<] (0 : ℝ)) (ν).AssociatedGraded)) := by + obtain ⟨b, hb, -⟩ := accumulatingSeries_derivative_nonzero + refine ⟨b, hb, ?_⟩ + rw [pow_two, cantorBendixsonGradedDerivation_mul, two_smul] + congr 1 + exact mul_comm _ _ + +/-- Dropping one of the two square-rule terms is false for the actual accumulating series. -/ +theorem accumulatingSeries_graded_square_not_single_copy : + ∃ b : (ν).filtrationLE 1, ((b : Nonpositive ℝ ℚ) : HahnSeries ℝ ℚ) = + accumulatingSeries ∧ + cantorBendixsonGradedDerivation ((ν).homogeneousMk 1 b ^ 2) ≠ + cantorBendixsonGradedDerivation ((ν).homogeneousMk 1 b) * + ((ν).homogeneousMk 1 b : Filter.Germ (𝓝[<] (0 : ℝ)) (ν).AssociatedGraded) := by + obtain ⟨b, hb, hD⟩ := accumulatingSeries_derivative_nonzero + refine ⟨b, hb, ?_⟩ + let x := (ν).homogeneousMk 1 b + have hx : x ≠ 0 := by + intro hx + exact hD (by change cantorBendixsonGradedDerivation x = 0; rw [hx, map_zero]) + let := cantorBendixson_associatedGraded_isDomain (G := ℝ) (R := ℚ) + have hp : cantorBendixsonGradedDerivation x * + (x : Filter.Germ (𝓝[<] (0 : ℝ)) (ν).AssociatedGraded) ≠ 0 := by + intro he + apply hD + generalize cantorBendixsonGradedDerivation x = f at he ⊢ + induction f using Filter.Germ.inductionOn with + | h f => + change ((fun γ ↦ f γ * x) : Filter.Germ (𝓝[<] (0 : ℝ)) (ν).AssociatedGraded) = 0 at he + rw [← Filter.Germ.coe_zero, Filter.Germ.coe_eq] at he ⊢ + filter_upwards [he] with γ hγ + exact (mul_eq_zero.mp hγ).resolve_right hx + intro he + have hs := cantorBendixsonGradedDerivation_mul x x + rw [← pow_two, he] at hs + have hc := mul_comm + (x : Filter.Germ (𝓝[<] (0 : ℝ)) (ν).AssociatedGraded) (cantorBendixsonGradedDerivation x) + rw [hc] at hs + exact hp (add_left_cancel (hs.symm.trans (add_zero _).symm)) + +end Derivative + +section GlobalCofactors + +open HahnSeries.Nonpositive + +local notation "ν" => (cantorBendixsonDegreeValuation (G := ℝ) (R := ℚ)) + +private theorem accumulating_neg_rank {y : ℝ} (hy : y < 0) : + accumulatingSeries.cantorBendixsonRank y = 0 := by + rw [← cantorBendixsonRank_truncLE _ y] + exact cantorBendixsonRank_of_finite _ (finite_strict_cut hy) y + +/-- The literal pointwise assembly conclusion is unsatisfiable at an accumulating rank level: +prescribing the constant one at every rank-zero point of the accumulating support forces a +coefficient one at cutoffs arbitrarily close to zero, while the required bound at the +nonpositive noncenter zero forces the support strictly below zero. The pointwise degree +hypothesis of the top-rank assembly therefore cannot be dropped. -/ +theorem no_literal_assembly_at_accumulating_level : + ∃ u : Nonpositive ℝ ℚ, (u : HahnSeries ℝ ℚ) = accumulatingSeries ∧ + ¬ ∃ c : Nonpositive ℝ ℚ, + (∀ i : {x // x ∈ (u : HahnSeries ℝ ℚ).closedSupport ∧ + (u : HahnSeries ℝ ℚ).closedSupport.cantorBendixsonRank + (u : HahnSeries ℝ ℚ).closedSupport_isPWO x = (0 : Ordinal)}, + ν (translatedTruncLE (i : ℝ) c - 1) = ⊥) ∧ + ∀ y : ℝ, y ≤ 0 → + ¬(y ∈ (u : HahnSeries ℝ ℚ).closedSupport ∧ + (u : HahnSeries ℝ ℚ).closedSupport.cantorBendixsonRank + (u : HahnSeries ℝ ℚ).closedSupport_isPWO y = (0 : Ordinal)) → + ν (translatedTruncLE y c) < ((0 : NatOrdinal) : WithBot NatOrdinal) := by + refine ⟨⟨accumulatingSeries, accumulating_support_nonpositive⟩, rfl, ?_⟩ + set u : Nonpositive ℝ ℚ := ⟨accumulatingSeries, accumulating_support_nonpositive⟩ + rintro ⟨c, hc1, hc2⟩ + have hm0 : (0 : ℝ) ∈ closure accumulatingSeries.support := by + rw [accumulatingSeries_support] + exact isClosed_closure.closure_subset (derivedSet_subset_closure _ accumulation) + have h0rank : (u : HahnSeries ℝ ℚ).cantorBendixsonRank 0 ≠ 0 := + Order.one_le_iff_ne_zero.mp accumulatingSeries_positive_rank.1 + have hnc : ¬((0 : ℝ) ∈ (u : HahnSeries ℝ ℚ).closedSupport ∧ + (u : HahnSeries ℝ ℚ).closedSupport.cantorBendixsonRank + (u : HahnSeries ℝ ℚ).closedSupport_isPWO 0 = (0 : Ordinal)) := by + rintro ⟨-, hr⟩ + exact h0rank (((u : HahnSeries ℝ ℚ).cantorBendixsonRank_eq 0).trans hr) + have hcbot : ν c = ⊥ := by + have hbot := hc2 0 le_rfl hnc + rw [translatedTruncLE_zero] at hbot + cases hν : ν c with + | bot => rfl + | coe a => + rw [hν, WithBot.coe_lt_coe] at hbot + exact absurd hbot (not_lt_of_ge (zero_le (a := a))) + obtain ⟨e, he0, hsupp⟩ := (cantorBendixsonDegreeValuation_eq_bot_iff c).mp hcbot + obtain ⟨n, hn⟩ := eventually_atTop.mp (negRecip_tendsto (Ioi_mem_nhds he0)) + have hen : e < negRecip n := hn n le_rfl + have hneg : negRecip n < 0 := by + rw [negRecip_apply] + simp only [one_div, Left.neg_neg_iff, inv_pos] + positivity + have hxsupp : negRecip n ∈ accumulatingSeries.support := by + rw [accumulatingSeries_support] + exact ⟨n, rfl⟩ + have hxmem : negRecip n ∈ (u : HahnSeries ℝ ℚ).closedSupport := + (HahnSeries.mem_closedSupport _ _).mpr (subset_closure hxsupp) + have hxrank : (u : HahnSeries ℝ ℚ).closedSupport.cantorBendixsonRank + (u : HahnSeries ℝ ℚ).closedSupport_isPWO (negRecip n) = (0 : Ordinal) := by + rw [← (u : HahnSeries ℝ ℚ).cantorBendixsonRank_eq] + exact accumulating_neg_rank hneg + have hcen := hc1 ⟨negRecip n, hxmem, hxrank⟩ + obtain ⟨e', he'0, hsupp'⟩ := (cantorBendixsonDegreeValuation_eq_bot_iff _).mp hcen + have h0diff : (0 : ℝ) ∉ + ((translatedTruncLE (negRecip n) c - 1 : Nonpositive ℝ ℚ) : HahnSeries ℝ ℚ).support := by + intro h + exact absurd (hsupp' h) (not_le.mpr he'0) + have hcoeff : (c : HahnSeries ℝ ℚ).coeff (negRecip n) = 1 := by + have hzero : ((translatedTruncLE (negRecip n) c - 1 : Nonpositive ℝ ℚ) : + HahnSeries ℝ ℚ).coeff 0 = 0 := by + by_contra hne + exact h0diff ((HahnSeries.mem_support _ _).mpr hne) + rw [AddSubgroupClass.coe_sub, HahnSeries.coeff_sub, coe_translatedTruncLE, + coeff_translate, zero_sub, neg_neg, HahnSeries.coeff_truncLE, ite_eq_left le_rfl, + OneMemClass.coe_one, HahnSeries.coeff_one, ite_eq_left rfl, sub_eq_zero] at hzero + exact hzero + have hxin : negRecip n ∈ (c : HahnSeries ℝ ℚ).support := + (HahnSeries.mem_support _ _).mpr (by rw [hcoeff]; exact one_ne_zero) + exact absurd (hsupp hxin) (not_le.mpr hen) + +/-- On the accumulating fixture, a degree-zero cofactor of the series itself makes every +translated truncation have degree strictly below one. The zero cofactor is not a substitute, +because the original series keeps degree one at cutoff zero. -/ +theorem accumulating_global_cofactor : + ∃ u c : Nonpositive ℝ ℚ, (u : HahnSeries ℝ ℚ) = accumulatingSeries ∧ + (∀ x : ℝ, x ≤ 0 → ν (translatedTruncLE x c) ≤ (0 : NatOrdinal)) ∧ + (∀ x : ℝ, x ≤ 0 → + ν (translatedTruncLE x (u - c * u)) < ((1 : NatOrdinal) : WithBot NatOrdinal)) ∧ + c ≠ 0 := by + classical + set u : Nonpositive ℝ ℚ := ⟨accumulatingSeries, accumulating_support_nonpositive⟩ with hu_def + have hν1 : ν u = ((1 : NatOrdinal) : WithBot NatOrdinal) := by + rw [cantorBendixsonDegreeValuation_apply, cantorBendixsonValuation_apply] + have hval : (u : HahnSeries ℝ ℚ).cantorBendixsonValue = Ordinal.omega0 := + accumulatingSeries_value + rw [hval] + simp + have huneg : ∀ {y : ℝ}, y < 0 → (u : HahnSeries ℝ ℚ).cantorBendixsonRank y = 0 := + fun hy ↦ accumulating_neg_rank hy + have hcut0 : ∀ x : ℝ, x < 0 → + ν (translatedTruncLE x u) < ((1 : NatOrdinal) : WithBot NatOrdinal) := by + intro x hx + rw [degree_translatedTruncLE_eq] + by_cases hxm : x ∈ (u : HahnSeries ℝ ℚ).closedSupport + · rw [ite_eq_left hxm, huneg hx, NatOrdinal.of_zero, WithBot.coe_lt_coe] + exact zero_lt_one + · rw [ite_eq_right hxm] + exact WithBot.bot_lt_coe 1 + have hu : ∀ x : ℝ, x ≤ 0 → + ν (translatedTruncLE x u) ≤ ((1 : NatOrdinal) : WithBot NatOrdinal) := by + intro x hx + rcases eq_or_lt_of_le hx with hx0 | hxneg + · subst hx0 + rw [translatedTruncLE_zero] + exact hν1.le + · exact (hcut0 x hxneg).le + have hlevel0 : ∀ i : {x // x ∈ (u : HahnSeries ℝ ℚ).closedSupport ∧ + (u : HahnSeries ℝ ℚ).closedSupport.cantorBendixsonRank + (u : HahnSeries ℝ ℚ).closedSupport_isPWO x = (1 : NatOrdinal).val}, + (i : ℝ) = 0 := by + rintro ⟨x, hxm, hxr⟩ + by_contra hne + have hx0 : x ≤ 0 := closure_minimal u.property isClosed_Iic + ((HahnSeries.mem_closedSupport _ _).mp hxm) + have hxneg : x < 0 := lt_of_le_of_ne hx0 hne + have h0 : (u : HahnSeries ℝ ℚ).closedSupport.cantorBendixsonRank + (u : HahnSeries ℝ ℚ).closedSupport_isPWO x = 0 := by + rw [← (u : HahnSeries ℝ ℚ).cantorBendixsonRank_eq] + exact huneg hxneg + rw [h0] at hxr + have : (1 : NatOrdinal).val = (1 : Ordinal) := NatOrdinal.val_one + rw [this] at hxr + exact zero_ne_one hxr + obtain ⟨c, hcb, hres⟩ := exists_forall_degree_translatedTruncLE_sub_sum_mul_lt + (G := ℝ) (R := ℚ) 1 (ι := Unit) (fun _ ↦ u) (fun _ ↦ 0) (fun _ ↦ 1) + (fun _ ↦ (zero_add 1).le) (fun _ ↦ hν1.le) (fun _ ↦ hcut0) u hu (fun _ _ ↦ 1) + (fun _ _ ↦ (ν).map_one_le_zero) (fun i ↦ by + rw [hlevel0 i, translatedTruncLE_zero] + have hsum : (∑ _j : Unit, (1 : Nonpositive ℝ ℚ) * u) = u := by + rw [Fintype.sum_unique, one_mul] + rw [hsum, sub_self, (ν).map_zero] + exact WithBot.bot_lt_coe 1) + have hsum : (∑ j : Unit, c j * u) = c () * u := by + rw [Fintype.sum_unique] + refine ⟨u, c (), rfl, fun x hx ↦ ?_, fun x hx ↦ ?_, ?_⟩ + · exact hcb () x hx + · have := hres x hx + rwa [hsum] at this + · intro hzero + have := hres 0 le_rfl + rw [hsum, hzero, zero_mul, sub_zero, translatedTruncLE_zero, hν1] at this + exact lt_irrefl _ this + +end GlobalCofactors + +section Lifts + +open HahnSeries.Nonpositive MvPolynomial + +local notation "ν" => (cantorBendixsonDegreeValuation (G := ℝ) (R := ℚ)) + +/-- Two distinct series lift one nonzero degree-one class; their difference has bottom degree. +Lifting detects the class, not the series. -/ +theorem distinct_lifts_of_one_class : + ∃ u u' : Nonpositive ℝ ℚ, u ≠ u' ∧ + ∃ e : (ν).AssociatedGraded, e ≠ 0 ∧ + Represents u 1 e ∧ Represents u' 1 e ∧ ν (u - u') = ⊥ := by + classical + obtain ⟨u, hu, hd, -⟩ := accumulatingSeries_graded_class + have hle : ν u ≤ (1 : NatOrdinal) := hd.le + have hs : (HahnSeries.single (-1 : ℝ) (1 : ℚ)).support ⊆ Iic 0 := by + intro x hx + have hx' : x = -1 := support_single_subset hx + simp only [mem_Iic, hx'] + norm_num + set s : Nonpositive ℝ ℚ := ⟨HahnSeries.single (-1) 1, hs⟩ with hs_def + have hsbot : ν s = ⊥ := by + apply (cantorBendixsonDegreeValuation_eq_bot_iff s).mpr + refine ⟨-1, by norm_num, ?_⟩ + intro x hx + have hx' : x = -1 := support_single_subset hx + simp only [mem_Iic, hx', le_refl] + set e : (ν).AssociatedGraded := + (ν).homogeneousMk 1 ⟨u, ((ν).mem_filtrationLE_iff 1 u).mpr hle⟩ with he_def + have hrepu : Represents u 1 e := represents_iff.mpr ⟨hle, rfl⟩ + have hrepu' : Represents (u + s) 1 e := by + have h := hrepu.add (represents_of_degree_lt (m := 1) + (by rw [hsbot]; exact WithBot.bot_lt_coe 1)) + rwa [add_zero] at h + refine ⟨u, u + s, ?_, e, ?_, hrepu, hrepu', ?_⟩ + · intro huu + have hc := congrArg (fun z : Nonpositive ℝ ℚ ↦ (z : HahnSeries ℝ ℚ).coeff (-1)) huu + have hadd : ((u + s : Nonpositive ℝ ℚ) : HahnSeries ℝ ℚ).coeff (-1) = + (u : HahnSeries ℝ ℚ).coeff (-1) + 1 := by + have hcoe : ((u + s : Nonpositive ℝ ℚ) : HahnSeries ℝ ℚ) = + (u : HahnSeries ℝ ℚ) + HahnSeries.single (-1) 1 := rfl + rw [hcoe, HahnSeries.coeff_add, HahnSeries.coeff_single_same] + change (u : HahnSeries ℝ ℚ).coeff (-1) = + ((u + s : Nonpositive ℝ ℚ) : HahnSeries ℝ ℚ).coeff (-1) at hc + rw [hadd] at hc + nth_rewrite 1 [← add_zero ((u : HahnSeries ℝ ℚ).coeff (-1))] at hc + exact zero_ne_one (add_left_cancel hc) + · rw [he_def, ne_eq, (ν).homogeneousMk_eq_zero_iff] + rw [hd] + exact lt_irrefl _ + · rw [show u - (u + s) = -s by ring, (ν).map_neg, hsbot] + +/-- Without independence of the lifted classes, a nonzero polynomial with small weights can +evaluate to bottom degree: the injectivity hypothesis of the uniqueness clause is not +removable. -/ +theorem pol_uniqueness_needs_independence : + ¬ ∀ (wt : Bool → NatOrdinal.{0}) (V : Bool → Nonpositive ℝ ℚ) (F : MvPolynomial Bool ℚ), + (∀ d ∈ F.support, (Finsupp.weight wt) d < 2) → ν (aeval V F) = ⊥ → F = 0 := by + classical + intro h + obtain ⟨u, u', hne, -, -, -, -, hbot⟩ := distinct_lifts_of_one_class + have hF : (MvPolynomial.X true - MvPolynomial.X false : MvPolynomial Bool ℚ) = 0 := by + apply h (fun _ ↦ 1) (fun b ↦ bif b then u else u') + · intro d hd + have hd' := MvPolynomial.support_sub Bool (MvPolynomial.X true) (MvPolynomial.X false) hd + have hw : (Finsupp.weight (fun _ : Bool ↦ (1 : NatOrdinal.{0}))) d = 1 := by + rcases Finset.mem_union.mp hd' with hd'' | hd'' <;> + · rw [MvPolynomial.support_X] at hd'' + rw [Finset.mem_singleton.mp hd'', Finsupp.weight_single, one_nsmul] + rw [hw] + exact one_lt_two + · rw [map_sub, aeval_X, aeval_X] + simpa only [Bool.cond_true, Bool.cond_false] using hbot + have hXX := sub_eq_zero.mp hF + exact absurd (MvPolynomial.X_injective hXX) (by decide) + +/-- The polynomial of a series modulo bounded series, run below degree one with no generators: +the machinery extracts the constant term, and only the correct constant works. -/ +theorem degree_lt_one_constant_extraction : + ∃ u : Nonpositive ℝ ℚ, + (u : HahnSeries ℝ ℚ) = 1 + HahnSeries.single (-1 : ℝ) (1 : ℚ) ∧ + (∃ c : ℚ, ν (u - algebraMap ℚ (Nonpositive ℝ ℚ) c) = ⊥) ∧ + ∀ c : ℚ, ν (u - algebraMap ℚ (Nonpositive ℝ ℚ) c) = ⊥ → c = 1 := by + classical + have hs : (1 + HahnSeries.single (-1 : ℝ) (1 : ℚ)).support ⊆ Iic 0 := by + intro x hx + rcases HahnSeries.support_add_subset _ _ hx with hx' | hx' + · rw [HahnSeries.support_one] at hx' + simp only [mem_singleton_iff] at hx' + simp [hx'] + · have hx'' : x = -1 := support_single_subset hx' + simp only [mem_Iic, hx''] + norm_num + set u : Nonpositive ℝ ℚ := ⟨1 + HahnSeries.single (-1) 1, hs⟩ with hu_def + have hcoeff0 : (u : HahnSeries ℝ ℚ).coeff 0 = 1 := by + change (1 + HahnSeries.single (-1 : ℝ) (1 : ℚ)).coeff 0 = 1 + rw [HahnSeries.coeff_add, HahnSeries.coeff_one, ite_eq_left rfl, + HahnSeries.coeff_single_of_ne (by norm_num : (0 : ℝ) ≠ -1), add_zero] + have hufin : (u : HahnSeries ℝ ℚ).support.Finite := by + apply Set.Finite.subset ((Set.finite_singleton (-1 : ℝ)).insert 0) + intro x hx + rcases HahnSeries.support_add_subset _ _ hx with hx' | hx' + · rw [HahnSeries.support_one] at hx' + exact Set.mem_insert_iff.mpr (Or.inl (mem_singleton_iff.mp hx')) + · exact Set.mem_insert_iff.mpr (Or.inr (support_single_subset hx')) + have hu0 : ν u ≤ (0 : NatOrdinal) := by + rw [cantorBendixsonDegreeValuation_apply, cantorBendixsonValuation_apply, + cantorBendixsonValue_of_finite_of_coeff_ne_zero _ hufin + (by rw [hcoeff0]; exact one_ne_zero), + NatOrdinal.of_one, NatOrdinal.cantorDegree_eq_ordinalCantorDegree, + NatOrdinal.val_one, Ordinal.cantorDegree_one, WithBot.coe_zero] + have hgen : ∀ β : NatOrdinal.{0}, β < 1 → + ∀ y ∈ DirectSum.rangeLof ℚ (ν).Component β, + ∃ F : MvPolynomial Empty ℚ, IsWeightedHomogeneous (fun _ ↦ 1) F β ∧ + aeval (fun _ ↦ (0 : (ν).AssociatedGraded)) F = y := by + intro β hβ y hy + have hβ0 : β = 0 := by + have h01 : β < 0 + 1 := by rwa [zero_add] + exact le_antisymm (Order.lt_add_one_iff.mp h01) (zero_le (a := β)) + subst hβ0 + obtain ⟨a, rfl⟩ := (DirectSum.mem_rangeLof_iff ℚ (ν).Component 0 y).mp hy + obtain ⟨k, hk⟩ := cantorBendixsonLayerScalarHom_surjective (G := ℝ) (K := ℚ) a + refine ⟨C k, isWeightedHomogeneous_C _ k, ?_⟩ + rw [aeval_C, cantorBendixson_algebraMap_apply, hk, DirectSum.lof_eq_of] + obtain ⟨F, -, -, hFbot⟩ := exists_forall_weight_lt_and_degree_sub_aeval_eq_bot + (V := fun _ ↦ 0) (fun _ ↦ (0 : (ν).AssociatedGraded)) + (fun i ↦ i.elim) 1 hgen u (hu0.trans_lt (WithBot.coe_lt_coe.mpr zero_lt_one)) + obtain ⟨c, hc⟩ := MvPolynomial.C_surjective Empty F + refine ⟨u, rfl, ⟨c, ?_⟩, ?_⟩ + · rw [← hc, aeval_C] at hFbot + exact hFbot + · intro c hc' + obtain ⟨e, he0, hesupp⟩ := (cantorBendixsonDegreeValuation_eq_bot_iff _).mp hc' + have h0notin : (0 : ℝ) ∉ + ((u - algebraMap ℚ (Nonpositive ℝ ℚ) c : Nonpositive ℝ ℚ) : HahnSeries ℝ ℚ).support := + fun h ↦ absurd (hesupp h) (not_le.mpr he0) + have hz : ((u - algebraMap ℚ (Nonpositive ℝ ℚ) c : Nonpositive ℝ ℚ) : + HahnSeries ℝ ℚ).coeff 0 = 0 := by + by_contra hnz + exact h0notin ((HahnSeries.mem_support _ _).mpr hnz) + rw [AddSubgroupClass.coe_sub, HahnSeries.coeff_sub, hcoeff0, + HahnSeries.Nonpositive.algebraMap_apply, coe_C, HahnSeries.C_apply, + HahnSeries.coeff_single_same, sub_eq_zero] at hz + exact hz.symm + +end Lifts + +end Tests.PWOAddition diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Topology/Tests.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Topology/Tests.lean new file mode 100644 index 0000000000..bf1f09551b --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Topology/Tests.lean @@ -0,0 +1,11 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ + +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Topology.Tests.CantorBendixson + +/-! Supporting modules for Conway refinement for omnific integers. -/ diff --git a/LeanPool/ConwayRefinement/ConwayRefinement/Topology/Tests/CantorBendixson.lean b/LeanPool/ConwayRefinement/ConwayRefinement/Topology/Tests/CantorBendixson.lean new file mode 100644 index 0000000000..73e0e629aa --- /dev/null +++ b/LeanPool/ConwayRefinement/ConwayRefinement/Topology/Tests/CantorBendixson.lean @@ -0,0 +1,183 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Topology.CantorBendixsonProduct +public import LeanPool.ConwayRefinement.ConwayRefinement.Topology.CantorBendixsonReconstruction +public import Mathlib.Topology.Instances.ENat +import Mathlib.Topology.DiscreteSubset +public import Mathlib.Topology.Maps.Proper.Basic + +/-! +# Semantic checks for transfinite Cantor–Bendixson derivatives + +In the order topology on extended naturals, stage one of the whole space is exactly infinity, +and stage two is empty. This separates derived set from closure and from a falsely discrete +ambient topology. The same calculation exercises a genuine limit stage. A two-to-one projection +also exercises the closed-map theorem without substituting injectivity for finite fibers. +-/ + +public noncomputable section + +open Set Filter Topology TopologicalSpace Order + +namespace Tests.CantorBendixson + +private theorem derivedSet_finite {X : Type*} [TopologicalSpace X] [T1Space X] + {s : Set X} (hs : s.Finite) : derivedSet s = ∅ := by + apply eq_empty_iff_forall_notMem.mpr + intro x hx + exact hs.not_infinite (Set.Infinite.of_accPt (mem_derivedSet.mp hx)) + +private theorem enat_derivedSet_univ : derivedSet (univ : Set ℕ∞) = {⊤} := by + ext x + constructor + · intro hx + by_contra hx0 + have hxne : x ≠ ⊤ := hx0 + have h := accPt_iff_frequently.mp (mem_derivedSet.mp hx) + simp [ENat.nhds_eq_pure hxne] at h + · intro hx + have hx' : x = ⊤ := hx + subst x + apply mem_derivedSet.mpr + apply accPt_iff_nhds.mpr + intro U hU + have he : ∀ᶠ n : ℕ in atTop, (n : ℕ∞) ∈ U := ENat.tendsto_natCast_nhds_top hU + obtain ⟨n, hn⟩ := he.exists + exact ⟨(n : ℕ∞), ⟨hn, mem_univ _⟩, ENat.natCast_ne_top n⟩ + +/-- The convergent-sequence limit survives stage one; isolated finite points do not. -/ +theorem enat_stage_one : + ((⊤ : Closeds ℕ∞).cantorBendixson (1 : Ordinal) : Set ℕ∞) = {⊤} := by + rw [show (1 : Ordinal) = 0 + 1 by simp, Closeds.cantorBendixson_add_one, + Closeds.cantorBendixson_zero, Closeds.coe_derived, Closeds.coe_top] + exact enat_derivedSet_univ + +/-- The surviving limit point is isolated in the first derivative and disappears at stage two. -/ +theorem enat_stage_two : (⊤ : Closeds ℕ∞).cantorBendixson (2 : Ordinal) = ⊥ := by + apply Closeds.ext + rw [show (2 : Ordinal) = 1 + 1 from one_add_one_eq_two.symm, Closeds.cantorBendixson_add_one, + Closeds.coe_derived, enat_stage_one, Closeds.coe_bot] + exact derivedSet_finite (finite_singleton _) + +/-- A genuine limit stage is computed by intersections, not by restarting the derivative. -/ +theorem enat_stage_omega : + (⊤ : Closeds ℕ∞).cantorBendixson Ordinal.omega0 = ⊥ := by + apply le_antisymm _ bot_le + have h := (⊤ : Closeds ℕ∞).cantorBendixson_antitone + (show (2 : Ordinal) ≤ Ordinal.omega0 from (Ordinal.natCast_lt_omega0 2).le) + simpa only [enat_stage_two] using h + +/-- The same finite points, in their own discrete ambient space, have no accumulation point. -/ +theorem nat_stage_one : (⊤ : Closeds ℕ).cantorBendixson (1 : Ordinal) = ⊥ := by + apply Closeds.ext + rw [show (1 : Ordinal) = 0 + 1 by simp, Closeds.cantorBendixson_add_one, + Closeds.cantorBendixson_zero, Closeds.coe_derived, Closeds.coe_top, Closeds.coe_bot] + apply eq_empty_iff_forall_notMem.mpr + intro n hn + have h := accPt_iff_frequently.mp (mem_derivedSet.mp hn) + simp at h + +/-- A closed projection with two-point fibers lifts every derivative, for arbitrary ordinals. -/ +theorem two_point_projection (o : Ordinal) : + ((⊤ : Closeds ℕ∞).cantorBendixson o : Set ℕ∞) ⊆ + Prod.fst '' ((⊤ : Closeds (ℕ∞ × Fin 2)).cantorBendixson o : Set (ℕ∞ × Fin 2)) := by + have hf : IsClosedMap (Prod.fst : ℕ∞ × Fin 2 → ℕ∞) := isClosedMap_fst_of_compactSpace + have hfin (y : ℕ∞) : (Prod.fst ⁻¹' {y} : Set (ℕ∞ × Fin 2)).Finite := by + have heq : (Prod.fst ⁻¹' {y} : Set (ℕ∞ × Fin 2)) = {y} ×ˢ univ := by + ext x + simp + rw [heq] + exact (finite_singleton _).prod (finite_univ) + have himage : (⟨Prod.fst '' (univ : Set (ℕ∞ × Fin 2)), hf _ isClosed_univ⟩ : + Closeds ℕ∞) = ⊤ := by + apply Closeds.ext + simp only [Closeds.coe_mk, Closeds.coe_top, image_univ] + exact Set.range_eq_univ.mpr Prod.fst_surjective + simpa only [Closeds.coe_top, himage] using hf.cantorBendixson_image_subset hfin ⊤ o + +/-- The product of two convergent sequences has no point at stage three. This exercises the +natural-sum bound with two nonzero coordinate ranks. -/ +theorem enat_product_stage_three : + (⊤ : Closeds (ℕ∞ × ℕ∞)).cantorBendixson (3 : Ordinal) = ⊥ := by + let r (n : ℕ∞) : NatOrdinal := if n = ⊤ then 1 else 0 + have hr (x : ℕ∞) (_hx : x ∈ (⊤ : Closeds ℕ∞)) : + ∀ᶠ z in 𝓝 x, z ∈ (⊤ : Closeds ℕ∞) → z ≠ x → r z < r x := by + by_cases hx : x = ⊤ + · subst x + exact Filter.Eventually.of_forall fun z _ hz ↦ by simp [r, hz] + · simp [ENat.nhds_eq_pure hx] + have hbound := (⊤ : Closeds ℕ∞).cantorBendixson_prod_subset_of_locally_lt + ⊤ r r hr hr (3 : Ordinal) + have hprod : (⊤ : Closeds ℕ∞) ×ˢ (⊤ : Closeds ℕ∞) = ⊤ := by + ext x + simp + rw [hprod] at hbound + apply Closeds.ext + apply eq_empty_iff_forall_notMem.mpr + intro p hp + have h := hbound hp + change (3 : Ordinal) ≤ (r p.1 + r p.2).val at h + have hle (n : ℕ∞) : r n ≤ 1 := by simp [r]; split <;> simp + have hsum : (r p.1 + r p.2).val ≤ 2 := by + have hs : r p.1 + r p.2 ≤ (2 : NatOrdinal) := by + calc + _ ≤ 1 + 1 := add_le_add (hle p.1) (hle p.2) + _ = 2 := one_add_one_eq_two + exact NatOrdinal.val.monotone hs + have hnot : ¬ (3 : Ordinal) ≤ 2 := by + exact_mod_cast (show ¬ (3 : ℕ) ≤ 2 by decide) + exact hnot (h.trans hsum) + +/-- The product bound is nondegenerate: the pair of limit points survives stage two. -/ +theorem enat_product_top_mem_stage_two : + (⊤, ⊤) ∈ (⊤ : Closeds (ℕ∞ × ℕ∞)).cantorBendixson (2 : Ordinal) := by + have htop : (⊤ : ℕ∞) ∈ derivedSet (univ : Set ℕ∞) := by rw [enat_derivedSet_univ]; simp + have hrow (y : ℕ∞) : (⊤, y) ∈ derivedSet (univ : Set (ℕ∞ × ℕ∞)) := by + have h := (Continuous.prodMk_left y).image_derivedSet + (fun _ _ heq ↦ congrArg Prod.fst heq) ⟨⊤, htop, rfl⟩ + exact derivedSet_mono _ _ (subset_univ _) h + have hcol : (⊤, ⊤) ∈ derivedSet (derivedSet (univ : Set (ℕ∞ × ℕ∞))) := by + have h := ((continuous_const : Continuous fun _ : ℕ∞ ↦ (⊤ : ℕ∞)).prodMk + continuous_id).image_derivedSet (fun _ _ heq ↦ congrArg Prod.snd heq) ⟨⊤, htop, rfl⟩ + exact derivedSet_mono _ _ (by rintro _ ⟨y, _, rfl⟩; exact hrow y) h + rw [show (2 : Ordinal) = (0 + 1) + 1 by simp only [zero_add, one_add_one_eq_two], + Closeds.cantorBendixson_add_one, Closeds.cantorBendixson_add_one, + Closeds.cantorBendixson_zero] + change (⊤, ⊤) ∈ ((⊤ : Closeds (ℕ∞ × ℕ∞)).derived.derived : Set (ℕ∞ × ℕ∞)) + simpa only [Closeds.coe_derived, Closeds.coe_top] using hcol + +/-- The sequence limit has point rank exactly one, rather than its order index `omega`. -/ +theorem enat_top_rank : + (⊤ : Closeds ℕ∞).cantorBendixsonRank (Set.isPWO_of_wellQuasiOrderedLE _) ⊤ = 1 := by + apply ((⊤ : Closeds ℕ∞).cantorBendixsonRank_eq_iff (Set.isPWO_of_wellQuasiOrderedLE _) + (by trivial) 1).mpr + constructor + · rw [enat_stage_one] + exact mem_singleton _ + · rw [one_add_one_eq_two, enat_stage_two] + exact notMem_empty _ + +/-- Every finite point is isolated, so its point rank is zero. -/ +theorem enat_nat_rank (n : ℕ) : + (⊤ : Closeds ℕ∞).cantorBendixsonRank (Set.isPWO_of_wellQuasiOrderedLE _) n = 0 := by + apply ((⊤ : Closeds ℕ∞).cantorBendixsonRank_eq_iff (Set.isPWO_of_wellQuasiOrderedLE _) + (by trivial) 0).mpr + constructor + · simp + · rw [zero_add, enat_stage_one] + exact ENat.natCast_ne_top n + +/-- The isolated rank-zero points are dense even though the limit point has rank one. -/ +theorem enat_rank_zero_dense : + closure {x : ℕ∞ | (⊤ : Closeds ℕ∞).cantorBendixsonRank + (Set.isPWO_of_wellQuasiOrderedLE _) x = 0} = univ := by + have hm (x : ℕ∞) : x ∈ (⊤ : Closeds ℕ∞) := by trivial + simpa only [hm, true_and, Closeds.cantorBendixson_zero, Closeds.coe_top] using + (⊤ : Closeds ℕ∞).closure_rank_level_eq (Set.isPWO_of_wellQuasiOrderedLE _) 0 + +end Tests.CantorBendixson diff --git a/LeanPool/ConwayRefinement/Solution.lean b/LeanPool/ConwayRefinement/Solution.lean new file mode 100644 index 0000000000..d2dd504195 --- /dev/null +++ b/LeanPool/ConwayRefinement/Solution.lean @@ -0,0 +1,27 @@ +/- +Copyright (c) 2026 Dan Abramov. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Dan Abramov +-/ +module + +public import LeanPool.ConwayRefinement.ConwayRefinement.Standalone.Mathlib.InlineConwayRefinementProof + +/-! +# Conway's refinement theorem + +This module connects Palomar's advertised declaration to the proof. +-/ + +public noncomputable section + +universe u + +namespace ConwayRefinement.Palomar + +/-- Conway's refinement theorem for omnific integers, stated from first principles. -/ +theorem conwayRefinement : + ConwayRefinement.Standalone.InlineConwayRefinement.Surreal.ConwayConjecture.{u} := + ConwayRefinement.Standalone.InlineConwayRefinement.Surreal.ConwayConjecture.proof + +end ConwayRefinement.Palomar diff --git a/LeanPool/projects.yml b/LeanPool/projects.yml index bdc7ab8604..4b5bb8b111 100644 --- a/LeanPool/projects.yml +++ b/LeanPool/projects.yml @@ -10706,3 +10706,32 @@ projects: - '68W30' - '15A75' - '94D10' + - title: Conway refinement for omnific integers + summary: 'Proves multiplicative refinement for omnific integers: every equality ab = cd admits a + two-by-two factor refinement. Develops factorization and refinement of generalized power-series + integer parts and connects these to surreal-number and standalone Mathlib formulations.' + branch: ordered algebra + main_declarations: + - ConwayRefinement.Palomar.conwayRefinement + main_results: + - declaration: ConwayRefinement.Palomar.conwayRefinement + informal: If four omnific integers satisfy ab = cd, there are omnific integers e, f, g, h with + a = ef, b = gh, c = eg, and d = fh, including degenerate cases. + tags: + - surreal-numbers + - ordered-algebra + - factorization + msc: + - 06A05 + - 13F25 + provenance: AI + slug: conway-refinement + entry_module: LeanPool.ConwayRefinement + authors: + - Dan Abramov + source: + url: https://github.com/gaearon/conway-refinement + github_repo: gaearon/conway-refinement + commit: 264445c93b78554c408e99e4e7f663693b4e91ab + license: Apache-2.0 + status: verified